.
--- a/ChangeSet.st Tue Apr 11 17:28:58 1995 +0200
+++ b/ChangeSet.st Tue May 02 01:02:29 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic3/ChangeSet.st,v 1.6 1995-02-05 23:38:09 claus Exp $
+$Header: /cvs/stx/stx/libbasic3/ChangeSet.st,v 1.7 1995-05-01 23:02:10 claus Exp $
'!
!ChangeSet class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic3/ChangeSet.st,v 1.6 1995-02-05 23:38:09 claus Exp $
+$Header: /cvs/stx/stx/libbasic3/ChangeSet.st,v 1.7 1995-05-01 23:02:10 claus Exp $
"
!
@@ -53,13 +53,29 @@
! !
+!ChangeSet class methodsFor:'queries'!
+
+current
+ "ST-80 compatibility: return the current changeSet"
+
+ |p|
+
+ (Project notNil and:[(p := Project current) notNil]) ifTrue:[
+ ^ p changeSet
+ ]
+
+ "
+ ChangeSet current
+ "
+! !
+
!ChangeSet methodsFor:'change management'!
addMethodChange:aMethod in:aClass
|newChange|
newChange := MethodChange class:aClass
- selector:(aClass selectorForMethod:aMethod)
+ selector:(aClass selectorAtMethod:aMethod)
source:aMethod source.
self add:newChange
!
@@ -68,7 +84,7 @@
|newChange|
newChange := MethodCategoryChange class:aClass
- selector:(aClass selectorForMethod:aMethod)
+ selector:(aClass selectorAtMethod:aMethod)
category:newCategory.
self add:newChange
--- a/ClassOrganizer.st Tue Apr 11 17:28:58 1995 +0200
+++ b/ClassOrganizer.st Tue May 02 01:02:29 1995 +0200
@@ -10,14 +10,14 @@
hereby transferred.
"
-Object subclass:#ClassOrganization
- instanceVariableNames:'class'
+Object subclass:#ClassOrganizer
+ instanceVariableNames:'globalComment categoryArray categoryStops elementArray class'
classVariableNames:''
poolDictionaries:''
- category:'System-Support'
+ category:'Kernel-Support'
!
-!ClassOrganization class methodsFor:'documentation'!
+!ClassOrganizer class methodsFor:'documentation'!
copyright
"
@@ -35,7 +35,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic3/ClassOrganizer.st,v 1.1 1995-02-22 01:15:44 claus Exp $
+$Header: /cvs/stx/stx/libbasic3/ClassOrganizer.st,v 1.2 1995-05-01 23:02:15 claus Exp $
"
!
@@ -44,15 +44,20 @@
in contrast to other smalltalks, ST/X does not keep the
method <-> category associations in the class (as organization),
but instead keeps the category as an instance variable of method.
- This may change in future versions.
For compatibility with (fileOut-) files which include a class organization
- message, aClass organization returns an instance of this class, which
+ message, 'aClass organization' returns an instance of this class, which
implements the category change functionality.
+ Also, some PD code seems to use & define methods for ClassOrganizers - having this
+ (somewhat dummy) around helps to fileIn that code.
+
+ Notice, that instances of ClassOrganizer are not used in the current ST/X
+ system; all is pure mimicri.
+ This may change in future versions.
"
! !
-!ClassOrganization class methodsFor:'instance creation'!
+!ClassOrganizer class methodsFor:'instance creation'!
for:aClass
"create & return a new instance of myself, to organize aClass"
@@ -60,7 +65,95 @@
^ self new class:aClass
! !
-!ClassOrganization methodsFor:'private access'!
+!ClassOrganizer methodsFor:'accessing'!
+
+classComment
+ ^ class comment
+
+ "
+ Number organization classComment
+ "
+!
+
+categoryOfElement:aSelectorSymbol
+ |m|
+
+ m := class compiledMethodAt:aSelectorSymbol.
+ m isNil ifTrue:[^ nil].
+ ^ m category
+
+ "
+ Number organization categoryOfElement:#foo.
+ Object organization categoryOfElement:#==
+ "
+!
+
+listAtCategoryNamed:aCategorySymbol
+ "return a collection of selectors whose methods are categorized
+ as aCategorySymbol"
+
+ |list|
+
+ list := OrderedCollection new.
+ class methodArray with:class selectorArray do:[:m :s |
+ m category == aCategorySymbol ifTrue:[list add:s]
+ ].
+ ^ list asArray
+
+ "
+ SmallInteger organization listAtCategoryNamed:#arithmetic
+ "
+!
+
+categories
+ "return a collection of categorySymbols"
+
+ |set|
+
+ set := IdentitySet new.
+ class methodArray do:[:m |
+ set add:m category
+ ].
+ ^ set asArray
+
+ "
+ SmallInteger organization categories
+ "
+! !
+
+!ClassOrganizer methodsFor:'printing & storing'!
+
+printOn:aStream
+ |coll|
+
+ coll := IdentityDictionary new.
+ class methodArray with:class selectorArray do:[:m :s |
+ |cat list|
+
+ cat := m category.
+ list := coll at:cat ifAbsent:[].
+ list isNil ifTrue:[
+ coll at:cat put:(list := OrderedCollection new).
+ ].
+ list add:s
+ ].
+ coll keysAndValuesDo:[:category :list |
+ aStream nextPut:$(.
+ aStream nextPutAll:category asString storeString.
+ list do:[:selector |
+ aStream space.
+ selector storeOn:aStream
+ ].
+ aStream nextPut:$).
+ aStream cr
+ ]
+
+ "
+ Number organization printString
+ "
+! !
+
+!ClassOrganizer methodsFor:'private access'!
class:aClass
"set the class"
@@ -68,7 +161,7 @@
class := aClass
! !
-!ClassOrganization methodsFor:'changing'!
+!ClassOrganizer methodsFor:'changing'!
changeFromString:organizationString
"take category<->selector associations from aString, and change
@@ -103,4 +196,3 @@
( ''category2'' #bar1 #bar2)'
"
! !
-
--- a/MessageTracer.st Tue Apr 11 17:28:58 1995 +0200
+++ b/MessageTracer.st Tue May 02 01:02:29 1995 +0200
@@ -12,7 +12,8 @@
Object subclass:#MessageTracer
instanceVariableNames:'traceDetail'
- classVariableNames:'BreakpointSignal CallingLevel'
+ classVariableNames:'BreakpointSignal CallingLevel BreakBlock TraceSenderBlock
+ LeaveBlock'
poolDictionaries:''
category:'System-Debugging-Support'
!
@@ -21,7 +22,7 @@
COPYRIGHT (c) 1994 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic3/MessageTracer.st,v 1.12 1995-04-11 15:28:58 claus Exp $
+$Header: /cvs/stx/stx/libbasic3/MessageTracer.st,v 1.13 1995-05-01 23:02:29 claus Exp $
'!
!MessageTracer class methodsFor:'documentation'!
@@ -42,7 +43,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic3/MessageTracer.st,v 1.12 1995-04-11 15:28:58 claus Exp $
+$Header: /cvs/stx/stx/libbasic3/MessageTracer.st,v 1.13 1995-05-01 23:02:29 claus Exp $
"
!
@@ -73,6 +74,22 @@
+ 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
@@ -143,6 +160,15 @@
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):
@@ -154,6 +180,13 @@
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].
"
! !
@@ -161,14 +194,30 @@
initialize
BreakpointSignal isNil ifTrue:[
-"/ HaltSignal isNil ifTrue:[super initialize].
-
BreakpointSignal := HaltSignal newSignalMayProceed:true.
BreakpointSignal nameClass:self message:#breakpointSignal.
BreakpointSignal notifierString:'breakpoint encountered'.
+
+ BreakBlock := [:con | BreakpointSignal raiseIn:con].
+ TraceSenderBlock := [:con | MessageTracer printEntrySender:con].
+ LeaveBlock := [:con :retVal | ].
]
! !
+!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:'signal access'!
breakpointSignal
@@ -179,9 +228,7 @@
trace:aBlock
"evaluate aBlock sending trace information to stdout.
- Return the value of the block.
- Warning, due to the implementation, only one process can be traced at a time.
- (since there is currently no per-process stepInterruptHandler)"
+ Return the value of the block."
^ self new trace:aBlock detail:false.
@@ -193,9 +240,7 @@
traceFull:aBlock
"evaluate aBlock sending trace information to stdout.
Return the value of the block.
- The trace information is more detailed.
- Warning, due to the implementation, only one process can be traced at a time.
- (since there is currently no per-process stepInterruptHandler)"
+ The trace information is more detailed."
^ self new trace:aBlock detail:true.
@@ -220,9 +265,7 @@
!MessageTracer methodsFor:'trace helpers '!
trace:aBlock detail:fullDetail
- "trace execution of aBlock.
- Warning, due to the implementation, only one process can be traced at a time.
- (since there is currently no per-process stepInterruptHandler)"
+ "trace execution of aBlock."
traceDetail := fullDetail.
ObjectMemory stepInterruptHandler:self.
@@ -259,7 +302,7 @@
^ self
! !
-!MessageTracer class methodsFor:'helpers '!
+!MessageTracer class methodsFor:'trace helpers'!
printEntryFull:aContext level:lvl
(String new:lvl) errorPrint.
@@ -302,7 +345,21 @@
!MessageTracer class methodsFor:'object wrapping'!
+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
+!
+
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
]
@@ -337,6 +394,16 @@
|newClass orgClass myMetaclass trapMethod s spec lits|
"
+ 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.
"
@@ -363,21 +430,21 @@
spec := Parser methodSpecificationForSelector:aSelector.
s := WriteStream on:String new.
s nextPutAll:spec.
- s cr.
- s nextPutAll:'|retVal stubClass|'; cr.
+ s nextPutAll:' |retVal stubClass| '.
withOriginalClass ifTrue:[
- s nextPutAll:'stubClass := self class.'; cr.
- s nextPutAll:'self changeClassTo:(stubClass superclass).'; cr.
+ s nextPutAll:'stubClass := self class. '.
+ s nextPutAll:'self changeClassTo:(stubClass superclass). '.
].
entryBlock notNil ifTrue:[
- s nextPutAll:'#literal1 yourself value:thisContext.'; cr.
+ s nextPutAll:'#literal1 yourself value:thisContext. '.
].
- s nextPutAll:('retVal := super ' , spec , '.'); cr.
+ 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.'; cr.
+ s nextPutAll:'#literal2 yourself value:thisContext value:retVal. '.
].
withOriginalClass ifTrue:[
- s nextPutAll:'self changeClassTo:stubClass.'; cr.
+ s nextPutAll:'self changeClassTo:stubClass. '.
].
s nextPutAll:'^ retVal'; cr.
@@ -390,6 +457,7 @@
silent:true.
lits := trapMethod literals.
+ lits at:(lits indexOf:#originalMethod) put:((orgClass whichClassIncludesSelector:aSelector) compiledMethodAt:aSelector).
entryBlock notNil ifTrue:[
lits at:(lits indexOf:#literal1) put:entryBlock.
].
@@ -401,6 +469,7 @@
(to avoid confusion in the debugger ...)
"
trapMethod source:'this is a wrapper method - not the real one'.
+ trapMethod changeClassTo:WrappedMethod.
"
install this new method
@@ -490,7 +559,10 @@
self error:'cannot place trap (no containing class found)'.
^ aMethod
].
- selector := class selectorForMethod:aMethod.
+ selector := class selectorAtMethod:aMethod.
+
+
+ WrappedMethod autoload. "/ for small systems
"
get a new method-spec
@@ -629,7 +701,7 @@
'no containing class for method found' printNL.
^ aMethod
].
- selector := class selectorForMethod:aMethod.
+ selector := class selectorAtMethod:aMethod.
originalMethod := aMethod originalMethod.
originalMethod isNil ifTrue:[
@@ -806,6 +878,27 @@
!MessageTracer class methodsFor:'object breakpointing'!
+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
+!
+
+trap:anObject selectors:aCollection
+ self wrap:anObject
+ selectors:aCollection
+ onEntry:BreakBlock
+ onExit:LeaveBlock.
+!
+
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.
@@ -813,10 +906,8 @@
self wrap:anObject
selector:aSelector
- onEntry:[:context |
- BreakpointSignal raiseIn:context
- ]
- onExit:[:context :retVal | ].
+ onEntry:BreakBlock
+ onExit:LeaveBlock.
"
|p|
@@ -907,10 +998,8 @@
entry/leave blocks."
^ self wrapMethod:aMethod
- onEntry:[:context |
- BreakpointSignal raiseIn:context
- ]
- onExit:[:context :retVal | ].
+ onEntry:BreakBlock
+ onExit:LeaveBlock.
"
MessageTracer trapMethod:(Collection compiledMethodAt:#select:).
@@ -944,7 +1033,7 @@
BreakpointSignal raiseIn:context
]
]
- onExit:[:context :retVal | ].
+ onExit:LeaveBlock.
"
MessageTracer trapMethod:(View compiledMethodAt:#redraw) forInstancesOf:myView.
@@ -1048,6 +1137,28 @@
!MessageTracer class methodsFor:'object tracing'!
+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"
@@ -1140,8 +1251,7 @@
' from ' errorPrint.
con sender errorPrintNL.
]
- onExit:[:con :retVal |
- ].
+ onExit:LeaveBlock.
"
|p|
@@ -1243,8 +1353,8 @@
Use untraceMethod to remove this trace."
^ self wrapMethod:aMethod
- onEntry:[:con | MessageTracer printEntrySender:con]
- onExit:[:con :retVal | ].
+ onEntry:TraceSenderBlock
+ onExit:LeaveBlock.
!
untraceMethod:aMethod
@@ -1299,3 +1409,5 @@
^ self untrapAllClasses
! !
+
+MessageTracer initialize!
--- a/MsgTracer.st Tue Apr 11 17:28:58 1995 +0200
+++ b/MsgTracer.st Tue May 02 01:02:29 1995 +0200
@@ -12,7 +12,8 @@
Object subclass:#MessageTracer
instanceVariableNames:'traceDetail'
- classVariableNames:'BreakpointSignal CallingLevel'
+ classVariableNames:'BreakpointSignal CallingLevel BreakBlock TraceSenderBlock
+ LeaveBlock'
poolDictionaries:''
category:'System-Debugging-Support'
!
@@ -21,7 +22,7 @@
COPYRIGHT (c) 1994 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic3/Attic/MsgTracer.st,v 1.12 1995-04-11 15:28:58 claus Exp $
+$Header: /cvs/stx/stx/libbasic3/Attic/MsgTracer.st,v 1.13 1995-05-01 23:02:29 claus Exp $
'!
!MessageTracer class methodsFor:'documentation'!
@@ -42,7 +43,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic3/Attic/MsgTracer.st,v 1.12 1995-04-11 15:28:58 claus Exp $
+$Header: /cvs/stx/stx/libbasic3/Attic/MsgTracer.st,v 1.13 1995-05-01 23:02:29 claus Exp $
"
!
@@ -73,6 +74,22 @@
+ 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
@@ -143,6 +160,15 @@
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):
@@ -154,6 +180,13 @@
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].
"
! !
@@ -161,14 +194,30 @@
initialize
BreakpointSignal isNil ifTrue:[
-"/ HaltSignal isNil ifTrue:[super initialize].
-
BreakpointSignal := HaltSignal newSignalMayProceed:true.
BreakpointSignal nameClass:self message:#breakpointSignal.
BreakpointSignal notifierString:'breakpoint encountered'.
+
+ BreakBlock := [:con | BreakpointSignal raiseIn:con].
+ TraceSenderBlock := [:con | MessageTracer printEntrySender:con].
+ LeaveBlock := [:con :retVal | ].
]
! !
+!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:'signal access'!
breakpointSignal
@@ -179,9 +228,7 @@
trace:aBlock
"evaluate aBlock sending trace information to stdout.
- Return the value of the block.
- Warning, due to the implementation, only one process can be traced at a time.
- (since there is currently no per-process stepInterruptHandler)"
+ Return the value of the block."
^ self new trace:aBlock detail:false.
@@ -193,9 +240,7 @@
traceFull:aBlock
"evaluate aBlock sending trace information to stdout.
Return the value of the block.
- The trace information is more detailed.
- Warning, due to the implementation, only one process can be traced at a time.
- (since there is currently no per-process stepInterruptHandler)"
+ The trace information is more detailed."
^ self new trace:aBlock detail:true.
@@ -220,9 +265,7 @@
!MessageTracer methodsFor:'trace helpers '!
trace:aBlock detail:fullDetail
- "trace execution of aBlock.
- Warning, due to the implementation, only one process can be traced at a time.
- (since there is currently no per-process stepInterruptHandler)"
+ "trace execution of aBlock."
traceDetail := fullDetail.
ObjectMemory stepInterruptHandler:self.
@@ -259,7 +302,7 @@
^ self
! !
-!MessageTracer class methodsFor:'helpers '!
+!MessageTracer class methodsFor:'trace helpers'!
printEntryFull:aContext level:lvl
(String new:lvl) errorPrint.
@@ -302,7 +345,21 @@
!MessageTracer class methodsFor:'object wrapping'!
+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
+!
+
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
]
@@ -337,6 +394,16 @@
|newClass orgClass myMetaclass trapMethod s spec lits|
"
+ 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.
"
@@ -363,21 +430,21 @@
spec := Parser methodSpecificationForSelector:aSelector.
s := WriteStream on:String new.
s nextPutAll:spec.
- s cr.
- s nextPutAll:'|retVal stubClass|'; cr.
+ s nextPutAll:' |retVal stubClass| '.
withOriginalClass ifTrue:[
- s nextPutAll:'stubClass := self class.'; cr.
- s nextPutAll:'self changeClassTo:(stubClass superclass).'; cr.
+ s nextPutAll:'stubClass := self class. '.
+ s nextPutAll:'self changeClassTo:(stubClass superclass). '.
].
entryBlock notNil ifTrue:[
- s nextPutAll:'#literal1 yourself value:thisContext.'; cr.
+ s nextPutAll:'#literal1 yourself value:thisContext. '.
].
- s nextPutAll:('retVal := super ' , spec , '.'); cr.
+ 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.'; cr.
+ s nextPutAll:'#literal2 yourself value:thisContext value:retVal. '.
].
withOriginalClass ifTrue:[
- s nextPutAll:'self changeClassTo:stubClass.'; cr.
+ s nextPutAll:'self changeClassTo:stubClass. '.
].
s nextPutAll:'^ retVal'; cr.
@@ -390,6 +457,7 @@
silent:true.
lits := trapMethod literals.
+ lits at:(lits indexOf:#originalMethod) put:((orgClass whichClassIncludesSelector:aSelector) compiledMethodAt:aSelector).
entryBlock notNil ifTrue:[
lits at:(lits indexOf:#literal1) put:entryBlock.
].
@@ -401,6 +469,7 @@
(to avoid confusion in the debugger ...)
"
trapMethod source:'this is a wrapper method - not the real one'.
+ trapMethod changeClassTo:WrappedMethod.
"
install this new method
@@ -490,7 +559,10 @@
self error:'cannot place trap (no containing class found)'.
^ aMethod
].
- selector := class selectorForMethod:aMethod.
+ selector := class selectorAtMethod:aMethod.
+
+
+ WrappedMethod autoload. "/ for small systems
"
get a new method-spec
@@ -629,7 +701,7 @@
'no containing class for method found' printNL.
^ aMethod
].
- selector := class selectorForMethod:aMethod.
+ selector := class selectorAtMethod:aMethod.
originalMethod := aMethod originalMethod.
originalMethod isNil ifTrue:[
@@ -806,6 +878,27 @@
!MessageTracer class methodsFor:'object breakpointing'!
+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
+!
+
+trap:anObject selectors:aCollection
+ self wrap:anObject
+ selectors:aCollection
+ onEntry:BreakBlock
+ onExit:LeaveBlock.
+!
+
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.
@@ -813,10 +906,8 @@
self wrap:anObject
selector:aSelector
- onEntry:[:context |
- BreakpointSignal raiseIn:context
- ]
- onExit:[:context :retVal | ].
+ onEntry:BreakBlock
+ onExit:LeaveBlock.
"
|p|
@@ -907,10 +998,8 @@
entry/leave blocks."
^ self wrapMethod:aMethod
- onEntry:[:context |
- BreakpointSignal raiseIn:context
- ]
- onExit:[:context :retVal | ].
+ onEntry:BreakBlock
+ onExit:LeaveBlock.
"
MessageTracer trapMethod:(Collection compiledMethodAt:#select:).
@@ -944,7 +1033,7 @@
BreakpointSignal raiseIn:context
]
]
- onExit:[:context :retVal | ].
+ onExit:LeaveBlock.
"
MessageTracer trapMethod:(View compiledMethodAt:#redraw) forInstancesOf:myView.
@@ -1048,6 +1137,28 @@
!MessageTracer class methodsFor:'object tracing'!
+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"
@@ -1140,8 +1251,7 @@
' from ' errorPrint.
con sender errorPrintNL.
]
- onExit:[:con :retVal |
- ].
+ onExit:LeaveBlock.
"
|p|
@@ -1243,8 +1353,8 @@
Use untraceMethod to remove this trace."
^ self wrapMethod:aMethod
- onEntry:[:con | MessageTracer printEntrySender:con]
- onExit:[:con :retVal | ].
+ onEntry:TraceSenderBlock
+ onExit:LeaveBlock.
!
untraceMethod:aMethod
@@ -1299,3 +1409,5 @@
^ self untrapAllClasses
! !
+
+MessageTracer initialize!