lib/call_stack.tcl

#!/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

}