"

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

       classVariableNames:''

       poolDictionaries:''

       category:'System-Support'

!

MessageTracer comment:'

COPYRIGHT (c) 1994 by Claus Gittinger

              All Rights Reserved

'!

!MessageTracer class methodsFor:'documentation'!

documentation

"

    This is not a real class, in that there are no instances of

    MessageTracer.

    It has been created, to provide a common home for the tracing

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

    allow easier separation of development vs. runtime configurations.

    trapping sends to a specific object:

        MessageTracer trap:anObject selector:aSelector

        ...

        MessageTracer untrap:anObject selector:aSelector

        or:

        MessageTracer untrap:anObject

    trapping evaluation of a specific method:

        MessageTracer trapMethod:aMethod

        ...

        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

"

! !

!MessageTracer class methodsFor:'object wrapping'!

wrap:anObject selector:aSelector onEntry:entryBlock onExit:exitBlock

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

     a message with aSelector is sent to anObject. 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 the context and the methods return value as arguments.

     The current implementation does not allow integers or nil to be wrapped."

    "I have not yet enough experience, if the wrapped original method should

     run as an instance of the original, or of the catching class; 

     The latter has the advantage of catching recursive and other sends, while

     it might lead into trouble when the message is sent from a debugger or a long

     return is done out of the original method ...

     Time will show, you can experiment by setting the withOriginalClass: flag to false

    "

    ^ self wrap:anObject selector:aSelector onEntry:entryBlock onExit:exitBlock withOriginalClass:true

!

wrap:anObject selector:aSelector onEntry:entryBlock onExit:exitBlock withOriginalClass:withOriginalClass

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

     a message with aSelector is sent to anObject. 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 the methods return value as argument.

     The argument withOriginalClass controls if the original method should be called for with

     the receiver being trapped upon or not.

     The current implementation does not allow integers or nil to be wrapped."

    |newClass orgClass myMetaclass trapMethod s spec lits|

    "

     create a new (anonymous) subclass of the receivers class

     but only if not already being trapped.

    "

    orgClass := anObject class.

    orgClass category == #trapping ifTrue:[

        newClass := orgClass

    ] ifFalse:[

        myMetaclass := orgClass class.

        newClass := myMetaclass new.

        newClass setSuperclass:orgClass.

        newClass instSize:orgClass instSize.

        newClass flags:orgClass flags.

        newClass setClassVariableString:''.

        newClass setInstanceVariableString:''.

        newClass setName:orgClass name.

        newClass category:#trapping.

        newClass setSelectorArray:(Array new).

        newClass setMethodArray:(Array new).

    ].

    "

     create a method, executing the trap-blocks and the original method via a super-send

    "

    spec := Parser methodSpecificationForSelector:aSelector.

    s := WriteStream on:String new.

    s nextPutAll:spec.

    s cr.

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

    withOriginalClass ifTrue:[

        s nextPutAll:'stubClass := self class.'; cr.

        s nextPutAll:'self changeClassTo:(stubClass superclass).'; 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.

    ].

    withOriginalClass ifTrue:[

        s nextPutAll:'self changeClassTo:stubClass.'; cr.

    ].

    s nextPutAll:'^ retVal'; cr.

    trapMethod := Compiler compile:s contents 

                          forClass:newClass 

                        inCategory:'breakpointed'

                         notifying:nil

                           install:false

                        skipIfSame:false

                            silent:true.

    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'.

    "

     install this new method

    "

    newClass setSelectorArray:(newClass selectorArray copyWith:aSelector).

    newClass setMethodArray:(newClass methodArray copyWith:trapMethod).

    "

     and finally, the big trick:

    "

    anObject changeClassTo:newClass

    "

     |p|

     p := Point new copy.

     MessageTracer 

                wrap:p

            Selector:#y: 

             onEntry:nil

              onExit:[:retVal |

                         Transcript show:'leave Point>>x:, returning:'.

                         Transcript showCr:retVal printString.

                         Transcript endEntry

                     ].

     Transcript showCr:'sending x: ...'.

     p x:1.

     Transcript showCr:'sending y: ...'.

     p y:2.

     p untrap.

     Transcript showCr:'sending x: ...'.

     p x:2.

     Transcript showCr:'sending y: ...'.

     p y:1.

    "

    "

     |p|

     p := Point new copy.

     MessageTracer wrap:p

               Selector:#y: 

                onEntry:[:context | self halt:'you are trapped']

                 onExit:nil.

     Transcript showCr:'sending x: ...'.

     p x:1.

     Transcript showCr:'sending y: ...'.

     p y:2.

     p untrap.

     Transcript showCr:'sending x: ...'.

     p x:2.

     Transcript showCr:'sending y: ...'.

     p y:1.

    "

! !

!MessageTracer class methodsFor:'method wrapping'!

