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