"
 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:'traceHow'
       classVariableNames:'BreakpointSignal CallingLevel'
       poolDictionaries:''
       category:'System-Support'
!

MessageTracer comment:'
COPYRIGHT (c) 1994 by Claus Gittinger
	      All Rights Reserved

$Header: /cvs/stx/stx/libbasic3/MessageTracer.st,v 1.6 1994-11-22 23:07:44 claus Exp $
'!

!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
"
$Header: /cvs/stx/stx/libbasic3/MessageTracer.st,v 1.6 1994-11-22 23:07:44 claus Exp $
"
!

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.
     Return the value of the block."

    ^ self new trace:aBlock.

    "
     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 traceFull:aBlock.

    "
     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 '!

trace:aBlock
    "trace execution of aBlock"

    ObjectMemory stepInterruptHandler:self.
    StepInterruptPending := true.
    InterruptPending := true.
    ^ aBlock valueNowOrOnUnwindDo:[
	StepInterruptPending := nil.
	ObjectMemory stepInterruptHandler:nil.
    ]

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

traceFull:aBlock
    "trace execution of aBlock"

    traceHow := #detail.
    ObjectMemory stepInterruptHandler:self.
    StepInterruptPending := true.
    InterruptPending := true.
    ^ aBlock valueNowOrOnUnwindDo:[
	StepInterruptPending := nil.
	ObjectMemory stepInterruptHandler:nil.
    ]

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

stepInterrupt
    "called for every send while tracing"

    StepInterruptPending := nil.
    traceHow == #detail ifTrue:[
	self class printEntryFull:thisContext sender.
"/        thisContext sender printNL.
    ] ifFalse:[    
	thisContext sender printNL.
    ].
    StepInterruptPending := true.
    InterruptPending := true.
    ^ 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
    ].

    "
     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.
    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) yourself. '.

    exitBlock notNil ifTrue:[
	s nextPutAll:'#exitBlock yourself value:thisContext value:retVal.'.
    ].
    s nextPutAll:'^ retVal'; cr.

    src := s contents.
    trapMethod := Compiler compile:src 
			  forClass:UndefinedObject 
			inCategory:aMethod category
			 notifying:nil
			   install:false
			skipIfSame:false
			    silent:true.
    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.         
    "
!

unwrapMethod:aMethod 
    "remove any wrapper on aMethod"

    |selector class originalMethod idx|

    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 selectorForMethod: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
!

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

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

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

    trapMethod := Compiler compile:s contents 
			  forClass:aClass 
			inCategory:'trapping'
			 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'.

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

!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:[:context |
		     BreakpointSignal raise
		     "/ Debugger enter:context withMessage:'breakPoint hit'
		 ]
	 onExit:[:context :retVal | ].

    "
     |p|

     p := Point new.
     MessageTracer trap:p selector:#x:.
     p x:5
    "
!

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

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

!MessageTracer class methodsFor:'method breakpointing'!

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:[:context |
			 BreakpointSignal raise
		      ]
	       onExit:[:context :retVal | ].

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

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
!

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 raise
			 ]
		      ]
	       onExit:[:context :retVal | ].

    "
     MessageTracer trapMethod:(View compiledMethodAt:#redraw) forInstancesOf:myView.
    "
!

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

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

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

untrapAllClasses
    "remove any traps on any class"

    Smalltalk allBehaviorsDo:[:aClass |
	self untrapClass:aClass
    ]

    "
     MessageTracer untrapAllClasses
    "
! !

!MessageTracer class methodsFor:'object tracing'!

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

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

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

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:[:con :retVal |
		].

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

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

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

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:[:con | MessageTracer printEntrySender:con]
	      onExit:[:con :retVal | ].
!

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:'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 
    "
!

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
!

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