| #!/usr/bin/wish |
| |
| # This file provides many valuable print procedures such as sprint_var, sprint_time, sprint_error, etc. |
| |
| my_source [list data_proc.tcl call_stack.tcl escape.tcl] |
| |
| # Need "Expect" package for trap procedure. |
| package require Expect |
| |
| |
| # Setting the following variables for use both inside this file and by programs sourcing this file. |
| set program_path $argv0 |
| set program_dir_path "[file dirname $argv0]/" |
| set program_name "[file tail $argv0]" |
| # Some procedures (e.g. sprint_pgm_header) need a program name value that looks more like a valid variable |
| # name. Therefore, we'll swap out odd characters (like ".") for underscores. |
| regsub {\.} $program_name "_" pgm_name_var_name |
| |
| # Initialize some time variables used in procedures in this file. |
| set start_time [clock microseconds] |
| |
| |
| proc calc_wrap_stack_ix_adjust {} { |
| |
| # Calculate and return a number which can be used as an offset into the call stack for wrapper procedures. |
| |
| # NOTE: This procedure is designed expressly to work with this file's print procedures scheme (i.e. |
| # print_x is a wrapper for sprint_x, etc.). In other words, this procedure may not be well-suited for |
| # general use. |
| |
| # Get a list of the procedures in the call stack beginning with our immediate caller on up to the |
| # top-level caller. |
| set call_stack [get_call_stack -2] |
| |
| # The first stack entry is our immediate caller. |
| set caller [lindex $call_stack 0] |
| # Remove first entry from stack. |
| set call_stack [lreplace $call_stack 0 0] |
| # Strip any leading "s" to arrive at base_caller name (e.g. the corresponding base name for "sprint_var" |
| # would be "print_var"). |
| set base_caller [string trimleft $caller s] |
| # Account for alias print procedures which have "p" vs "print_" (e.g. pvar vs print_var). |
| regsub "print_" $base_caller "p" alias_base_caller |
| |
| # Initialize the stack_ix_adjust value. |
| set stack_ix_adjust 0 |
| # Note: print_vars|pvars is a special case so we add it explicitly to the regex below. |
| set regex ".*(${base_caller}|${alias_base_caller}|print_vars|pvars)$" |
| foreach proc_name $call_stack { |
| # For every remaining stack item that looks like a wrapper (i.e. matches our regex), we increment the |
| # stack_ix_adjust. |
| if { [regexp -expanded $regex $proc_name]} { |
| incr stack_ix_adjust |
| continue |
| } |
| # If there is no match, then we are done. |
| break |
| } |
| |
| return $stack_ix_adjust |
| |
| } |
| |
| |
| # hidden_text is a list of passwords which are to be replaced with asterisks by print procedures defined in |
| # this file. |
| set hidden_text [list] |
| # password_regex is created from the contents of the hidden_text list above. |
| set password_regex "" |
| |
| proc register_passwords {args} { |
| |
| # Register one or more passwords which are to be hidden in output produced by the print procedures in this |
| # file. |
| |
| # Note: Blank password values are NOT registered. They are simply ignored. |
| |
| # Description of argument(s): |
| # args One or more password values. If a given password value is already |
| # registered, this procedure will simply ignore it, i.e. there will be no |
| # duplicate values in the hidden_text list. |
| |
| global hidden_text |
| global password_regex |
| |
| foreach password $args { |
| # Skip blank passwords. |
| if { $password == "" } { continue } |
| # Skip already-registered passwords. |
| if { [lsearch -exact $hidden_text $password] != -1 } { continue } |
| # Put the password into the global hidden_text list. |
| lappend hidden_text [escape_regex_metachars $password] |
| } |
| |
| set password_regex [join $hidden_text |] |
| |
| } |
| |
| |
| proc replace_passwords {buffer} { |
| |
| # Replace all registered password found in buffer with a string of asterisks and return the result. |
| |
| # Description of argument(s): |
| # buffer The string to be altered and returned. |
| |
| # Note: If environment variable GEN_PRINT_DEBUG is set, this procedure will do nothing. |
| |
| global env |
| if { [get_var ::env(GEN_PRINT_DEBUG) 0] } { return $buffer } |
| if { [get_var ::env(DEBUG_SHOW_PASSWORDS) 0] } { return $buffer } |
| |
| global password_regex |
| |
| # No passwords to replace? |
| if { $password_regex == "" } { return $buffer } |
| |
| regsub -all "${password_regex}" $buffer {********} buffer |
| return $buffer |
| |
| } |
| |
| |
| proc my_time { cmd_buf { iterations 100 } } { |
| |
| # Run the "time" function on the given command string and print the results. |
| |
| # The main benefit of running this vs just doing the "time" command directly: |
| # - This will print the results. |
| |
| # Description of argument(s): |
| # cmd_buf The command string to be run. |
| # iterations The number of times to run the command string. Typically, more |
| # iterations yields more accurate results. |
| |
| print_issuing $cmd_buf |
| set result [time {uplevel 1 $cmd_buf} $iterations] |
| |
| set raw_microseconds [lindex [split [lindex $result 0] .] 0] |
| set seconds [expr $raw_microseconds / 1000000] |
| set raw_microseconds [expr $raw_microseconds % 1000000] |
| |
| set seconds_per_iteration [format "%i.%06i" ${seconds}\ |
| ${raw_microseconds}] |
| |
| print_var seconds_per_iteration |
| |
| } |
| |
| |
| # If environment variable "GEN_PRINT_DEBUG" is set, this module will output debug data. This is primarily |
| # intended for the developer of this module. |
| set GEN_PRINT_DEBUG [get_var ::env(GEN_PRINT_DEBUG) 0] |
| |
| # The user can set the following environment variables to influence the output from print_time and print_var |
| # procedures. See the prologs of those procedures for details. |
| set NANOSECONDS [get_var ::env(NANOSECONDS) 0] |
| set SHOW_ELAPSED_TIME [get_var ::env(SHOW_ELAPSED_TIME) 0] |
| |
| # _gtp_default_print_var_width_ is adjusted based on NANOSECONDS and SHOW_ELAPSED_TIME. |
| if { $NANOSECONDS } { |
| set _gtp_default_print_var_width_ 36 |
| set width_incr 14 |
| } else { |
| set _gtp_default_print_var_width_ 29 |
| set width_incr 7 |
| } |
| if { $SHOW_ELAPSED_TIME } { |
| incr _gtp_default_print_var_width_ $width_incr |
| # Initializing _sprint_time_last_seconds_ which is a global value to remember the clock seconds from the |
| # last time sprint_time was called. |
| set _gtp_sprint_time_last_micro_seconds_ [clock microseconds] |
| } |
| # tcl_precision is a built-in Tcl variable that specifies the number of digits to generate when converting |
| # floating-point values to strings. |
| set tcl_precision 17 |
| |
| |
| proc sprint { { buffer {} } } { |
| |
| # Simply return the user's buffer. |
| # This procedure is used by the qprint and dprint functions defined dynamically below, i.e. it would not |
| # normally be called for general use. |
| |
| # Description of arguments. |
| # buffer This will be returned to the caller. |
| |
| return $buffer |
| |
| } |
| |
| |
| proc sprintn { { buffer {} } } { |
| |
| # Simply return the user's buffer plus a trailing line feed.. |
| # This procedure is used by the qprintn and dprintn functions defined dynamically below, i.e. it would not |
| # normally be called for general use. |
| |
| # Description of arguments. |
| # buffer This will be returned to the caller. |
| |
| return ${buffer}\n |
| |
| } |
| |
| |
| proc sprint_time { { buffer {} } } { |
| |
| # Return the time in a formatted manner as described below. |
| |
| # Example: |
| |
| # The following tcl code... |
| |
| # puts -nonewline [sprint_time()] |
| # puts -nonewline ["Hi.\n"] |
| |
| # Will result in the following type of output: |
| |
| # #(CDT) 2016/07/08 15:25:35 - Hi. |
| |
| # Example: |
| |
| # The following tcl code... |
| |
| # puts -nonewline [sprint_time("Hi.\n")] |
| |
| # Will result in the following type of output: |
| |
| # #(CDT) 2016/08/03 17:12:05 - Hi. |
| |
| # The following environment variables will affect the formatting as described: |
| # NANOSECONDS This will cause the time stamps to be precise to the microsecond (Yes, it |
| # probably should have been named MICROSECONDS but the convention was set |
| # long ago so we're sticking with it). Example of the output when |
| # environment variable NANOSECONDS=1. |
| |
| # #(CDT) 2016/08/03 17:16:25.510469 - Hi. |
| |
| # SHOW_ELAPSED_TIME This will cause the elapsed time to be included in the output. This is |
| # the amount of time that has elapsed since the last time this procedure |
| # was called. The precision of the elapsed time field is also affected by |
| # the value of the NANOSECONDS environment variable. Example of the output |
| # when environment variable NANOSECONDS=0 and SHOW_ELAPSED_TIME=1. |
| |
| # #(CDT) 2016/08/03 17:17:40 - 0 - Hi. |
| |
| # Example of the output when environment variable NANOSECONDS=1 and SHOW_ELAPSED_TIME=1. |
| |
| # #(CDT) 2016/08/03 17:18:47.317339 - 0.000046 - Hi. |
| |
| # Description of argument(s). |
| # buffer A string string whhich is to be appended to the formatted time string and |
| # returned. |
| |
| global NANOSECONDS |
| global _gtp_sprint_time_last_micro_seconds_ |
| global SHOW_ELAPSED_TIME |
| |
| # Get micro seconds since the epoch. |
| set epoch_micro [clock microseconds] |
| # Break the left and right of the decimal point. |
| set epoch_seconds [expr $epoch_micro / 1000000] |
| set epoch_decimal_micro [expr $epoch_micro % 1000000] |
| |
| set format_string "#(%Z) %Y/%m/%d %H:%M:%S" |
| set return_string [clock format $epoch_seconds -format\ |
| "#(%Z) %Y/%m/%d %H:%M:%S"] |
| |
| if { $NANOSECONDS } { |
| append return_string ".[format "%06i" ${epoch_decimal_micro}]" |
| } |
| |
| if { $SHOW_ELAPSED_TIME } { |
| set return_string "${return_string} - " |
| |
| set elapsed_micro [expr $epoch_micro - \ |
| $_gtp_sprint_time_last_micro_seconds_] |
| set elapsed_seconds [expr $elapsed_micro / 1000000] |
| |
| if { $NANOSECONDS } { |
| set elapsed_decimal_micro [expr $elapsed_micro % 1000000] |
| set elapsed_float [format "%i.%06i" ${elapsed_seconds}\ |
| ${elapsed_decimal_micro}] |
| set elapsed_time_buffer "[format "%11.6f" ${elapsed_float}]" |
| } else { |
| set elapsed_time_buffer "[format "%4i" $elapsed_seconds]" |
| } |
| set return_string "${return_string}${elapsed_time_buffer}" |
| } |
| |
| set return_string "${return_string} - ${buffer}" |
| |
| set _gtp_sprint_time_last_micro_seconds_ $epoch_micro |
| |
| return $return_string |
| |
| } |
| |
| |
| proc sprint_timen { args } { |
| |
| # Return the value of sprint_time + a line feed. |
| |
| # Description of argument(s): |
| # args All args are passed directly to subordinate function, sprint_time. See |
| # that function's prolog for details. |
| |
| return [sprint_time {*}$args]\n |
| |
| } |
| |
| |
| proc sprint_error { { buffer {} } } { |
| |
| # Return a standardized error string which includes the callers buffer text. |
| |
| # Description of argument(s): |
| # buffer Text to be returned as part of the error message. |
| |
| return [sprint_time "**ERROR** $buffer"] |
| |
| } |
| |
| |
| proc sprint_varx { var_name var_value { indent 0 } { width {} } { hex 0 } } { |
| |
| # Return the name and value of the variable named in var_name in a formatted way. |
| |
| # This procedure will visually align the output to look good next to print_time output. |
| |
| # Example: |
| |
| # Given the following code: |
| |
| # print_timen "Initializing variables." |
| # set first_name "Joe" |
| # set last_name "Montana" |
| # set age 50 |
| # print_varx last_name $last_name |
| # print_varx first_name $first_name 2 |
| # print_varx age $age 2 |
| |
| # With environment variables NANOSECONDS and SHOW_ELAPSED_TIME both set, the following output is produced: |
| |
| # #(CST) 2017/12/14 16:38:28.259480 - 0.000651 - Initializing variables. |
| # last_name: Montana |
| # first_name: Joe |
| # age: 50 |
| |
| # Description of argument(s): |
| # var_name The name of the variable whose name and value are to be printed. |
| # var_value The value to be printed. |
| # indent The number of spaces to indent each line of output. |
| # width The width of the column containing the variable name. By default this |
| # will align with the print_time text (see example above). |
| # hex Indicates that the variable value is to be printed in hexedecimal format. |
| # This is only valid if the variable value is an integer. If the variable |
| # is NOT an integer and is blank, this will be interpreted to mean "print |
| # the string '<blank>', rather than an actual blank value". |
| |
| # Note: This procedure relies on global var _gtp_default_print_var_width_ |
| |
| set_var_default indent 0 |
| |
| global _gtp_default_print_var_width_ |
| set_var_default width $_gtp_default_print_var_width_ |
| |
| if { $indent > 0 } { |
| set width [expr $width - $indent] |
| } |
| |
| if { $hex } { |
| if { [catch {format "0x%08x" "$var_value"} result] } { |
| if { $var_value == "" } { set var_value "<blank>" } |
| set hex 0 |
| } |
| } |
| |
| if { $hex } { |
| append buffer "[format "%-${indent}s%-${width}s0x%08x" "" "$var_name:" \ |
| "$var_value"]" |
| } else { |
| append buffer "[format "%-${indent}s%-${width}s%s" "" "$var_name:" \ |
| "$var_value"]" |
| } |
| |
| return $buffer\n |
| |
| } |
| |
| |
| proc sprint_var { var_name args } { |
| |
| # Return the name and value of the variable named in var_name in a formatted way. |
| |
| # This procedure will visually align the output to look good next to print_time output. |
| |
| # Note: This procedure is the equivalent of sprint_varx with one difference: This function will figure |
| # out the value of the named variable whereas sprint_varx expects you to pass the value. This procedure in |
| # fact calls sprint_varx to do its work. |
| |
| # Note: This procedure will detect whether var_name is an array and print it accordingly (see the second |
| # example below). |
| |
| # Example: |
| |
| # Given the following code: |
| |
| # print_timen "Initializing variables." |
| # set first_name "Joe" |
| # set last_name "Montana" |
| # set age 50 |
| # print_var last_name |
| # print_var first_name 2 |
| # print_var age 2 |
| |
| # With environment variables NANOSECONDS and SHOW_ELAPSED_TIME both set, the following output is produced: |
| |
| # #(CST) 2017/12/14 16:38:28.259480 - 0.000651 - Initializing variables. |
| # last_name: Montana |
| # first_name: Joe |
| # age: 50 |
| |
| # Example: |
| # Given the following code: |
| |
| # set data(0) cow |
| # set data(1) horse |
| # print_var data |
| |
| # data: |
| # data(0): cow |
| # data(1): horse |
| |
| # Description of argument(s): |
| # var_name The name of the variable whose name and value are to be printed. |
| # args The args understood by sprint_varx (after var_name and var_value). See |
| # sprint_varx's prolog for details. |
| |
| # Note: This procedure relies on global var _gtp_default_print_var_width_ |
| |
| # Determine who our caller is and therefore what upvar_level to use to get var_value. |
| set stack_ix_adjust [calc_wrap_stack_ix_adjust] |
| set upvar_level [expr $stack_ix_adjust + 1] |
| upvar $upvar_level $var_name var_value |
| |
| # Special processing for arrays: |
| if { [array exists var_value] } { |
| set indent [lindex $args 0] |
| set args [lrange $args 1 end] |
| set_var_default indent 0 |
| |
| append buffer [format "%-${indent}s%s\n" "" "$var_name:"] |
| incr indent 2 |
| incr width -2 |
| |
| set search_token [array startsearch var_value] |
| while {[array anymore var_value $search_token]} { |
| set key [array nextelement var_value $search_token] |
| set arr_value $var_value($key) |
| append buffer [sprint_varx "${var_name}(${key})" $arr_value $indent\ |
| {*}$args] |
| } |
| array donesearch var_value $search_token |
| return $buffer |
| } |
| |
| # If var_value is not defined, catch the error and print its value as "variable not set". |
| if {[catch {set buffer [sprint_varx $var_name $var_value {*}$args]} error_text options]} { |
| set regex ":\[ \]no\[ \]such\[ \]variable" |
| if { [regexp -expanded ${regex} ${error_text}]} { |
| return [sprint_varx $var_name {** variable not set **} {*}$args] |
| } else { |
| print_dict options |
| exit 1 |
| } |
| } else { |
| return $buffer |
| } |
| |
| } |
| |
| |
| proc sprint_list { var_name args } { |
| |
| # Return the name and value of the list variable named in var_name in a formatted way. |
| |
| # This procedure is the equivalent of sprint_var but for lists. |
| |
| # Description of argument(s): |
| # var_name The name of the variable whose name and value are to be printed. |
| # args The args understood by sprint_varx (after var_name and var_value). See |
| # sprint_varx's prolog for details. |
| |
| # Note: In TCL, there is no way to determine that a variable represents a list vs a string, etc. It is up |
| # to the programmer to decide how the data is to be interpreted. Thus the need for procedures such as this |
| # one. Consider the following code: |
| |
| # set my_list {one two three} |
| # print_var my_list |
| # print_list my_list |
| |
| # Output from aforementioned code: |
| # my_list: one two three |
| # my_list: |
| # my_list[0]: one |
| # my_list[1]: two |
| # my_list[2]: three |
| |
| # As far as print_var is concerned, my_list is a string and is printed accordingly. By using print_list, |
| # the programmer is asking to have the output shown as a list with list indices, etc. |
| |
| # Determine who our caller is and therefore what upvar_level to use. |
| set stack_ix_adjust [calc_wrap_stack_ix_adjust] |
| set upvar_level [expr $stack_ix_adjust + 1] |
| upvar $upvar_level $var_name var_value |
| |
| set indent [lindex $args 0] |
| set args [lrange $args 1 end] |
| set_var_default indent 0 |
| |
| append buffer [format "%-${indent}s%s\n" "" "$var_name:"] |
| incr indent 2 |
| |
| set index 0 |
| foreach element $var_value { |
| append buffer [sprint_varx "${var_name}\[${index}\]" $element $indent\ |
| {*}$args] |
| incr index |
| } |
| |
| return $buffer |
| |
| } |
| |
| |
| proc sprint_dict { var_name args } { |
| |
| # Return the name and value of the dictionary variable named in var_name in a formatted way. |
| |
| # This procedure is the equivalent of sprint_var but for dictionaries. |
| |
| # Description of argument(s): |
| # var_name The name of the variable whose name and value are to be printed. |
| # args The args understood by sprint_varx (after var_name and var_value). See |
| # sprint_varx's prolog for details. |
| |
| # Note: In TCL, there is no way to determine that a variable represents a dictionary vs a string, etc. It |
| # is up to the programmer to decide how the data is to be interpreted. Thus the need for procedures such |
| # as this one. Consider the following code: |
| |
| # set my_dict [dict create first Joe last Montana age 50] |
| # print_var my_dict |
| # print_dict my_dict |
| |
| # Output from aforementioned code: |
| # my_dict: first Joe last Montana age 50 |
| # my_dict: |
| # my_dict[first]: Joe |
| # my_dict[last]: Montana |
| # my_dict[age]: 50 |
| |
| # As far as print_var is concerned, my_dict is a string and is printed accordingly. By using print_dict, |
| # the programmer is asking to have the output shown as a dictionary with dictionary keys/values, etc. |
| |
| # Determine who our caller is and therefore what upvar_level to use. |
| set stack_ix_adjust [calc_wrap_stack_ix_adjust] |
| set upvar_level [expr $stack_ix_adjust + 1] |
| upvar $upvar_level $var_name var_value |
| |
| set indent [lindex $args 0] |
| set args [lrange $args 1 end] |
| set_var_default indent 0 |
| |
| append buffer [format "%-${indent}s%s\n" "" "$var_name:"] |
| incr indent 2 |
| |
| foreach {key value} $var_value { |
| append buffer [sprint_varx "${var_name}\[${key}\]" $value $indent {*}$args] |
| incr index |
| } |
| |
| return $buffer |
| |
| } |
| |
| |
| proc sprint_vars { args } { |
| |
| # Sprint the values of one or more variables. |
| |
| # Description of arg(s): |
| # args: A list of variable names to be printed. The first argument in the arg list found to be an |
| # integer (rather than a variable name) will be interpreted to be first of several possible sprint_var |
| # arguments (e.g. indent, width, hex). See the prologue for sprint_var above for descriptions of this |
| # variables. |
| |
| # Example usage: |
| # set var1 "hello" |
| # set var2 "there" |
| # set indent 2 |
| # set buffer [sprint_vars var1 var2] |
| # or... |
| # set buffer [sprint_vars var1 var2 $indent] |
| |
| # Look for integer arguments. |
| set first_int_ix [lsearch -regexp $args {^[0-9]+$}] |
| if { $first_int_ix == -1 } { |
| # If none are found, sub_args is set to empty. |
| set sub_args {} |
| } else { |
| # Set sub_args to the portion of the arg list that are integers. |
| set sub_args [lrange $args $first_int_ix end] |
| # Re-set args to exclude the integer values. |
| set args [lrange $args 0 [expr $first_int_ix - 1]] |
| } |
| |
| foreach arg $args { |
| append buffer [sprint_var $arg {*}$sub_args] |
| } |
| |
| return $buffer |
| |
| } |
| |
| |
| proc sprint_dashes { { indent 0 } { width 80 } { line_feed 1 } { char "-" } } { |
| |
| # Return a string of dashes to the caller. |
| |
| # Description of argument(s): |
| # indent The number of characters to indent the output. |
| # width The width of the string of dashes. |
| # line_feed Indicates whether the output should end with a line feed. |
| # char The character to be repeated in the output string. In other words, you |
| # can call on this function to print a string of any character (e.g. "=", |
| # "_", etc.). |
| |
| set_var_default indent 0 |
| set_var_default width 80 |
| set_var_default line_feed 1 |
| |
| append buffer [string repeat " " $indent][string repeat $char $width] |
| append buffer [string repeat "\n" $line_feed] |
| |
| return $buffer |
| |
| } |
| |
| |
| proc sprint_executing {{ include_args 1 }} { |
| |
| # Return a string that looks something like this: |
| # #(CST) 2017/11/28 15:08:03.261466 - 0.015214 - Executing: proc1 hi |
| |
| # Description of argument(s): |
| # include_args Indicates whether proc args should be included in the result. |
| |
| set stack_ix_adjust [calc_wrap_stack_ix_adjust] |
| set level [expr -(2 + $stack_ix_adjust)] |
| return "[sprint_time]Executing: [get_stack_proc_name $level $include_args]\n" |
| |
| } |
| |
| |
| proc sprint_issuing { { cmd_buf "" } { test_mode 0 } } { |
| |
| # Return a line indicating a command that the program is about to execute. |
| |
| # Sample output for a cmd_buf of "ls" |
| |
| # #(CDT) 2016/08/25 17:57:36 - Issuing: ls |
| |
| # Description of arg(s): |
| # cmd_buf The command to be executed by caller. If this is blank, this procedure |
| # will search up the stack for the first cmd_buf value to use. |
| # test_mode With test_mode set, your output will look like this: |
| |
| # #(CDT) 2016/08/25 17:57:36 - (test_mode) Issuing: ls |
| |
| if { $cmd_buf == "" } { |
| set cmd_buf [get_stack_var cmd_buf {} 2] |
| } |
| |
| append buffer [sprint_time] |
| if { $test_mode } { |
| append buffer "(test_mode) " |
| } |
| append buffer "Issuing: ${cmd_buf}\n" |
| |
| return $buffer |
| |
| } |
| |
| |
| proc sprint_call_stack { { indent 0 } } { |
| |
| # Return a call stack report for the given point in the program with line numbers, procedure names and |
| # procedure parameters and arguments. |
| |
| # Sample output: |
| |
| # --------------------------------------------------------------------------- |
| # TCL procedure call stack |
| |
| # Line # Procedure name and arguments |
| # ------ -------------------------------------------------------------------- |
| # 21 print_call_stack |
| # 32 proc1 257 |
| # --------------------------------------------------------------------------- |
| |
| # Description of arguments: |
| # indent The number of characters to indent each line of output. |
| |
| append buffer "[sprint_dashes ${indent}]" |
| append buffer "[string repeat " " $indent]TCL procedure call stack\n\n" |
| append buffer "[string repeat " " $indent]" |
| append buffer "Line # Procedure name and arguments\n" |
| append buffer "[sprint_dashes $indent 6 0] [sprint_dashes 0 73]" |
| |
| for {set ix [expr [info level]-1]} {$ix > 0} {incr ix -1} { |
| set frame_dict [info frame $ix] |
| set line_num [dict get $frame_dict line] |
| set proc_name_plus_args [dict get $frame_dict cmd] |
| append buffer [format "%-${indent}s%6i %s\n" "" $line_num\ |
| $proc_name_plus_args] |
| } |
| append buffer "[sprint_dashes $indent]" |
| |
| return $buffer |
| |
| } |
| |
| |
| proc sprint_tcl_version {} { |
| |
| # Return the name and value of tcl_version in a formatted way. |
| |
| global tcl_version |
| |
| return [sprint_var tcl_version] |
| |
| } |
| |
| |
| proc sprint_error_report { { error_text "\n" } { indent 0 } } { |
| |
| # Return a string with a standardized report which includes the caller's error text, the call stack and |
| # the program header. |
| |
| # Description of arg(s): |
| # error_text The error text to be included in the report. The caller should include |
| # any needed linefeeds. |
| # indent The number of characters to indent each line of output. |
| |
| set width 120 |
| set char "=" |
| set line_feed 1 |
| append buffer [sprint_dashes $indent $width $line_feed $char] |
| append buffer [string repeat " " $indent][sprint_error $error_text] |
| append buffer "\n" |
| append buffer [sprint_call_stack $indent] |
| append buffer [sprint_pgm_header $indent] |
| append buffer [sprint_dashes $indent $width $line_feed $char] |
| |
| return $buffer |
| |
| } |
| |
| |
| proc sprint_pgm_header { {indent 0} {linefeed 1} } { |
| |
| # Return a standardized header that programs should print at the beginning of the run. It includes useful |
| # information like command line, pid, userid, program parameters, etc. |
| |
| # Description of arguments: |
| # indent The number of characters to indent each line of output. |
| # linefeed Indicates whether a line feed be included at the beginning and end of the |
| # report. |
| |
| global program_name |
| global pgm_name_var_name |
| global argv0 |
| global argv |
| global env |
| global _gtp_default_print_var_width_ |
| |
| set_var_default indent 0 |
| |
| set indent_str [string repeat " " $indent] |
| set width [expr $_gtp_default_print_var_width_ + $indent] |
| |
| # Get variable values for output. |
| set command_line "$argv0 $argv" |
| set pid_var_name ${pgm_name_var_name}_pid |
| set $pid_var_name [pid] |
| set uid [get_var ::env(USER) 0] |
| set host_name [get_var ::env(HOSTNAME) 0] |
| set DISPLAY [get_var ::env(DISPLAY) 0] |
| |
| # Generate the report. |
| if { $linefeed } { append buffer "\n" } |
| append buffer ${indent_str}[sprint_timen "Running ${program_name}."] |
| append buffer ${indent_str}[sprint_timen "Program parameter values, etc.:\n"] |
| append buffer [sprint_var command_line $indent $width] |
| append buffer [sprint_var $pid_var_name $indent $width] |
| append buffer [sprint_var uid $indent $width] |
| append buffer [sprint_var host_name $indent $width] |
| append buffer [sprint_var DISPLAY $indent $width] |
| |
| # Print caller's parm names/values. |
| global longoptions |
| global pos_parms |
| |
| regsub -all ":" "${longoptions} ${pos_parms}" {} parm_names |
| |
| foreach parm_name $parm_names { |
| set cmd_buf "global $parm_name ; append buffer" |
| append cmd_buf " \[sprint_var $parm_name $indent $width\]" |
| eval $cmd_buf |
| } |
| |
| if { $linefeed } { append buffer "\n" } |
| |
| return $buffer |
| |
| } |
| |
| |
| proc sprint_pgm_footer {} { |
| |
| # Return a standardized footer that programs should print at the end of the program run. It includes |
| # useful information like total run time, etc. |
| |
| global program_name |
| global pgm_name_var_name |
| global start_time |
| |
| # Calculate total runtime. |
| set total_time_micro [expr [clock microseconds] - $start_time] |
| # Break the left and right of the decimal point. |
| set total_seconds [expr $total_time_micro / 1000000] |
| set total_decimal_micro [expr $total_time_micro % 1000000] |
| set total_time_float [format "%i.%06i" ${total_seconds}\ |
| ${total_decimal_micro}] |
| set total_time_string [format "%0.6f" $total_time_float] |
| set runtime_var_name ${pgm_name_var_name}_runtime |
| set $runtime_var_name $total_time_string |
| |
| append buffer [sprint_timen "Finished running ${program_name}."] |
| append buffer "\n" |
| append buffer [sprint_var $runtime_var_name] |
| append buffer "\n" |
| |
| return $buffer |
| |
| } |
| |
| |
| proc sprint_arg_desc { arg_title arg_desc { indent 0 } { col1_width 25 }\ |
| { line_width 80 } } { |
| |
| # Return a formatted argument description. |
| |
| # Example: |
| # |
| # set desc "When in the Course of human events, it becomes necessary for one people to dissolve the |
| # political bands which have connected them with another, and to assume among the powers of the earth, the |
| # separate and equal station to which the Laws of Nature and of Nature's God entitle them, a decent respect |
| # to the opinions of mankind requires that they should declare the causes which impel them to the |
| # separation." |
| |
| # set buffer [sprint_arg_desc "--declaration" $desc] |
| # puts $buffer |
| |
| # Resulting output: |
| # --declaration When in the Course of human events, it becomes |
| # necessary for one people to dissolve the |
| # political bands which have connected them with |
| # another, and to assume among the powers of the |
| # earth, the separate and equal station to which |
| # the Laws of Nature and of Nature's God entitle |
| # them, a decent respect to the opinions of mankind |
| # requires that they should declare the causes |
| # which impel them to the separation. |
| |
| # Description of argument(s): |
| # arg_title The content that you want to appear on the first line in column 1. |
| # arg_desc The text that describes the argument. |
| # indent The number of characters to indent. |
| # col1_width The width of column 1, which is the column containing the arg_title. |
| # line_width The total max width of each line of output. |
| |
| set fold_width [expr $line_width - $col1_width] |
| set escaped_arg_desc [escape_bash_quotes "${arg_desc}"] |
| |
| set cmd_buf "echo '${escaped_arg_desc}' | fold --spaces --width=" |
| append cmd_buf "${fold_width} | sed -re 's/\[ \]+$//g'" |
| set out_buf [eval exec bash -c {$cmd_buf}] |
| |
| set help_lines [split $out_buf "\n"] |
| |
| set buffer {} |
| |
| set line_num 1 |
| foreach help_line $help_lines { |
| if { $line_num == 1 } { |
| if { [string length $arg_title] > $col1_width } { |
| # If the arg_title is already wider than column1, print it on its own |
| # line. |
| append buffer [format "%${indent}s%-${col1_width}s\n" ""\ |
| "$arg_title"] |
| append buffer [format "%${indent}s%-${col1_width}s%s\n" "" ""\ |
| "${help_line}"] |
| } else { |
| append buffer [format "%${indent}s%-${col1_width}s%s\n" ""\ |
| "$arg_title" "${help_line}"] |
| } |
| } else { |
| append buffer [format "%${indent}s%-${col1_width}s%s\n" "" ""\ |
| "${help_line}"] |
| } |
| incr line_num |
| } |
| |
| return $buffer |
| |
| } |
| |
| |
| # Define the create_print_wrapper_procs to help us create print wrappers. |
| # First, create templates. |
| # Notes: |
| # - The resulting procedures will replace all registered passwords. |
| # - The resulting "quiet" and "debug" print procedures will search the stack for quiet and debug, |
| # respectively. That means that the if a procedure calls qprint_var and the procedure has a local version |
| # of quiet set to 1, the print will not occur, even if there is a global version of quiet set to 0. |
| set print_proc_template " puts -nonewline<output_stream> \[replace_passwords" |
| append print_proc_template " \[<base_proc_name> {*}\$args\]\]\n}\n" |
| set qprint_proc_template " set quiet \[get_stack_var quiet 0\]\n if {" |
| append qprint_proc_template " \$quiet } { return }\n${print_proc_template}" |
| set dprint_proc_template " set debug \[get_stack_var debug 0\]\n if { !" |
| append dprint_proc_template " \$debug } { return }\n${print_proc_template}" |
| |
| # Put each template into the print_proc_templates array. |
| set print_proc_templates(p) $print_proc_template |
| set print_proc_templates(q) $qprint_proc_template |
| set print_proc_templates(d) $dprint_proc_template |
| proc create_print_wrapper_procs {proc_names {stderr_proc_names {}} } { |
| |
| # Generate code for print wrapper procs and return the generated code as a string. |
| |
| # To illustrate, suppose there is a "print_foo_bar" proc in the proc_names list. |
| # This proc will... |
| # - Expect that there is an sprint_foo_bar proc already in existence. |
| # - Create a print_foo_bar proc which calls sprint_foo_bar and prints the result. |
| # - Create a qprint_foo_bar proc which calls upon sprint_foo_bar only if global value quiet is 0. |
| # - Create a dprint_foo_bar proc which calls upon sprint_foo_bar only if global value debug is 1. |
| |
| # Also, code will be generated to define aliases for each proc as well. Each alias will be created by |
| # replacing "print_" in the proc name with "p" For example, the alias for print_foo_bar will be pfoo_bar. |
| |
| # Description of argument(s): |
| # proc_names A list of procs for which print wrapper proc code is to be generated. |
| # stderr_proc_names A list of procs whose generated code should print to stderr rather than |
| # to stdout. |
| |
| global print_proc_template |
| global print_proc_templates |
| |
| foreach proc_name $proc_names { |
| |
| if { [expr [lsearch $stderr_proc_names $proc_name] == -1] } { |
| set replace_dict(output_stream) "" |
| } else { |
| set replace_dict(output_stream) " stderr" |
| } |
| |
| set base_proc_name "s${proc_name}" |
| set replace_dict(base_proc_name) $base_proc_name |
| |
| set wrap_proc_names(p) $proc_name |
| set wrap_proc_names(q) q${proc_name} |
| set wrap_proc_names(d) d${proc_name} |
| |
| foreach template_key [list p q d] { |
| set wrap_proc_name $wrap_proc_names($template_key) |
| set call_line "proc ${wrap_proc_name} \{args\} \{\n" |
| set proc_body $print_proc_templates($template_key) |
| set proc_def ${call_line}${proc_body} |
| foreach {key value} [array get replace_dict] { |
| regsub -all "<$key>" $proc_def $value proc_def |
| } |
| regsub "print_" $wrap_proc_name "p" alias_proc_name |
| regsub "${wrap_proc_name}" $proc_def $alias_proc_name alias_def |
| append buffer "${proc_def}${alias_def}" |
| } |
| } |
| |
| return $buffer |
| |
| } |
| |
| |
| # Get this file's path. |
| set frame_dict [info frame 0] |
| set file_path [dict get $frame_dict file] |
| # Get a list of this file's sprint procs. |
| set sprint_procs [get_file_proc_names $file_path sprint] |
| # Create a corresponding list of print_procs. |
| set proc_names [list_map $sprint_procs {[string range $x 1 end]}] |
| # Sort them for ease of debugging. |
| set proc_names [lsort $proc_names] |
| |
| set stderr_proc_names [list print_error print_error_report] |
| |
| set proc_def [create_print_wrapper_procs $proc_names $stderr_proc_names] |
| if { $GEN_PRINT_DEBUG } { puts $proc_def } |
| eval "${proc_def}" |