wrapMethod:aMethod onEntry:entryBlock onExit:exitBlock 

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

     aMethod is evaluated. 

     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."

    |parser selector args nArgs class trapMethod s spec lits src idx|

    "

     create a new method, which calls the original one,

     but only if not already being trapped.

    "

    aMethod isWrapped ifTrue:[

        ^ aMethod

    ].

    "

     get class/selector

    "

    class := aMethod containingClass.

    class isNil ifTrue:[

        self error:'cannot place trap (no containing class found)'.

        ^ aMethod

    ].

    selector := class selectorForMethod:aMethod.

    "

     get a new method-spec

    "

    spec := Parser methodSpecificationForSelector:selector.

    "

     create a method, executing the trap-blocks and the original method via a direct call

    "

    s := WriteStream on:String new.

    s nextPutAll:spec.

    s nextPutAll:' |retVal| '.

    entryBlock notNil ifTrue:[

        s nextPutAll:'#entryBlock yourself value:thisContext. '.

    ].

    s nextPutAll:'retVal := #originalMethod yourself';

      nextPutAll:             ' valueWithReceiver:(thisContext receiver)'; 

      nextPutAll:             ' arguments:(thisContext args)';

      nextPutAll:             ' selector:(thisContext selector)'; 

      nextPutAll:             ' search:(thisContext searchClass) yourself. '.

    exitBlock notNil ifTrue:[

        s nextPutAll:'#exitBlock yourself value:thisContext value:retVal.'.

    ].

    s nextPutAll:'^ retVal'; cr.

    src := s contents.

    trapMethod := Compiler compile:src 

                          forClass:UndefinedObject 

                        inCategory:aMethod category

                         notifying:nil

                           install:false

                        skipIfSame:false

                            silent:true.

    trapMethod changeClassTo:WrappedMethod.

    lits := trapMethod basicLiterals.

    entryBlock notNil ifTrue:[

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

    ].

    lits at:(lits indexOf:#originalMethod) put:aMethod.

    exitBlock notNil ifTrue:[

        lits at:(lits indexOf:#exitBlock) 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'.

    idx := class selectorArray indexOf:selector.

    idx ~~ 0 ifTrue:[

        class methodArray at:idx put:trapMethod

    ] ifFalse:[

        self halt:'oops, unexpected error'.

        ^ aMethod

    ].

    ObjectMemory flushCaches.

    ^ trapMethod

    "

     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 unwrapMethod:(Point compiledMethodAt:#scaleBy:).  

     (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 unwrapMethod:(Integer compiledMethodAt:#factorial).  

     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 unwrapMethod:(Integer compiledMethodAt:#factorial).  

     Transcript showCr:'5 factorial normal'.

     5 factorial.         

    "

!

unwrapMethod:aMethod 

    "remove any wrapper on aMethod"

    |parser selector args nArgs class originalMethod s spec lits src idx|

    aMethod isWrapped ifFalse:[

        ^ aMethod

    ].

    "

     get class/selector

    "

    class := aMethod containingClass.

    class isNil ifTrue:[

        self error:'cannot place trap (no containing class found)'.

        ^ aMethod

    ].

    selector := class selectorForMethod:aMethod.

    originalMethod := aMethod originalMethod.

    originalMethod isNil ifTrue:[

        self error:'oops, could not find original method'.

        ^ aMethod

    ].

    idx := class selectorArray indexOf:selector.

    idx ~~ 0 ifTrue:[

        class methodArray at:idx put:originalMethod

    ] ifFalse:[

        self halt:'oops, unexpected error'.

        ^ aMethod

    ].

    ObjectMemory flushCaches.

    ^ originalMethod

!

unwrapAllMethods

    "just in case you dont know what methods have break/trace-points

     on them; this removes them all"

    WrappedMethod allInstancesDo:[:aMethod |

        self unwrapMethod:aMethod

    ]

! !

!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.

    "

    |parser sourceString selector args nArgs newClass orgClass myMetaclass trapMethod s spec lits src idx|

    "

     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.

    trapMethod := Compiler compile:s contents 

                          forClass:newClass 

                        inCategory:'trapping'

                         notifying:nil

                           install:false

                        skipIfSame:false

                            silent:true.

    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 setSelectorArray:(aClass selectorArray copyWith:aSelector).

            aClass setMethodArray:(aClass methodArray copyWith:trapMethod)

        ].

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

    ] ifFalse:[

        myMetaclass := aClass class.

        newClass := myMetaclass 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 setSelectorArray:aClass selectorArray.

        newClass setMethodArray:aClass methodArray.

        aClass setSuperclass:newClass.

        aClass setClassVariableString:''.

        aClass setInstanceVariableString:''.

        aClass category:#trapping.

        aClass setSelectorArray:(Array with:aSelector).

        aClass setMethodArray:(Array with:trapMethod).

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

    ].

    ObjectMemory flushCaches.