# HG changeset patch # User claus # Date 785545664 -3600 # Node ID e416e7aa11e18341a4f498dbda8a29b8a5a6bdd1 # Parent 2bfc13a2b95afe32b702feb944a51414b71aac1e *** empty log message *** diff -r 2bfc13a2b95a -r e416e7aa11e1 MessageTracer.st --- a/MessageTracer.st Mon Nov 21 17:40:42 1994 +0100 +++ b/MessageTracer.st Wed Nov 23 00:07:44 1994 +0100 @@ -12,7 +12,7 @@ Object subclass:#MessageTracer instanceVariableNames:'traceHow' - classVariableNames:'BreakpointSignal' + classVariableNames:'BreakpointSignal CallingLevel' poolDictionaries:'' category:'System-Support' ! @@ -21,7 +21,7 @@ COPYRIGHT (c) 1994 by Claus Gittinger All Rights Reserved -$Header: /cvs/stx/stx/libbasic3/MessageTracer.st,v 1.5 1994-11-21 16:40:42 claus Exp $ +$Header: /cvs/stx/stx/libbasic3/MessageTracer.st,v 1.6 1994-11-22 23:07:44 claus Exp $ '! !MessageTracer class methodsFor:'documentation'! @@ -42,7 +42,7 @@ version " -$Header: /cvs/stx/stx/libbasic3/MessageTracer.st,v 1.5 1994-11-21 16:40:42 claus Exp $ +$Header: /cvs/stx/stx/libbasic3/MessageTracer.st,v 1.6 1994-11-22 23:07:44 claus Exp $ " ! @@ -263,31 +263,43 @@ !MessageTracer class methodsFor:'helpers '! -printEntryFull:aContext - 'enter ' errorPrint. aContext receiver class name errorPrint. - '>>' errorPrint. +printEntryFull:aContext level:lvl + (String new:lvl) errorPrint. + 'enter ' errorPrint. + aContext methodClass name errorPrint. + ' ' errorPrint. aContext selector errorPrint. - ' receiver=' errorPrint. - aContext receiver printString errorPrint. + ' rcvr=' errorPrint. + aContext receiver "printString" errorPrint. ' args=' errorPrint. - (aContext args) printString errorPrint. + (aContext args) "printString" errorPrint. ' from:' errorPrint. aContext sender errorPrintNL. ! +printEntryFull:aContext + self printEntryFull:aContext level:0 +! + printEntrySender:aContext - aContext receiver class name errorPrint. - '>>' errorPrint. aContext selector errorPrint. + aContext methodClass name errorPrint. + ' ' errorPrint. aContext selector errorPrint. ' from ' errorPrint. aContext sender errorPrintNL. ! -printExit:aContext with:retVal - 'leave ' errorPrint. aContext receiver class name errorPrint. - '>>' errorPrint. +printExit:aContext with:retVal level:lvl + (String new:lvl) errorPrint. + 'leave ' errorPrint. + aContext methodClass name errorPrint. + ' ' errorPrint. aContext selector errorPrint. - ' receiver=' errorPrint. - aContext receiver printString errorPrint. - ' returning:' errorPrint. retVal printString errorPrintNL. + ' 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'! @@ -453,12 +465,14 @@ 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 get the current context passed as argument. - ExitBlock will be called, when the method is left, and get context and + 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. @@ -512,6 +526,9 @@ silent:true. trapMethod changeClassTo:WrappedMethod. + " + raising our eyebrows here ... + " lits := trapMethod basicLiterals. entryBlock notNil ifTrue:[ lits at:(lits indexOf:#entryBlock) put:entryBlock. @@ -596,7 +613,9 @@ |selector class originalMethod idx| - (aMethod isNil or:[aMethod isWrapped]) ifFalse:[ + CallingLevel := 0. + + (aMethod isNil or:[aMethod isWrapped not]) ifTrue:[ ^ aMethod ]. @@ -1028,6 +1047,22 @@ !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 @@ -1152,26 +1187,52 @@ "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 | MessageTracer printEntryFull:con] - onExit:[:con :retVal | MessageTracer printExit:con with:retVal] + 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 unwrapMethod:(Integer compiledMethodAt:#factorial) + MessageTracer untraceMethod:(Integer compiledMethodAt:#factorial) " " MessageTracer traceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:). #(6 1 9 66 2 17) copy sort. - MessageTracer unwrapMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:). + MessageTracer untraceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:). + " + " + dont do this: " " - MessageTracer traceMethod:(Array compiledMethodAt:#at:). - MessageTracer traceMethod:(Array compiledMethodAt:#at:put:). + MessageTracer traceMethod:(Object compiledMethodAt:#at:). + MessageTracer traceMethod:(Object compiledMethodAt:#at:put:). #(6 1 9 66 2 17) copy sort. - MessageTracer unwrapMethod:(Array compiledMethodAt:#at:). - MessageTracer unwrapMethod:(Array compiledMethodAt:#at:put:). + MessageTracer untraceMethod:(Object compiledMethodAt:#at:). + MessageTracer untraceMethod:(Object compiledMethodAt:#at:put:). " ! @@ -1200,10 +1261,7 @@ "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 wrapMethod:(aClass compiledMethodAt:aSelector) - onEntry:[:con | MessageTracer printEntryFull:con] - onExit:[:con :retVal | MessageTracer printExit:con with:retVal] - + self traceMethod:(aClass compiledMethodAt:aSelector) " MessageTracer traceClass:Integer selector:#factorial. diff -r 2bfc13a2b95a -r e416e7aa11e1 MsgTracer.st --- a/MsgTracer.st Mon Nov 21 17:40:42 1994 +0100 +++ b/MsgTracer.st Wed Nov 23 00:07:44 1994 +0100 @@ -12,7 +12,7 @@ Object subclass:#MessageTracer instanceVariableNames:'traceHow' - classVariableNames:'BreakpointSignal' + classVariableNames:'BreakpointSignal CallingLevel' poolDictionaries:'' category:'System-Support' ! @@ -21,7 +21,7 @@ COPYRIGHT (c) 1994 by Claus Gittinger All Rights Reserved -$Header: /cvs/stx/stx/libbasic3/Attic/MsgTracer.st,v 1.5 1994-11-21 16:40:42 claus Exp $ +$Header: /cvs/stx/stx/libbasic3/Attic/MsgTracer.st,v 1.6 1994-11-22 23:07:44 claus Exp $ '! !MessageTracer class methodsFor:'documentation'! @@ -42,7 +42,7 @@ version " -$Header: /cvs/stx/stx/libbasic3/Attic/MsgTracer.st,v 1.5 1994-11-21 16:40:42 claus Exp $ +$Header: /cvs/stx/stx/libbasic3/Attic/MsgTracer.st,v 1.6 1994-11-22 23:07:44 claus Exp $ " ! @@ -263,31 +263,43 @@ !MessageTracer class methodsFor:'helpers '! -printEntryFull:aContext - 'enter ' errorPrint. aContext receiver class name errorPrint. - '>>' errorPrint. +printEntryFull:aContext level:lvl + (String new:lvl) errorPrint. + 'enter ' errorPrint. + aContext methodClass name errorPrint. + ' ' errorPrint. aContext selector errorPrint. - ' receiver=' errorPrint. - aContext receiver printString errorPrint. + ' rcvr=' errorPrint. + aContext receiver "printString" errorPrint. ' args=' errorPrint. - (aContext args) printString errorPrint. + (aContext args) "printString" errorPrint. ' from:' errorPrint. aContext sender errorPrintNL. ! +printEntryFull:aContext + self printEntryFull:aContext level:0 +! + printEntrySender:aContext - aContext receiver class name errorPrint. - '>>' errorPrint. aContext selector errorPrint. + aContext methodClass name errorPrint. + ' ' errorPrint. aContext selector errorPrint. ' from ' errorPrint. aContext sender errorPrintNL. ! -printExit:aContext with:retVal - 'leave ' errorPrint. aContext receiver class name errorPrint. - '>>' errorPrint. +printExit:aContext with:retVal level:lvl + (String new:lvl) errorPrint. + 'leave ' errorPrint. + aContext methodClass name errorPrint. + ' ' errorPrint. aContext selector errorPrint. - ' receiver=' errorPrint. - aContext receiver printString errorPrint. - ' returning:' errorPrint. retVal printString errorPrintNL. + ' 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'! @@ -453,12 +465,14 @@ 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 get the current context passed as argument. - ExitBlock will be called, when the method is left, and get context and + 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. @@ -512,6 +526,9 @@ silent:true. trapMethod changeClassTo:WrappedMethod. + " + raising our eyebrows here ... + " lits := trapMethod basicLiterals. entryBlock notNil ifTrue:[ lits at:(lits indexOf:#entryBlock) put:entryBlock. @@ -596,7 +613,9 @@ |selector class originalMethod idx| - (aMethod isNil or:[aMethod isWrapped]) ifFalse:[ + CallingLevel := 0. + + (aMethod isNil or:[aMethod isWrapped not]) ifTrue:[ ^ aMethod ]. @@ -1028,6 +1047,22 @@ !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 @@ -1152,26 +1187,52 @@ "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 | MessageTracer printEntryFull:con] - onExit:[:con :retVal | MessageTracer printExit:con with:retVal] + 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 unwrapMethod:(Integer compiledMethodAt:#factorial) + MessageTracer untraceMethod:(Integer compiledMethodAt:#factorial) " " MessageTracer traceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:). #(6 1 9 66 2 17) copy sort. - MessageTracer unwrapMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:). + MessageTracer untraceMethod:(SequenceableCollection compiledMethodAt:#quickSortFrom:to:). + " + " + dont do this: " " - MessageTracer traceMethod:(Array compiledMethodAt:#at:). - MessageTracer traceMethod:(Array compiledMethodAt:#at:put:). + MessageTracer traceMethod:(Object compiledMethodAt:#at:). + MessageTracer traceMethod:(Object compiledMethodAt:#at:put:). #(6 1 9 66 2 17) copy sort. - MessageTracer unwrapMethod:(Array compiledMethodAt:#at:). - MessageTracer unwrapMethod:(Array compiledMethodAt:#at:put:). + MessageTracer untraceMethod:(Object compiledMethodAt:#at:). + MessageTracer untraceMethod:(Object compiledMethodAt:#at:put:). " ! @@ -1200,10 +1261,7 @@ "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 wrapMethod:(aClass compiledMethodAt:aSelector) - onEntry:[:con | MessageTracer printEntryFull:con] - onExit:[:con :retVal | MessageTracer printExit:con with:retVal] - + self traceMethod:(aClass compiledMethodAt:aSelector) " MessageTracer traceClass:Integer selector:#factorial.