--- a/MessageTracer.st	Sat Jan 31 15:23:47 2015 +0100
+++ b/MessageTracer.st	Sun Feb 01 10:21:20 2015 +0100
@@ -11,6 +11,8 @@
 "
 "{ Package: 'stx:libbasic3' }"
 
+"{ NameSpace: Smalltalk }"
+
 Object subclass:#MessageTracer
 	instanceVariableNames:'traceDetail tracedBlock'
 	classVariableNames:'BreakpointSignal CallingLevel BreakBlock TraceSenderBlock
@@ -29,6 +31,13 @@
 	privateIn:MessageTracer
 !
 
+Object subclass:#MethodSpyInfo
+	instanceVariableNames:'profiler'
+	classVariableNames:''
+	poolDictionaries:''
+	privateIn:MessageTracer
+!
+
 Object subclass:#MethodTimingInfo
 	instanceVariableNames:'count minTime maxTime sumTimes avgTime'
 	classVariableNames:''
@@ -1385,6 +1394,193 @@
     "Created: / 29-07-2014 / 09:45:54 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 ! !
 
+!MessageTracer class methodsFor:'method profiling'!
+
+spyMethod:aMethod
+    "arrange for given method to collect profiling data
+     using message tally profiler.
+     Use unwrapMethod to remove this.
+    "
+
+    self spyMethod: aMethod interval: MessageTally normalSamplingIntervalMS
+
+    "Created: / 01-02-2015 / 09:02:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+spyMethod:aMethod interval: anInteger
+    "arrange for given method to collect profiling data
+     using message tally profiler.
+     Use unwrapMethod to remove this.
+    "
+
+    |selector class trapMethod s spec src dict sel saveUS xselector info |
+
+    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)' mayProceed:true.
+        ^ aMethod
+    ].
+    selector := class selectorAtMethod:aMethod.
+
+    WrappedMethod autoload. "/ for small systems
+
+    "
+     get a new method-spec
+    "
+    xselector := '_x'.
+    aMethod numArgs timesRepeat:[
+        xselector := xselector , '_:'
+    ].
+    spec := Parser methodSpecificationForSelector:xselector.
+
+
+    info := MethodSpyInfo new.
+    "
+     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:' <context: #return>'.
+    s nextPutAll:' |retVal context| '.
+    s nextPutAll:' context := thisContext.'.
+    s nextPutAll: '#info profiler: (Tools::Profiler ? MessageTally) new.';
+      nextPutAll: '#info profiler spyOn: [';
+      nextPutAll:'retVal := #originalMethod yourself';
+      nextPutAll:             ' valueWithReceiver:(context receiver)';
+      nextPutAll:             ' arguments:(context args)';
+      nextPutAll:             ' selector:(context selector)';
+      nextPutAll:             ' search:(context searchClass)';
+      nextPutAll:             ' sender:nil. ';
+      nextPutAll:'] interval:'; nextPutAll: anInteger printString; nextPutAll: '.'.
+    s nextPutAll:'^ retVal'; cr.
+
+    src := s contents.
+    saveUS := Compiler allowUnderscoreInIdentifier.
+    ParserFlags
+        withSTCCompilation:#never
+        do:[
+            [
+                Compiler allowUnderscoreInIdentifier:true.
+                Class withoutUpdatingChangesDo:[
+                    trapMethod := Compiler
+                                    compile:src
+                                    forClass:UndefinedObject
+                                    inCategory:aMethod category
+                                    notifying:nil
+                                    install:false
+                                    skipIfSame:false
+                                    silent:false. "/ true.
+                ]
+            ] ensure:[
+                Compiler allowUnderscoreInIdentifier:saveUS.
+            ].
+        ].
+
+    trapMethod setPackage:aMethod package.
+    trapMethod changeClassTo:WrappedMethod.
+    trapMethod register.
+
+    "
+     raising our eyebrows here ...
+    "
+    trapMethod changeLiteral:#info to: info. 
+    trapMethod changeLiteral:#originalMethod to:aMethod.
+    "
+     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 sourceFilename:(aMethod getSource) position:(aMethod getSourcePosition).
+
+    dict := class methodDictionary.
+    sel := dict at:selector ifAbsent:[0].
+    sel == 0 ifTrue:[
+        self error:'oops, unexpected error' mayProceed:true.
+        ^ aMethod
+    ].
+
+    dict at:selector put:trapMethod.
+    class methodDictionary:dict.
+    ObjectMemory flushCaches.
+
+    class changed:#methodTrap with:selector. "/ tell browsers
+    MethodTrapChangeNotificationParameter notNil ifTrue:[
+        Smalltalk changed:#methodTrap with:(MethodTrapChangeNotificationParameter changeClass:class changeSelector:selector).
+    ].
+    ^ 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.
+    "
+
+    "Created: / 01-02-2015 / 09:22:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
 !MessageTracer class methodsFor:'method timing'!
 
 executionTimesOfMethod:aMethod
@@ -3510,6 +3706,16 @@
     InterruptPending := 1.
 ! !
 
+!MessageTracer::MethodSpyInfo methodsFor:'accessing'!
+
+profiler
+    ^ profiler
+!
+
+profiler:aMessageTally
+    profiler := aMessageTally.
+! !
+
 !MessageTracer::MethodTimingInfo methodsFor:'accessing'!
 
 avgTime
@@ -3682,7 +3888,7 @@
 !MessageTracer class methodsFor:'documentation'!
 
 version_CVS
-    ^ '$Header: /cvs/stx/stx/libbasic3/MessageTracer.st,v 1.135 2014-12-11 14:17:04 cg Exp $'
+    ^ '$Header: /cvs/stx/stx/libbasic3/MessageTracer.st,v 1.136 2015-02-01 09:21:20 vrany Exp $'
 ! !