1 # tcltrace.tcl --
2 #
3 # trace only certain classes -- tcl-side only!
4 #
5 # Copyright (c) 1998-2002 The Regents of the University of California.
6 # All rights reserved.
7 #
8 # Redistribution and use in source and binary forms, with or without
9 # modification, are permitted provided that the following conditions are met:
10 #
11 # A. Redistributions of source code must retain the above copyright notice,
12 # this list of conditions and the following disclaimer.
13 # B. Redistributions in binary form must reproduce the above copyright notice,
14 # this list of conditions and the following disclaimer in the documentation
15 # and/or other materials provided with the distribution.
16 # C. Neither the names of the copyright holders nor the names of its
17 # contributors may be used to endorse or promote products derived from this
18 # software without specific prior written permission.
19 #
20 # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
21 # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22 # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23 # ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
24 # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
25 # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
26 # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
27 # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
28 # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
29 # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30
31
32 # trace only certain classes -- tcl-side only!
33 #
34 # don't bother creating new instances -- just say
35 # import Trace
36 # in relevent files, and to put a trace msg, call
37 # Trc flag "my msg"
38 # or
39 # Trc "my msg"
40 #<p>
41 # Indicate which flags to trace via:
42 # Trace on|off
43 # Trace add FLAG ...
44 # and/or
45 # Trace rm FLAG ...
46 #
47 # e.g., for class-level ctrl of method tracing, in instprocs put:
48 # Trc $class "--> ${class}::$proc"
49 #
50 # Precedence is as follows: on/off first, then individual flags,
51 # but if onoff==1 and flags="", trace everything
52 #
53 Class Trace
54
55 Trace set flags ""
56 Trace set onoff 0
57
58 Trace proc add {args} {
59 set f [Trace set flags]
60 foreach a $args {
61 if {[lsearch -exact $f $a]==-1} {
62 lappend f $a
63 }
64 }
65 Trace set flags $f
66 }
67
68 Trace proc rm {args} {
69 set f [Trace set flags]
70 foreach a $args {
71 set idx [lsearch -exact $f $a]
72 if {$idx != -1} {
73 set f [lreplace $f $idx $idx]
74 }
75 }
76 Trace set flags $f
77 }
78
79 Trace proc on {} {Trace set onoff 1}
80 Trace proc off {} {Trace set onoff 0}
81
82 proc Trc {flag {msg ""}} {
83 if ![Trace set onoff] {return}
84 set t [clock format [clock seconds] -format {%H:%M:%S}]
85 if {$msg == ""} {
86 puts "\[$t\] Trc: $flag" ;# `flag' is actually the msg
87 } else {
88 set f [Trace set flags]
89 if {$f == "" || [lsearch $f $flag] != -1} {
90 puts "\[$t\] Trc - $flag: $msg"
91 }
92 }
93 }
94
This page was automatically generated by the
LXR engine.
Visit the LXR main site for more
information.