"

 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

	poolDictionaries:''

	category:'System-Debugging-Support'

!

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.

    [author:]

        Claus Gittinger

"

!

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):

                                                                        [exBegin]

     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 

                                                                        [exEnd]

  (by method):

                                                                        [exBegin]

     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:).

                                                                        [exEnd]

  (by method & instance class):

                                                                        [exBegin]

     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:).

                                                                        [exEnd]

  tracing specific methods:

  (by class/selector):

                                                                        [exBegin]

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

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

     MessageTracer untraceClass:SequenceableCollection 

                                                                        [exEnd]

  (by method):

                                                                        [exBegin]

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

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

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

                                                                        [exEnd]

  object trapping:

                                                                        [exBegin]

     |o|

     o := OrderedCollection new.

     MessageTracer trapAll:o.

     o collect:[:el | el].

                                                                        [exEnd]

"

! !

initialize

    BreakpointSignal isNil ifTrue:[

    ]

    "

     BreakpointSignal := nil.

     MessageTracer initialize

    "

! !

breakpointSignal

    ^ BreakpointSignal

! !

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

! !

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

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

     aSelector is sent to instances of orgClass 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 implClass newClass save dict|

    WrappedMethod autoload.     "/ just to make sure ...

    "

     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 := #originalMethod. ').    "/ just to get a literal to be replaced by theoriginal method

    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:orgClass 

                            inCategory:'trapping'

                             notifying:nil

                               install:false

                            skipIfSame:false

                                silent:true.

        ]

    ] valueNowOrOnUnwindDo:[

        Compiler stcCompilation:save

    ].

    implClass := orgClass whichClassIncludesSelector:aSelector.

    implClass isNil ifTrue:[

        Transcript showCR:aSelector , ' is not understood by ' , orgClass name.

    ] ifFalse:[

        trapMethod changeLiteral:#originalMethod to:(implClass compiledMethodAt:aSelector).

    ].

    entryBlock notNil ifTrue:[

        trapMethod changeLiteral:#literal1 to:entryBlock.

    ].

    exitBlock notNil ifTrue:[

        trapMethod changeLiteral:#literal2 to: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'.

    trapMethod changeClassTo:WrappedMethod.

    dict := orgClass methodDictionary.

    "

     if not already trapping, create a new class

    "

    orgClass category == #'* trapping *' ifTrue:[

        dict at:aSelector put:trapMethod.

        orgClass methodDictionary:dict.

        newClass := orgClass superclass.

    ] ifFalse:[

        myMetaclass := orgClass class.

        newClass := myMetaclass copy new.

        newClass setSuperclass:orgClass superclass.

        newClass instSize:orgClass instSize.

        newClass flags:orgClass flags.

        newClass setClassVariableString:orgClass classVariableString.

        newClass setInstanceVariableString:orgClass instanceVariableString.

        newClass setName:orgClass name.

        newClass category:orgClass category.

        newClass methodDictionary:dict.      

        orgClass setSuperclass:newClass.

        orgClass setClassVariableString:''.

        orgClass setInstanceVariableString:''.

        orgClass category:#'* trapping *'.

        dict := MethodDictionary new:1.

        dict at:aSelector put:trapMethod.

        orgClass methodDictionary:dict.

    ].

    trapMethod changeLiteral:(newClass superclass) to:newClass.

    ObjectMemory flushCaches.

    "

     MessageTracer 

                wrapClass:Point

                 selector:#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 selector:#scaleBy:.  

     (1@2) scaleBy:5.         

    "

    "

     MessageTracer 

                wrapClass:Integer

                 selector:#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 selector:#factorial.  

     Transcript showCR:'5 factorial normal'.

     5 factorial.         

    "

    "

     |lvl|

     lvl := 0.

     MessageTracer 

                wrapClass:Integer 

                 selector:#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 selector:#factorial.  

     Transcript showCR:'5 factorial normal'.

     5 factorial.         

    "

    "Modified: 25.6.1996 / 22:01:05 / stefan"

    "Modified: 10.9.1996 / 20:07:01 / cg"

! !

cleanup

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

     this cleans up everything ..."

    self untrapAllClasses.

    self unwrapAllMethods

    "

     MessageTracer cleanup

    "

! !

debugTrace:aBlock

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

    Smalltalk sendTraceOn.

    ^ aBlock valueNowOrOnUnwindDo:[

        Smalltalk sendTraceOff.

    ]

    "

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

    "

    "Modified: 18.3.1996 / 19:49:36 / cg"

!

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]

    "

! !