"

 COPYRIGHT (c) 1989 by Claus Gittinger

              All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

"{ Package: 'stx:libtool' }"

StandardSystemView subclass:#DebugView

	instanceVariableNames:'busy haveControl exitAction canContinue contextView codeView

		receiverInspector contextInspector contextArray selectedContext

		catchBlock grabber mayProceed traceView tracing bigStep

		skipLineNr steppedContextAddress abortButton terminateButton

		continueButton stepButton nextButton nextOverButton nextOutButton

		sendButton returnButton restartButton exclusive inspecting

		nChainShown inspectedProcess updateProcess stopButton

		updateButton defineButton monitorToggle stepping

		steppedContextLineno stepForReturn actualContext inWrap

		stackInspector steppedContext wrapperContext verboseBacktrace

		firstContext stepHow cachable currentMethod ignoreBreakpoints

		stepUntilEntering lastStepUntilEntering

		lastSelectionInReceiverInspector lastSelectionInContextInspector

		canShowMore exitAbort reportButton setOfHiddenCallingSelectors

		isStoppedAtHaltOrBreakPoint exceptionInfoLabel methodCodeToggle

		methodCodeToggleSelectionHolder'

	classVariableNames:'CachedDebugger CachedExclusive OpenDebuggers MoreDebuggingDetail

		DebuggingDebugger DefaultDebuggerBackgroundColor

		InitialNChainShown IgnoredHalts ShowThreadID LastIgnoreHaltNTimes

		LastIgnoreHaltDuration LastExtent LastOrigin'

	poolDictionaries:''

	category:'Interface-Debugger'

!

Object subclass:#IgnoredHalt

	instanceVariableNames:'weakMethodHolder lineNumber ignoreEndTime ignoreCount

		ignoreUntilShiftKeyPressed'

	classVariableNames:''

	poolDictionaries:''

	privateIn:DebugView

!

!DebugView class methodsFor:'documentation'!

copyright

"

 COPYRIGHT (c) 1989 by Claus Gittinger

              All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

!

documentation

"

    This class implements a graphical debugger interface.

    The debugger usually sits on top of the faulting process,

    taking over its event processing.

    (this is different from other Smalltalk debuggers, which control

     the debuggee as a separate process. Consider this an historic

     leftover - the debugger was one of the first applications written for

     ST/X; however, why should we change it without a particular need ...).

    Only the 'stopped' debugged process is affected;

    other processes continue to respond to events.

    The one exception is when an error occurs within the dispatcher process

    or in one of the eventhandler processes - in this case, the debugger

    will sit on an exclusive display connection.

    The whole debugging will be changed, once the required process primitives

    are available, which allow control of another processes execution

    (i.e. single-step, restart & return). The setup will be changed then,

    to have the debugger control the debuggee (i.e. two processes)

    See additional information in 'doc/misc/debugger.doc'.

    Notice:

        the DebugView class caches the last used debugger in a class

        variable. It may happen, that a malfunctioning debugger (for example,

        a halfway destroyed one) is kept there. You will notice this, if a

        debugger comes up without showing any contents. In this case, close

        (or destroy) the broken debugView, and execute

            Debugger newDebugger

        which removes the cached debugger and forces creation of a new one the

        next time. This is a temporary workaround - the debugger will be fixed to

        avoid this problem.

        You also have to remove the cached debugger, if you change the debugger's

        initialization code (buttons, menu, etc.) and you want the new code to become

        effective.

    [author:]

        Claus Gittinger

    [see also:]

        Exception Signal

        Process

"

! !

!DebugView class methodsFor:'initialization'!

initialize

    InitialNChainShown := 50.

    "/ DefaultDebuggerBackgroundColor := nil.

    "/ DefaultDebuggerBackgroundColor := Color red lightened.

    "/ DefaultDebuggerBackgroundColor := Color blue lightened lightened.

    "Created: 20.3.1997 / 16:53:37 / cg"

    "Modified: 20.3.1997 / 16:54:32 / cg"

