1#!/usr/bin/wish
2
3# This file provides many valuable stack inquiry procedures like
4# get_file_proc_names, get_stack_var, etc..
5
6my_source [list print.tcl]
7
8
9proc get_file_proc_names { file_path { name_regex "" } } {
10
11  # Get all proc names from the file indicated by file_path and return them
12  # as a list.
13
14  # Description of argument(s):
15  # file_path                       The path to the file whose proc names are
16  #                                 to be retrieved.
17  # name_regex                      A regular expression to be used to narrow
18  #                                 the result to just the desired procs.
19
20  # The first sed command serves to eliminate curly braces from the target
21  # file.  They are a distraction to what we are trying to do.
22  # TCL proc lines begin with...
23  # - Zero or more spaces...
24  # - The "proc" keyword...
25  # - One or more spaces...
26  set proc_regex "^\[ \]*proc\[ \]+"
27  set cmd_buf "sed -re 's/\[\\\{\\\}]//g' $file_path | egrep"
28  append cmd_buf " '${proc_regex}${name_regex}[ ]' | sed -re"
29  append cmd_buf " 's/${proc_regex}(\[^ \]+).*/\\1/g'"
30  return [split [eval exec bash -c {$cmd_buf}] "\n"]
31
32}
33
34
35proc get_stack_var { var_name { default {} } { init_stack_ix 1 } } {
36
37  # Starting with the caller's stack level, search upward in the call stack,
38  # for a variable named "${var_name}" and return its value.  If the variable
39  # cannot be found, return ${default}.
40
41  # Description of argument(s):
42  # var_name                        The name of the variable be searched for.
43  # default                         The value to return if the the variable
44  #                                 cannot be found.
45
46  for {set stack_ix $init_stack_ix} {$stack_ix <= [info level]} \
47      {incr stack_ix} {
48    upvar $stack_ix $var_name var_ref
49    if { [info exists var_ref] } { return $var_ref }
50  }
51
52  return $default
53
54}
55
56
57proc get_stack_var_level { var_name { init_stack_ix 1 } { fail_on_err 1 } } {
58
59  # Starting with the caller's stack level, search upward in the call stack,
60  # for a variable named "${var_name}" and return its associated stack level.
61  # If the variable cannot be found, return -1.
62
63  # Description of argument(s):
64  # var_name                        The name of the variable be searched for.
65  # init_stack_ix                   The level of the stack where the search
66  #                                 should start.  The default is 1 which is
67  #                                 the caller's stack level.
68  # fail_on_err                     Indicates that if the variable cannot be
69  #                                 found on the stack, this proc should write
70  #                                 to stderr and exit with a non-zero return
71  #                                 code.
72
73  for {set stack_ix $init_stack_ix} {$stack_ix <= [info level]} \
74      {incr stack_ix} {
75    upvar $stack_ix $var_name var_ref
76    set stack_level [expr $stack_ix - $init_stack_ix]
77    if { [info exists var_ref] } { return $stack_level }
78  }
79
80  if { $fail_on_err } {
81    append message "Programmer error - Couldn't find variable \"${var_name}\""
82    append message " on the stack."
83    print_error_report $message
84    exit 1
85  }
86
87  return -1
88
89}
90
91
92proc get_stack_proc_name { { level -1 } { include_args 0 } } {
93
94  # Get the name of the procedure at the indicated call stack level and
95  # return it.
96
97  # Description of argument(s):
98  # level                           The call stack level: 0 would mean this
99  #                                 procedure's level (i.e.
100  #                                 get_stack_proc_name's level), -1 would
101  #                                 indicate the caller's level, etc.
102  # include_args                    Indicates whether proc arg values should
103  #                                 be included in the result.
104
105  # Set default.
106  set_var_default level -1
107
108  if { $include_args } {
109    set cmd_buf "set proc_name \[info level $level\]"
110  } else {
111    set cmd_buf "set proc_name \[lindex \[info level $level\] 0\]"
112  }
113
114  if { [ catch $cmd_buf result ] } {
115    # The command failed most likely due to being called from "main".
116    set proc_name "main"
117  }
118
119  return $proc_name
120
121}
122
123
124proc get_call_stack { { stack_top_ix -1 } { include_args 0 } } {
125
126  # Return the call stack as a list of procedure names.
127
128  # Example:
129  # set call_stack [get_call_stack 0]
130  # call_stack: get_call_stack calc_wrap_stack_ix_adjust sprint_var
131  # sprint_vars print_vars
132
133  # Description of argument(s):
134  # stack_top_ix                    The index to the bottom of the stack to be
135  #                                 returned.  0 means include the entire
136  #                                 stack.  1 means include the entire stack
137  #                                 with the exception of this procedure
138  #                                 itself, etc.
139  # include_args                    Indicates whether proc args should be
140  #                                 included in the result.
141
142  set_var_default stack_top_ix -1
143
144  # Get the current stack size.
145  set stack_size [info level]
146  # Calculate stack_bottom_ix.  Example:  if stack_size is 5, stack_bottom_ix
147  # is -4.
148  set stack_bottom_ix [expr 1 - $stack_size]
149  for {set stack_ix $stack_top_ix} {$stack_ix >= $stack_bottom_ix} \
150      {incr stack_ix -1} {
151    if { $include_args } {
152      set proc_name [info level $stack_ix]
153    } else {
154      set proc_name [lindex [info level $stack_ix] 0]
155    }
156    lappend call_stack $proc_name
157  }
158
159  return $call_stack
160
161}
162