1 # recorder.tcl --
2 #
3 # FIXME: This file needs a description here.
4 #
5 # Copyright (c) 1993-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 #
33 # A simple recording facility to dump function calls to a class
34 # note that this class traps all function calls to an object
35 # so, it will affect performance...
36 #
37 Class Tcl_Recorder
38
39 # Review: should have caller specify log file
40 Tcl_Recorder instproc init {classname args} {
41 $self instvar theobj_ classname_ logf_ clock_ st_
42 $self next
43
44 set st_ [gettimeofday]
45 set hn [info hostname]
46 set hn [lindex [split $hn .] 0]
47 set logf_ [open $hn.rlog "w+"]
48 set classname_ $classname
49 set theobj_ [eval new $classname_ $args]
50 }
51
52 Tcl_Recorder instproc unknown {m args} {
53 $self instvar theobj_ classname_ clock_ st_ logf_
54 puts $logf_ "[expr [gettimeofday] - $st_] $classname_ $m $args"
55 set ret [eval $theobj_ $m $args]
56 # puts stderr "rec returns: ($ret)"
57 return $ret
58 }
59
60 # Allows playback of commands send to an object that had been recorded
61 # using Tcl_Recorder, from a log file
62 Class Tcl_Player
63
64 Tcl_Player instproc init {logfn target isRealTime} {
65 $self instvar logf_ tgt_ isRealTime_
66 set logf_ [open $logfn "r+"]
67 set tgt_ $target
68 set isRealTime_ $isRealTime
69 }
70
71 Tcl_Player instproc start {} {
72 $self instvar st_ now_ nextCmd_
73 set now_ 0
74 set next_ 0
75 set nextCmd_ ""
76 $self run_next
77 }
78
79 Tcl_Player instproc run_next {} {
80 set nextCmd [$self set nextCmd_]
81 if {$nextCmd!=""} {
82 eval [$self set tgt_] $nextCmd
83 }
84 set c [gets [$self set logf_] line]
85 if {$c == -1} {
86 close [$self set logf_]
87 delete $self
88 return
89 }
90 $self instvar nextCmd_ isRealTime_ now_
91 set nextCmd_ [lrange $line 2 end]
92 if $isRealTime_ {
93 set currTime $now_
94 set nexttime [expr int ([lindex $line 0] * 1000)]
95 set now_ $nexttime
96 after [expr $nexttime - $currTime] "$self run_next"
97 } else {
98 after idle "$self run_next"
99 }
100 }
101
This page was automatically generated by the
LXR engine.
Visit the LXR main site for more
information.