!

reinitialize

    "reinitialize after an image-restart"

    self newDebugger

! !

!DebugView class methodsFor:'cleanup'!

lowSpaceCleanup

    "in low memory situations, give up cached debuggers"

    CachedDebugger := nil.

    CachedExclusive := nil.

    OpenDebuggers := nil.

    "

     DebugView lowSpaceCleanup

    "

    "Modified: 18.4.1996 / 16:48:03 / cg"

!

newDebugger

    "force creation of a new debugger (give up cached debuggers)"

    CachedDebugger := nil.

    CachedExclusive := nil.

    OpenDebuggers := nil.

    (Debugger isBehavior and:[Debugger name = #DebugView]) ifTrue:[

        Debugger := self

    ].

    "

     DebugView newDebugger

    "

! !

!DebugView class methodsFor:'defaults'!

defaultIcon

    "return the browsers default window icon"

    <resource: #programImage>

    ^ ToolbarIconLibrary debug22x22Icon

    "/ ^ ToolbarIconLibrary debugIt20x20Icon

    "Modified: / 11-02-2007 / 11:47:20 / cg"

!

defaultIconForAboutBox

    <resource: #programImage>

    ^ ToolbarIconLibrary debug22x22IconForBlackBackgound

!

defaultVerboseBacktrace

    <resource: #obsolete>

    self obsoleteMethodWarning.

    ^ UserPreferences current verboseBacktraceInDebugger

    "Created: 11.1.1997 / 12:14:35 / cg"

!

defaultVerboseBacktrace:aBoolean

    <resource: #obsolete>

    self obsoleteMethodWarning.

    UserPreferences current verboseBacktraceInDebugger:aBoolean

!

updateStyleCache

    "extract values from the styleSheet and cache them in class variables"

    <resource: #style (#'debugView.viewBackgroundColor')>

    DefaultDebuggerBackgroundColor := StyleSheet at:#'debugView.viewBackgroundColor'

    "Modified: / 17.11.2001 / 17:31:42 / cg"

! !

!DebugView class methodsFor:'ignoring halts'!

haltIgnoreInformationFor:haltingMethod atLineNr:lineNrInHaltingMethod

    "the information (if any) about the ignore-state of a halt"

    IgnoredHalts isNil ifTrue:[^ nil].

    IgnoredHalts do:[:ign |

        (ign isHaltIgnoredInMethod:haltingMethod line:lineNrInHaltingMethod) ifTrue:[

            ^ ign

        ].

    ].

    ^ nil.

!

hasIgnoredHalts

    self removeInactiveIgnores.

    ^ IgnoredHalts notEmptyOrNil

!

ignoreHaltIn:haltingMethod at:lineNrOfHalt forCount:countOrNil orTimeDuration:dTOrNil orUntilShiftKey:untilShiftKey

    "remember to ignore a halt in some method for some number of invocations

     or until some time has elapsed.

     With nil count and time arguments, such an ignored halt is reactivated"

    |oldEntry ign|

    IgnoredHalts notNil ifTrue:[

        self removeInactiveIgnores.

        oldEntry := IgnoredHalts

                        detect:[:ign | ign isForMethod:haltingMethod line:lineNrOfHalt]

                        ifNone:nil.

        oldEntry notNil ifTrue:[

            IgnoredHalts remove:oldEntry ifAbsent:[].

        ]

    ].

    (countOrNil notNil or:[dTOrNil notNil or:[untilShiftKey == true]]) ifTrue:[

        IgnoredHalts isNil ifTrue:[

            IgnoredHalts := OrderedCollection new.

        ].

        ign := IgnoredHalt new method:haltingMethod lineNumber:lineNrOfHalt.

        (countOrNil notNil and:[countOrNil > 0]) ifTrue:[

            ign ignoreCount:countOrNil.

        ].

        (dTOrNil notNil) ifTrue:[

            ign ignoreEndTime:(Timestamp now + dTOrNil).

        ].

        untilShiftKey == true ifTrue:[

            ign ignoreUntilShiftKeyPressed:true.

        ].

        IgnoredHalts add:ign.

    ].

    Smalltalk changed:#ignoredHalts.

    "Created: / 27-01-2012 / 11:33:38 / cg"

!

isHaltToBeIgnored

    |c sender haltingMethod lineNrInHaltingMethod|

    "/ should a halt be ignored ?

    IgnoredHalts isNil ifTrue:[^ false].

    "/ look for a breakpoint-wrapper's context

    c := thisContext findNextContextWithSelector:#doRaise or:nil or:nil.

    c notNil ifTrue:[

        (c receiver isKindOf:NoHandlerError) ifTrue:[

            c := c sender findNextContextWithSelector:#doRaise or:nil or:nil.

        ].

        (c receiver isKindOf:BreakPointInterrupt) ifFalse:[

            c := nil

        ] ifTrue:[

            [ ((sender := c sender) receiver isKindOf:BreakPointInterrupt)

            or:[ sender receiver == BreakPointInterrupt ]] whileTrue:[

                c := sender

            ].

            [ (sender := c sender) isBlockContext ] whileTrue:[

                c := sender

            ].

            sender := nil. "/ avoid keeping a reference to this context

        ].

    ].

    c isNil ifTrue:[

        "/ look for halts or explicit breakpoints

        c := thisContext findNextContextWithSelector:#halt or:#halt: or:nil.

        c isNil ifTrue:[

            c := thisContext findNextContextWithSelector:#breakPoint: or:#breakPoint:info: or:nil.

            c isNil ifTrue:[

               ^ false

            ].

        ].

    ].

    c := c sender.

    "/ a code-breakpoint ?

    (c receiver isKindOf:Breakpoint) ifTrue:[

        c := c sender.

    ].

    haltingMethod := c method.

    haltingMethod isWrapped ifTrue:[

        lineNrInHaltingMethod := 1.

    ] ifFalse:[

        lineNrInHaltingMethod := c lineNumber.

        "/ Transcript showCR:c.

    ].

    ^ self

        isHaltToBeIgnoredIn:haltingMethod

        atLineNr:lineNrInHaltingMethod

        modifyEntryCount:true.

    "Created: / 22-10-2010 / 12:09:53 / cg"

    "Modified: / 27-01-2012 / 11:08:32 / cg"

!

isHaltToBeIgnoredIn:haltingMethod atLineNr:lineNrInHaltingMethod

    ^ self

        isHaltToBeIgnoredIn:haltingMethod

        atLineNr:lineNrInHaltingMethod

        modifyEntryCount:false

!

isHaltToBeIgnoredIn:haltingMethod atLineNr:lineNrInHaltingMethod modifyEntryCount:modifyCount

    "/ should a halt be ignored ?

    IgnoredHalts isNil ifTrue:[^ false].

    "/ Transcript showCR:'halt/break in ',haltingMethod printString,' at ',lineNrInHaltingMethod printString.

    IgnoredHalts do:[:ign |

        (ign isHaltIgnoredInMethod:haltingMethod line:lineNrInHaltingMethod) ifTrue:[

            Transcript show:'Debugger [info]: halt ignored in ', haltingMethod whoString.

            Transcript show:' ('; show:ign; showCR:')'.

            modifyCount ifTrue:[ ign decrementIgnoreCount ].

            ign isHaltIgnored ifFalse:[

                Transcript showCR:'Debugger [info]: no longer ignore halt in ', haltingMethod whoString.

                IgnoredHalts remove:ign ifAbsent:[].

            ].

            ^ true.

        ].

    ].

    IgnoredHalts := IgnoredHalts

        select:[:ign |

            ign isActive and:[ (ign isForMethod:haltingMethod line:lineNrInHaltingMethod) not ]

        ].

    IgnoredHalts isEmpty ifTrue:[

        IgnoredHalts := nil.

    ].

    ^ false.

    "Modified: / 27-01-2012 / 11:41:19 / cg"

!

removeInactiveIgnores

    IgnoredHalts notNil ifTrue:[

        IgnoredHalts := IgnoredHalts select:[:i | i isActive].

    ].

!

stopIgnoringHalts

    "forget about all ignored halts"

    IgnoredHalts := nil.

    Smalltalk changed:#ignoredHalts.

! !

!DebugView class methodsFor:'instance creation / entering'!

enter

    "enter a debugger"

    <context: #return>

    ^ self

        enter:thisContext sender

        withMessage:'debugger entered'

        mayProceed:true.

!

enter:aContext withMessage:aString

    "enter a debugger"

    <context: #return>

    ^ self

        enter:aContext

        withMessage:aString

        mayProceed:true

!

enter:aContext withMessage:aString mayProceed:mayProceed

    "enter a debugger; if this is a recursive invocation, enter

     a MiniDebugger instead.

     This is the standard way of entering the debugger;

     sent from error- and halt messages."

    <context: #return>

    |active|

    StepInterruptPending := nil.

    ControlInterrupt handle:[:ex |

        'DebugView [info]: breakpoint in debugger setup ignored [enter.]' infoPrintCR.

        ('DebugView [info]: breakpoint on:' , ex suspendedContext printString) infoPrintCR.

        ex proceed

    ] do:[

        "

         well, it could be a stepping or sending debugger up there;

         in this case, return to it. This happens, when a stepping process

         runs into an error (for example, a halt). In this case, we want the

         stepping debugger to come up again instead of a new one.

        "

        OpenDebuggers notNil ifTrue:[

            active := Processor activeProcess.

            OpenDebuggers do:[:aDebugger |

                (aDebugger notNil and:[aDebugger ~~ 0]) ifTrue:[

                    (aDebugger inspectedProcess == active) ifTrue:[

                        aDebugger device isOpen ifTrue:[

                            "/ 'entering stepping debugger again' printNL.

                            aDebugger unstep.

                            aDebugger setLabelFor:aString in:active.

                            aDebugger mayProceed:mayProceed.

                            ^ aDebugger enter:aContext select:nil.

                        ]

                    ]

                ]

            ]

        ].

    ].

    ^ self enterUnconditional:aContext withMessage:aString mayProceed:mayProceed

    "Modified: / 18.11.2001 / 00:48:03 / cg"

!

enterException:ex

    "enter a debugger; if this is a recursive invocation, enter

     a MiniDebugger instead.

     This is the standard way of entering the debugger;

     sent from error- and halt messages."

    ^ self

        enter:ex returnableSuspendedContext

        withMessage:ex descriptionForDebugger

        mayProceed:(ex mayProceed).

!

enterUnconditional:aContext withMessage:aString mayProceed:mayProceed

    "enter a debugger - do not check for recursive invocation"

    <context: #return>

    |aDebugger|

    StepInterruptPending := nil.

    "/ ignore halts & breakpoints while setting up the debugger

    "/ to avoid recursive debugging ...

    ControlInterrupt handle:[:ex |

        'DebugView [info]: breakpoint in debugger setup ignored [enterUncond.]' infoPrintCR.

        ('DebugView [info]: breakpoint on:' , ex suspendedContext printString) infoPrintCR.

        ex proceed

    ] do:[

        aDebugger := self new.

    ].

    aDebugger isNil ifTrue:[

        'DebugView [error]: cannot open debugger' errorPrintCR.

        'DebugView [error]: Exception: ' errorPrint. aString errorPrintCR.

        mayProceed ifTrue:[

            (Dialog confirm:'Error/Breakpoint cought.\\Press Continue or Abort.' withCRs

                   yesLabel:'Continue' noLabel:'Abort')

            ifTrue:[

                ^ nil

            ].

        ] ifFalse:[

            self information:'Error cought.\\Press OK to abort the operation.' withCRs.

        ].

        AbortOperationRequest raise.

        "not reached"

    ].