New call_stack.tcl file
Change-Id: I8d141a449459b6876f458ab25aff7a425b4ab4a6
Signed-off-by: Michael Walsh <micwalsh@us.ibm.com>
diff --git a/lib/call_stack.tcl b/lib/call_stack.tcl
new file mode 100755
index 0000000..fe3158c
--- /dev/null
+++ b/lib/call_stack.tcl
@@ -0,0 +1,161 @@
+#!/usr/bin/wish
+
+# This file provides many valuable stack inquiry procedures like
+# get_file_proc_names, get_stack_var, etc..
+
+my_source [list print.tcl]
+
+
+proc get_file_proc_names { file_path { name_regex "" } } {
+
+ # Get all proc names from the file indicated by file_path and return them
+ # as a list.
+
+ # Description of argument(s):
+ # file_path The path to the file whose proc names are
+ # to be retrieved.
+ # name_regex A regular expression to be used to narrow
+ # the result to just the desired procs.
+
+ # The first sed command serves to eliminate curly braces from the target
+ # file. They are a distraction to what we are trying to do.
+ # TCL proc lines begin with...
+ # - Zero or more spaces...
+ # - The "proc" keyword...
+ # - One or more spaces...
+ set proc_regex "^\[ \]*proc\[ \]+"
+ set cmd_buf "sed -re 's/\[\\\{\\\}]//g' $file_path | egrep"
+ append cmd_buf " '${proc_regex}${name_regex}[ ]' | sed -re"
+ append cmd_buf " 's/${proc_regex}(\[^ \]+).*/\\1/g'"
+ return [split [eval exec bash -c {$cmd_buf}] "\n"]
+
+}
+
+
+proc get_stack_var { var_name { default {} } { init_stack_ix 1 } } {
+
+ # Starting with the caller's stack level, search upward in the call stack,
+ # for a variable named "${var_name}" and return its value. If the variable
+ # cannot be found, return ${default}.
+
+ # Description of argument(s):
+ # var_name The name of the variable be searched for.
+ # default The value to return if the the variable
+ # cannot be found.
+
+ for {set stack_ix $init_stack_ix} {$stack_ix <= [info level]} \
+ {incr stack_ix} {
+ upvar $stack_ix $var_name var_ref
+ if { [info exists var_ref] } { return $var_ref }
+ }
+
+ return $default
+
+}
+
+
+proc get_stack_var_level { var_name { init_stack_ix 1 } { fail_on_err 1 } } {
+
+ # Starting with the caller's stack level, search upward in the call stack,
+ # for a variable named "${var_name}" and return its associated stack level.
+ # If the variable cannot be found, return -1.
+
+ # Description of argument(s):
+ # var_name The name of the variable be searched for.
+ # init_stack_ix The level of the stack where the search
+ # should start. The default is 1 which is
+ # the caller's stack level.
+ # fail_on_err Indicates that if the variable cannot be
+ # found on the stack, this proc should write
+ # to stderr and exit with a non-zero return
+ # code.
+
+ for {set stack_ix $init_stack_ix} {$stack_ix <= [info level]} \
+ {incr stack_ix} {
+ upvar $stack_ix $var_name var_ref
+ set stack_level [expr $stack_ix - $init_stack_ix]
+ if { [info exists var_ref] } { return $stack_level }
+ }
+
+ if { $fail_on_err } {
+ append message "Programmer error - Couldn't find variable \"${var_name}\""
+ append message " on the stack."
+ print_error_report $message
+ exit 1
+ }
+
+ return -1
+
+}
+
+
+proc get_stack_proc_name { { level -1 } { include_args 0 } } {
+
+ # Get the name of the procedure at the indicated call stack level and
+ # return it.
+
+ # Description of argument(s):
+ # level The call stack level: 0 would mean this
+ # procedure's level (i.e.
+ # get_stack_proc_name's level), -1 would
+ # indicate the caller's level, etc.
+ # include_args Indicates whether proc arg values should
+ # be included in the result.
+
+ # Set default.
+ set_var_default level -1
+
+ if { $include_args } {
+ set cmd_buf "set proc_name \[info level $level\]"
+ } else {
+ set cmd_buf "set proc_name \[lindex \[info level $level\] 0\]"
+ }
+
+ if { [ catch $cmd_buf result ] } {
+ # The command failed most likely due to being called from "main".
+ set proc_name "main"
+ }
+
+ return $proc_name
+
+}
+
+
+proc get_call_stack { { stack_top_ix -1 } { include_args 0 } } {
+
+ # Return the call stack as a list of procedure names.
+
+ # Example:
+ # set call_stack [get_call_stack 0]
+ # call_stack: get_call_stack calc_wrap_stack_ix_adjust sprint_var
+ # sprint_vars print_vars
+
+ # Description of argument(s):
+ # stack_top_ix The index to the bottom of the stack to be
+ # returned. 0 means include the entire
+ # stack. 1 means include the entire stack
+ # with the exception of this procedure
+ # itself, etc.
+ # include_args Indicates whether proc args should be
+ # included in the result.
+
+ set_var_default stack_top_ix -1
+
+ # Get the current stack size.
+ set stack_size [info level]
+ # Calculate stack_bottom_ix. Example: if stack_size is 5, stack_bottom_ix
+ # is -4.
+ set stack_bottom_ix [expr 1 - $stack_size]
+ for {set stack_ix $stack_top_ix} {$stack_ix >= $stack_bottom_ix} \
+ {incr stack_ix -1} {
+ if { $include_args } {
+ set proc_name [info level $stack_ix]
+ } else {
+ set proc_name [lindex [info level $stack_ix] 0]
+ }
+ lappend call_stack $proc_name
+ }
+
+ return $call_stack
+
+}