|
1 " |
|
2 COPYRIGHT (c) 1994 by Claus Gittinger |
|
3 All Rights Reserved |
|
4 |
|
5 This software is furnished under a license and may be used |
|
6 only in accordance with the terms of that license and with the |
|
7 inclusion of the above copyright notice. This software may not |
|
8 be provided or otherwise made available to, or used by, any |
|
9 other person. No title to or ownership of the software is |
|
10 hereby transferred. |
|
11 " |
|
12 |
|
13 Object subclass:#MessageTracer |
|
14 instanceVariableNames:'' |
|
15 classVariableNames:'' |
|
16 poolDictionaries:'' |
|
17 category:'System-Support' |
|
18 ! |
|
19 |
|
20 MessageTracer comment:' |
|
21 |
|
22 COPYRIGHT (c) 1994 by Claus Gittinger |
|
23 All Rights Reserved |
|
24 |
|
25 $Header: /cvs/stx/stx/libbasic3/MessageTracer.st,v 1.1 1994-06-02 11:35:47 claus Exp $ |
|
26 '! |
|
27 |
|
28 !MessageTracer class methodsFor:'documentation'! |
|
29 |
|
30 documentation |
|
31 " |
|
32 This is not a real class, in that there are no instances of |
|
33 MessageTracer. |
|
34 It has been created, to provide a common home for the tracing |
|
35 facilities (originally, they where in Object, but have moved to |
|
36 allow easier separation of development vs. runtime configurations. |
|
37 |
|
38 trapping sends to a specific object: |
|
39 |
|
40 MessageTracer trap:anObject selector:aSelector |
|
41 ... |
|
42 MessageTracer untrap:anObject selector:aSelector |
|
43 or: |
|
44 MessageTracer untrap:anObject |
|
45 |
|
46 |
|
47 trapping evaluation of a specific method: |
|
48 |
|
49 MessageTracer trapMethod:aMethod |
|
50 ... |
|
51 MessageTracer unwrapMethod:aMethod |
|
52 |
|
53 |
|
54 |
|
55 tracing sends to a specific object: |
|
56 |
|
57 MessageTracer trace:anObject selector:aSelector |
|
58 ... |
|
59 MessageTracer untrace:anObject selector:aSelector |
|
60 or: |
|
61 MessageTracer untrace:anObject |
|
62 |
|
63 |
|
64 tracing sender only: |
|
65 |
|
66 MessageTracer traceSender:anObject selector:aSelector |
|
67 ... |
|
68 MessageTracer untrace:anObject selector:aSelector |
|
69 or: |
|
70 MessageTracer untrace:anObject |
|
71 |
|
72 |
|
73 tracing evaluation of a specific method: |
|
74 |
|
75 MessageTracer traceMethod:aMethod |
|
76 ... |
|
77 MessageTracer unwrapmethod:aMethod |
|
78 " |
|
79 ! ! |
|
80 |
|
81 !MessageTracer class methodsFor:'object wrapping'! |
|
82 |
|
83 wrap:anObject selector:aSelector onEntry:entryBlock onExit:exitBlock |
|
84 "arrange for the two blocks entryBlock and exitBlock to be evaluated whenever |
|
85 a message with aSelector is sent to anObject. EntryBlock will be called on |
|
86 entry, and get the current context passed as argument. ExitBlock will be called, |
|
87 when the method is left, and get the context and the methods return value as arguments. |
|
88 The current implementation does not allow integers or nil to be wrapped." |
|
89 |
|
90 "I have not yet enough experience, if the wrapped original method should |
|
91 run as an instance of the original, or of the catching class; |
|
92 The latter has the advantage of catching recursive and other sends, while |
|
93 it might lead into trouble when the message is sent from a debugger or a long |
|
94 return is done out of the original method ... |
|
95 Time will show, you can experiment by setting the withOriginalClass: flag to false |
|
96 " |
|
97 ^ self wrap:anObject selector:aSelector onEntry:entryBlock onExit:exitBlock withOriginalClass:true |
|
98 ! |
|
99 |
|
100 wrap:anObject selector:aSelector onEntry:entryBlock onExit:exitBlock withOriginalClass:withOriginalClass |
|
101 "arrange for the two blocks entryBlock and exitBlock to be evaluated whenever |
|
102 a message with aSelector is sent to anObject. EntryBlock will be called on |
|
103 entry, and get the current context passed as argument. ExitBlock will be called, |
|
104 when the method is left, and get the methods return value as argument. |
|
105 The argument withOriginalClass controls if the original method should be called for with |
|
106 the receiver being trapped upon or not. |
|
107 The current implementation does not allow integers or nil to be wrapped." |
|
108 |
|
109 |newClass orgClass myMetaclass trapMethod s spec lits| |
|
110 |
|
111 " |
|
112 create a new (anonymous) subclass of the receivers class |
|
113 but only if not already being trapped. |
|
114 " |
|
115 orgClass := anObject class. |
|
116 orgClass category == #trapping ifTrue:[ |
|
117 newClass := orgClass |
|
118 ] ifFalse:[ |
|
119 myMetaclass := orgClass class. |
|
120 |
|
121 newClass := myMetaclass new. |
|
122 newClass setSuperclass:orgClass. |
|
123 newClass instSize:orgClass instSize. |
|
124 newClass flags:orgClass flags. |
|
125 newClass setClassVariableString:''. |
|
126 newClass setInstanceVariableString:''. |
|
127 newClass setName:orgClass name. |
|
128 newClass category:#trapping. |
|
129 newClass setSelectorArray:(Array new). |
|
130 newClass setMethodArray:(Array new). |
|
131 ]. |
|
132 |
|
133 " |
|
134 create a method, executing the trap-blocks and the original method via a super-send |
|
135 " |
|
136 spec := Parser methodSpecificationForSelector:aSelector. |
|
137 s := WriteStream on:String new. |
|
138 s nextPutAll:spec. |
|
139 s cr. |
|
140 s nextPutAll:'|retVal stubClass|'; cr. |
|
141 withOriginalClass ifTrue:[ |
|
142 s nextPutAll:'stubClass := self class.'; cr. |
|
143 s nextPutAll:'self changeClassTo:(stubClass superclass).'; cr. |
|
144 ]. |
|
145 entryBlock notNil ifTrue:[ |
|
146 s nextPutAll:'#literal1 yourself value:thisContext.'; cr. |
|
147 ]. |
|
148 s nextPutAll:('retVal := super ' , spec , '.'); cr. |
|
149 exitBlock notNil ifTrue:[ |
|
150 s nextPutAll:'#literal2 yourself value:thisContext value:retVal.'; cr. |
|
151 ]. |
|
152 withOriginalClass ifTrue:[ |
|
153 s nextPutAll:'self changeClassTo:stubClass.'; cr. |
|
154 ]. |
|
155 s nextPutAll:'^ retVal'; cr. |
|
156 |
|
157 trapMethod := Compiler compile:s contents |
|
158 forClass:newClass |
|
159 inCategory:'breakpointed' |
|
160 notifying:nil |
|
161 install:false |
|
162 skipIfSame:false |
|
163 silent:true. |
|
164 |
|
165 lits := trapMethod literals. |
|
166 entryBlock notNil ifTrue:[ |
|
167 lits at:(lits indexOf:#literal1) put:entryBlock. |
|
168 ]. |
|
169 exitBlock notNil ifTrue:[ |
|
170 lits at:(lits indexOf:#literal2) put:exitBlock. |
|
171 ]. |
|
172 " |
|
173 change the source of this new method |
|
174 (to avoid confusion in the debugger ...) |
|
175 " |
|
176 trapMethod source:'this is a wrapper method - not the real one'. |
|
177 |
|
178 " |
|
179 install this new method |
|
180 " |
|
181 newClass setSelectorArray:(newClass selectorArray copyWith:aSelector). |
|
182 newClass setMethodArray:(newClass methodArray copyWith:trapMethod). |
|
183 |
|
184 " |
|
185 and finally, the big trick: |
|
186 " |
|
187 anObject changeClassTo:newClass |
|
188 |
|
189 " |
|
190 |p| |
|
191 |
|
192 p := Point new copy. |
|
193 MessageTracer |
|
194 wrap:p |
|
195 Selector:#y: |
|
196 onEntry:nil |
|
197 onExit:[:retVal | |
|
198 Transcript show:'leave Point>>x:, returning:'. |
|
199 Transcript showCr:retVal printString. |
|
200 Transcript endEntry |
|
201 ]. |
|
202 Transcript showCr:'sending x: ...'. |
|
203 p x:1. |
|
204 Transcript showCr:'sending y: ...'. |
|
205 p y:2. |
|
206 p untrap. |
|
207 Transcript showCr:'sending x: ...'. |
|
208 p x:2. |
|
209 Transcript showCr:'sending y: ...'. |
|
210 p y:1. |
|
211 " |
|
212 |
|
213 " |
|
214 |p| |
|
215 |
|
216 p := Point new copy. |
|
217 MessageTracer wrap:p |
|
218 Selector:#y: |
|
219 onEntry:[:context | self halt:'you are trapped'] |
|
220 onExit:nil. |
|
221 Transcript showCr:'sending x: ...'. |
|
222 p x:1. |
|
223 Transcript showCr:'sending y: ...'. |
|
224 p y:2. |
|
225 p untrap. |
|
226 Transcript showCr:'sending x: ...'. |
|
227 p x:2. |
|
228 Transcript showCr:'sending y: ...'. |
|
229 p y:1. |
|
230 " |
|
231 ! ! |
|
232 |
|
233 !MessageTracer class methodsFor:'method wrapping'! |
|
234 |
|
235 wrapMethod:aMethod onEntry:entryBlock onExit:exitBlock |
|
236 "arrange for the two blocks entryBlock and exitBlock to be evaluated whenever |
|
237 aMethod is evaluated. |
|
238 EntryBlock will be called on entry, and get the current context passed as argument. |
|
239 ExitBlock will be called, when the method is left, and get context and |
|
240 the methods return value as arguments." |
|
241 |
|
242 |parser selector args nArgs class trapMethod s spec lits src idx| |
|
243 |
|
244 " |
|
245 create a new method, which calls the original one, |
|
246 but only if not already being trapped. |
|
247 " |
|
248 aMethod isWrapped ifTrue:[ |
|
249 ^ aMethod |
|
250 ]. |
|
251 |
|
252 " |
|
253 get class/selector |
|
254 " |
|
255 class := aMethod containingClass. |
|
256 class isNil ifTrue:[ |
|
257 self error:'cannot place trap (no containing class found)'. |
|
258 ^ aMethod |
|
259 ]. |
|
260 selector := class selectorForMethod:aMethod. |
|
261 |
|
262 " |
|
263 get a new method-spec |
|
264 " |
|
265 spec := Parser methodSpecificationForSelector:selector. |
|
266 |
|
267 " |
|
268 create a method, executing the trap-blocks and the original method via a direct call |
|
269 " |
|
270 s := WriteStream on:String new. |
|
271 s nextPutAll:spec. |
|
272 s nextPutAll:' |retVal| '. |
|
273 entryBlock notNil ifTrue:[ |
|
274 s nextPutAll:'#entryBlock yourself value:thisContext. '. |
|
275 ]. |
|
276 s nextPutAll:'retVal := #originalMethod yourself'; |
|
277 nextPutAll: ' valueWithReceiver:(thisContext receiver)'; |
|
278 nextPutAll: ' arguments:(thisContext args)'; |
|
279 nextPutAll: ' selector:(thisContext selector)'; |
|
280 nextPutAll: ' search:(thisContext searchClass) yourself. '. |
|
281 |
|
282 exitBlock notNil ifTrue:[ |
|
283 s nextPutAll:'#exitBlock yourself value:thisContext value:retVal.'. |
|
284 ]. |
|
285 s nextPutAll:'^ retVal'; cr. |
|
286 |
|
287 src := s contents. |
|
288 trapMethod := Compiler compile:src |
|
289 forClass:UndefinedObject |
|
290 inCategory:aMethod category |
|
291 notifying:nil |
|
292 install:false |
|
293 skipIfSame:false |
|
294 silent:true. |
|
295 trapMethod changeClassTo:WrappedMethod. |
|
296 |
|
297 lits := trapMethod basicLiterals. |
|
298 entryBlock notNil ifTrue:[ |
|
299 lits at:(lits indexOf:#entryBlock) put:entryBlock. |
|
300 ]. |
|
301 lits at:(lits indexOf:#originalMethod) put:aMethod. |
|
302 exitBlock notNil ifTrue:[ |
|
303 lits at:(lits indexOf:#exitBlock) put:exitBlock. |
|
304 ]. |
|
305 " |
|
306 change the source of this new method |
|
307 (to avoid confusion in the debugger ...) |
|
308 " |
|
309 trapMethod source:'this is a wrapper method - not the real one'. |
|
310 |
|
311 idx := class selectorArray indexOf:selector. |
|
312 idx ~~ 0 ifTrue:[ |
|
313 class methodArray at:idx put:trapMethod |
|
314 ] ifFalse:[ |
|
315 self halt:'oops, unexpected error'. |
|
316 ^ aMethod |
|
317 ]. |
|
318 |
|
319 ObjectMemory flushCaches. |
|
320 ^ trapMethod |
|
321 |
|
322 " |
|
323 MessageTracer |
|
324 wrapMethod:(Point compiledMethodAt:#scaleBy:) |
|
325 onEntry:nil |
|
326 onExit:[:con :retVal | |
|
327 Transcript show:'leave Point>>scaleBy:; returning:'. |
|
328 Transcript showCr:retVal printString. |
|
329 Transcript endEntry |
|
330 ]. |
|
331 (1@2) scaleBy:5. |
|
332 MessageTracer unwrapMethod:(Point compiledMethodAt:#scaleBy:). |
|
333 (1@2) scaleBy:5. |
|
334 " |
|
335 " |
|
336 MessageTracer |
|
337 wrapMethod:(Integer compiledMethodAt:#factorial) |
|
338 onEntry:[:con | |
|
339 Transcript showCr:('entering ' , con receiver printString , '>>factorial'). |
|
340 ] |
|
341 onExit:[:con :retVal | |
|
342 Transcript show:'leave Integer>>factorial; returning:'. |
|
343 Transcript showCr:retVal printString. |
|
344 Transcript endEntry |
|
345 ]. |
|
346 Transcript showCr:'5 factorial traced'. |
|
347 5 factorial. |
|
348 MessageTracer unwrapMethod:(Integer compiledMethodAt:#factorial). |
|
349 Transcript showCr:'5 factorial normal'. |
|
350 5 factorial. |
|
351 " |
|
352 " |
|
353 |lvl| |
|
354 |
|
355 lvl := 0. |
|
356 MessageTracer |
|
357 wrapMethod:(Integer compiledMethodAt:#factorial) |
|
358 onEntry:[:con | |
|
359 Transcript spaces:lvl. lvl := lvl + 2. |
|
360 Transcript showCr:('entering ' , con receiver printString , '>>factorial'). |
|
361 ] |
|
362 onExit:[:con :retVal | |
|
363 lvl := lvl - 2. Transcript spaces:lvl. |
|
364 Transcript show:('leave ' , con receiver printString , '>>factorial; returning:'). |
|
365 Transcript showCr:retVal printString. |
|
366 Transcript endEntry |
|
367 ]. |
|
368 Transcript showCr:'5 factorial traced'. |
|
369 5 factorial. |
|
370 MessageTracer unwrapMethod:(Integer compiledMethodAt:#factorial). |
|
371 Transcript showCr:'5 factorial normal'. |
|
372 5 factorial. |
|
373 " |
|
374 ! |
|
375 |
|
376 unwrapMethod:aMethod |
|
377 "remove any wrapper on aMethod" |
|
378 |
|
379 |parser selector args nArgs class originalMethod s spec lits src idx| |
|
380 |
|
381 aMethod isWrapped ifFalse:[ |
|
382 ^ aMethod |
|
383 ]. |
|
384 |
|
385 " |
|
386 get class/selector |
|
387 " |
|
388 class := aMethod containingClass. |
|
389 class isNil ifTrue:[ |
|
390 self error:'cannot place trap (no containing class found)'. |
|
391 ^ aMethod |
|
392 ]. |
|
393 selector := class selectorForMethod:aMethod. |
|
394 |
|
395 originalMethod := aMethod originalMethod. |
|
396 originalMethod isNil ifTrue:[ |
|
397 self error:'oops, could not find original method'. |
|
398 ^ aMethod |
|
399 ]. |
|
400 |
|
401 idx := class selectorArray indexOf:selector. |
|
402 idx ~~ 0 ifTrue:[ |
|
403 class methodArray at:idx put:originalMethod |
|
404 ] ifFalse:[ |
|
405 self halt:'oops, unexpected error'. |
|
406 ^ aMethod |
|
407 ]. |
|
408 |
|
409 ObjectMemory flushCaches. |
|
410 ^ originalMethod |
|
411 ! |
|
412 |
|
413 unwrapAllMethods |
|
414 "just in case you dont know what methods have break/trace-points |
|
415 on them; this removes them all" |
|
416 |
|
417 WrappedMethod allInstancesDo:[:aMethod | |
|
418 self unwrapMethod:aMethod |
|
419 ] |
|
420 ! ! |
|
421 |
|
422 !MessageTracer class methodsFor:'class wrapping'! |
|
423 |
|
424 wrapClass:aClass selector:aSelector onEntry:entryBlock onExit:exitBlock |
|
425 "arrange for the two blocks entryBlock and exitBlock to be evaluated whenever |
|
426 aSelector is sent to instances of aClass or subclasses. |
|
427 EntryBlock will be called on entry, and get the current context passed as argument. |
|
428 ExitBlock will be called, when the method is left, and get context and the methods return value as arguments. |
|
429 " |
|
430 |
|
431 |parser sourceString selector args nArgs newClass orgClass myMetaclass trapMethod s spec lits src idx| |
|
432 |
|
433 " |
|
434 create a new method, which calls the original one, |
|
435 but only if not already being trapped. |
|
436 " |
|
437 spec := Parser methodSpecificationForSelector:aSelector. |
|
438 |
|
439 s := WriteStream on:String new. |
|
440 s nextPutAll:spec. |
|
441 s cr. |
|
442 s nextPutAll:'|retVal stubClass|'; cr. |
|
443 entryBlock notNil ifTrue:[ |
|
444 s nextPutAll:'#literal1 yourself value:thisContext.'; cr. |
|
445 ]. |
|
446 s nextPutAll:('retVal := super ' , spec , '.'); cr. |
|
447 exitBlock notNil ifTrue:[ |
|
448 s nextPutAll:'#literal2 yourself value:thisContext value:retVal.'; cr. |
|
449 ]. |
|
450 s nextPutAll:'^ retVal'; cr. |
|
451 |
|
452 trapMethod := Compiler compile:s contents |
|
453 forClass:newClass |
|
454 inCategory:'trapping' |
|
455 notifying:nil |
|
456 install:false |
|
457 skipIfSame:false |
|
458 silent:true. |
|
459 |
|
460 lits := trapMethod literals. |
|
461 entryBlock notNil ifTrue:[ |
|
462 lits at:(lits indexOf:#literal1) put:entryBlock. |
|
463 ]. |
|
464 exitBlock notNil ifTrue:[ |
|
465 lits at:(lits indexOf:#literal2) put:exitBlock. |
|
466 ]. |
|
467 " |
|
468 change the source of this new method |
|
469 (to avoid confusion in the debugger ...) |
|
470 " |
|
471 trapMethod source:'this is a wrapper method - not the real one'. |
|
472 |
|
473 " |
|
474 if not already trapping, create a new class |
|
475 " |
|
476 aClass category == #trapping ifTrue:[ |
|
477 idx := aClass selectorArray indexOf:aSelector. |
|
478 idx ~~ 0 ifTrue:[ |
|
479 aClass methodArray at:idx put:trapMethod |
|
480 ] ifFalse:[ |
|
481 aClass setSelectorArray:(aClass selectorArray copyWith:aSelector). |
|
482 aClass setMethodArray:(aClass methodArray copyWith:trapMethod) |
|
483 ]. |
|
484 lits at:(lits indexOf:#literal3) put:aClass superclass. |
|
485 ] ifFalse:[ |
|
486 myMetaclass := aClass class. |
|
487 |
|
488 newClass := myMetaclass new. |
|
489 newClass setSuperclass:aClass superclass. |
|
490 newClass instSize:aClass instSize. |
|
491 newClass flags:aClass flags. |
|
492 newClass setClassVariableString:aClass classVariableString. |
|
493 newClass setInstanceVariableString:aClass instanceVariableString. |
|
494 newClass setName:aClass name. |
|
495 newClass category:aClass category. |
|
496 newClass setSelectorArray:aClass selectorArray. |
|
497 newClass setMethodArray:aClass methodArray. |
|
498 |
|
499 aClass setSuperclass:newClass. |
|
500 aClass setClassVariableString:''. |
|
501 aClass setInstanceVariableString:''. |
|
502 aClass category:#trapping. |
|
503 aClass setSelectorArray:(Array with:aSelector). |
|
504 aClass setMethodArray:(Array with:trapMethod). |
|
505 |
|
506 lits at:(lits indexOf:#literal3) put:newClass. |
|
507 ]. |
|
508 |
|
509 ObjectMemory flushCaches. |
|
510 |
|
511 " |
|
512 MessageTracer |
|
513 wrapMethod:(Point compiledMethodAt:#scaleBy:) |
|
514 onEntry:nil |
|
515 onExit:[:con :retVal | |
|
516 Transcript show:'leave Point>>scaleBy:; returning:'. |
|
517 Transcript showCr:retVal printString. |
|
518 Transcript endEntry |
|
519 ]. |
|
520 (1@2) scaleBy:5. |
|
521 MessageTracer untrapClass:Point. |
|
522 (1@2) scaleBy:5. |
|
523 " |
|
524 " |
|
525 MessageTracer |
|
526 wrapMethod:(Integer compiledMethodAt:#factorial) |
|
527 onEntry:[:con | |
|
528 Transcript showCr:('entering ' , con receiver printString , '>>factorial'). |
|
529 ] |
|
530 onExit:[:con :retVal | |
|
531 Transcript show:'leave Integer>>factorial; returning:'. |
|
532 Transcript showCr:retVal printString. |
|
533 Transcript endEntry |
|
534 ]. |
|
535 Transcript showCr:'5 factorial traced'. |
|
536 5 factorial. |
|
537 MessageTracer untrapClass:Integer. |
|
538 Transcript showCr:'5 factorial normal'. |
|
539 5 factorial. |
|
540 " |
|
541 " |
|
542 |lvl| |
|
543 |
|
544 lvl := 0. |
|
545 MessageTracer |
|
546 wrapMethod:(Integer compiledMethodAt:#factorial) |
|
547 onEntry:[:con | |
|
548 Transcript spaces:lvl. lvl := lvl + 2. |
|
549 Transcript showCr:('entering ' , con receiver printString , '>>factorial'). |
|
550 ] |
|
551 onExit:[:con :retVal | |
|
552 lvl := lvl - 2. Transcript spaces:lvl. |
|
553 Transcript show:('leave ' , con receiver printString , '>>factorial; returning:'). |
|
554 Transcript showCr:retVal printString. |
|
555 Transcript endEntry |
|
556 ]. |
|
557 Transcript showCr:'5 factorial traced'. |
|
558 5 factorial. |
|
559 MessageTracer untrapClass:Integer. |
|
560 Transcript showCr:'5 factorial normal'. |
|
561 5 factorial. |
|
562 " |
|
563 ! ! |
|
564 |
|
565 !MessageTracer class methodsFor:'object breakpointing'! |
|
566 |
|
567 trap:anObject selector:aSelector |
|
568 "arrange for the debugger to be entered when a message with aSelector is |
|
569 sent to anObject. Use untrap to remove this trap. |
|
570 The current implementation does not allow integers or nil to be trapped." |
|
571 |
|
572 self wrap:anObject |
|
573 selector:aSelector |
|
574 onEntry:[:context | |
|
575 Debugger enter:context withMessage:'breakPoint hit' |
|
576 ] |
|
577 onExit:[:context :retVal | ]. |
|
578 |
|
579 " |
|
580 |p| |
|
581 |
|
582 p := Point new. |
|
583 MessageTracer trap:p selector:#x:. |
|
584 p x:5 |
|
585 " |
|
586 ! |
|
587 |
|
588 untrap:anObject selector:aSelector |
|
589 "remove trap on aSelector from anObject" |
|
590 |
|
591 |orgClass idx sels| |
|
592 |
|
593 orgClass := anObject class. |
|
594 orgClass category == #trapping ifFalse:[^ self]. |
|
595 |
|
596 sels := orgClass selectorArray. |
|
597 idx := sels indexOf:aSelector. |
|
598 idx == 0 ifTrue:[^ self]. |
|
599 |
|
600 sels size == 1 ifTrue:[ |
|
601 "the last trap got removed" |
|
602 anObject changeClassTo:orgClass superclass. |
|
603 ^ self |
|
604 ]. |
|
605 orgClass setSelectorArray:(sels copyWithoutIndex:idx). |
|
606 orgClass setMethodArray:(orgClass methodArray copyWithoutIndex:idx). |
|
607 ObjectMemory flushCaches. "avoid calling the old trap method" |
|
608 |
|
609 " |
|
610 |p| |
|
611 |
|
612 p := Point new copy. |
|
613 MessageTracer trace:p selector:#x:. |
|
614 MessageTracer trace:p selector:#y:. |
|
615 'trace both ...' errorPrintNL. |
|
616 p x:2. |
|
617 p y:1. |
|
618 'trace only y ...' errorPrintNL. |
|
619 MessageTracer untrap:p selector:#x:. |
|
620 p x:2. |
|
621 p y:1. |
|
622 'trace none ...' errorPrintNL. |
|
623 MessageTracer untrap:p selector:#y:. |
|
624 p x:2. |
|
625 p y:1. |
|
626 " |
|
627 ! |
|
628 |
|
629 untrap:anObject |
|
630 "remove any traps on anObject" |
|
631 |
|
632 "this is done by just patching the objects class back to the original" |
|
633 |
|
634 |orgClass| |
|
635 |
|
636 orgClass := anObject class. |
|
637 orgClass category == #trapping ifFalse:[ |
|
638 ^ self |
|
639 ]. |
|
640 |
|
641 anObject changeClassTo:orgClass superclass |
|
642 |
|
643 " |
|
644 |p| |
|
645 |
|
646 p := Point new copy. |
|
647 MessageTracer trace:p selector:#x:. |
|
648 MessageTracer trace:p selector:#y:. |
|
649 p y:1. |
|
650 p x:2. |
|
651 MessageTracer untrap:p |
|
652 p y:2. |
|
653 p x:1. |
|
654 " |
|
655 ! ! |
|
656 |
|
657 !MessageTracer class methodsFor:'method breakpointing'! |
|
658 |
|
659 trapMethod:aMethod |
|
660 "arrange for the debugger to be entered when aMethod is about to be executed. |
|
661 Use unwrapMethod or untrapClass to remove this trap. |
|
662 Be careful, to not place a trap on code needed in the debugger (i.e. on scrollBars etc.); |
|
663 if there is a need to trap those, use the low-level wrap-methods, and put a check into the |
|
664 entry/leave blocks." |
|
665 |
|
666 ^ self wrapMethod:aMethod |
|
667 onEntry:[:context | |
|
668 Debugger enter:context withMessage:'breakPoint hit' |
|
669 ] |
|
670 onExit:[:context :retVal | ]. |
|
671 |
|
672 " |
|
673 MessageTracer trapMethod:(Collection compiledMethodAt:#select:). |
|
674 Dictionary new select:[:e | ]. 'not cought - Dictionary has its own select'. |
|
675 (Array new:10) select:[:e | ]. 'not cought - SeqColl has its own select'. |
|
676 Set new select:[:e | ]. 'cought - Set inherits this from Collection'. |
|
677 MessageTracer unwrapMethod:(Collection compiledMethodAt:#select:). |
|
678 " |
|
679 ! |
|
680 |
|
681 untrapMethod:aMethod |
|
682 "remove break on aMethod" |
|
683 |
|
684 "just a rename for your convenience - the same basic mechanism is used for all of these |
|
685 trace facilities ..." |
|
686 |
|
687 ^ self unwrapMethod:aMethod |
|
688 ! ! |
|
689 |
|
690 !MessageTracer class methodsFor:'class breakpointing'! |
|
691 |
|
692 trapClass:aClass selector:aSelector |
|
693 "arrange for the debugger to be entered when a message with aSelector is |
|
694 sent to instances of aClass (or subclass instances). Use untrapClass to remove this trap. |
|
695 Be careful, to not place a trap on code needed in the debugger (i.e. on scrollBars etc.); |
|
696 if there is a need to trap those, use the low-level wrap-methods, and put a check into the |
|
697 entry/leave blocks." |
|
698 |
|
699 self wrapMethod:(aClass compiledMethodAt:aSelector) |
|
700 onEntry:[:context | |
|
701 Debugger enter:context withMessage:'breakPoint hit' |
|
702 ] |
|
703 onExit:[:context :retVal | ]. |
|
704 |
|
705 " |
|
706 MessageTracer trapClass:Collection selector:#select:. |
|
707 Dictionary new select:[:e | ]. 'not cought - Dictionary has its own select'. |
|
708 (Array new:10) select:[:e | ]. 'not cought - SeqColl has its own select'. |
|
709 Set new select:[:e | ]. 'cought - Set inherits this from Collection'. |
|
710 MessageTracer untrapClass:Collection |
|
711 " |
|
712 ! |
|
713 |
|
714 untrapClass:aClass selector:aSelector |
|
715 "remove trap of aSelector sent to aClass" |
|
716 |
|
717 |idx sels newSels newMethods| |
|
718 |
|
719 aClass category == #trapping ifFalse:[ |
|
720 ^ self |
|
721 ]. |
|
722 |
|
723 sels := aClass selectorArray. |
|
724 idx := sels indexOf:aSelector. |
|
725 idx == 0 ifTrue:[ |
|
726 ^ self |
|
727 ]. |
|
728 sels size == 1 ifTrue:[ |
|
729 "the last trapped method" |
|
730 ^ self untrapClass:aClass |
|
731 ]. |
|
732 newSels := sels copyWithoutIndex:idx. |
|
733 newMethods := aClass methodArray copyWithoutIndex:idx. |
|
734 aClass selectors:newSels methods:newMethods. |
|
735 |
|
736 " |
|
737 MessageTracer trapClass:Point selector:#copy. |
|
738 (1@2) copy. |
|
739 (1@2) deepCopy. |
|
740 MessageTracer trapClass:Point selector:#deepCopy. |
|
741 (1@2) copy. |
|
742 (1@2) deepCopy. |
|
743 MessageTracer untrapClass:Point selector:#copy. |
|
744 (1@2) copy. |
|
745 (1@2) deepCopy. |
|
746 MessageTracer untrapClass:Point selector:#deepCopy. |
|
747 (1@2) copy. |
|
748 (1@2) deepCopy. |
|
749 " |
|
750 ! |
|
751 |
|
752 untrapClass:aClass |
|
753 "remove any traps on aClass" |
|
754 |
|
755 "this is done by just patching the class back to the original" |
|
756 |
|
757 |orgClass| |
|
758 |
|
759 aClass category == #trapping ifFalse:[ |
|
760 ^ self |
|
761 ]. |
|
762 orgClass := aClass superclass. |
|
763 |
|
764 aClass setSuperclass:orgClass superclass. |
|
765 aClass setClassVariableString:orgClass classVariableString. |
|
766 aClass setInstanceVariableString:orgClass instanceVariableString. |
|
767 aClass category:orgClass category. |
|
768 aClass setSelectorArray:orgClass selectorArray. |
|
769 aClass setMethodArray:orgClass methodArray. |
|
770 |
|
771 ObjectMemory flushCaches. |
|
772 |
|
773 " |
|
774 MessageTracer untrapClass:Point |
|
775 " |
|
776 ! |
|
777 |
|
778 untrapAllClasses |
|
779 "remove any traps on any class" |
|
780 |
|
781 Smalltalk allBehaviorsDo:[:aClass | |
|
782 self untrapClass:aClass |
|
783 ] |
|
784 |
|
785 " |
|
786 MessageTracer untrapAllClasses |
|
787 " |
|
788 ! ! |
|
789 |
|
790 !MessageTracer class methodsFor:'object tracing'! |
|
791 |
|
792 trace:anObject selector:aSelector |
|
793 "arrange for a trace message to be output on Stderr, when a message with |
|
794 aSelector is sent to anObject. Both entry and exit are traced. |
|
795 Use untrap to remove this trace. |
|
796 The current implementation does not allow integers or nil to be traced." |
|
797 |
|
798 |methodName| |
|
799 |
|
800 methodName := anObject class name , '>>' , aSelector. |
|
801 self wrap:anObject |
|
802 selector:aSelector |
|
803 onEntry:[:con | |
|
804 'enter ' errorPrint. methodName errorPrint. |
|
805 ' receiver=' errorPrint. con receiver printString errorPrint. |
|
806 ' args=' errorPrint. (con args) printString errorPrintNL. |
|
807 ] |
|
808 onExit:[:con :retVal | |
|
809 'leave ' errorPrint. methodName errorPrint. |
|
810 ' receiver=' errorPrint. con receiver printString errorPrint. |
|
811 ' returning:' errorPrint. retVal printString errorPrintNL. |
|
812 ]. |
|
813 |
|
814 " |
|
815 |p| |
|
816 |
|
817 p := Point new. |
|
818 MessageTracer trace:p selector:#x:. |
|
819 p x:5. |
|
820 p y:1. |
|
821 p x:10. |
|
822 MessageTracer untrap:p. |
|
823 p x:7 |
|
824 " |
|
825 " |
|
826 |a| |
|
827 |
|
828 a := #(6 1 9 66 2 17) copy. |
|
829 MessageTracer trace:a selector:#at:put:. |
|
830 MessageTracer trace:a selector:#at:. |
|
831 a sort. |
|
832 " |
|
833 ! |
|
834 |
|
835 traceSender:anObject selector:aSelector |
|
836 "arrange for a trace message to be output on Stderr, when a message with |
|
837 aSelector is sent to anObject. Only the sender is traced on entry. |
|
838 Use untrap to remove this trace. |
|
839 The current implementation does not allow integers or nil to be traced." |
|
840 |
|
841 |methodName| |
|
842 |
|
843 methodName := anObject class name , '>>' , aSelector. |
|
844 self wrap:anObject |
|
845 selector:aSelector |
|
846 onEntry:[:con | |
|
847 methodName errorPrint. |
|
848 ' from ' errorPrint. |
|
849 con sender errorPrintNL. |
|
850 ] |
|
851 onExit:[:con :retVal | |
|
852 ]. |
|
853 |
|
854 " |
|
855 |p| |
|
856 |
|
857 p := Point new. |
|
858 MessageTracer traceSender:p selector:#x:. |
|
859 p x:5. |
|
860 p y:1. |
|
861 p x:10. |
|
862 MessageTracer untrap:p. |
|
863 p x:7 |
|
864 " |
|
865 " |
|
866 |a| |
|
867 |
|
868 a := #(6 1 9 66 2 17) copy. |
|
869 MessageTracer traceSender:a selector:#at:put:. |
|
870 MessageTracer traceSender:a selector:#at:. |
|
871 a sort. |
|
872 " |
|
873 ! |
|
874 |
|
875 untrace:anObject selector:aSelector |
|
876 "remove traces of aSelector sent to anObject" |
|
877 |
|
878 "just a rename for your convenience - the same basic mechanism is used for all of these |
|
879 trace facilities ..." |
|
880 |
|
881 ^ self untrap:anObject selector:aSelector |
|
882 ! |
|
883 |
|
884 untrace:anObject |
|
885 "remove any traces on anObject" |
|
886 |
|
887 "just a rename for your convenience - the same basic mechanism is used for all of these |
|
888 trace facilities ..." |
|
889 |
|
890 ^ self untrap:anObject |
|
891 ! ! |
|
892 |
|
893 !MessageTracer class methodsFor:'method tracing'! |
|
894 |
|
895 traceMethod:aMethod |
|
896 "arrange for a trace message to be output on Stderr, when aMethod is executed. |
|
897 Use unwrapMethod to remove this." |
|
898 |
|
899 ^ self wrapMethod:aMethod |
|
900 onEntry:[:con | |
|
901 'enter ' errorPrint. con receiver class name errorPrint. |
|
902 '>>' errorPrint. |
|
903 con selector errorPrint. |
|
904 ' receiver=' errorPrint. con receiver printString errorPrint. |
|
905 ' args=' errorPrint. (con args) printString errorPrintNL. |
|
906 ] |
|
907 onExit:[:con :retVal | |
|
908 'leave ' errorPrint. con receiver class name errorPrint. |
|
909 '>>' errorPrint. |
|
910 con selector errorPrint. |
|
911 ' receiver=' errorPrint. con receiver printString errorPrint. |
|
912 ' returning:' errorPrint. retVal printString errorPrintNL. |
|
913 ]. |
|
914 |
|
915 " |
|
916 MessageTracer traceMethod:(Integer compiledMethodAt:#factorial). |
|
917 5 factorial. |
|
918 MessageTracer unwrapMethod:(Integer compiledMethodAt:#factorial) |
|
919 " |
|
920 " |
|
921 MessageTracer traceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:). |
|
922 #(6 1 9 66 2 17) copy sort. |
|
923 MessageTracer unwrapMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:). |
|
924 " |
|
925 " |
|
926 MessageTracer traceMethod:(Array compiledMethodAt:#at:). |
|
927 MessageTracer traceMethod:(Array compiledMethodAt:#at:put:). |
|
928 #(6 1 9 66 2 17) copy sort. |
|
929 MessageTracer unwrapMethod:(Array compiledMethodAt:#at:). |
|
930 MessageTracer unwrapMethod:(Array compiledMethodAt:#at:put:). |
|
931 " |
|
932 ! |
|
933 |
|
934 traceMethodSender:aMethod |
|
935 "arrange for a trace message to be output on Stderr, when amethod is executed. |
|
936 Only the sender is traced on entry. |
|
937 Use untraceMethod to remove this trace." |
|
938 |
|
939 ^ self wrapMethod:aMethod |
|
940 onEntry:[:con | |
|
941 con receiver class name errorPrint. |
|
942 '>>' errorPrint. con selector errorPrint. |
|
943 ' from ' errorPrint. |
|
944 con sender errorPrintNL. |
|
945 ] |
|
946 onExit:[:con :retVal | ]. |
|
947 ! |
|
948 |
|
949 untraceMethod:aMethod |
|
950 "remove tracing of aMethod" |
|
951 |
|
952 "just a rename for your convenience - the same basic mechanism is used for all of these |
|
953 trace facilities ..." |
|
954 |
|
955 ^ self unwrapMethod:aMethod |
|
956 ! ! |
|
957 |
|
958 !MessageTracer class methodsFor:'class tracing'! |
|
959 |
|
960 traceClass:aClass selector:aSelector |
|
961 "arrange for a trace message to be output on Stderr, when a message with aSelector is |
|
962 sent to instances of aClass (or subclass instances). Use untraceClass to remove this." |
|
963 |
|
964 self wrapMethod:(aClass compiledMethodAt:aSelector) |
|
965 onEntry:[:con | |
|
966 'enter ' errorPrint. con receiver class name errorPrint. |
|
967 '>>' errorPrint. |
|
968 con selector errorPrint. |
|
969 ' receiver=' errorPrint. con receiver printString errorPrint. |
|
970 ' args=' errorPrint. (con args) printString errorPrintNL. |
|
971 ] |
|
972 onExit:[:con :retVal | |
|
973 'leave ' errorPrint. con receiver class name errorPrint. |
|
974 '>>' errorPrint. |
|
975 con selector errorPrint. |
|
976 ' receiver=' errorPrint. con receiver printString errorPrint. |
|
977 ' returning:' errorPrint. retVal printString errorPrintNL. |
|
978 ]. |
|
979 |
|
980 " |
|
981 MessageTracer traceClass:Integer selector:#factorial. |
|
982 5 factorial. |
|
983 MessageTracer untraceClass:Integer |
|
984 " |
|
985 " |
|
986 MessageTracer traceClass:SequenceableCollection selector:#quickSortFrom:to:. |
|
987 #(6 1 9 66 2 17) copy sort. |
|
988 MessageTracer untraceClass:SequenceableCollection |
|
989 " |
|
990 " |
|
991 MessageTracer traceClass:Array selector:#at:. |
|
992 MessageTracer traceClass:Array selector:#at:put:. |
|
993 #(6 1 9 66 2 17) copy sort. |
|
994 " |
|
995 ! |
|
996 |
|
997 untraceClass:aClass |
|
998 "remove all traces of messages sent to instances of aClass" |
|
999 |
|
1000 "just a rename for your convenience - the same basic mechanism is used for all of these |
|
1001 trace facilities ..." |
|
1002 |
|
1003 ^ self untrapClass:aClass |
|
1004 ! |
|
1005 |
|
1006 untraceAllClasses |
|
1007 "remove all traces of messages sent to any class" |
|
1008 |
|
1009 "just a rename for your convenience - the same basic mechanism is used for all of these |
|
1010 trace facilities ..." |
|
1011 |
|
1012 ^ self untrapAllClasses |
|
1013 ! ! |