"

 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.

"

"{ Package: 'stx:libbasic3' }"

Object subclass:#MessageTracer

	instanceVariableNames:'traceDetail tracedBlock'

	classVariableNames:'BreakpointSignal CallingLevel BreakBlock TraceSenderBlock

		TraceSenderBlock2 LeaveBreakBlock LeaveTraceBlock MethodCounts

		MethodCountsPerReceiverClass MethodMemoryUsage MethodTiming

		TraceFullBlock TraceFullBlock2 ObjectWrittenBreakpointSignal

		ObjectCopyHolders TimeForWrappers MockedMethodMarker'

	poolDictionaries:''

	category:'System-Debugging-Support'

!

MessageTracer subclass:#InteractionCollector

	instanceVariableNames:''

	classVariableNames:''

	poolDictionaries:''

	privateIn:MessageTracer

!

Object subclass:#MethodTimingInfo

	instanceVariableNames:'count minTime maxTime sumTimes avgTime'

	classVariableNames:''

	poolDictionaries:''

	privateIn:MessageTracer

!

MessageTracer subclass:#PrintingMessageTracer

	instanceVariableNames:'output'

	classVariableNames:''

	poolDictionaries:''

	privateIn:MessageTracer

!

!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 developer 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 caught - Dictionary has its own select'.

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

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

     MessageTracer untrapClass:Collection

									[exEnd]

  (by method):

									[exBegin]

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

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

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

     Set new select:[:e | ].              'caught - 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 caught - Dictionary has its own select'.

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

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

     SortedCollection new select:[:e | ].  'caught - 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]

  trapping modifications to an objects instVars:

									[exBegin]

     |o|

     o := Point new.

     MessageTracer trapModificationsIn:o.

     o x:1.

     o y:2.

     o x:1.

     o y:2.

     MessageTracer untrap:o

									[exEnd]

  trapping modifications of a particular instVar:

									[exBegin]

     |o|

     o := Point new.

     MessageTracer trapModificationsIn:o filter:[:old :new | old x ~~ new x].

     o x:1.

     o y:2.

     o x:1.

     o y:2.

     MessageTracer untrap:o

									[exEnd]

  tracing during block execution:

									[exBegin]

     MessageTracer trace:[ 10 factorialR ]

									[exEnd]

"

! !

!MessageTracer class methodsFor:'Signal constants'!

breakpointSignal

    ^ BreakpointSignal

!

objectWrittenBreakpointSignal

    ^ ObjectWrittenBreakpointSignal

    "Created: / 21.4.1998 / 14:38:49 / cg"

! !

!MessageTracer class methodsFor:'class initialization'!

initialize

    BreakpointSignal isNil ifTrue:[

        "/ BreakpointSignal := HaltSignal newSignalMayProceed:true.

        "/ BreakpointSignal nameClass:self message:#breakpointSignal.

        BreakpointSignal := BreakPointInterrupt.

        BreakpointSignal notifierString:'breakpoint encountered'.

    ].

    ObjectWrittenBreakpointSignal isNil ifTrue:[

        ObjectWrittenBreakpointSignal := BreakpointSignal newSignalMayProceed:true.

        ObjectWrittenBreakpointSignal nameClass:self message:#objectWrittenBreakpointSignal.

        ObjectWrittenBreakpointSignal notifierString:'object modified'.

    ].

    "/ the following have been written as cheapBlocks (by purpose)

    BreakBlock       := [:con | BreakpointSignal raiseRequestWith:nil errorString:nil in:con].

    TraceSenderBlock  := [:con | MessageTracer printEntrySender:con on:(Smalltalk at:#Stderr)     ].

    TraceSenderBlock2 := [:con | MessageTracer printEntrySender:con on:(Smalltalk at:#Transcript) ].

    TraceFullBlock    := [:con | MessageTracer traceEntryFull:con on:(Smalltalk at:#Stderr)       ].

    TraceFullBlock2   := [:con | MessageTracer traceEntryFull:con on:(Smalltalk at:#Transcript)   ].

    LeaveBreakBlock  := [:con :retVal | retVal ].

    LeaveTraceBlock  := [:con :retVal | retVal ].

    ObjectMemory addDependent:self.

    MockedMethodMarker := Object new.

    "

     BreakpointSignal := nil.

     MessageTracer initialize

    "

    "Modified: / 15-09-2011 / 19:02:13 / cg"

    "Modified: / 29-07-2014 / 09:16:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

update:something with:parameter from:changedObject

    "sent when restarted after a snapIn"

    (something == #restarted) ifTrue:[

	TimeForWrappers := nil

    ]

    "Created: / 30.7.1998 / 17:00:09 / cg"

! !

!MessageTracer class methodsFor:'class tracing'!

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: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 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:'<context: #return>'; 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.

    ParserFlags

	withSTCCompilation:#never

	do:[

	    Class withoutUpdatingChangesDo:[

		trapMethod := Compiler

				compile:s contents

				forClass:orgClass

				inCategory:'trapping'

				notifying:nil

				install:false

				skipIfSame:false

				silent:true.

	    ]

	].

    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.

    trapMethod register.

    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 setSharedPoolNames:(orgClass sharedPoolNames).

	newClass setInstanceVariableString:orgClass instanceVariableString.

	newClass setName:orgClass name.

	newClass setCategory:orgClass category.

	newClass methodDictionary:dict.

	orgClass setSuperclass:newClass.

	orgClass setClassVariableString:''.

	orgClass setInstanceVariableString:''.

	orgClass setCategory:#'* 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 |