"

 COPYRIGHT (c) 1994 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.

"

Object subclass:#MessageTracer

	instanceVariableNames:'traceDetail'

	classVariableNames:'BreakpointSignal CallingLevel BreakBlock TraceSenderBlock

		LeaveBlock MethodCounts TraceFullBlock'

	poolDictionaries:''

	category:'System-Debugging-Support'

!

!MessageTracer class methodsFor:'documentation'!

copyright

"

 COPYRIGHT (c) 1994 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 provides a common home for the tracing

    facilities (originally, they where in Object, but have been moved to

    allow easier separation of development vs. runtime configurations.

    tracing execution of a block:

	MessageTracer trace:[ ... ]

	MessageTracer traceFull:[ ... ]

	(for system developper only:)

	MessageTracer debugTrace:[ ... ]

    trapping sends to a specific object:

	MessageTracer trap:anObject selector:aSelector

	...

	MessageTracer untrap:anObject selector:aSelector

	or:

	MessageTracer untrap:anObject

    trapping some messages sent to a specific object:

	MessageTracer trap:anObject selectors:aCollectionOfSelectors

	...

	MessageTracer untrap:anObject

    trapping any message sent to a specific object:

	MessageTracer trapAll:anObject

	...

	MessageTracer untrap:anObject

    trapping evaluation of a specific method:

	MessageTracer trapMethod:aMethod

	...

	MessageTracer unwrapMethod:aMethod

    trapping evaluation of a specific method with

    receiver being an instance of some class:

	MessageTracer trapMethod:aMethod forInstancesOf:aClass

	...

	MessageTracer unwrapMethod:aMethod

    tracing sends to a specific object:

	MessageTracer trace:anObject selector:aSelector

	...

	MessageTracer untrace:anObject selector:aSelector

	or:

	MessageTracer untrace:anObject

    tracing sender only:

	MessageTracer traceSender:anObject selector:aSelector

	...

	MessageTracer untrace:anObject selector:aSelector

	or:

	MessageTracer untrace:anObject

    tracing evaluation of a specific method:

	MessageTracer traceMethod:aMethod

	...

	MessageTracer unwrapmethod:aMethod

  see more in examples and in method comments.

"

!

examples

"

  For the common cases, you will find a menu entry in the SystemBrowser.

  Howeever, more special cases (especially with condition checks) can be

  set up by evaluating the lower level entries.

  trapping specific methods:

  (by class/selector):

     MessageTracer trapClass:Collection selector:#select:.

     Dictionary new select:[:e | ].       'not cought - Dictionary has its own select'.

     (Array new:10) select:[:e | ].       'not cought - SeqColl has its own select'.

     Set new select:[:e | ].              'cought - Set inherits this from Collection'.

     MessageTracer untrapClass:Collection 

  (by method):

     MessageTracer trapMethod:(Collection compiledMethodAt:#select:).

     Dictionary new select:[:e | ].       'not cought - Dictionary has its own select'.

     (Array new:10) select:[:e | ].       'not cought - SeqColl has its own select'.

     Set new select:[:e | ].              'cought - Set inherits this from Collection'.

     MessageTracer unwrapMethod:(Collection compiledMethodAt:#select:).

  (by method & instance class):

     MessageTracer trapMethod:(SequenceableCollection compiledMethodAt:#select:)

		   forInstancesOf:SortedCollection.

     Dictionary new select:[:e | ].       'not cought - Dictionary has its own select'.

     (Array new:10) select:[:e | ].       'not cought - not a SortedCollection'.

     OrderedCollection new select:[:e | ]. 'not cought - not a SortedCollection'.

     SortedCollection new select:[:e | ].  'cought - Set inherits this from Collection'.

     MessageTracer unwrapMethod:(SequenceableCollection compiledMethodAt:#select:).

  tracing specific methods:

  (by class/selector):

     MessageTracer traceClass:SequenceableCollection selector:#quickSortFrom:to:.

     #(6 1 9 66 2 17) copy sort.

     MessageTracer untraceClass:SequenceableCollection 

  (by method):

     MessageTracer traceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).

     #(6 1 9 66 2 17) copy sort.

     MessageTracer unwrapMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:). 

  object trapping:

     |o|

     o := OrderedCollection new.

     MessageTracer trapAll:o.

     o collect:[:el | el].

"

! !

!MessageTracer class methodsFor:'initialization'!

initialize

    BreakpointSignal isNil ifTrue:[

        BreakpointSignal := HaltSignal newSignalMayProceed:true.

        BreakpointSignal nameClass:self message:#breakpointSignal.

        BreakpointSignal notifierString:'breakpoint encountered'.

        BreakBlock       := [:con | BreakpointSignal raiseIn:con].

        TraceSenderBlock := [:con | MessageTracer printEntrySender:con].

        TraceFullBlock   := [:con | con fullPrintAll].

        LeaveBlock       := [:con :retVal | ].

    ]

    "

     BreakpointSignal := nil.

     MessageTracer initialize

    "

    "Modified: 15.12.1995 / 18:19:13 / cg"

! !

!MessageTracer class methodsFor:'Signal constants'!

breakpointSignal

    ^ BreakpointSignal

! !

!MessageTracer class methodsFor:'class tracing'!

traceClass:aClass selector:aSelector

    "arrange for a trace message to be output on Stderr, when a message with aSelector is

     sent to instances of aClass (or subclass instances). Use untraceClass to remove this."

    self traceMethod:(aClass compiledMethodAt:aSelector)

    "

     MessageTracer traceClass:Integer selector:#factorial.

     5 factorial.

     MessageTracer untraceClass:Integer 

    "

    "

     MessageTracer traceClass:SequenceableCollection selector:#quickSortFrom:to:.

     #(6 1 9 66 2 17) copy sort.

     MessageTracer untraceClass:SequenceableCollection 

    "

    "

     MessageTracer traceClass:Array selector:#at:.

     MessageTracer traceClass:Array selector:#at:put:.

     #(6 1 9 66 2 17) copy sort.

     MessageTracer untraceClass:Array 

    "

!

untraceAllClasses

    "remove all traces of messages sent to any class"

    "just a rename for your convenience - the same basic mechanism is used for all of these

     trace facilities ..."

    ^ self untrapAllClasses

!

untraceClass:aClass

    "remove all traces of messages sent to instances of aClass"

    "just a rename for your convenience - the same basic mechanism is used for all of these

     trace facilities ..."

    ^ self untrapClass:aClass

! !

!MessageTracer class methodsFor:'class wrapping'!

wrapClass:aClass selector:aSelector onEntry:entryBlock onExit:exitBlock 

    "arrange for the two blocks entryBlock and exitBlock to be evaluated whenever

     aSelector is sent to instances of aClass or subclasses. 

     EntryBlock will be called on entry, and get the current context passed as argument. 

     ExitBlock will be called, when the method is left, and get context and the methods return value as arguments.

    "

    |myMetaclass trapMethod s spec lits idx newClass save|

    "

     create a new method, which calls the original one,

     but only if not already being trapped.

    "

    spec := Parser methodSpecificationForSelector:aSelector.

    s := WriteStream on:String new.

    s nextPutAll:spec.

    s cr.

    s nextPutAll:'|retVal stubClass|'; cr.

    entryBlock notNil ifTrue:[

        s nextPutAll:'#literal1 yourself value:thisContext.'; cr.

    ].

    s nextPutAll:('retVal := super ' , spec , '.'); cr.

    exitBlock notNil ifTrue:[

        s nextPutAll:'#literal2 yourself value:thisContext value:retVal.'; cr.

    ].

    s nextPutAll:'^ retVal'; cr.

    save := Compiler stcCompilation.

    Compiler stcCompilation:#never.

    [

        Class withoutUpdatingChangesDo:[

            trapMethod := Compiler compile:s contents 

                              forClass:aClass 

                            inCategory:'trapping'

                             notifying:nil

                               install:false

                            skipIfSame:false

                                silent:true.

        ]

    ] valueNowOrOnUnwindDo:[

        Compiler stcCompilation:save

    ].

    lits := trapMethod literals.

    entryBlock notNil ifTrue:[

        lits at:(lits indexOf:#literal1) put:entryBlock.

    ].

    exitBlock notNil ifTrue:[

        lits at:(lits indexOf:#literal2) put:exitBlock.

    ].

    "

     change the source of this new method

     (to avoid confusion in the debugger ...)

    "

    trapMethod source:'this is a wrapper method - not the real one'.

    "

     if not already trapping, create a new class

    "

    aClass category == #trapping ifTrue:[

        idx := aClass selectorArray indexOf:aSelector.

        idx ~~ 0 ifTrue:[

            aClass methodArray at:idx put:trapMethod

        ] ifFalse:[

            aClass 

                setSelectors:(aClass selectorArray copyWith:aSelector)

                methods:(aClass methodArray copyWith:trapMethod)

        ].

        lits at:(lits indexOf:#literal3) put:aClass superclass.

    ] ifFalse:[

        myMetaclass := aClass class.

        newClass := myMetaclass copy new.

        newClass setSuperclass:aClass superclass.

        newClass instSize:aClass instSize.

        newClass flags:aClass flags.

        newClass setClassVariableString:aClass classVariableString.

        newClass setInstanceVariableString:aClass instanceVariableString.

        newClass setName:aClass name.

        newClass category:aClass category.

        newClass       

            setSelectors:aClass selectorArray

            methods:aClass methodArray.

        aClass setSuperclass:newClass.

        aClass setClassVariableString:''.

        aClass setInstanceVariableString:''.

        aClass category:#trapping.

        aClass 

            setSelectors:(Array with:aSelector)

            methods:(Array with:trapMethod).

        lits at:(lits indexOf:#literal3) put:newClass.

    ].

    ObjectMemory flushCaches.

    "

     MessageTracer 

                wrapMethod:(Point compiledMethodAt:#scaleBy:) 

                   onEntry:nil

                    onExit:[:con :retVal |

                               Transcript show:'leave Point>>scaleBy:; returning:'.

                               Transcript showCr:retVal printString.

                               Transcript endEntry

                           ].

     (1@2) scaleBy:5.   

     MessageTracer untrapClass:Point.  

     (1@2) scaleBy:5.         

    "

    "

     MessageTracer 

                wrapMethod:(Integer compiledMethodAt:#factorial) 

                   onEntry:[:con |

                               Transcript showCr:('entering ' , con receiver printString , '>>factorial').

                           ]

                    onExit:[:con :retVal |

                               Transcript show:'leave Integer>>factorial; returning:'.

                               Transcript showCr:retVal printString.

                               Transcript endEntry

                           ].

     Transcript showCr:'5 factorial traced'.

     5 factorial.   

     MessageTracer untrapClass:Integer.  

     Transcript showCr:'5 factorial normal'.

     5 factorial.         

    "

    "

     |lvl|

     lvl := 0.

     MessageTracer 

                wrapMethod:(Integer compiledMethodAt:#factorial) 

                   onEntry:[:con |

                               Transcript spaces:lvl. lvl := lvl + 2.

                               Transcript showCr:('entering ' , con receiver printString , '>>factorial').

                           ]

                    onExit:[:con :retVal |

                               lvl := lvl - 2. Transcript spaces:lvl.

                               Transcript show:('leave ' , con receiver printString , '>>factorial; returning:').

                               Transcript showCr:retVal printString.

                               Transcript endEntry

                           ].

     Transcript showCr:'5 factorial traced'.

     5 factorial.   

     MessageTracer untrapClass:Integer.  

     Transcript showCr:'5 factorial normal'.

     5 factorial.         

    "

    "Modified: 13.12.1995 / 16:05:26 / cg"

! !

!MessageTracer class methodsFor:'cleanup'!

cleanup

    "if you forgot which classes/methods where wrapped and/or trapped,

     this cleans up everything ..."

    self untrapAllClasses.

    self unwrapAllMethods

    "

     MessageTracer cleanup

    "

! !

!MessageTracer class methodsFor:'execution trace '!

debugTrace:aBlock

    "trace execution of aBlock. This is for system debugging only"

    Smalltalk debugOn.

    ^ aBlock valueNowOrOnUnwindDo:[

	Smalltalk debugOff.

    ]

    "

     MessageTracer debugTrace:[#(6 5 4 3 2 1) sort]

    "

!

trace:aBlock

    "evaluate aBlock sending trace information to stdout.

     Return the value of the block."

    ^ self new trace:aBlock detail:false.

    "

     MessageTracer trace:[#(6 5 4 3 2 1) sort]

    "

!

traceFull:aBlock

    "evaluate aBlock sending trace information to stdout.

     Return the value of the block.

     The trace information is more detailed."

     ^ self new trace:aBlock detail:true.

    "

     MessageTracer traceFull:[#(6 5 4 3 2 1) sort]

    "

! !

!MessageTracer class methodsFor:'method breakpointing'!

trapClass:aClass selector:aSelector

    "arrange for the debugger to be entered when a message with aSelector is 

     sent to instances of aClass (or subclass instances). Use untrapClass to remove this trap.

     Be careful, to not place a trap on code needed in the debugger (i.e. on scrollBars etc.);

     if there is a need to trap those, use the low-level wrap-methods, and put a check into the

     entry/leave blocks."

    self trapMethod:(aClass compiledMethodAt:aSelector)

    "

     MessageTracer trapClass:Collection selector:#select:.

     Dictionary new select:[:e | ].       'not cought - Dictionary has its own select'.

     (Array new:10) select:[:e | ].       'not cought - SeqColl has its own select'.

     Set new select:[:e | ].              'cought - Set inherits this from Collection'.

     MessageTracer untrapClass:Collection 

    "

!

trapMethod:aMethod

    "arrange for the debugger to be entered when aMethod is about to be executed.

     Use unwrapMethod or untrapClass to remove this trap.

     Be careful, to not place a trap on code needed in the debugger (i.e. on scrollBars etc.);

     if there is a need to trap those, use the low-level wrap-methods, and put a check into the

     entry/leave blocks."

    ^ self wrapMethod:aMethod

	      onEntry:BreakBlock

	       onExit:LeaveBlock.

    "

     MessageTracer trapMethod:(Collection compiledMethodAt:#select:).