--- a/MessageTracer.st Fri Apr 17 20:51:47 1998 +0200
+++ b/MessageTracer.st Tue Apr 21 16:01:19 1998 +0200
@@ -14,7 +14,8 @@
instanceVariableNames:'traceDetail'
classVariableNames:'BreakpointSignal CallingLevel BreakBlock TraceSenderBlock
LeaveBreakBlock LeaveTraceBlock MethodCounts MethodMemoryUsage
- MethodTiming TraceFullBlock'
+ MethodTiming TraceFullBlock ObjectWrittenBreakpointSignal
+ ObjectCopyHolders'
poolDictionaries:''
category:'System-Debugging-Support'
!
@@ -199,6 +200,10 @@
BreakpointSignal nameClass:self message:#breakpointSignal.
BreakpointSignal notifierString:'breakpoint encountered'.
+ ObjectWrittenBreakpointSignal := BreakpointSignal newSignalMayProceed:true.
+ ObjectWrittenBreakpointSignal nameClass:self message:#objectWrittenBreakpointSignal.
+ ObjectWrittenBreakpointSignal notifierString:'object modified'.
+
BreakBlock := [:con | BreakpointSignal raiseIn:con].
TraceSenderBlock := [:con | MessageTracer printEntrySender:con].
TraceFullBlock := [:con | con fullPrintAll].
@@ -211,13 +216,19 @@
MessageTracer initialize
"
- "Modified: 22.10.1996 / 17:39:14 / cg"
+ "Modified: / 21.4.1998 / 14:38:35 / cg"
! !
!MessageTracer class methodsFor:'Signal constants'!
breakpointSignal
^ BreakpointSignal
+!
+
+objectWrittenBreakpointSignal
+ ^ ObjectWrittenBreakpointSignal
+
+ "Created: / 21.4.1998 / 14:38:49 / cg"
! !
!MessageTracer class methodsFor:'class tracing'!
@@ -1359,7 +1370,8 @@
^ self
].
- anObject changeClassTo:orgClass superclass
+ anObject changeClassTo:orgClass superclass.
+ ObjectCopyHolders removeKey:anObject ifAbsent:nil.
"
|p|
@@ -1374,7 +1386,7 @@
p x:1.
"
- "Modified: 10.9.1996 / 20:06:07 / cg"
+ "Modified: / 21.4.1998 / 15:43:33 / cg"
!
untrap:anObject selector:aSelector
@@ -1391,6 +1403,7 @@
dict size == 1 ifTrue:[
"the last trap got removed"
anObject changeClassTo:orgClass superclass.
+ ObjectCopyHolders removeKey:anObject ifAbsent:nil.
^ self
].
dict removeKey:aSelector.
@@ -1416,8 +1429,8 @@
p y:1.
"
- "Modified: 5.6.1996 / 13:56:08 / stefan"
- "Modified: 10.9.1996 / 20:06:14 / cg"
+ "Modified: / 5.6.1996 / 13:56:08 / stefan"
+ "Modified: / 21.4.1998 / 15:43:55 / cg"
!
wrappedSelectorsOf:anObject
@@ -1429,6 +1442,139 @@
^ anObject class selectors
! !
+!MessageTracer class methodsFor:'object modification traps'!
+
+trapModificationsIn:anObject
+ "trap modifications in anObject"
+
+ self
+ trapModificationsIn:anObject filter:[:new | true]
+
+ "
+ |a|
+
+ a := Array new:10.
+ MessageTracer trapModificationsIn:a.
+
+ a size.
+ a at:1.
+ a at:2 put:nil.
+ a at:2 put:2.
+ a at:2.
+ a at:3.
+ a at:2 put:2.
+ a at:2 put:3.
+ MessageTracer untrace:a.
+ a at:3 put:5.
+ "
+
+ "Created: / 21.4.1998 / 14:32:34 / cg"
+ "Modified: / 21.4.1998 / 14:58:24 / cg"
+!
+
+trapModificationsIn:anObject filter:aFilterBlock
+ "trap modifications in anObject"
+
+ |allSelectors|
+
+ allSelectors := IdentitySet new.
+ anObject class withAllSuperclasses do:[:aClass |
+ aClass methodDictionary keys addAllTo:allSelectors
+ ].
+ allSelectors remove:#class.
+
+ self trapModificationsIn:anObject selectors:allSelectors filter:aFilterBlock
+
+ "trap if arrays 5th slot is modified:
+
+ |a|
+
+ a := Array new:10.
+ MessageTracer trapModificationsIn:a filter:[:old :new | (old at:5) ~~ (new at:5)].
+
+ a size.
+ a at:1.
+ a at:2 put:nil.
+ a at:2 put:2.
+ a at:2.
+ a at:3.
+ a at:2 put:2.
+ a at:2 put:3.
+ a at:5 put:3.
+ a at:5 put:3.
+ MessageTracer untrace:a.
+ a at:3 put:5.
+ "
+
+ "Modified: / 21.4.1998 / 15:53:38 / cg"
+!
+
+trapModificationsIn:anObject selector:aSelector filter:aFilterBlock
+ "install a trap for modifications in anObject by aSelector-messages.
+ the filterBlock will be invoked (after a modification) with the old and
+ new values as arguments and should return true,
+ if the debugger is really wanted."
+
+ self
+ trapModificationsIn:anObject
+ selectors:(Array with:aSelector)
+ filter:aFilterBlock
+
+ "Modified: / 21.4.1998 / 15:34:44 / cg"
+!
+
+trapModificationsIn:anObject selectors:aCollectionOfSelectors filter:aFilterBlock
+ "install a trap for modifications in anObject by aSelector-messages.
+ the filterBlock will be invoked (after a modification) with the old and
+ new values as arguments and should return true,
+ if the debugger is really wanted."
+
+ |copyHolder|
+
+ ObjectCopyHolders isNil ifTrue:[
+ ObjectCopyHolders := IdentityDictionary new.
+ ].
+ copyHolder := ObjectCopyHolders at:anObject ifAbsent:nil.
+ copyHolder isNil ifTrue:[
+ ObjectCopyHolders at:anObject put:(copyHolder := ValueHolder new).
+ ].
+
+ copyHolder value:(anObject shallowCopy).
+
+ aCollectionOfSelectors do:[:aSelector |
+ |methodName|
+
+ methodName := anObject class name , '>>' , aSelector.
+ self
+ wrap:anObject
+ selector:aSelector
+ onEntry:[:con | ]
+ onExit:[:con :retVal |
+ |oldValue|
+
+ oldValue := copyHolder value.
+
+ "/ compare with copy ...
+ (anObject sameContentsAs:oldValue) ifFalse:[
+ "/ see oldValue vs. anObject
+ (aFilterBlock value:oldValue value:anObject) ifTrue:[
+ copyHolder value:(anObject shallowCopy).
+ ObjectWrittenBreakpointSignal
+ raiseRequestWith:(oldValue -> anObject)
+ errorString:('object was modififed in ' , methodName)
+ in:con sender
+ ]
+ ]
+ ]
+ withOriginalClass:true
+ flushCaches:false.
+ ].
+ ObjectMemory flushCaches
+
+ "Created: / 21.4.1998 / 15:34:05 / cg"
+ "Modified: / 21.4.1998 / 16:00:39 / cg"
+! !
+
!MessageTracer class methodsFor:'object tracing'!
trace:anObject selector:aSelector
@@ -1437,22 +1583,9 @@
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 errorPrintCR.
- ]
- onExit:[:con :retVal |
- 'leave ' errorPrint. methodName errorPrint.
- ' receiver=' errorPrint. con receiver printString errorPrint.
- ' returning:' errorPrint. retVal printString errorPrintCR.
- ].
+ self
+ trace:anObject
+ selectors:(Array with:aSelector)
"
|p|
@@ -1474,23 +1607,60 @@
a sort.
"
- "Modified: 10.1.1997 / 17:54:50 / cg"
+ "Modified: / 21.4.1998 / 15:37:05 / cg"
!
-trace:anObject selectors:aCollection
- aCollection do:[:aSelector |
- self trace:anObject selector:aSelector
- ]
+trace:anObject selectors:aCollectionOfSelectors
+ "arrange for a trace message to be output on Stderr, when any message
+ from aCollectionOfSelectors is sent to anObject.
+ Both entry and exit are traced.
+ Use untrap:/untrace: to remove this trace.
+ The current implementation does not allow integers or nil to be traced."
+
+ |methodName|
+
+ aCollectionOfSelectors do:[:aSelector |
+ 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 errorPrintCR.
+ ]
+ onExit:[:con :retVal |
+ 'leave ' errorPrint. methodName errorPrint.
+ ' receiver=' errorPrint. con receiver printString errorPrint.
+ ' returning:' errorPrint. retVal printString errorPrintCR.
+ ]
+ withOriginalClass:true
+ flushCaches:false
+ ].
+ ObjectMemory flushCaches
"
- trace all methods in Display, which are implemented
- in the DisplayWorkstation class.
+ |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.
"
- "
- MessageTracer trace:Display selectors:(XWorkstation selectorArray)
- MessageTracer untrace:Display
- "
+ "Modified: / 21.4.1998 / 15:41:57 / cg"
!
traceAll:anObject
@@ -1610,10 +1780,18 @@
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
+ ^ self
+ wrap:anObject
+ selector:aSelector
+ onEntry:entryBlock
+ onExit:exitBlock
+ withOriginalClass:true
+ flushCaches:true
+
+ "Modified: / 21.4.1998 / 15:29:50 / cg"
!
-wrap:anObject selector:aSelector onEntry:entryBlock onExit:exitBlock withOriginalClass:withOriginalClass
+wrap:anObject selector:aSelector onEntry:entryBlock onExit:exitBlock withOriginalClass:withOriginalClass flushCaches:flushCaches
"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,
@@ -1627,7 +1805,8 @@
"
some are not allowed (otherwise we get into trouble ...)
"
- (#(class changeClassTo:) includes:aSelector) ifTrue:[
+ (aSelector == #class
+ or:[aSelector == #changeClassTo:]) ifTrue:[
Transcript showCR:'sorry, cannot place trap on: ' , aSelector.
^ self
].
@@ -1724,12 +1903,18 @@
"
dict := newClass methodDictionary.
dict := dict at:aSelector putOrAppend:trapMethod.
- newClass methodDictionary:dict.
+ flushCaches ifTrue:[
+ newClass methodDictionary:dict.
+ ] ifFalse:[
+ newClass setMethodDictionary:dict.
+ ].
"
and finally, the big trick:
"
- anObject changeClassTo:newClass
+ newClass ~~ orgClass ifTrue:[
+ anObject changeClassTo:newClass
+ ].
"
[exBegin]
@@ -1782,14 +1967,22 @@
"Modified: / 25.6.1996 / 22:11:21 / stefan"
"Modified: / 6.2.1998 / 02:48:13 / cg"
+ "Created: / 21.4.1998 / 15:30:27 / 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
- ]
+ self
+ wrap:anObject selector:aSelector
+ onEntry:entryBlock onExit:exitBlock
+ withOriginalClass:true
+ flushCaches:false
+ ].
+ ObjectMemory flushCaches
+
+ "Modified: / 21.4.1998 / 15:40:28 / cg"
!
wrapAll:anObject onEntry:entryBlock onExit:exitBlock
@@ -1967,6 +2160,6 @@
!MessageTracer class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libbasic3/MessageTracer.st,v 1.57 1998-02-06 01:53:53 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic3/MessageTracer.st,v 1.58 1998-04-21 14:01:19 cg Exp $'
! !
MessageTracer initialize!