13896e389SMichael Walsh#!/usr/bin/wish 23896e389SMichael Walsh 3*410b1787SMichael Walsh# This file provides many valuable stack inquiry procedures like get_file_proc_names, get_stack_var, etc.. 43896e389SMichael Walsh 53896e389SMichael Walshmy_source [list print.tcl] 63896e389SMichael Walsh 73896e389SMichael Walsh 83896e389SMichael Walshproc get_file_proc_names { file_path { name_regex "" } } { 93896e389SMichael Walsh 10*410b1787SMichael Walsh # Get all proc names from the file indicated by file_path and return them as a list. 113896e389SMichael Walsh 123896e389SMichael Walsh # Description of argument(s): 13*410b1787SMichael Walsh # file_path The path to the file whose proc names are to be retrieved. 14*410b1787SMichael Walsh # name_regex A regular expression to be used to narrow the result to just the desired 15*410b1787SMichael Walsh # procs. 163896e389SMichael Walsh 17*410b1787SMichael Walsh # The first sed command serves to eliminate curly braces from the target file. They are a distraction to 18*410b1787SMichael Walsh # what we are trying to do. 193896e389SMichael Walsh # TCL proc lines begin with... 203896e389SMichael Walsh # - Zero or more spaces... 213896e389SMichael Walsh # - The "proc" keyword... 223896e389SMichael Walsh # - One or more spaces... 233896e389SMichael Walsh set proc_regex "^\[ \]*proc\[ \]+" 243896e389SMichael Walsh set cmd_buf "sed -re 's/\[\\\{\\\}]//g' $file_path | egrep" 253896e389SMichael Walsh append cmd_buf " '${proc_regex}${name_regex}[ ]' | sed -re" 263896e389SMichael Walsh append cmd_buf " 's/${proc_regex}(\[^ \]+).*/\\1/g'" 273896e389SMichael Walsh return [split [eval exec bash -c {$cmd_buf}] "\n"] 283896e389SMichael Walsh 293896e389SMichael Walsh} 303896e389SMichael Walsh 313896e389SMichael Walsh 323896e389SMichael Walshproc get_stack_var { var_name { default {} } { init_stack_ix 1 } } { 333896e389SMichael Walsh 34*410b1787SMichael Walsh # Starting with the caller's stack level, search upward in the call stack, for a variable named 35*410b1787SMichael Walsh # "${var_name}" and return its value. If the variable cannot be found, return ${default}. 363896e389SMichael Walsh 373896e389SMichael Walsh # Description of argument(s): 383896e389SMichael Walsh # var_name The name of the variable be searched for. 39*410b1787SMichael Walsh # default The value to return if the the variable cannot be found. 403896e389SMichael Walsh 413896e389SMichael Walsh for {set stack_ix $init_stack_ix} {$stack_ix <= [info level]} \ 423896e389SMichael Walsh {incr stack_ix} { 433896e389SMichael Walsh upvar $stack_ix $var_name var_ref 443896e389SMichael Walsh if { [info exists var_ref] } { return $var_ref } 453896e389SMichael Walsh } 463896e389SMichael Walsh 473896e389SMichael Walsh return $default 483896e389SMichael Walsh 493896e389SMichael Walsh} 503896e389SMichael Walsh 513896e389SMichael Walsh 523896e389SMichael Walshproc get_stack_var_level { var_name { init_stack_ix 1 } { fail_on_err 1 } } { 533896e389SMichael Walsh 54*410b1787SMichael Walsh # Starting with the caller's stack level, search upward in the call stack, for a variable named 55*410b1787SMichael Walsh # "${var_name}" and return its associated stack level. If the variable cannot be found, return -1. 563896e389SMichael Walsh 573896e389SMichael Walsh # Description of argument(s): 583896e389SMichael Walsh # var_name The name of the variable be searched for. 59*410b1787SMichael Walsh # init_stack_ix The level of the stack where the search should start. The default is 1 60*410b1787SMichael Walsh # which is the caller's stack level. 61*410b1787SMichael Walsh # fail_on_err Indicates that if the variable cannot be found on the stack, this proc 62*410b1787SMichael Walsh # should write to stderr and exit with a non-zero return code. 633896e389SMichael Walsh 643896e389SMichael Walsh for {set stack_ix $init_stack_ix} {$stack_ix <= [info level]} \ 653896e389SMichael Walsh {incr stack_ix} { 663896e389SMichael Walsh upvar $stack_ix $var_name var_ref 673896e389SMichael Walsh set stack_level [expr $stack_ix - $init_stack_ix] 683896e389SMichael Walsh if { [info exists var_ref] } { return $stack_level } 693896e389SMichael Walsh } 703896e389SMichael Walsh 713896e389SMichael Walsh if { $fail_on_err } { 723896e389SMichael Walsh append message "Programmer error - Couldn't find variable \"${var_name}\"" 733896e389SMichael Walsh append message " on the stack." 743896e389SMichael Walsh print_error_report $message 753896e389SMichael Walsh exit 1 763896e389SMichael Walsh } 773896e389SMichael Walsh 783896e389SMichael Walsh return -1 793896e389SMichael Walsh 803896e389SMichael Walsh} 813896e389SMichael Walsh 823896e389SMichael Walsh 833896e389SMichael Walshproc get_stack_proc_name { { level -1 } { include_args 0 } } { 843896e389SMichael Walsh 85*410b1787SMichael Walsh # Get the name of the procedure at the indicated call stack level and return it. 863896e389SMichael Walsh 873896e389SMichael Walsh # Description of argument(s): 88*410b1787SMichael Walsh # level The call stack level: 0 would mean this procedure's level (i.e. 89*410b1787SMichael Walsh # get_stack_proc_name's level), -1 would indicate the caller's level, etc. 90*410b1787SMichael Walsh # include_args Indicates whether proc arg values should be included in the result. 913896e389SMichael Walsh 923896e389SMichael Walsh # Set default. 933896e389SMichael Walsh set_var_default level -1 943896e389SMichael Walsh 953896e389SMichael Walsh if { $include_args } { 963896e389SMichael Walsh set cmd_buf "set proc_name \[info level $level\]" 973896e389SMichael Walsh } else { 983896e389SMichael Walsh set cmd_buf "set proc_name \[lindex \[info level $level\] 0\]" 993896e389SMichael Walsh } 1003896e389SMichael Walsh 1013896e389SMichael Walsh if { [ catch $cmd_buf result ] } { 1023896e389SMichael Walsh # The command failed most likely due to being called from "main". 1033896e389SMichael Walsh set proc_name "main" 1043896e389SMichael Walsh } 1053896e389SMichael Walsh 1063896e389SMichael Walsh return $proc_name 1073896e389SMichael Walsh 1083896e389SMichael Walsh} 1093896e389SMichael Walsh 1103896e389SMichael Walsh 1113896e389SMichael Walshproc get_call_stack { { stack_top_ix -1 } { include_args 0 } } { 1123896e389SMichael Walsh 1133896e389SMichael Walsh # Return the call stack as a list of procedure names. 1143896e389SMichael Walsh 1153896e389SMichael Walsh # Example: 1163896e389SMichael Walsh # set call_stack [get_call_stack 0] 117*410b1787SMichael Walsh # call_stack: get_call_stack calc_wrap_stack_ix_adjust sprint_var sprint_vars print_vars 1183896e389SMichael Walsh 1193896e389SMichael Walsh # Description of argument(s): 120*410b1787SMichael Walsh # stack_top_ix The index to the bottom of the stack to be returned. 0 means include the 121*410b1787SMichael Walsh # entire stack. 1 means include the entire stack with the exception of 122*410b1787SMichael Walsh # this procedure itself, etc. 123*410b1787SMichael Walsh # include_args Indicates whether proc args should be included in the result. 1243896e389SMichael Walsh 1253896e389SMichael Walsh set_var_default stack_top_ix -1 1263896e389SMichael Walsh 1273896e389SMichael Walsh # Get the current stack size. 1283896e389SMichael Walsh set stack_size [info level] 129*410b1787SMichael Walsh # Calculate stack_bottom_ix. Example: if stack_size is 5, stack_bottom_ix is -4. 1303896e389SMichael Walsh set stack_bottom_ix [expr 1 - $stack_size] 1313896e389SMichael Walsh for {set stack_ix $stack_top_ix} {$stack_ix >= $stack_bottom_ix} \ 1323896e389SMichael Walsh {incr stack_ix -1} { 1333896e389SMichael Walsh if { $include_args } { 1343896e389SMichael Walsh set proc_name [info level $stack_ix] 1353896e389SMichael Walsh } else { 1363896e389SMichael Walsh set proc_name [lindex [info level $stack_ix] 0] 1373896e389SMichael Walsh } 1383896e389SMichael Walsh lappend call_stack $proc_name 1393896e389SMichael Walsh } 1403896e389SMichael Walsh 1413896e389SMichael Walsh return $call_stack 1423896e389SMichael Walsh 1433896e389SMichael Walsh} 144