"
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:).
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:).
"
!
trapMethod:aMethod forInstancesOf:aClass
"arrange for the debugger to be entered when aMethod is about to be executed
for an instance of aClass.
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:[:context |
(context receiver isMemberOf:aClass) ifTrue:[
BreakpointSignal raiseIn:context
]
]
onExit:LeaveBlock.
"
MessageTracer trapMethod:(View compiledMethodAt:#redraw) forInstancesOf:myView.
"
!
untrapAllClasses
"remove any traps on any class"
Smalltalk allBehaviorsDo:[:aClass |
self untrapClass:aClass
]
"
MessageTracer untrapAllClasses
"
!
untrapClass:aClass
"remove any traps on aClass"
"this is done by just patching the class back to the original"
|orgClass|
aClass category == #trapping ifFalse:[
^ self
].
orgClass := aClass superclass.
aClass setSuperclass:orgClass superclass.
aClass setClassVariableString:orgClass classVariableString.
aClass setInstanceVariableString:orgClass instanceVariableString.
aClass category:orgClass category.
aClass
setSelectors:orgClass selectorArray
methods:orgClass methodArray.
ObjectMemory flushCaches.
"
MessageTracer untrapClass:Point
"
!
untrapClass:aClass selector:aSelector
"remove trap of aSelector sent to aClass"
|idx sels newSels newMethods|
aClass category == #trapping ifFalse:[
^ self
].
sels := aClass selectorArray.
idx := sels indexOf:aSelector.
idx == 0 ifTrue:[
^ self
].
sels size == 1 ifTrue:[
"the last trapped method"
^ self untrapClass:aClass
].
newSels := sels copyWithoutIndex:idx.
newMethods := aClass methodArray copyWithoutIndex:idx.
aClass selectors:newSels methods:newMethods.
"
MessageTracer trapClass:Point selector:#copy.
(1@2) copy.
(1@2) deepCopy.
MessageTracer trapClass:Point selector:#deepCopy.
(1@2) copy.
(1@2) deepCopy.
MessageTracer untrapClass:Point selector:#copy.
(1@2) copy.
(1@2) deepCopy.
MessageTracer untrapClass:Point selector:#deepCopy.
(1@2) copy.
(1@2) deepCopy.
"
!
untrapMethod:aMethod
"remove break on aMethod"
"just a rename for your convenience - the same basic mechanism is used for all of these
trace facilities ..."
^ self unwrapMethod:aMethod
! !
!MessageTracer class methodsFor:'method counting'!
countMethod:aMethod
"arrange for a aMethods execution to be counted.
Use unwrapMethod to remove this."
|lvl inside|
MethodCounts isNil ifTrue:[
MethodCounts := IdentityDictionary new.
].
MethodCounts at:aMethod put:0.
^ self wrapMethod:aMethod
onEntry:[:con |
|cnt|
cnt := MethodCounts at:aMethod ifAbsent:0.
MethodCounts at:aMethod put:(cnt + 1).
]
onExit:[:con :retVal |
]
"
MessageTracer countMethod:(Integer compiledMethodAt:#factorial).
5 factorial.
MessageTracer executionCountOf:(Integer compiledMethodAt:#factorial) printNL.
MessageTracer stopCountingMethod:(Integer compiledMethodAt:#factorial)
"
"Created: 15.12.1995 / 10:57:49 / cg"
"Modified: 15.12.1995 / 15:46:41 / cg"
!
executionCountOfMethod:aMethod
"return the current count"
|count|
MethodCounts isNil ifTrue:[^ 0].
aMethod isWrapped ifTrue:[
count := MethodCounts at:aMethod originalMethod ifAbsent:nil.
count notNil ifTrue:[^ count].
].
^ MethodCounts at:aMethod ifAbsent:0
"Created: 15.12.1995 / 11:01:56 / cg"
"Modified: 15.12.1995 / 15:45:15 / cg"
!
isCounting:aMethod
"return true if aMethod is counted"
MethodCounts isNil ifTrue:[^ false].
(MethodCounts includesKey:aMethod) ifTrue:[^ true].
aMethod isWrapped ifTrue:[
^ MethodCounts includesKey:aMethod originalMethod
].
^ false
"Created: 15.12.1995 / 11:07:58 / cg"
"Modified: 15.12.1995 / 15:42:10 / cg"
!
stopCountingMethod:aMethod
"remove counting of aMethod"
^ self unwrapMethod:aMethod
"Modified: 15.12.1995 / 15:43:53 / cg"
! !
!MessageTracer class methodsFor:'method tracing'!
traceMethod:aMethod
"arrange for a trace message to be output on Stderr, when aMethod is executed.
Use unwrapMethod to remove this."
|lvl inside|
^ self wrapMethod:aMethod
onEntry:[:con |
inside isNil ifTrue:[
inside := true.
CallingLevel isNil ifTrue:[
CallingLevel := 0.
].
lvl notNil ifTrue:[
lvl := lvl + 1
] ifFalse:[
CallingLevel := lvl := CallingLevel + 1.
].
MessageTracer printEntryFull:con level:lvl.
inside := nil
]
]
onExit:[:con :retVal |
inside isNil ifTrue:[
inside := true.
MessageTracer printExit:con with:retVal level:lvl.
CallingLevel := lvl := lvl - 1.
inside := nil
]
]
"
MessageTracer traceMethod:(Integer compiledMethodAt:#factorial).
5 factorial.
MessageTracer untraceMethod:(Integer compiledMethodAt:#factorial)
"
"
MessageTracer traceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).
#(6 1 9 66 2 17) copy sort.
MessageTracer untraceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:).
"
"
dont do this:
"
"
MessageTracer traceMethod:(Object compiledMethodAt:#at:).
MessageTracer traceMethod:(Object compiledMethodAt:#at:put:).
#(6 1 9 66 2 17) copy sort.
MessageTracer untraceMethod:(Object compiledMethodAt:#at:).
MessageTracer untraceMethod:(Object compiledMethodAt:#at:put:).
"
!
traceMethodFull:aMethod
"arrange for a full trace message to be output on Stderr, when amethod is executed.
Only the sender is traced on entry.
Use untraceMethod to remove this trace."
^ self wrapMethod:aMethod
onEntry:TraceFullBlock
onExit:LeaveBlock.
"Created: 15.12.1995 / 18:19:31 / cg"
!
traceMethodSender:aMethod
"arrange for a trace message to be output on Stderr, when amethod is executed.
Only the sender is traced on entry.
Use untraceMethod to remove this trace."
^ self wrapMethod:aMethod
onEntry:TraceSenderBlock
onExit:LeaveBlock.
!
untraceMethod:aMethod
"remove tracing of aMethod"
"just a rename for your convenience - the same basic mechanism is used for all of these
trace facilities ..."
^ self unwrapMethod:aMethod
! !
!MessageTracer class methodsFor:'method wrapping'!
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
]
!
unwrapMethod:aMethod
"remove any wrapper on aMethod"
|selector class originalMethod idx|
MethodCounts notNil ifTrue:[
aMethod isWrapped ifTrue:[
MethodCounts removeKey:aMethod originalMethod ifAbsent:nil.
].
MethodCounts removeKey:aMethod ifAbsent:nil.
MethodCounts isEmpty ifTrue:[MethodCounts := nil].
].
CallingLevel := 0.
(aMethod isNil or:[aMethod isWrapped not]) ifTrue:[
^ aMethod
].
"
get class/selector
"
class := aMethod containingClass.
class isNil ifTrue:[
'no containing class for method found' printNL.
^ aMethod
].
selector := class selectorAtMethod: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
"Modified: 15.12.1995 / 15:43:48 / cg"
!
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 save|
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 selectorAtMethod:aMethod.
WrappedMethod autoload. "/ for small systems
"
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)';
nextPutAll: ' sender:nil. '.
exitBlock notNil ifTrue:[
s nextPutAll:'#exitBlock yourself value:thisContext value:retVal.'.
].
s nextPutAll:'^ retVal'; cr.
src := s contents.
save := Compiler stcCompilation.
Compiler stcCompilation:#never.
[
Class withoutUpdatingChangesDo:[
trapMethod := Compiler compile:src
forClass:UndefinedObject
inCategory:aMethod category
notifying:nil
install:false
skipIfSame:false
silent:true.
]
] valueNowOrOnUnwindDo:[
Compiler stcCompilation:save
].
trapMethod changeClassTo:WrappedMethod.
"
raising our eyebrows here ...
"
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.
"
"Modified: 13.12.1995 / 16:06:22 / cg"
! !
!MessageTracer class methodsFor:'object breakpointing'!
trap:anObject selector:aSelector
"arrange for the debugger to be entered when a message with aSelector is
sent to anObject. Use untrap to remove this trap.
The current implementation does not allow integers or nil to be trapped."
self wrap:anObject
selector:aSelector
onEntry:BreakBlock
onExit:LeaveBlock.
"
|p|
p := Point new.
MessageTracer trap:p selector:#x:.
p x:5
"
!
trap:anObject selectors:aCollection
self wrap:anObject
selectors:aCollection
onEntry:BreakBlock
onExit:LeaveBlock.
!
trapAll:anObject
"trap on all messages which are understood by anObject"
self wrapAll:anObject
onEntry:BreakBlock
onExit:LeaveBlock.
!
trapAll:anObject from:aClass
"trap on all messages defined in aClass sent to anObject"
self trap:anObject selectors:aClass selectorArray
!
untrap:anObject
"remove any traps on anObject"
"this is done by just patching the objects class back to the original"
|orgClass|
orgClass := anObject class.
orgClass category == #trapping ifFalse:[
^ self
].
anObject changeClassTo:orgClass superclass
"
|p|
p := Point new copy.
MessageTracer trace:p selector:#x:.
MessageTracer trace:p selector:#y:.
p y:1.
p x:2.
MessageTracer untrap:p
p y:2.
p x:1.
"
!
untrap:anObject selector:aSelector
"remove trap on aSelector from anObject"
|orgClass idx sels|
orgClass := anObject class.
orgClass category == #trapping ifFalse:[^ self].
sels := orgClass selectorArray.
idx := sels indexOf:aSelector.
idx == 0 ifTrue:[^ self].
sels size == 1 ifTrue:[
"the last trap got removed"
anObject changeClassTo:orgClass superclass.
^ self
].
orgClass
setSelectors:(sels copyWithoutIndex:idx)
methods:(orgClass methodArray copyWithoutIndex:idx).
ObjectMemory flushCaches. "avoid calling the old trap method"
"
|p|
p := Point new copy.
MessageTracer trace:p selector:#x:.
MessageTracer trace:p selector:#y:.
'trace both ...' errorPrintNL.
p x:2.
p y:1.
'trace only y ...' errorPrintNL.
MessageTracer untrap:p selector:#x:.
p x:2.
p y:1.
'trace none ...' errorPrintNL.
MessageTracer untrap:p selector:#y:.
p x:2.
p y:1.
"
! !
!MessageTracer class methodsFor:'object tracing'!
trace:anObject selector:aSelector
"arrange for a trace message to be output on Stderr, when a message with
aSelector is sent to anObject. Both entry and exit are traced.
Use untrap to remove this trace.
The current implementation does not allow integers or nil to be traced."
|methodName|
methodName := anObject class name , '>>' , aSelector.
self wrap:anObject
selector:aSelector
onEntry:[:con |
'enter ' errorPrint. methodName errorPrint.
' receiver=' errorPrint. con receiver printString errorPrint.
' args=' errorPrint. (con args) printString errorPrint.
' from:' errorPrint. con sender errorPrintNL.
]
onExit:[:con :retVal |
'leave ' errorPrint. methodName errorPrint.
' receiver=' errorPrint. con receiver printString errorPrint.
' returning:' errorPrint. retVal printString errorPrintNL.
].
"
|p|
p := Point new.
MessageTracer trace:p selector:#x:.
p x:5.
p y:1.
p x:10.
MessageTracer untrap:p.
p x:7
"
"
|a|
a := #(6 1 9 66 2 17) copy.
MessageTracer trace:a selector:#at:put:.
MessageTracer trace:a selector:#at:.
a sort.
"
!
trace:anObject selectors:aCollection
aCollection do:[:aSelector |
self trace:anObject selector:aSelector
]
"
trace all methods in Display, which are implemented
in the DisplayWorkstation class.
"
"
MessageTracer trace:Display selectors:(XWorkstation selectorArray)
MessageTracer untrace:Display
"
!
traceAll:anObject
"trace all messages which are understood by anObject"
|allSelectors|
allSelectors := IdentitySet new.
anObject class withAllSuperclasses do:[:aClass |
aClass selectorArray addAllTo:allSelectors
].
self trace:anObject selectors:allSelectors
"
trace all (implemented) messages sent to Display
(other messages lead to an error, anyway)
"
"
MessageTracer traceAll:Display
MessageTracer untrace:Display
"
!
traceAll:anObject from:aClass
"trace all messages defined in aClass sent to anObject"
self trace:anObject selectors:aClass selectorArray
"
trace all methods in Display, which are implemented
in the DisplayWorkstation class.
"
"
MessageTracer traceAll:Display from:XWorkstation
MessageTracer untrace:Display
"
!
traceSender:anObject selector:aSelector
"arrange for a trace message to be output on Stderr, when a message with
aSelector is sent to anObject. Only the sender is traced on entry.
Use untrap to remove this trace.
The current implementation does not allow integers or nil to be traced."
|methodName|
methodName := anObject class name , '>>' , aSelector.
self wrap:anObject
selector:aSelector
onEntry:[:con |
methodName errorPrint.
' from ' errorPrint.
con sender errorPrintNL.
]
onExit:LeaveBlock.
"
|p|
p := Point new.
MessageTracer traceSender:p selector:#x:.
p x:5.
p y:1.
p x:10.
MessageTracer untrap:p.
p x:7
"
"
|a|
a := #(6 1 9 66 2 17) copy.
MessageTracer traceSender:a selector:#at:put:.
MessageTracer traceSender:a selector:#at:.
a sort.
"
!
untrace:anObject
"remove any traces on anObject"
"just a rename for your convenience - the same basic mechanism is used for all of these
trace facilities ..."
^ self untrap:anObject
!
untrace:anObject selector:aSelector
"remove traces of aSelector sent to anObject"
"just a rename for your convenience - the same basic mechanism is used for all of these
trace facilities ..."
^ self untrap:anObject selector:aSelector
! !
!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 implClass save|
"
some are not allowed (otherwise we get into trouble ...)
"
(#(class changeClassTo:) includes:aSelector) ifTrue:[
Transcript showCr:'sorry, cannot place trap on: ' , aSelector.
^ self
].
WrappedMethod autoload. "/ just to make sure ...
"
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 copy 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 nextPutAll:' |retVal stubClass| '.
withOriginalClass ifTrue:[
s nextPutAll:'stubClass := self class. '.
s nextPutAll:'self changeClassTo:(stubClass superclass). '.
].
entryBlock notNil ifTrue:[
s nextPutAll:'#literal1 yourself value:thisContext. '.
].
s nextPutAll:('retVal := #originalMethod. '). "/ just to get a place for the origianlMethod
s nextPutAll:('retVal := super ' , spec , '. ').
exitBlock notNil ifTrue:[
s nextPutAll:'#literal2 yourself value:thisContext value:retVal. '.
].
withOriginalClass ifTrue:[
s nextPutAll:'self changeClassTo:stubClass. '.
].
s nextPutAll:'^ retVal'; cr.
save := Compiler stcCompilation.
Compiler stcCompilation:#never.
[
Class withoutUpdatingChangesDo:[
trapMethod := Compiler compile:s contents
forClass:newClass
inCategory:'breakpointed'
notifying:nil
install:false
skipIfSame:false
silent:true.
]
] valueNowOrOnUnwindDo:[
Compiler stcCompilation:save
].
lits := trapMethod literals.
implClass := orgClass whichClassIncludesSelector:aSelector.
implClass isNil ifTrue:[
Transcript showCr:aSelector , ' is not understood by ' , orgClass name.
] ifFalse:[
lits at:(lits indexOf:#originalMethod) put:(implClass compiledMethodAt:aSelector).
].
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'.
trapMethod changeClassTo:WrappedMethod.
"
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.
"
"Modified: 13.12.1995 / 16:06:56 / cg"
!
wrap:anObject selectors:aCollection onEntry:entryBlock onExit:exitBlock
"install wrappers for anObject on all selectors from aCollection"
aCollection do:[:aSelector |
self wrap:anObject selector:aSelector onEntry:entryBlock onExit:exitBlock
]
!
wrapAll:anObject onEntry:entryBlock onExit:exitBlock
"install wrappers for anObject on all implemented selectors"
|allSelectors|
allSelectors := IdentitySet new.
anObject class withAllSuperclasses do:[:aClass |
aClass selectorArray addAllTo:allSelectors
].
self wrap:anObject selectors:allSelectors onEntry:entryBlock onExit:exitBlock
! !
!MessageTracer class methodsFor:'trace helpers'!
printEntryFull:aContext
self printEntryFull:aContext level:0
!
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.
!
printEntrySender:aContext
aContext methodClass name errorPrint.
' ' errorPrint. aContext selector errorPrint.
' from ' errorPrint.
aContext sender errorPrintNL.
!
printExit:aContext with:retVal
self printExit:aContext with:retVal level:0
!
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.
! !
!MessageTracer methodsFor:'trace helpers '!
stepInterrupt
"called for every send while tracing"
|con|
StepInterruptPending := nil.
con := thisContext sender.
con lineNumber == 1 ifTrue:[
traceDetail == true ifTrue:[
self class printEntryFull:con.
] ifFalse:[
con printNL.
]
].
ObjectMemory flushInlineCaches.
StepInterruptPending := 1.
InterruptPending := 1.
^ self
!
trace:aBlock detail:fullDetail
"trace execution of aBlock."
traceDetail := fullDetail.
ObjectMemory stepInterruptHandler:self.
^ [
ObjectMemory flushInlineCaches.
StepInterruptPending := 1.
InterruptPending := 1.
aBlock value
] valueNowOrOnUnwindDo:[
StepInterruptPending := nil.
ObjectMemory stepInterruptHandler:nil.
]
"
MessageTracer trace:[#(6 5 4 3 2 1) sort] detail:false
MessageTracer trace:[#(6 5 4 3 2 1) sort] detail:true
"
! !
!MessageTracer class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libbasic3/MessageTracer.st,v 1.28 1995-12-15 20:43:17 cg Exp $'
! !
MessageTracer initialize!