"

 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

       classVariableNames:'BreakpointSignal CallingLevel'

       poolDictionaries:''

       category:'System-Support'

!

MessageTracer comment:'

COPYRIGHT (c) 1994 by Claus Gittinger

	      All Rights Reserved

'!

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

"

!

version

"

"

!

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

"

!

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

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

"

! !

!MessageTracer class methodsFor:'initialization'!

initialize

    BreakpointSignal isNil ifTrue:[

	Object initialize.

	BreakpointSignal := Object haltSignal newSignalMayProceed:true.

	BreakpointSignal nameClass:self message:#breakpointSignal.

	BreakpointSignal notifierString:'breakpoint encountered'.

    ]

! !

!MessageTracer class methodsFor:'signal access'!

breakpointSignal

    ^ BreakpointSignal

! !

!MessageTracer class methodsFor:'execution trace '!

trace:aBlock

    "evaluate aBlock sending trace information to stdout.

    "

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

    "

!

traceFull:aBlock

    "evaluate aBlock sending trace information to stdout.

     Return the value of the block.

    "

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

    "

!

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]

    "

! !

!MessageTracer methodsFor:'trace helpers '!

    ObjectMemory stepInterruptHandler:self.

	StepInterruptPending := nil.

	ObjectMemory stepInterruptHandler:nil.

    ]

    "

    "

!

stepInterrupt

    "called for every send while tracing"

    StepInterruptPending := nil.

    ].

    ^ self

! !

!MessageTracer class methodsFor:'helpers '!

printEntryFull:aContext level:lvl

    (String new:lvl) errorPrint.

    'enter ' errorPrint. 

    aContext methodClass name errorPrint.

    ' ' errorPrint.

    aContext selector errorPrint. 

    ' rcvr=' errorPrint. 

    aContext receiver "printString" errorPrint.

    ' args=' errorPrint. 

    (aContext args) "printString" errorPrint.

    ' from:' errorPrint. aContext sender errorPrintNL.

!

printEntryFull:aContext

    self printEntryFull:aContext level:0

!

printEntrySender:aContext

    aContext methodClass name errorPrint.

    ' ' errorPrint. aContext selector errorPrint. 

    ' from ' errorPrint.

    aContext sender errorPrintNL.  

!

printExit:aContext with:retVal level:lvl

    (String new:lvl) errorPrint.

    'leave ' errorPrint. 

    aContext methodClass name errorPrint.

    ' ' errorPrint.

    aContext selector errorPrint. 

    ' rcvr=' errorPrint. 

    aContext receiver "printString" errorPrint.

    ' return:' errorPrint. retVal "printString" errorPrintNL.

!

printExit:aContext with:retVal

    self printExit:aContext with:retVal level:0

! !

!MessageTracer class methodsFor:'object wrapping'!

wrap:anObject selectors:aCollection onEntry:entryBlock onExit:exitBlock

    aCollection do:[:aSelector |

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

    ]

!

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 setSelectors:(Array new) methods:(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 

	setSelectors:(newClass selectorArray copyWith:aSelector)

	methods:(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 gets the current context passed as argument. 

     ExitBlock will be called, when the method is left, and gets the context and 

     the methods return value as arguments."

    |selector class trapMethod s spec lits src idx|

    CallingLevel := 0.

    "

     create a new method, which calls the original one,

     but only if not already being trapped.

    "

    (aMethod isNil or:[aMethod isWrapped]) ifTrue:[

	^ aMethod

    ].

    aMethod isLazyMethod ifTrue:[

	aMethod makeRealMethod

    ].

    "

     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.