137c74f7fSMichael Walsh#!/usr/bin/wish 237c74f7fSMichael Walsh 3410b1787SMichael Walsh# This file provides many valuable print procedures such as sprint_var, sprint_time, sprint_error, etc. 437c74f7fSMichael Walsh 5*721f970aSDavid Shawmy_source [list data_proc.tcl call_stack.tcl escape.tcl] 637c74f7fSMichael Walsh 737c74f7fSMichael Walsh# Need "Expect" package for trap procedure. 837c74f7fSMichael Walshpackage require Expect 937c74f7fSMichael Walsh 1037c74f7fSMichael Walsh 11410b1787SMichael Walsh# Setting the following variables for use both inside this file and by programs sourcing this file. 1237c74f7fSMichael Walshset program_path $argv0 1337c74f7fSMichael Walshset program_dir_path "[file dirname $argv0]/" 1437c74f7fSMichael Walshset program_name "[file tail $argv0]" 15410b1787SMichael Walsh# Some procedures (e.g. sprint_pgm_header) need a program name value that looks more like a valid variable 16410b1787SMichael Walsh# name. Therefore, we'll swap out odd characters (like ".") for underscores. 1737c74f7fSMichael Walshregsub {\.} $program_name "_" pgm_name_var_name 1837c74f7fSMichael Walsh 1937c74f7fSMichael Walsh# Initialize some time variables used in procedures in this file. 2037c74f7fSMichael Walshset start_time [clock microseconds] 2137c74f7fSMichael Walsh 2237c74f7fSMichael Walsh 2337c74f7fSMichael Walshproc calc_wrap_stack_ix_adjust {} { 2437c74f7fSMichael Walsh 25410b1787SMichael Walsh # Calculate and return a number which can be used as an offset into the call stack for wrapper procedures. 2637c74f7fSMichael Walsh 27410b1787SMichael Walsh # NOTE: This procedure is designed expressly to work with this file's print procedures scheme (i.e. 28410b1787SMichael Walsh # print_x is a wrapper for sprint_x, etc.). In other words, this procedure may not be well-suited for 29410b1787SMichael Walsh # general use. 3037c74f7fSMichael Walsh 31410b1787SMichael Walsh # Get a list of the procedures in the call stack beginning with our immediate caller on up to the 32410b1787SMichael Walsh # top-level caller. 3337c74f7fSMichael Walsh set call_stack [get_call_stack -2] 3437c74f7fSMichael Walsh 3537c74f7fSMichael Walsh # The first stack entry is our immediate caller. 3637c74f7fSMichael Walsh set caller [lindex $call_stack 0] 3737c74f7fSMichael Walsh # Remove first entry from stack. 3837c74f7fSMichael Walsh set call_stack [lreplace $call_stack 0 0] 39410b1787SMichael Walsh # Strip any leading "s" to arrive at base_caller name (e.g. the corresponding base name for "sprint_var" 40410b1787SMichael Walsh # would be "print_var"). 4137c74f7fSMichael Walsh set base_caller [string trimleft $caller s] 42410b1787SMichael Walsh # Account for alias print procedures which have "p" vs "print_" (e.g. pvar vs print_var). 4337c74f7fSMichael Walsh regsub "print_" $base_caller "p" alias_base_caller 4437c74f7fSMichael Walsh 4537c74f7fSMichael Walsh # Initialize the stack_ix_adjust value. 4637c74f7fSMichael Walsh set stack_ix_adjust 0 47410b1787SMichael Walsh # Note: print_vars|pvars is a special case so we add it explicitly to the regex below. 4837c74f7fSMichael Walsh set regex ".*(${base_caller}|${alias_base_caller}|print_vars|pvars)$" 4937c74f7fSMichael Walsh foreach proc_name $call_stack { 50410b1787SMichael Walsh # For every remaining stack item that looks like a wrapper (i.e. matches our regex), we increment the 51410b1787SMichael Walsh # stack_ix_adjust. 5237c74f7fSMichael Walsh if { [regexp -expanded $regex $proc_name]} { 5337c74f7fSMichael Walsh incr stack_ix_adjust 5437c74f7fSMichael Walsh continue 5537c74f7fSMichael Walsh } 5637c74f7fSMichael Walsh # If there is no match, then we are done. 5737c74f7fSMichael Walsh break 5837c74f7fSMichael Walsh } 5937c74f7fSMichael Walsh 6037c74f7fSMichael Walsh return $stack_ix_adjust 6137c74f7fSMichael Walsh 6237c74f7fSMichael Walsh} 6337c74f7fSMichael Walsh 6437c74f7fSMichael Walsh 65410b1787SMichael Walsh# hidden_text is a list of passwords which are to be replaced with asterisks by print procedures defined in 66410b1787SMichael Walsh# this file. 6737c74f7fSMichael Walshset hidden_text [list] 6837c74f7fSMichael Walsh# password_regex is created from the contents of the hidden_text list above. 6937c74f7fSMichael Walshset password_regex "" 7037c74f7fSMichael Walsh 7137c74f7fSMichael Walshproc register_passwords {args} { 7237c74f7fSMichael Walsh 73410b1787SMichael Walsh # Register one or more passwords which are to be hidden in output produced by the print procedures in this 74410b1787SMichael Walsh # file. 7537c74f7fSMichael Walsh 7637c74f7fSMichael Walsh # Note: Blank password values are NOT registered. They are simply ignored. 7737c74f7fSMichael Walsh 7837c74f7fSMichael Walsh # Description of argument(s): 79410b1787SMichael Walsh # args One or more password values. If a given password value is already 80410b1787SMichael Walsh # registered, this procedure will simply ignore it, i.e. there will be no 81410b1787SMichael Walsh # duplicate values in the hidden_text list. 8237c74f7fSMichael Walsh 8337c74f7fSMichael Walsh global hidden_text 8437c74f7fSMichael Walsh global password_regex 8537c74f7fSMichael Walsh 8637c74f7fSMichael Walsh foreach password $args { 8737c74f7fSMichael Walsh # Skip blank passwords. 8837c74f7fSMichael Walsh if { $password == "" } { continue } 8937c74f7fSMichael Walsh # Skip already-registered passwords. 9037c74f7fSMichael Walsh if { [lsearch -exact $hidden_text $password] != -1 } { continue } 9137c74f7fSMichael Walsh # Put the password into the global hidden_text list. 92*721f970aSDavid Shaw lappend hidden_text [escape_regex_metachars $password] 9337c74f7fSMichael Walsh } 9437c74f7fSMichael Walsh 9537c74f7fSMichael Walsh set password_regex [join $hidden_text |] 9637c74f7fSMichael Walsh 9737c74f7fSMichael Walsh} 9837c74f7fSMichael Walsh 9937c74f7fSMichael Walsh 10037c74f7fSMichael Walshproc replace_passwords {buffer} { 10137c74f7fSMichael Walsh 102410b1787SMichael Walsh # Replace all registered password found in buffer with a string of asterisks and return the result. 10337c74f7fSMichael Walsh 10437c74f7fSMichael Walsh # Description of argument(s): 10537c74f7fSMichael Walsh # buffer The string to be altered and returned. 10637c74f7fSMichael Walsh 107410b1787SMichael Walsh # Note: If environment variable GEN_PRINT_DEBUG is set, this procedure will do nothing. 10837c74f7fSMichael Walsh 10937c74f7fSMichael Walsh global env 11037c74f7fSMichael Walsh if { [get_var ::env(GEN_PRINT_DEBUG) 0] } { return $buffer } 111b21aec17SMichael Walsh if { [get_var ::env(DEBUG_SHOW_PASSWORDS) 0] } { return $buffer } 11237c74f7fSMichael Walsh 11337c74f7fSMichael Walsh global password_regex 11437c74f7fSMichael Walsh 11537c74f7fSMichael Walsh # No passwords to replace? 11637c74f7fSMichael Walsh if { $password_regex == "" } { return $buffer } 11737c74f7fSMichael Walsh 11837c74f7fSMichael Walsh regsub -all "${password_regex}" $buffer {********} buffer 11937c74f7fSMichael Walsh return $buffer 12037c74f7fSMichael Walsh 12137c74f7fSMichael Walsh} 12237c74f7fSMichael Walsh 12337c74f7fSMichael Walsh 12437c74f7fSMichael Walshproc my_time { cmd_buf { iterations 100 } } { 12537c74f7fSMichael Walsh 12637c74f7fSMichael Walsh # Run the "time" function on the given command string and print the results. 12737c74f7fSMichael Walsh 12837c74f7fSMichael Walsh # The main benefit of running this vs just doing the "time" command directly: 12937c74f7fSMichael Walsh # - This will print the results. 13037c74f7fSMichael Walsh 13137c74f7fSMichael Walsh # Description of argument(s): 13237c74f7fSMichael Walsh # cmd_buf The command string to be run. 133410b1787SMichael Walsh # iterations The number of times to run the command string. Typically, more 134410b1787SMichael Walsh # iterations yields more accurate results. 13537c74f7fSMichael Walsh 13637c74f7fSMichael Walsh print_issuing $cmd_buf 13737c74f7fSMichael Walsh set result [time {uplevel 1 $cmd_buf} $iterations] 13837c74f7fSMichael Walsh 13937c74f7fSMichael Walsh set raw_microseconds [lindex [split [lindex $result 0] .] 0] 14037c74f7fSMichael Walsh set seconds [expr $raw_microseconds / 1000000] 14137c74f7fSMichael Walsh set raw_microseconds [expr $raw_microseconds % 1000000] 14237c74f7fSMichael Walsh 14337c74f7fSMichael Walsh set seconds_per_iteration [format "%i.%06i" ${seconds}\ 14437c74f7fSMichael Walsh ${raw_microseconds}] 14537c74f7fSMichael Walsh 14637c74f7fSMichael Walsh print_var seconds_per_iteration 14737c74f7fSMichael Walsh 14837c74f7fSMichael Walsh} 14937c74f7fSMichael Walsh 15037c74f7fSMichael Walsh 151410b1787SMichael Walsh# If environment variable "GEN_PRINT_DEBUG" is set, this module will output debug data. This is primarily 152410b1787SMichael Walsh# intended for the developer of this module. 15337c74f7fSMichael Walshset GEN_PRINT_DEBUG [get_var ::env(GEN_PRINT_DEBUG) 0] 15437c74f7fSMichael Walsh 155410b1787SMichael Walsh# The user can set the following environment variables to influence the output from print_time and print_var 156410b1787SMichael Walsh# procedures. See the prologs of those procedures for details. 15737c74f7fSMichael Walshset NANOSECONDS [get_var ::env(NANOSECONDS) 0] 15837c74f7fSMichael Walshset SHOW_ELAPSED_TIME [get_var ::env(SHOW_ELAPSED_TIME) 0] 15937c74f7fSMichael Walsh 160410b1787SMichael Walsh# _gtp_default_print_var_width_ is adjusted based on NANOSECONDS and SHOW_ELAPSED_TIME. 16137c74f7fSMichael Walshif { $NANOSECONDS } { 16237c74f7fSMichael Walsh set _gtp_default_print_var_width_ 36 16337c74f7fSMichael Walsh set width_incr 14 16437c74f7fSMichael Walsh} else { 16537c74f7fSMichael Walsh set _gtp_default_print_var_width_ 29 16637c74f7fSMichael Walsh set width_incr 7 16737c74f7fSMichael Walsh} 16837c74f7fSMichael Walshif { $SHOW_ELAPSED_TIME } { 16937c74f7fSMichael Walsh incr _gtp_default_print_var_width_ $width_incr 170410b1787SMichael Walsh # Initializing _sprint_time_last_seconds_ which is a global value to remember the clock seconds from the 171410b1787SMichael Walsh # last time sprint_time was called. 17237c74f7fSMichael Walsh set _gtp_sprint_time_last_micro_seconds_ [clock microseconds] 17337c74f7fSMichael Walsh} 174410b1787SMichael Walsh# tcl_precision is a built-in Tcl variable that specifies the number of digits to generate when converting 175410b1787SMichael Walsh# floating-point values to strings. 17637c74f7fSMichael Walshset tcl_precision 17 17737c74f7fSMichael Walsh 17837c74f7fSMichael Walsh 17937c74f7fSMichael Walshproc sprint { { buffer {} } } { 18037c74f7fSMichael Walsh 18137c74f7fSMichael Walsh # Simply return the user's buffer. 182410b1787SMichael Walsh # This procedure is used by the qprint and dprint functions defined dynamically below, i.e. it would not 183410b1787SMichael Walsh # normally be called for general use. 18437c74f7fSMichael Walsh 18537c74f7fSMichael Walsh # Description of arguments. 18637c74f7fSMichael Walsh # buffer This will be returned to the caller. 18737c74f7fSMichael Walsh 18837c74f7fSMichael Walsh return $buffer 18937c74f7fSMichael Walsh 19037c74f7fSMichael Walsh} 19137c74f7fSMichael Walsh 19237c74f7fSMichael Walsh 19337c74f7fSMichael Walshproc sprintn { { buffer {} } } { 19437c74f7fSMichael Walsh 19537c74f7fSMichael Walsh # Simply return the user's buffer plus a trailing line feed.. 196410b1787SMichael Walsh # This procedure is used by the qprintn and dprintn functions defined dynamically below, i.e. it would not 197410b1787SMichael Walsh # normally be called for general use. 19837c74f7fSMichael Walsh 19937c74f7fSMichael Walsh # Description of arguments. 20037c74f7fSMichael Walsh # buffer This will be returned to the caller. 20137c74f7fSMichael Walsh 20237c74f7fSMichael Walsh return ${buffer}\n 20337c74f7fSMichael Walsh 20437c74f7fSMichael Walsh} 20537c74f7fSMichael Walsh 20637c74f7fSMichael Walsh 20737c74f7fSMichael Walshproc sprint_time { { buffer {} } } { 20837c74f7fSMichael Walsh 20937c74f7fSMichael Walsh # Return the time in a formatted manner as described below. 21037c74f7fSMichael Walsh 21137c74f7fSMichael Walsh # Example: 21237c74f7fSMichael Walsh 21337c74f7fSMichael Walsh # The following tcl code... 21437c74f7fSMichael Walsh 21537c74f7fSMichael Walsh # puts -nonewline [sprint_time()] 21637c74f7fSMichael Walsh # puts -nonewline ["Hi.\n"] 21737c74f7fSMichael Walsh 21837c74f7fSMichael Walsh # Will result in the following type of output: 21937c74f7fSMichael Walsh 22037c74f7fSMichael Walsh # #(CDT) 2016/07/08 15:25:35 - Hi. 22137c74f7fSMichael Walsh 22237c74f7fSMichael Walsh # Example: 22337c74f7fSMichael Walsh 22437c74f7fSMichael Walsh # The following tcl code... 22537c74f7fSMichael Walsh 22637c74f7fSMichael Walsh # puts -nonewline [sprint_time("Hi.\n")] 22737c74f7fSMichael Walsh 22837c74f7fSMichael Walsh # Will result in the following type of output: 22937c74f7fSMichael Walsh 23037c74f7fSMichael Walsh # #(CDT) 2016/08/03 17:12:05 - Hi. 23137c74f7fSMichael Walsh 232410b1787SMichael Walsh # The following environment variables will affect the formatting as described: 233410b1787SMichael Walsh # NANOSECONDS This will cause the time stamps to be precise to the microsecond (Yes, it 234410b1787SMichael Walsh # probably should have been named MICROSECONDS but the convention was set 235410b1787SMichael Walsh # long ago so we're sticking with it). Example of the output when 236410b1787SMichael Walsh # environment variable NANOSECONDS=1. 23737c74f7fSMichael Walsh 23837c74f7fSMichael Walsh # #(CDT) 2016/08/03 17:16:25.510469 - Hi. 23937c74f7fSMichael Walsh 240410b1787SMichael Walsh # SHOW_ELAPSED_TIME This will cause the elapsed time to be included in the output. This is 241410b1787SMichael Walsh # the amount of time that has elapsed since the last time this procedure 242410b1787SMichael Walsh # was called. The precision of the elapsed time field is also affected by 243410b1787SMichael Walsh # the value of the NANOSECONDS environment variable. Example of the output 244410b1787SMichael Walsh # when environment variable NANOSECONDS=0 and SHOW_ELAPSED_TIME=1. 24537c74f7fSMichael Walsh 24637c74f7fSMichael Walsh # #(CDT) 2016/08/03 17:17:40 - 0 - Hi. 24737c74f7fSMichael Walsh 248410b1787SMichael Walsh # Example of the output when environment variable NANOSECONDS=1 and SHOW_ELAPSED_TIME=1. 24937c74f7fSMichael Walsh 25037c74f7fSMichael Walsh # #(CDT) 2016/08/03 17:18:47.317339 - 0.000046 - Hi. 25137c74f7fSMichael Walsh 25237c74f7fSMichael Walsh # Description of argument(s). 253410b1787SMichael Walsh # buffer A string string whhich is to be appended to the formatted time string and 254410b1787SMichael Walsh # returned. 25537c74f7fSMichael Walsh 25637c74f7fSMichael Walsh global NANOSECONDS 25737c74f7fSMichael Walsh global _gtp_sprint_time_last_micro_seconds_ 25837c74f7fSMichael Walsh global SHOW_ELAPSED_TIME 25937c74f7fSMichael Walsh 26037c74f7fSMichael Walsh # Get micro seconds since the epoch. 26137c74f7fSMichael Walsh set epoch_micro [clock microseconds] 26237c74f7fSMichael Walsh # Break the left and right of the decimal point. 26337c74f7fSMichael Walsh set epoch_seconds [expr $epoch_micro / 1000000] 26437c74f7fSMichael Walsh set epoch_decimal_micro [expr $epoch_micro % 1000000] 26537c74f7fSMichael Walsh 26637c74f7fSMichael Walsh set format_string "#(%Z) %Y/%m/%d %H:%M:%S" 26737c74f7fSMichael Walsh set return_string [clock format $epoch_seconds -format\ 26837c74f7fSMichael Walsh "#(%Z) %Y/%m/%d %H:%M:%S"] 26937c74f7fSMichael Walsh 27037c74f7fSMichael Walsh if { $NANOSECONDS } { 27137c74f7fSMichael Walsh append return_string ".[format "%06i" ${epoch_decimal_micro}]" 27237c74f7fSMichael Walsh } 27337c74f7fSMichael Walsh 27437c74f7fSMichael Walsh if { $SHOW_ELAPSED_TIME } { 27537c74f7fSMichael Walsh set return_string "${return_string} - " 27637c74f7fSMichael Walsh 27737c74f7fSMichael Walsh set elapsed_micro [expr $epoch_micro - \ 27837c74f7fSMichael Walsh $_gtp_sprint_time_last_micro_seconds_] 27937c74f7fSMichael Walsh set elapsed_seconds [expr $elapsed_micro / 1000000] 28037c74f7fSMichael Walsh 28137c74f7fSMichael Walsh if { $NANOSECONDS } { 28237c74f7fSMichael Walsh set elapsed_decimal_micro [expr $elapsed_micro % 1000000] 28337c74f7fSMichael Walsh set elapsed_float [format "%i.%06i" ${elapsed_seconds}\ 28437c74f7fSMichael Walsh ${elapsed_decimal_micro}] 28537c74f7fSMichael Walsh set elapsed_time_buffer "[format "%11.6f" ${elapsed_float}]" 28637c74f7fSMichael Walsh } else { 28737c74f7fSMichael Walsh set elapsed_time_buffer "[format "%4i" $elapsed_seconds]" 28837c74f7fSMichael Walsh } 28937c74f7fSMichael Walsh set return_string "${return_string}${elapsed_time_buffer}" 29037c74f7fSMichael Walsh } 29137c74f7fSMichael Walsh 29237c74f7fSMichael Walsh set return_string "${return_string} - ${buffer}" 29337c74f7fSMichael Walsh 29437c74f7fSMichael Walsh set _gtp_sprint_time_last_micro_seconds_ $epoch_micro 29537c74f7fSMichael Walsh 29637c74f7fSMichael Walsh return $return_string 29737c74f7fSMichael Walsh 29837c74f7fSMichael Walsh} 29937c74f7fSMichael Walsh 30037c74f7fSMichael Walsh 30137c74f7fSMichael Walshproc sprint_timen { args } { 30237c74f7fSMichael Walsh 30337c74f7fSMichael Walsh # Return the value of sprint_time + a line feed. 30437c74f7fSMichael Walsh 30537c74f7fSMichael Walsh # Description of argument(s): 306410b1787SMichael Walsh # args All args are passed directly to subordinate function, sprint_time. See 30737c74f7fSMichael Walsh # that function's prolog for details. 30837c74f7fSMichael Walsh 30937c74f7fSMichael Walsh return [sprint_time {*}$args]\n 31037c74f7fSMichael Walsh 31137c74f7fSMichael Walsh} 31237c74f7fSMichael Walsh 31337c74f7fSMichael Walsh 31437c74f7fSMichael Walshproc sprint_error { { buffer {} } } { 31537c74f7fSMichael Walsh 31637c74f7fSMichael Walsh # Return a standardized error string which includes the callers buffer text. 31737c74f7fSMichael Walsh 31837c74f7fSMichael Walsh # Description of argument(s): 319410b1787SMichael Walsh # buffer Text to be returned as part of the error message. 32037c74f7fSMichael Walsh 32137c74f7fSMichael Walsh return [sprint_time "**ERROR** $buffer"] 32237c74f7fSMichael Walsh 32337c74f7fSMichael Walsh} 32437c74f7fSMichael Walsh 32537c74f7fSMichael Walsh 32637c74f7fSMichael Walshproc sprint_varx { var_name var_value { indent 0 } { width {} } { hex 0 } } { 32737c74f7fSMichael Walsh 328410b1787SMichael Walsh # Return the name and value of the variable named in var_name in a formatted way. 32937c74f7fSMichael Walsh 330410b1787SMichael Walsh # This procedure will visually align the output to look good next to print_time output. 33137c74f7fSMichael Walsh 33237c74f7fSMichael Walsh # Example: 33337c74f7fSMichael Walsh 33437c74f7fSMichael Walsh # Given the following code: 33537c74f7fSMichael Walsh 33637c74f7fSMichael Walsh # print_timen "Initializing variables." 33737c74f7fSMichael Walsh # set first_name "Joe" 33837c74f7fSMichael Walsh # set last_name "Montana" 33937c74f7fSMichael Walsh # set age 50 34037c74f7fSMichael Walsh # print_varx last_name $last_name 34137c74f7fSMichael Walsh # print_varx first_name $first_name 2 34237c74f7fSMichael Walsh # print_varx age $age 2 34337c74f7fSMichael Walsh 344410b1787SMichael Walsh # With environment variables NANOSECONDS and SHOW_ELAPSED_TIME both set, the following output is produced: 34537c74f7fSMichael Walsh 34637c74f7fSMichael Walsh # #(CST) 2017/12/14 16:38:28.259480 - 0.000651 - Initializing variables. 34737c74f7fSMichael Walsh # last_name: Montana 34837c74f7fSMichael Walsh # first_name: Joe 34937c74f7fSMichael Walsh # age: 50 35037c74f7fSMichael Walsh 35137c74f7fSMichael Walsh # Description of argument(s): 352410b1787SMichael Walsh # var_name The name of the variable whose name and value are to be printed. 35337c74f7fSMichael Walsh # var_value The value to be printed. 354410b1787SMichael Walsh # indent The number of spaces to indent each line of output. 355410b1787SMichael Walsh # width The width of the column containing the variable name. By default this 356410b1787SMichael Walsh # will align with the print_time text (see example above). 357410b1787SMichael Walsh # hex Indicates that the variable value is to be printed in hexedecimal format. 358410b1787SMichael Walsh # This is only valid if the variable value is an integer. If the variable 359410b1787SMichael Walsh # is NOT an integer and is blank, this will be interpreted to mean "print 360410b1787SMichael Walsh # the string '<blank>', rather than an actual blank value". 36137c74f7fSMichael Walsh 36237c74f7fSMichael Walsh # Note: This procedure relies on global var _gtp_default_print_var_width_ 36337c74f7fSMichael Walsh 36437c74f7fSMichael Walsh set_var_default indent 0 36537c74f7fSMichael Walsh 36637c74f7fSMichael Walsh global _gtp_default_print_var_width_ 36737c74f7fSMichael Walsh set_var_default width $_gtp_default_print_var_width_ 36837c74f7fSMichael Walsh 36937c74f7fSMichael Walsh if { $indent > 0 } { 37037c74f7fSMichael Walsh set width [expr $width - $indent] 37137c74f7fSMichael Walsh } 37237c74f7fSMichael Walsh 37337c74f7fSMichael Walsh if { $hex } { 37437c74f7fSMichael Walsh if { [catch {format "0x%08x" "$var_value"} result] } { 37537c74f7fSMichael Walsh if { $var_value == "" } { set var_value "<blank>" } 37637c74f7fSMichael Walsh set hex 0 37737c74f7fSMichael Walsh } 37837c74f7fSMichael Walsh } 37937c74f7fSMichael Walsh 38037c74f7fSMichael Walsh if { $hex } { 38137c74f7fSMichael Walsh append buffer "[format "%-${indent}s%-${width}s0x%08x" "" "$var_name:" \ 38237c74f7fSMichael Walsh "$var_value"]" 38337c74f7fSMichael Walsh } else { 38437c74f7fSMichael Walsh append buffer "[format "%-${indent}s%-${width}s%s" "" "$var_name:" \ 38537c74f7fSMichael Walsh "$var_value"]" 38637c74f7fSMichael Walsh } 38737c74f7fSMichael Walsh 38837c74f7fSMichael Walsh return $buffer\n 38937c74f7fSMichael Walsh 39037c74f7fSMichael Walsh} 39137c74f7fSMichael Walsh 39237c74f7fSMichael Walsh 39337c74f7fSMichael Walshproc sprint_var { var_name args } { 39437c74f7fSMichael Walsh 395410b1787SMichael Walsh # Return the name and value of the variable named in var_name in a formatted way. 39637c74f7fSMichael Walsh 397410b1787SMichael Walsh # This procedure will visually align the output to look good next to print_time output. 39837c74f7fSMichael Walsh 399410b1787SMichael Walsh # Note: This procedure is the equivalent of sprint_varx with one difference: This function will figure 400410b1787SMichael Walsh # out the value of the named variable whereas sprint_varx expects you to pass the value. This procedure in 401410b1787SMichael Walsh # fact calls sprint_varx to do its work. 40237c74f7fSMichael Walsh 403410b1787SMichael Walsh # Note: This procedure will detect whether var_name is an array and print it accordingly (see the second 404410b1787SMichael Walsh # example below). 40537c74f7fSMichael Walsh 40637c74f7fSMichael Walsh # Example: 40737c74f7fSMichael Walsh 40837c74f7fSMichael Walsh # Given the following code: 40937c74f7fSMichael Walsh 41037c74f7fSMichael Walsh # print_timen "Initializing variables." 41137c74f7fSMichael Walsh # set first_name "Joe" 41237c74f7fSMichael Walsh # set last_name "Montana" 41337c74f7fSMichael Walsh # set age 50 41437c74f7fSMichael Walsh # print_var last_name 41537c74f7fSMichael Walsh # print_var first_name 2 41637c74f7fSMichael Walsh # print_var age 2 41737c74f7fSMichael Walsh 418410b1787SMichael Walsh # With environment variables NANOSECONDS and SHOW_ELAPSED_TIME both set, the following output is produced: 41937c74f7fSMichael Walsh 42037c74f7fSMichael Walsh # #(CST) 2017/12/14 16:38:28.259480 - 0.000651 - Initializing variables. 42137c74f7fSMichael Walsh # last_name: Montana 42237c74f7fSMichael Walsh # first_name: Joe 42337c74f7fSMichael Walsh # age: 50 42437c74f7fSMichael Walsh 42537c74f7fSMichael Walsh # Example: 42637c74f7fSMichael Walsh # Given the following code: 42737c74f7fSMichael Walsh 42837c74f7fSMichael Walsh # set data(0) cow 42937c74f7fSMichael Walsh # set data(1) horse 43037c74f7fSMichael Walsh # print_var data 43137c74f7fSMichael Walsh 43237c74f7fSMichael Walsh # data: 43337c74f7fSMichael Walsh # data(0): cow 43437c74f7fSMichael Walsh # data(1): horse 43537c74f7fSMichael Walsh 43637c74f7fSMichael Walsh # Description of argument(s): 437410b1787SMichael Walsh # var_name The name of the variable whose name and value are to be printed. 438410b1787SMichael Walsh # args The args understood by sprint_varx (after var_name and var_value). See 43937c74f7fSMichael Walsh # sprint_varx's prolog for details. 44037c74f7fSMichael Walsh 44137c74f7fSMichael Walsh # Note: This procedure relies on global var _gtp_default_print_var_width_ 44237c74f7fSMichael Walsh 443410b1787SMichael Walsh # Determine who our caller is and therefore what upvar_level to use to get var_value. 44437c74f7fSMichael Walsh set stack_ix_adjust [calc_wrap_stack_ix_adjust] 44537c74f7fSMichael Walsh set upvar_level [expr $stack_ix_adjust + 1] 44637c74f7fSMichael Walsh upvar $upvar_level $var_name var_value 44737c74f7fSMichael Walsh 44837c74f7fSMichael Walsh # Special processing for arrays: 44937c74f7fSMichael Walsh if { [array exists var_value] } { 45037c74f7fSMichael Walsh set indent [lindex $args 0] 45137c74f7fSMichael Walsh set args [lrange $args 1 end] 45237c74f7fSMichael Walsh set_var_default indent 0 45337c74f7fSMichael Walsh 45437c74f7fSMichael Walsh append buffer [format "%-${indent}s%s\n" "" "$var_name:"] 45537c74f7fSMichael Walsh incr indent 2 45637c74f7fSMichael Walsh incr width -2 45737c74f7fSMichael Walsh 45837c74f7fSMichael Walsh set search_token [array startsearch var_value] 45937c74f7fSMichael Walsh while {[array anymore var_value $search_token]} { 46037c74f7fSMichael Walsh set key [array nextelement var_value $search_token] 46137c74f7fSMichael Walsh set arr_value $var_value($key) 46237c74f7fSMichael Walsh append buffer [sprint_varx "${var_name}(${key})" $arr_value $indent\ 46337c74f7fSMichael Walsh {*}$args] 46437c74f7fSMichael Walsh } 46537c74f7fSMichael Walsh array donesearch var_value $search_token 46637c74f7fSMichael Walsh return $buffer 46737c74f7fSMichael Walsh } 46837c74f7fSMichael Walsh 469410b1787SMichael Walsh # If var_value is not defined, catch the error and print its value as "variable not set". 470355b8ef2SMichael Walsh if {[catch {set buffer [sprint_varx $var_name $var_value {*}$args]} error_text options]} { 471355b8ef2SMichael Walsh set regex ":\[ \]no\[ \]such\[ \]variable" 472355b8ef2SMichael Walsh if { [regexp -expanded ${regex} ${error_text}]} { 473355b8ef2SMichael Walsh return [sprint_varx $var_name {** variable not set **} {*}$args] 474355b8ef2SMichael Walsh } else { 475355b8ef2SMichael Walsh print_dict options 476355b8ef2SMichael Walsh exit 1 477355b8ef2SMichael Walsh } 478355b8ef2SMichael Walsh } else { 479355b8ef2SMichael Walsh return $buffer 480355b8ef2SMichael Walsh } 48137c74f7fSMichael Walsh 48237c74f7fSMichael Walsh} 48337c74f7fSMichael Walsh 48437c74f7fSMichael Walsh 48537c74f7fSMichael Walshproc sprint_list { var_name args } { 48637c74f7fSMichael Walsh 487410b1787SMichael Walsh # Return the name and value of the list variable named in var_name in a formatted way. 48837c74f7fSMichael Walsh 48937c74f7fSMichael Walsh # This procedure is the equivalent of sprint_var but for lists. 49037c74f7fSMichael Walsh 49137c74f7fSMichael Walsh # Description of argument(s): 492410b1787SMichael Walsh # var_name The name of the variable whose name and value are to be printed. 493410b1787SMichael Walsh # args The args understood by sprint_varx (after var_name and var_value). See 49437c74f7fSMichael Walsh # sprint_varx's prolog for details. 49537c74f7fSMichael Walsh 496410b1787SMichael Walsh # Note: In TCL, there is no way to determine that a variable represents a list vs a string, etc. It is up 497410b1787SMichael Walsh # to the programmer to decide how the data is to be interpreted. Thus the need for procedures such as this 498410b1787SMichael Walsh # one. Consider the following code: 49937c74f7fSMichael Walsh 50037c74f7fSMichael Walsh # set my_list {one two three} 50137c74f7fSMichael Walsh # print_var my_list 50237c74f7fSMichael Walsh # print_list my_list 50337c74f7fSMichael Walsh 50437c74f7fSMichael Walsh # Output from aforementioned code: 50537c74f7fSMichael Walsh # my_list: one two three 50637c74f7fSMichael Walsh # my_list: 50737c74f7fSMichael Walsh # my_list[0]: one 50837c74f7fSMichael Walsh # my_list[1]: two 50937c74f7fSMichael Walsh # my_list[2]: three 51037c74f7fSMichael Walsh 511410b1787SMichael Walsh # As far as print_var is concerned, my_list is a string and is printed accordingly. By using print_list, 512410b1787SMichael Walsh # the programmer is asking to have the output shown as a list with list indices, etc. 51337c74f7fSMichael Walsh 51437c74f7fSMichael Walsh # Determine who our caller is and therefore what upvar_level to use. 51537c74f7fSMichael Walsh set stack_ix_adjust [calc_wrap_stack_ix_adjust] 51637c74f7fSMichael Walsh set upvar_level [expr $stack_ix_adjust + 1] 51737c74f7fSMichael Walsh upvar $upvar_level $var_name var_value 51837c74f7fSMichael Walsh 51937c74f7fSMichael Walsh set indent [lindex $args 0] 52037c74f7fSMichael Walsh set args [lrange $args 1 end] 52137c74f7fSMichael Walsh set_var_default indent 0 52237c74f7fSMichael Walsh 52337c74f7fSMichael Walsh append buffer [format "%-${indent}s%s\n" "" "$var_name:"] 52437c74f7fSMichael Walsh incr indent 2 52537c74f7fSMichael Walsh 52637c74f7fSMichael Walsh set index 0 52737c74f7fSMichael Walsh foreach element $var_value { 52837c74f7fSMichael Walsh append buffer [sprint_varx "${var_name}\[${index}\]" $element $indent\ 52937c74f7fSMichael Walsh {*}$args] 53037c74f7fSMichael Walsh incr index 53137c74f7fSMichael Walsh } 53237c74f7fSMichael Walsh 53337c74f7fSMichael Walsh return $buffer 53437c74f7fSMichael Walsh 53537c74f7fSMichael Walsh} 53637c74f7fSMichael Walsh 53737c74f7fSMichael Walsh 53837c74f7fSMichael Walshproc sprint_dict { var_name args } { 53937c74f7fSMichael Walsh 540410b1787SMichael Walsh # Return the name and value of the dictionary variable named in var_name in a formatted way. 54137c74f7fSMichael Walsh 54237c74f7fSMichael Walsh # This procedure is the equivalent of sprint_var but for dictionaries. 54337c74f7fSMichael Walsh 54437c74f7fSMichael Walsh # Description of argument(s): 545410b1787SMichael Walsh # var_name The name of the variable whose name and value are to be printed. 546410b1787SMichael Walsh # args The args understood by sprint_varx (after var_name and var_value). See 54737c74f7fSMichael Walsh # sprint_varx's prolog for details. 54837c74f7fSMichael Walsh 549410b1787SMichael Walsh # Note: In TCL, there is no way to determine that a variable represents a dictionary vs a string, etc. It 550410b1787SMichael Walsh # is up to the programmer to decide how the data is to be interpreted. Thus the need for procedures such 551410b1787SMichael Walsh # as this one. Consider the following code: 55237c74f7fSMichael Walsh 55337c74f7fSMichael Walsh # set my_dict [dict create first Joe last Montana age 50] 55437c74f7fSMichael Walsh # print_var my_dict 55537c74f7fSMichael Walsh # print_dict my_dict 55637c74f7fSMichael Walsh 55737c74f7fSMichael Walsh # Output from aforementioned code: 558410b1787SMichael Walsh # my_dict: first Joe last Montana age 50 55937c74f7fSMichael Walsh # my_dict: 56037c74f7fSMichael Walsh # my_dict[first]: Joe 56137c74f7fSMichael Walsh # my_dict[last]: Montana 56237c74f7fSMichael Walsh # my_dict[age]: 50 56337c74f7fSMichael Walsh 564410b1787SMichael Walsh # As far as print_var is concerned, my_dict is a string and is printed accordingly. By using print_dict, 565410b1787SMichael Walsh # the programmer is asking to have the output shown as a dictionary with dictionary keys/values, etc. 56637c74f7fSMichael Walsh 56737c74f7fSMichael Walsh # Determine who our caller is and therefore what upvar_level to use. 56837c74f7fSMichael Walsh set stack_ix_adjust [calc_wrap_stack_ix_adjust] 56937c74f7fSMichael Walsh set upvar_level [expr $stack_ix_adjust + 1] 57037c74f7fSMichael Walsh upvar $upvar_level $var_name var_value 57137c74f7fSMichael Walsh 57237c74f7fSMichael Walsh set indent [lindex $args 0] 57337c74f7fSMichael Walsh set args [lrange $args 1 end] 57437c74f7fSMichael Walsh set_var_default indent 0 57537c74f7fSMichael Walsh 57637c74f7fSMichael Walsh append buffer [format "%-${indent}s%s\n" "" "$var_name:"] 57737c74f7fSMichael Walsh incr indent 2 57837c74f7fSMichael Walsh 57937c74f7fSMichael Walsh foreach {key value} $var_value { 58037c74f7fSMichael Walsh append buffer [sprint_varx "${var_name}\[${key}\]" $value $indent {*}$args] 58137c74f7fSMichael Walsh incr index 58237c74f7fSMichael Walsh } 58337c74f7fSMichael Walsh 58437c74f7fSMichael Walsh return $buffer 58537c74f7fSMichael Walsh 58637c74f7fSMichael Walsh} 58737c74f7fSMichael Walsh 58837c74f7fSMichael Walsh 58937c74f7fSMichael Walshproc sprint_vars { args } { 59037c74f7fSMichael Walsh 59137c74f7fSMichael Walsh # Sprint the values of one or more variables. 59237c74f7fSMichael Walsh 59337c74f7fSMichael Walsh # Description of arg(s): 594410b1787SMichael Walsh # args: A list of variable names to be printed. The first argument in the arg list found to be an 595410b1787SMichael Walsh # integer (rather than a variable name) will be interpreted to be first of several possible sprint_var 596410b1787SMichael Walsh # arguments (e.g. indent, width, hex). See the prologue for sprint_var above for descriptions of this 597410b1787SMichael Walsh # variables. 59837c74f7fSMichael Walsh 59937c74f7fSMichael Walsh # Example usage: 60037c74f7fSMichael Walsh # set var1 "hello" 60137c74f7fSMichael Walsh # set var2 "there" 60237c74f7fSMichael Walsh # set indent 2 60337c74f7fSMichael Walsh # set buffer [sprint_vars var1 var2] 60437c74f7fSMichael Walsh # or... 60537c74f7fSMichael Walsh # set buffer [sprint_vars var1 var2 $indent] 60637c74f7fSMichael Walsh 60737c74f7fSMichael Walsh # Look for integer arguments. 60837c74f7fSMichael Walsh set first_int_ix [lsearch -regexp $args {^[0-9]+$}] 60937c74f7fSMichael Walsh if { $first_int_ix == -1 } { 61037c74f7fSMichael Walsh # If none are found, sub_args is set to empty. 61137c74f7fSMichael Walsh set sub_args {} 61237c74f7fSMichael Walsh } else { 61337c74f7fSMichael Walsh # Set sub_args to the portion of the arg list that are integers. 61437c74f7fSMichael Walsh set sub_args [lrange $args $first_int_ix end] 61537c74f7fSMichael Walsh # Re-set args to exclude the integer values. 61637c74f7fSMichael Walsh set args [lrange $args 0 [expr $first_int_ix - 1]] 61737c74f7fSMichael Walsh } 61837c74f7fSMichael Walsh 61937c74f7fSMichael Walsh foreach arg $args { 62037c74f7fSMichael Walsh append buffer [sprint_var $arg {*}$sub_args] 62137c74f7fSMichael Walsh } 62237c74f7fSMichael Walsh 62337c74f7fSMichael Walsh return $buffer 62437c74f7fSMichael Walsh 62537c74f7fSMichael Walsh} 62637c74f7fSMichael Walsh 62737c74f7fSMichael Walsh 62837c74f7fSMichael Walshproc sprint_dashes { { indent 0 } { width 80 } { line_feed 1 } { char "-" } } { 62937c74f7fSMichael Walsh 63037c74f7fSMichael Walsh # Return a string of dashes to the caller. 63137c74f7fSMichael Walsh 63237c74f7fSMichael Walsh # Description of argument(s): 633410b1787SMichael Walsh # indent The number of characters to indent the output. 63437c74f7fSMichael Walsh # width The width of the string of dashes. 635410b1787SMichael Walsh # line_feed Indicates whether the output should end with a line feed. 636410b1787SMichael Walsh # char The character to be repeated in the output string. In other words, you 637410b1787SMichael Walsh # can call on this function to print a string of any character (e.g. "=", 638410b1787SMichael Walsh # "_", etc.). 63937c74f7fSMichael Walsh 64037c74f7fSMichael Walsh set_var_default indent 0 64137c74f7fSMichael Walsh set_var_default width 80 64237c74f7fSMichael Walsh set_var_default line_feed 1 64337c74f7fSMichael Walsh 64437c74f7fSMichael Walsh append buffer [string repeat " " $indent][string repeat $char $width] 64537c74f7fSMichael Walsh append buffer [string repeat "\n" $line_feed] 64637c74f7fSMichael Walsh 64737c74f7fSMichael Walsh return $buffer 64837c74f7fSMichael Walsh 64937c74f7fSMichael Walsh} 65037c74f7fSMichael Walsh 65137c74f7fSMichael Walsh 65237c74f7fSMichael Walshproc sprint_executing {{ include_args 1 }} { 65337c74f7fSMichael Walsh 65437c74f7fSMichael Walsh # Return a string that looks something like this: 65537c74f7fSMichael Walsh # #(CST) 2017/11/28 15:08:03.261466 - 0.015214 - Executing: proc1 hi 65637c74f7fSMichael Walsh 65737c74f7fSMichael Walsh # Description of argument(s): 658410b1787SMichael Walsh # include_args Indicates whether proc args should be included in the result. 65937c74f7fSMichael Walsh 66037c74f7fSMichael Walsh set stack_ix_adjust [calc_wrap_stack_ix_adjust] 66137c74f7fSMichael Walsh set level [expr -(2 + $stack_ix_adjust)] 66237c74f7fSMichael Walsh return "[sprint_time]Executing: [get_stack_proc_name $level $include_args]\n" 66337c74f7fSMichael Walsh 66437c74f7fSMichael Walsh} 66537c74f7fSMichael Walsh 66637c74f7fSMichael Walsh 66737c74f7fSMichael Walshproc sprint_issuing { { cmd_buf "" } { test_mode 0 } } { 66837c74f7fSMichael Walsh 66937c74f7fSMichael Walsh # Return a line indicating a command that the program is about to execute. 67037c74f7fSMichael Walsh 67137c74f7fSMichael Walsh # Sample output for a cmd_buf of "ls" 67237c74f7fSMichael Walsh 67337c74f7fSMichael Walsh # #(CDT) 2016/08/25 17:57:36 - Issuing: ls 67437c74f7fSMichael Walsh 67537c74f7fSMichael Walsh # Description of arg(s): 676410b1787SMichael Walsh # cmd_buf The command to be executed by caller. If this is blank, this procedure 677410b1787SMichael Walsh # will search up the stack for the first cmd_buf value to use. 678410b1787SMichael Walsh # test_mode With test_mode set, your output will look like this: 67937c74f7fSMichael Walsh 68037c74f7fSMichael Walsh # #(CDT) 2016/08/25 17:57:36 - (test_mode) Issuing: ls 68137c74f7fSMichael Walsh 68237c74f7fSMichael Walsh if { $cmd_buf == "" } { 68337c74f7fSMichael Walsh set cmd_buf [get_stack_var cmd_buf {} 2] 68437c74f7fSMichael Walsh } 68537c74f7fSMichael Walsh 68637c74f7fSMichael Walsh append buffer [sprint_time] 68737c74f7fSMichael Walsh if { $test_mode } { 68837c74f7fSMichael Walsh append buffer "(test_mode) " 68937c74f7fSMichael Walsh } 69037c74f7fSMichael Walsh append buffer "Issuing: ${cmd_buf}\n" 69137c74f7fSMichael Walsh 69237c74f7fSMichael Walsh return $buffer 69337c74f7fSMichael Walsh 69437c74f7fSMichael Walsh} 69537c74f7fSMichael Walsh 69637c74f7fSMichael Walsh 69737c74f7fSMichael Walshproc sprint_call_stack { { indent 0 } } { 69837c74f7fSMichael Walsh 699410b1787SMichael Walsh # Return a call stack report for the given point in the program with line numbers, procedure names and 700410b1787SMichael Walsh # procedure parameters and arguments. 70137c74f7fSMichael Walsh 70237c74f7fSMichael Walsh # Sample output: 70337c74f7fSMichael Walsh 70437c74f7fSMichael Walsh # --------------------------------------------------------------------------- 70537c74f7fSMichael Walsh # TCL procedure call stack 70637c74f7fSMichael Walsh 70737c74f7fSMichael Walsh # Line # Procedure name and arguments 70837c74f7fSMichael Walsh # ------ -------------------------------------------------------------------- 70937c74f7fSMichael Walsh # 21 print_call_stack 71037c74f7fSMichael Walsh # 32 proc1 257 71137c74f7fSMichael Walsh # --------------------------------------------------------------------------- 71237c74f7fSMichael Walsh 71337c74f7fSMichael Walsh # Description of arguments: 714410b1787SMichael Walsh # indent The number of characters to indent each line of output. 71537c74f7fSMichael Walsh 71637c74f7fSMichael Walsh append buffer "[sprint_dashes ${indent}]" 71737c74f7fSMichael Walsh append buffer "[string repeat " " $indent]TCL procedure call stack\n\n" 71837c74f7fSMichael Walsh append buffer "[string repeat " " $indent]" 71937c74f7fSMichael Walsh append buffer "Line # Procedure name and arguments\n" 72037c74f7fSMichael Walsh append buffer "[sprint_dashes $indent 6 0] [sprint_dashes 0 73]" 72137c74f7fSMichael Walsh 72237c74f7fSMichael Walsh for {set ix [expr [info level]-1]} {$ix > 0} {incr ix -1} { 72337c74f7fSMichael Walsh set frame_dict [info frame $ix] 72437c74f7fSMichael Walsh set line_num [dict get $frame_dict line] 72537c74f7fSMichael Walsh set proc_name_plus_args [dict get $frame_dict cmd] 72637c74f7fSMichael Walsh append buffer [format "%-${indent}s%6i %s\n" "" $line_num\ 72737c74f7fSMichael Walsh $proc_name_plus_args] 72837c74f7fSMichael Walsh } 72937c74f7fSMichael Walsh append buffer "[sprint_dashes $indent]" 73037c74f7fSMichael Walsh 73137c74f7fSMichael Walsh return $buffer 73237c74f7fSMichael Walsh 73337c74f7fSMichael Walsh} 73437c74f7fSMichael Walsh 73537c74f7fSMichael Walsh 73637c74f7fSMichael Walshproc sprint_tcl_version {} { 73737c74f7fSMichael Walsh 73837c74f7fSMichael Walsh # Return the name and value of tcl_version in a formatted way. 73937c74f7fSMichael Walsh 74037c74f7fSMichael Walsh global tcl_version 74137c74f7fSMichael Walsh 74237c74f7fSMichael Walsh return [sprint_var tcl_version] 74337c74f7fSMichael Walsh 74437c74f7fSMichael Walsh} 74537c74f7fSMichael Walsh 74637c74f7fSMichael Walsh 74737c74f7fSMichael Walshproc sprint_error_report { { error_text "\n" } { indent 0 } } { 74837c74f7fSMichael Walsh 749410b1787SMichael Walsh # Return a string with a standardized report which includes the caller's error text, the call stack and 750410b1787SMichael Walsh # the program header. 75137c74f7fSMichael Walsh 75237c74f7fSMichael Walsh # Description of arg(s): 753410b1787SMichael Walsh # error_text The error text to be included in the report. The caller should include 754410b1787SMichael Walsh # any needed linefeeds. 755410b1787SMichael Walsh # indent The number of characters to indent each line of output. 75637c74f7fSMichael Walsh 75737c74f7fSMichael Walsh set width 120 75837c74f7fSMichael Walsh set char "=" 75937c74f7fSMichael Walsh set line_feed 1 76037c74f7fSMichael Walsh append buffer [sprint_dashes $indent $width $line_feed $char] 76137c74f7fSMichael Walsh append buffer [string repeat " " $indent][sprint_error $error_text] 76237c74f7fSMichael Walsh append buffer "\n" 76337c74f7fSMichael Walsh append buffer [sprint_call_stack $indent] 76437c74f7fSMichael Walsh append buffer [sprint_pgm_header $indent] 76537c74f7fSMichael Walsh append buffer [sprint_dashes $indent $width $line_feed $char] 76637c74f7fSMichael Walsh 76737c74f7fSMichael Walsh return $buffer 76837c74f7fSMichael Walsh 76937c74f7fSMichael Walsh} 77037c74f7fSMichael Walsh 77137c74f7fSMichael Walsh 77237c74f7fSMichael Walshproc sprint_pgm_header { {indent 0} {linefeed 1} } { 77337c74f7fSMichael Walsh 774410b1787SMichael Walsh # Return a standardized header that programs should print at the beginning of the run. It includes useful 775410b1787SMichael Walsh # information like command line, pid, userid, program parameters, etc. 77637c74f7fSMichael Walsh 77737c74f7fSMichael Walsh # Description of arguments: 778410b1787SMichael Walsh # indent The number of characters to indent each line of output. 779410b1787SMichael Walsh # linefeed Indicates whether a line feed be included at the beginning and end of the 780410b1787SMichael Walsh # report. 78137c74f7fSMichael Walsh 78237c74f7fSMichael Walsh global program_name 78337c74f7fSMichael Walsh global pgm_name_var_name 78437c74f7fSMichael Walsh global argv0 78537c74f7fSMichael Walsh global argv 78637c74f7fSMichael Walsh global env 78737c74f7fSMichael Walsh global _gtp_default_print_var_width_ 78837c74f7fSMichael Walsh 78937c74f7fSMichael Walsh set_var_default indent 0 79037c74f7fSMichael Walsh 79137c74f7fSMichael Walsh set indent_str [string repeat " " $indent] 79237c74f7fSMichael Walsh set width [expr $_gtp_default_print_var_width_ + $indent] 79337c74f7fSMichael Walsh 79437c74f7fSMichael Walsh # Get variable values for output. 79537c74f7fSMichael Walsh set command_line "$argv0 $argv" 79637c74f7fSMichael Walsh set pid_var_name ${pgm_name_var_name}_pid 79737c74f7fSMichael Walsh set $pid_var_name [pid] 79837c74f7fSMichael Walsh set uid [get_var ::env(USER) 0] 79937c74f7fSMichael Walsh set host_name [get_var ::env(HOSTNAME) 0] 80037c74f7fSMichael Walsh set DISPLAY [get_var ::env(DISPLAY) 0] 80137c74f7fSMichael Walsh 80237c74f7fSMichael Walsh # Generate the report. 80337c74f7fSMichael Walsh if { $linefeed } { append buffer "\n" } 80437c74f7fSMichael Walsh append buffer ${indent_str}[sprint_timen "Running ${program_name}."] 80537c74f7fSMichael Walsh append buffer ${indent_str}[sprint_timen "Program parameter values, etc.:\n"] 80637c74f7fSMichael Walsh append buffer [sprint_var command_line $indent $width] 80737c74f7fSMichael Walsh append buffer [sprint_var $pid_var_name $indent $width] 80837c74f7fSMichael Walsh append buffer [sprint_var uid $indent $width] 80937c74f7fSMichael Walsh append buffer [sprint_var host_name $indent $width] 81037c74f7fSMichael Walsh append buffer [sprint_var DISPLAY $indent $width] 81137c74f7fSMichael Walsh 81237c74f7fSMichael Walsh # Print caller's parm names/values. 81337c74f7fSMichael Walsh global longoptions 81437c74f7fSMichael Walsh global pos_parms 81537c74f7fSMichael Walsh 81637c74f7fSMichael Walsh regsub -all ":" "${longoptions} ${pos_parms}" {} parm_names 81737c74f7fSMichael Walsh 81837c74f7fSMichael Walsh foreach parm_name $parm_names { 81937c74f7fSMichael Walsh set cmd_buf "global $parm_name ; append buffer" 82037c74f7fSMichael Walsh append cmd_buf " \[sprint_var $parm_name $indent $width\]" 82137c74f7fSMichael Walsh eval $cmd_buf 82237c74f7fSMichael Walsh } 82337c74f7fSMichael Walsh 82437c74f7fSMichael Walsh if { $linefeed } { append buffer "\n" } 82537c74f7fSMichael Walsh 82637c74f7fSMichael Walsh return $buffer 82737c74f7fSMichael Walsh 82837c74f7fSMichael Walsh} 82937c74f7fSMichael Walsh 83037c74f7fSMichael Walsh 83137c74f7fSMichael Walshproc sprint_pgm_footer {} { 83237c74f7fSMichael Walsh 833410b1787SMichael Walsh # Return a standardized footer that programs should print at the end of the program run. It includes 834410b1787SMichael Walsh # useful information like total run time, etc. 83537c74f7fSMichael Walsh 83637c74f7fSMichael Walsh global program_name 83737c74f7fSMichael Walsh global pgm_name_var_name 83837c74f7fSMichael Walsh global start_time 83937c74f7fSMichael Walsh 84037c74f7fSMichael Walsh # Calculate total runtime. 84137c74f7fSMichael Walsh set total_time_micro [expr [clock microseconds] - $start_time] 84237c74f7fSMichael Walsh # Break the left and right of the decimal point. 84337c74f7fSMichael Walsh set total_seconds [expr $total_time_micro / 1000000] 84437c74f7fSMichael Walsh set total_decimal_micro [expr $total_time_micro % 1000000] 84537c74f7fSMichael Walsh set total_time_float [format "%i.%06i" ${total_seconds}\ 84637c74f7fSMichael Walsh ${total_decimal_micro}] 84737c74f7fSMichael Walsh set total_time_string [format "%0.6f" $total_time_float] 84837c74f7fSMichael Walsh set runtime_var_name ${pgm_name_var_name}_runtime 84937c74f7fSMichael Walsh set $runtime_var_name $total_time_string 85037c74f7fSMichael Walsh 85137c74f7fSMichael Walsh append buffer [sprint_timen "Finished running ${program_name}."] 85237c74f7fSMichael Walsh append buffer "\n" 85337c74f7fSMichael Walsh append buffer [sprint_var $runtime_var_name] 85437c74f7fSMichael Walsh append buffer "\n" 85537c74f7fSMichael Walsh 85637c74f7fSMichael Walsh return $buffer 85737c74f7fSMichael Walsh 85837c74f7fSMichael Walsh} 85937c74f7fSMichael Walsh 86037c74f7fSMichael Walsh 86137c74f7fSMichael Walshproc sprint_arg_desc { arg_title arg_desc { indent 0 } { col1_width 25 }\ 86237c74f7fSMichael Walsh { line_width 80 } } { 86337c74f7fSMichael Walsh 86437c74f7fSMichael Walsh # Return a formatted argument description. 86537c74f7fSMichael Walsh 86637c74f7fSMichael Walsh # Example: 86737c74f7fSMichael Walsh # 868410b1787SMichael Walsh # set desc "When in the Course of human events, it becomes necessary for one people to dissolve the 869410b1787SMichael Walsh # political bands which have connected them with another, and to assume among the powers of the earth, the 870410b1787SMichael Walsh # separate and equal station to which the Laws of Nature and of Nature's God entitle them, a decent respect 871410b1787SMichael Walsh # to the opinions of mankind requires that they should declare the causes which impel them to the 872410b1787SMichael Walsh # separation." 87337c74f7fSMichael Walsh 87437c74f7fSMichael Walsh # set buffer [sprint_arg_desc "--declaration" $desc] 87537c74f7fSMichael Walsh # puts $buffer 87637c74f7fSMichael Walsh 87737c74f7fSMichael Walsh # Resulting output: 87837c74f7fSMichael Walsh # --declaration When in the Course of human events, it becomes 87937c74f7fSMichael Walsh # necessary for one people to dissolve the 88037c74f7fSMichael Walsh # political bands which have connected them with 88137c74f7fSMichael Walsh # another, and to assume among the powers of the 88237c74f7fSMichael Walsh # earth, the separate and equal station to which 88337c74f7fSMichael Walsh # the Laws of Nature and of Nature's God entitle 88437c74f7fSMichael Walsh # them, a decent respect to the opinions of mankind 88537c74f7fSMichael Walsh # requires that they should declare the causes 88637c74f7fSMichael Walsh # which impel them to the separation. 88737c74f7fSMichael Walsh 88837c74f7fSMichael Walsh # Description of argument(s): 889410b1787SMichael Walsh # arg_title The content that you want to appear on the first line in column 1. 89037c74f7fSMichael Walsh # arg_desc The text that describes the argument. 89137c74f7fSMichael Walsh # indent The number of characters to indent. 892410b1787SMichael Walsh # col1_width The width of column 1, which is the column containing the arg_title. 89337c74f7fSMichael Walsh # line_width The total max width of each line of output. 89437c74f7fSMichael Walsh 89537c74f7fSMichael Walsh set fold_width [expr $line_width - $col1_width] 89637c74f7fSMichael Walsh set escaped_arg_desc [escape_bash_quotes "${arg_desc}"] 89737c74f7fSMichael Walsh 89837c74f7fSMichael Walsh set cmd_buf "echo '${escaped_arg_desc}' | fold --spaces --width=" 89937c74f7fSMichael Walsh append cmd_buf "${fold_width} | sed -re 's/\[ \]+$//g'" 90037c74f7fSMichael Walsh set out_buf [eval exec bash -c {$cmd_buf}] 90137c74f7fSMichael Walsh 90237c74f7fSMichael Walsh set help_lines [split $out_buf "\n"] 90337c74f7fSMichael Walsh 90437c74f7fSMichael Walsh set buffer {} 90537c74f7fSMichael Walsh 90637c74f7fSMichael Walsh set line_num 1 90737c74f7fSMichael Walsh foreach help_line $help_lines { 90837c74f7fSMichael Walsh if { $line_num == 1 } { 90937c74f7fSMichael Walsh if { [string length $arg_title] > $col1_width } { 91037c74f7fSMichael Walsh # If the arg_title is already wider than column1, print it on its own 91137c74f7fSMichael Walsh # line. 91237c74f7fSMichael Walsh append buffer [format "%${indent}s%-${col1_width}s\n" ""\ 91337c74f7fSMichael Walsh "$arg_title"] 91437c74f7fSMichael Walsh append buffer [format "%${indent}s%-${col1_width}s%s\n" "" ""\ 91537c74f7fSMichael Walsh "${help_line}"] 91637c74f7fSMichael Walsh } else { 91737c74f7fSMichael Walsh append buffer [format "%${indent}s%-${col1_width}s%s\n" ""\ 91837c74f7fSMichael Walsh "$arg_title" "${help_line}"] 91937c74f7fSMichael Walsh } 92037c74f7fSMichael Walsh } else { 92137c74f7fSMichael Walsh append buffer [format "%${indent}s%-${col1_width}s%s\n" "" ""\ 92237c74f7fSMichael Walsh "${help_line}"] 92337c74f7fSMichael Walsh } 92437c74f7fSMichael Walsh incr line_num 92537c74f7fSMichael Walsh } 92637c74f7fSMichael Walsh 92737c74f7fSMichael Walsh return $buffer 92837c74f7fSMichael Walsh 92937c74f7fSMichael Walsh} 93037c74f7fSMichael Walsh 93137c74f7fSMichael Walsh 93237c74f7fSMichael Walsh# Define the create_print_wrapper_procs to help us create print wrappers. 93337c74f7fSMichael Walsh# First, create templates. 93437c74f7fSMichael Walsh# Notes: 93537c74f7fSMichael Walsh# - The resulting procedures will replace all registered passwords. 936410b1787SMichael Walsh# - The resulting "quiet" and "debug" print procedures will search the stack for quiet and debug, 937410b1787SMichael Walsh# respectively. That means that the if a procedure calls qprint_var and the procedure has a local version 938410b1787SMichael Walsh# of quiet set to 1, the print will not occur, even if there is a global version of quiet set to 0. 93937c74f7fSMichael Walshset print_proc_template " puts -nonewline<output_stream> \[replace_passwords" 94037c74f7fSMichael Walshappend print_proc_template " \[<base_proc_name> {*}\$args\]\]\n}\n" 94137c74f7fSMichael Walshset qprint_proc_template " set quiet \[get_stack_var quiet 0\]\n if {" 94237c74f7fSMichael Walshappend qprint_proc_template " \$quiet } { return }\n${print_proc_template}" 94337c74f7fSMichael Walshset dprint_proc_template " set debug \[get_stack_var debug 0\]\n if { !" 94437c74f7fSMichael Walshappend dprint_proc_template " \$debug } { return }\n${print_proc_template}" 94537c74f7fSMichael Walsh 94637c74f7fSMichael Walsh# Put each template into the print_proc_templates array. 94737c74f7fSMichael Walshset print_proc_templates(p) $print_proc_template 94837c74f7fSMichael Walshset print_proc_templates(q) $qprint_proc_template 94937c74f7fSMichael Walshset print_proc_templates(d) $dprint_proc_template 95037c74f7fSMichael Walshproc create_print_wrapper_procs {proc_names {stderr_proc_names {}} } { 95137c74f7fSMichael Walsh 952410b1787SMichael Walsh # Generate code for print wrapper procs and return the generated code as a string. 95337c74f7fSMichael Walsh 954410b1787SMichael Walsh # To illustrate, suppose there is a "print_foo_bar" proc in the proc_names list. 95537c74f7fSMichael Walsh # This proc will... 95637c74f7fSMichael Walsh # - Expect that there is an sprint_foo_bar proc already in existence. 957410b1787SMichael Walsh # - Create a print_foo_bar proc which calls sprint_foo_bar and prints the result. 958410b1787SMichael Walsh # - Create a qprint_foo_bar proc which calls upon sprint_foo_bar only if global value quiet is 0. 959410b1787SMichael Walsh # - Create a dprint_foo_bar proc which calls upon sprint_foo_bar only if global value debug is 1. 96037c74f7fSMichael Walsh 961410b1787SMichael Walsh # Also, code will be generated to define aliases for each proc as well. Each alias will be created by 962410b1787SMichael Walsh # replacing "print_" in the proc name with "p" For example, the alias for print_foo_bar will be pfoo_bar. 96337c74f7fSMichael Walsh 96437c74f7fSMichael Walsh # Description of argument(s): 965410b1787SMichael Walsh # proc_names A list of procs for which print wrapper proc code is to be generated. 966410b1787SMichael Walsh # stderr_proc_names A list of procs whose generated code should print to stderr rather than 967410b1787SMichael Walsh # to stdout. 96837c74f7fSMichael Walsh 96937c74f7fSMichael Walsh global print_proc_template 97037c74f7fSMichael Walsh global print_proc_templates 97137c74f7fSMichael Walsh 97237c74f7fSMichael Walsh foreach proc_name $proc_names { 97337c74f7fSMichael Walsh 97437c74f7fSMichael Walsh if { [expr [lsearch $stderr_proc_names $proc_name] == -1] } { 97537c74f7fSMichael Walsh set replace_dict(output_stream) "" 97637c74f7fSMichael Walsh } else { 97737c74f7fSMichael Walsh set replace_dict(output_stream) " stderr" 97837c74f7fSMichael Walsh } 97937c74f7fSMichael Walsh 98037c74f7fSMichael Walsh set base_proc_name "s${proc_name}" 98137c74f7fSMichael Walsh set replace_dict(base_proc_name) $base_proc_name 98237c74f7fSMichael Walsh 98337c74f7fSMichael Walsh set wrap_proc_names(p) $proc_name 98437c74f7fSMichael Walsh set wrap_proc_names(q) q${proc_name} 98537c74f7fSMichael Walsh set wrap_proc_names(d) d${proc_name} 98637c74f7fSMichael Walsh 98737c74f7fSMichael Walsh foreach template_key [list p q d] { 98837c74f7fSMichael Walsh set wrap_proc_name $wrap_proc_names($template_key) 98937c74f7fSMichael Walsh set call_line "proc ${wrap_proc_name} \{args\} \{\n" 99037c74f7fSMichael Walsh set proc_body $print_proc_templates($template_key) 99137c74f7fSMichael Walsh set proc_def ${call_line}${proc_body} 99237c74f7fSMichael Walsh foreach {key value} [array get replace_dict] { 99337c74f7fSMichael Walsh regsub -all "<$key>" $proc_def $value proc_def 99437c74f7fSMichael Walsh } 99537c74f7fSMichael Walsh regsub "print_" $wrap_proc_name "p" alias_proc_name 99637c74f7fSMichael Walsh regsub "${wrap_proc_name}" $proc_def $alias_proc_name alias_def 99737c74f7fSMichael Walsh append buffer "${proc_def}${alias_def}" 99837c74f7fSMichael Walsh } 99937c74f7fSMichael Walsh } 100037c74f7fSMichael Walsh 100137c74f7fSMichael Walsh return $buffer 100237c74f7fSMichael Walsh 100337c74f7fSMichael Walsh} 100437c74f7fSMichael Walsh 100537c74f7fSMichael Walsh 100637c74f7fSMichael Walsh# Get this file's path. 100737c74f7fSMichael Walshset frame_dict [info frame 0] 100837c74f7fSMichael Walshset file_path [dict get $frame_dict file] 100937c74f7fSMichael Walsh# Get a list of this file's sprint procs. 101037c74f7fSMichael Walshset sprint_procs [get_file_proc_names $file_path sprint] 101137c74f7fSMichael Walsh# Create a corresponding list of print_procs. 101237c74f7fSMichael Walshset proc_names [list_map $sprint_procs {[string range $x 1 end]}] 101337c74f7fSMichael Walsh# Sort them for ease of debugging. 101437c74f7fSMichael Walshset proc_names [lsort $proc_names] 101537c74f7fSMichael Walsh 101637c74f7fSMichael Walshset stderr_proc_names [list print_error print_error_report] 101737c74f7fSMichael Walsh 101837c74f7fSMichael Walshset proc_def [create_print_wrapper_procs $proc_names $stderr_proc_names] 101937c74f7fSMichael Walshif { $GEN_PRINT_DEBUG } { puts $proc_def } 102037c74f7fSMichael Walsheval "${proc_def}" 1021