1#!/usr/bin/wish
2
3# This file provides many valuable print procedures such as sprint_var,
4# sprint_time, sprint_error, etc.
5
6my_source [list data_proc.tcl call_stack.tcl]
7
8# Need "Expect" package for trap procedure.
9package require Expect
10
11
12# Setting the following variables for use both inside this file and by
13# programs sourcing this file.
14set program_path $argv0
15set program_dir_path "[file dirname $argv0]/"
16set program_name "[file tail $argv0]"
17# Some procedures (e.g. sprint_pgm_header) need a program name value that
18# looks more like a valid variable name.  Therefore, we'll swap out odd
19# characters (like ".") for underscores.
20regsub {\.} $program_name "_" pgm_name_var_name
21
22# Initialize some time variables used in procedures in this file.
23set start_time [clock microseconds]
24
25
26proc calc_wrap_stack_ix_adjust {} {
27
28  # Calculate and return a number which can be used as an offset into the
29  # call stack for wrapper procedures.
30
31  # NOTE: This procedure is designed expressly to work with this file's print
32  # procedures scheme (i.e. print_x is a wrapper for sprint_x, etc.).  In
33  # other words, this procedure may not be well-suited for general use.
34
35  # Get a list of the procedures in the call stack beginning with our
36  # immediate caller on up to the top-level caller.
37  set call_stack [get_call_stack -2]
38
39  # The first stack entry is our immediate caller.
40  set caller [lindex $call_stack 0]
41  # Remove first entry from stack.
42  set call_stack [lreplace $call_stack 0 0]
43  # Strip any leading "s" to arrive at base_caller name (e.g. the
44  # corresponding base name for "sprint_var" would be "print_var").
45  set base_caller [string trimleft $caller s]
46  # Account for alias print procedures which have "p" vs "print_" (e.g. pvar
47  # vs print_var).
48  regsub "print_" $base_caller "p" alias_base_caller
49
50  # Initialize the stack_ix_adjust value.
51  set stack_ix_adjust 0
52  # Note: print_vars|pvars is a special case so we add it explicitly to the
53  # regex below.
54  set regex ".*(${base_caller}|${alias_base_caller}|print_vars|pvars)$"
55  foreach proc_name $call_stack {
56    # For every remaining stack item that looks like a wrapper (i.e. matches
57    # our regex), we increment the stack_ix_adjust.
58    if { [regexp -expanded $regex $proc_name]} {
59      incr stack_ix_adjust
60      continue
61    }
62    # If there is no match, then we are done.
63    break
64  }
65
66  return $stack_ix_adjust
67
68}
69
70
71# hidden_text is a list of passwords which are to be replaced with asterisks
72# by print procedures defined in this file.
73set hidden_text [list]
74# password_regex is created from the contents of the hidden_text list above.
75set password_regex ""
76
77proc register_passwords {args} {
78
79  # Register one or more passwords which are to be hidden in output produced
80  # by the print procedures in this file.
81
82  # Note: Blank password values are NOT registered.  They are simply ignored.
83
84  # Description of argument(s):
85  # args                            One or more password values.  If a given
86  #                                 password value is already registered, this
87  #                                 procedure will simply ignore it, i.e.
88  #                                 there will be no duplicate values in the
89  #                                 hidden_text list.
90
91  global hidden_text
92  global password_regex
93
94  foreach password $args {
95    # Skip blank passwords.
96    if { $password == "" } { continue }
97    # Skip already-registered passwords.
98    if { [lsearch -exact $hidden_text $password] != -1 } { continue }
99    # Put the password into the global hidden_text list.
100    lappend hidden_text $password
101  }
102
103  # TODO: Escape metachars in the password_regex.
104  set password_regex [join $hidden_text |]
105
106}
107
108
109proc replace_passwords {buffer} {
110
111  # Replace all registered password found in buffer with a string of
112  # asterisks and return the result.
113
114  # Description of argument(s):
115  # buffer                          The string to be altered and returned.
116
117  # Note:  If environment variable GEN_PRINT_DEBUG is set, this procedure
118  # will do nothing.
119
120  global env
121  if { [get_var ::env(GEN_PRINT_DEBUG) 0] } { return $buffer }
122  if { [get_var ::env(DEBUG_SHOW_PASSWORDS) 0] } { return $buffer }
123
124  global password_regex
125
126  # No passwords to replace?
127  if { $password_regex == "" } { return $buffer }
128
129  regsub -all "${password_regex}" $buffer {********} buffer
130  return $buffer
131
132}
133
134
135proc my_time { cmd_buf { iterations 100 } } {
136
137  # Run the "time" function on the given command string and print the results.
138
139  # The main benefit of running this vs just doing the "time" command directly:
140  # - This will print the results.
141
142  # Description of argument(s):
143  # cmd_buf                         The command string to be run.
144  # iterations                      The number of times to run the command
145  #                                 string.  Typically, more iterations yields
146  #                                 more accurate results.
147
148  print_issuing $cmd_buf
149  set result [time {uplevel 1 $cmd_buf} $iterations]
150
151  set raw_microseconds [lindex [split [lindex $result 0] .] 0]
152  set seconds [expr $raw_microseconds / 1000000]
153  set raw_microseconds [expr $raw_microseconds % 1000000]
154
155  set seconds_per_iteration [format "%i.%06i" ${seconds}\
156        ${raw_microseconds}]
157
158  print_var seconds_per_iteration
159
160}
161
162
163# If environment variable "GEN_PRINT_DEBUG" is set, this module will output
164# debug data.  This is primarily intended for the developer of this module.
165set GEN_PRINT_DEBUG [get_var ::env(GEN_PRINT_DEBUG) 0]
166
167# The user can set the following environment variables to influence the
168# output from print_time and print_var procedures.  See the prologs of those
169# procedures for details.
170set NANOSECONDS [get_var ::env(NANOSECONDS) 0]
171set SHOW_ELAPSED_TIME [get_var ::env(SHOW_ELAPSED_TIME) 0]
172
173# _gtp_default_print_var_width_ is adjusted based on NANOSECONDS and
174# SHOW_ELAPSED_TIME.
175if { $NANOSECONDS } {
176  set _gtp_default_print_var_width_ 36
177  set width_incr 14
178} else {
179  set _gtp_default_print_var_width_ 29
180  set width_incr 7
181}
182if { $SHOW_ELAPSED_TIME } {
183  incr _gtp_default_print_var_width_ $width_incr
184  # Initializing _sprint_time_last_seconds_ which is a global value to
185  # remember the clock seconds from the last time sprint_time was called.
186  set _gtp_sprint_time_last_micro_seconds_ [clock microseconds]
187}
188# tcl_precision is a built-in Tcl variable that specifies the number of
189# digits to generate when converting floating-point values to strings.
190set tcl_precision 17
191
192
193proc sprint { { buffer {} } } {
194
195  # Simply return the user's buffer.
196  # This procedure is used by the qprint and dprint functions defined
197  # dynamically below, i.e. it would not normally be called for general use.
198
199  # Description of arguments.
200  # buffer                          This will be returned to the caller.
201
202  return $buffer
203
204}
205
206
207proc sprintn { { buffer {} } } {
208
209  # Simply return the user's buffer plus a trailing line feed..
210  # This procedure is used by the qprintn and dprintn functions defined
211  # dynamically below, i.e. it would not normally be called for general use.
212
213  # Description of arguments.
214  # buffer                          This will be returned to the caller.
215
216  return ${buffer}\n
217
218}
219
220
221proc sprint_time { { buffer {} } } {
222
223  # Return the time in a formatted manner as described below.
224
225  # Example:
226
227  # The following tcl code...
228
229  # puts -nonewline [sprint_time()]
230  # puts -nonewline ["Hi.\n"]
231
232  # Will result in the following type of output:
233
234  # #(CDT) 2016/07/08 15:25:35 - Hi.
235
236  # Example:
237
238  # The following tcl code...
239
240  # puts -nonewline [sprint_time("Hi.\n")]
241
242  # Will result in the following type of output:
243
244  # #(CDT) 2016/08/03 17:12:05 - Hi.
245
246  # The following environment variables will affect the formatting as
247  # described:
248  # NANOSECONDS                     This will cause the time stamps to be
249  #                                 precise to the microsecond (Yes, it
250  #                                 probably should have been named
251  #                                 MICROSECONDS but the convention was set
252  #                                 long ago so we're sticking with it).
253  #                                 Example of the output when environment
254  #                                 variable NANOSECONDS=1.
255
256  # #(CDT) 2016/08/03 17:16:25.510469 - Hi.
257
258  # SHOW_ELAPSED_TIME               This will cause the elapsed time to be
259  #                                 included in the output.  This is the
260  #                                 amount of time that has elapsed since the
261  #                                 last time this procedure was called.  The
262  #                                 precision of the elapsed time field is
263  #                                 also affected by the value of the
264  #                                 NANOSECONDS environment variable.  Example
265  #                                 of the output when environment variable
266  #                                 NANOSECONDS=0 and SHOW_ELAPSED_TIME=1.
267
268  # #(CDT) 2016/08/03 17:17:40 -    0 - Hi.
269
270  # Example of the output when environment variable NANOSECONDS=1 and
271  # SHOW_ELAPSED_TIME=1.
272
273  # #(CDT) 2016/08/03 17:18:47.317339 -    0.000046 - Hi.
274
275  # Description of argument(s).
276  # buffer                          A string string whhich is to be appended
277  #                                 to the formatted time string and returned.
278
279  global NANOSECONDS
280  global _gtp_sprint_time_last_micro_seconds_
281  global SHOW_ELAPSED_TIME
282
283  # Get micro seconds since the epoch.
284  set epoch_micro [clock microseconds]
285  # Break the left and right of the decimal point.
286  set epoch_seconds [expr $epoch_micro / 1000000]
287  set epoch_decimal_micro [expr $epoch_micro % 1000000]
288
289  set format_string "#(%Z) %Y/%m/%d %H:%M:%S"
290  set return_string [clock format $epoch_seconds -format\
291    "#(%Z) %Y/%m/%d %H:%M:%S"]
292
293  if { $NANOSECONDS } {
294    append return_string ".[format "%06i" ${epoch_decimal_micro}]"
295  }
296
297  if { $SHOW_ELAPSED_TIME } {
298    set return_string "${return_string} - "
299
300    set elapsed_micro [expr $epoch_micro - \
301      $_gtp_sprint_time_last_micro_seconds_]
302    set elapsed_seconds [expr $elapsed_micro / 1000000]
303
304    if { $NANOSECONDS } {
305      set elapsed_decimal_micro [expr $elapsed_micro % 1000000]
306      set elapsed_float [format "%i.%06i" ${elapsed_seconds}\
307        ${elapsed_decimal_micro}]
308      set elapsed_time_buffer "[format "%11.6f" ${elapsed_float}]"
309    } else {
310      set elapsed_time_buffer "[format "%4i" $elapsed_seconds]"
311    }
312    set return_string "${return_string}${elapsed_time_buffer}"
313  }
314
315  set return_string "${return_string} - ${buffer}"
316
317  set _gtp_sprint_time_last_micro_seconds_ $epoch_micro
318
319  return $return_string
320
321}
322
323
324proc sprint_timen { args } {
325
326  # Return the value of sprint_time + a line feed.
327
328  # Description of argument(s):
329  # args                            All args are passed directly to
330  #                                 subordinate function, sprint_time.  See
331  #                                 that function's prolog for details.
332
333  return [sprint_time {*}$args]\n
334
335}
336
337
338proc sprint_error { { buffer {} } } {
339
340  # Return a standardized error string which includes the callers buffer text.
341
342  # Description of argument(s):
343  # buffer                          Text to be returned as part of the error
344  #                                 message.
345
346  return [sprint_time "**ERROR** $buffer"]
347
348}
349
350
351proc sprint_varx { var_name var_value { indent 0 } { width {} } { hex 0 } } {
352
353  # Return the name and value of the variable named in var_name in a
354  # formatted way.
355
356  # This procedure will visually align the output to look good next to
357  # print_time output.
358
359  # Example:
360
361  # Given the following code:
362
363  # print_timen "Initializing variables."
364  # set first_name "Joe"
365  # set last_name "Montana"
366  # set age 50
367  # print_varx last_name $last_name
368  # print_varx first_name $first_name 2
369  # print_varx age $age 2
370
371  # With environment variables NANOSECONDS and SHOW_ELAPSED_TIME both set,
372  # the following output is produced:
373
374  # #(CST) 2017/12/14 16:38:28.259480 -    0.000651 - Initializing variables.
375  # last_name:                                        Montana
376  #   first_name:                                     Joe
377  #   age:                                            50
378
379  # Description of argument(s):
380  # var_name                        The name of the variable whose name and
381  #                                 value are to be printed.
382  # var_value                       The value to be printed.
383  # indent                          The number of spaces to indent each line
384  #                                 of output.
385  # width                           The width of the column containing the
386  #                                 variable name.  By default this will align
387  #                                 with the print_time text (see example
388  #                                 above).
389  # hex                             Indicates that the variable value is to be
390  #                                 printed in hexedecimal format.  This is
391  #                                 only valid if the variable value is an
392  #                                 integer.  If the variable is NOT an
393  #                                 integer and is blank, this will be
394  #                                 interpreted to mean "print the string
395  #                                 '<blank>', rather than an actual blank
396  #                                 value".
397
398  # Note: This procedure relies on global var _gtp_default_print_var_width_
399
400  set_var_default indent 0
401
402  global _gtp_default_print_var_width_
403  set_var_default width $_gtp_default_print_var_width_
404
405  if { $indent > 0 } {
406    set width [expr $width - $indent]
407  }
408
409  if { $hex } {
410    if { [catch {format "0x%08x" "$var_value"} result] } {
411      if { $var_value == "" } { set var_value "<blank>" }
412      set hex 0
413    }
414  }
415
416  if { $hex } {
417    append buffer "[format "%-${indent}s%-${width}s0x%08x" "" "$var_name:" \
418      "$var_value"]"
419  } else {
420    append buffer "[format "%-${indent}s%-${width}s%s" "" "$var_name:" \
421      "$var_value"]"
422  }
423
424  return $buffer\n
425
426}
427
428
429proc sprint_var { var_name args } {
430
431  # Return the name and value of the variable named in var_name in a
432  # formatted way.
433
434  # This procedure will visually align the output to look good next to
435  # print_time output.
436
437  # Note: This procedure is the equivalent of sprint_varx with one
438  # difference:  This function will figure out the value of the named variable
439  # whereas sprint_varx expects you to pass the value.  This procedure in fact
440  # calls sprint_varx to do its work.
441
442  # Note: This procedure will detect whether var_name is an array and print
443  # it accordingly (see the second example below).
444
445  # Example:
446
447  # Given the following code:
448
449  # print_timen "Initializing variables."
450  # set first_name "Joe"
451  # set last_name "Montana"
452  # set age 50
453  # print_var last_name
454  # print_var first_name 2
455  # print_var age 2
456
457  # With environment variables NANOSECONDS and SHOW_ELAPSED_TIME both set,
458  # the following output is produced:
459
460  # #(CST) 2017/12/14 16:38:28.259480 -    0.000651 - Initializing variables.
461  # last_name:                                        Montana
462  #   first_name:                                     Joe
463  #   age:                                            50
464
465  # Example:
466  # Given the following code:
467
468  # set data(0) cow
469  # set data(1) horse
470  # print_var data
471
472  # data:
473  #   data(0):                                        cow
474  #   data(1):                                        horse
475
476  # Description of argument(s):
477  # var_name                        The name of the variable whose name and
478  #                                 value are to be printed.
479  # args                            The args understood by sprint_varx (after
480  #                                 var_name and var_value).  See
481  #                                 sprint_varx's prolog for details.
482
483  # Note: This procedure relies on global var _gtp_default_print_var_width_
484
485  # Determine who our caller is and therefore what upvar_level to use to get
486  # var_value.
487  set stack_ix_adjust [calc_wrap_stack_ix_adjust]
488  set upvar_level [expr $stack_ix_adjust + 1]
489  upvar $upvar_level $var_name var_value
490
491  # Special processing for arrays:
492  if { [array exists var_value] } {
493    set indent [lindex $args 0]
494    set args [lrange $args 1 end]
495    set_var_default indent 0
496
497    append buffer [format "%-${indent}s%s\n" "" "$var_name:"]
498    incr indent 2
499    incr width -2
500
501    set search_token [array startsearch var_value]
502    while {[array anymore var_value $search_token]} {
503      set key [array nextelement var_value $search_token]
504      set arr_value $var_value($key)
505      append buffer [sprint_varx "${var_name}(${key})" $arr_value $indent\
506        {*}$args]
507    }
508    array donesearch var_value $search_token
509    return $buffer
510  }
511
512  # If var_value is not defined, catch the error and print its value as
513  # "variable not set".
514  if {[catch {set buffer [sprint_varx $var_name $var_value {*}$args]} error_text options]} {
515    set regex ":\[ \]no\[ \]such\[ \]variable"
516    if { [regexp -expanded ${regex} ${error_text}]} {
517      return [sprint_varx $var_name {** variable not set **} {*}$args]
518    } else {
519      print_dict options
520      exit 1
521    }
522  } else {
523    return $buffer
524  }
525
526}
527
528
529proc sprint_list { var_name args } {
530
531  # Return the name and value of the list variable named in var_name in a
532  # formatted way.
533
534  # This procedure is the equivalent of sprint_var but for lists.
535
536  # Description of argument(s):
537  # var_name                        The name of the variable whose name and
538  #                                 value are to be printed.
539  # args                            The args understood by sprint_varx (after
540  #                                 var_name and var_value).  See
541  #                                 sprint_varx's prolog for details.
542
543  # Note: In TCL, there is no way to determine that a variable represents a
544  # list vs a string, etc.  It is up to the programmer to decide how the data
545  # is to be interpreted.  Thus the need for procedures such as this one.
546  # Consider the following code:
547
548  # set my_list {one two three}
549  # print_var my_list
550  # print_list my_list
551
552  # Output from aforementioned code:
553  # my_list:                                          one two three
554  # my_list:
555  #   my_list[0]:                                     one
556  #   my_list[1]:                                     two
557  #   my_list[2]:                                     three
558
559  # As far as print_var is concerned, my_list is a string and is printed
560  # accordingly.  By using print_list, the programmer is asking to have the
561  # output shown as a list with list indices, etc.
562
563  # Determine who our caller is and therefore what upvar_level to use.
564  set stack_ix_adjust [calc_wrap_stack_ix_adjust]
565  set upvar_level [expr $stack_ix_adjust + 1]
566  upvar $upvar_level $var_name var_value
567
568  set indent [lindex $args 0]
569  set args [lrange $args 1 end]
570  set_var_default indent 0
571
572  append buffer [format "%-${indent}s%s\n" "" "$var_name:"]
573  incr indent 2
574
575  set index 0
576  foreach element $var_value {
577    append buffer [sprint_varx "${var_name}\[${index}\]" $element $indent\
578      {*}$args]
579    incr index
580  }
581
582  return $buffer
583
584}
585
586
587proc sprint_dict { var_name args } {
588
589  # Return the name and value of the dictionary variable named in var_name in
590  # a formatted way.
591
592  # This procedure is the equivalent of sprint_var but for dictionaries.
593
594  # Description of argument(s):
595  # var_name                        The name of the variable whose name and
596  #                                 value are to be printed.
597  # args                            The args understood by sprint_varx (after
598  #                                 var_name and var_value).  See
599  #                                 sprint_varx's prolog for details.
600
601  # Note: In TCL, there is no way to determine that a variable represents a
602  # dictionary vs a string, etc.  It is up to the programmer to decide how the
603  # data is to be interpreted.  Thus the need for procedures such as this one.
604  # Consider the following code:
605
606  # set my_dict [dict create first Joe last Montana age 50]
607  # print_var my_dict
608  # print_dict my_dict
609
610  # Output from aforementioned code:
611  # my_dict:                                         first Joe last Montana
612  # age 50
613  # my_dict:
614  #  my_dict[first]:                                 Joe
615  #  my_dict[last]:                                  Montana
616  #  my_dict[age]:                                   50
617
618  # As far as print_var is concerned, my_dict is a string and is printed
619  # accordingly.  By using print_dict, the programmer is asking to have the
620  # output shown as a dictionary with dictionary keys/values, etc.
621
622  # Determine who our caller is and therefore what upvar_level to use.
623  set stack_ix_adjust [calc_wrap_stack_ix_adjust]
624  set upvar_level [expr $stack_ix_adjust + 1]
625  upvar $upvar_level $var_name var_value
626
627  set indent [lindex $args 0]
628  set args [lrange $args 1 end]
629  set_var_default indent 0
630
631  append buffer [format "%-${indent}s%s\n" "" "$var_name:"]
632  incr indent 2
633
634  foreach {key value} $var_value {
635    append buffer [sprint_varx "${var_name}\[${key}\]" $value $indent {*}$args]
636    incr index
637  }
638
639  return $buffer
640
641}
642
643
644proc sprint_vars { args } {
645
646  # Sprint the values of one or more variables.
647
648  # Description of arg(s):
649  # args:  A list of variable names to be printed.  The first argument in the
650  # arg list found to be an integer (rather than a variable name) will be
651  # interpreted to be first of several possible sprint_var arguments (e.g.
652  # indent, width, hex).  See the prologue for sprint_var above for
653  # descriptions of this variables.
654
655  # Example usage:
656  # set var1 "hello"
657  # set var2 "there"
658  # set indent 2
659  # set buffer [sprint_vars var1 var2]
660  # or...
661  # set buffer [sprint_vars var1 var2 $indent]
662
663  # Look for integer arguments.
664  set first_int_ix [lsearch -regexp $args {^[0-9]+$}]
665  if { $first_int_ix == -1 } {
666    # If none are found, sub_args is set to empty.
667    set sub_args {}
668  } else {
669    # Set sub_args to the portion of the arg list that are integers.
670    set sub_args [lrange $args $first_int_ix end]
671    # Re-set args to exclude the integer values.
672    set args [lrange $args 0 [expr $first_int_ix - 1]]
673  }
674
675  foreach arg $args {
676    append buffer [sprint_var $arg {*}$sub_args]
677  }
678
679  return $buffer
680
681}
682
683
684proc sprint_dashes { { indent 0 } { width 80 } { line_feed 1 } { char "-" } } {
685
686  # Return a string of dashes to the caller.
687
688  # Description of argument(s):
689  # indent                          The number of characters to indent the
690  #                                 output.
691  # width                           The width of the string of dashes.
692  # line_feed                       Indicates whether the output should end
693  #                                 with a line feed.
694  # char                            The character to be repeated in the output
695  #                                 string.  In other words, you can call on
696  #                                 this function to print a string of any
697  #                                 character (e.g. "=", "_", etc.).
698
699  set_var_default indent 0
700  set_var_default width 80
701  set_var_default line_feed 1
702
703  append buffer [string repeat " " $indent][string repeat $char $width]
704  append buffer [string repeat "\n" $line_feed]
705
706  return $buffer
707
708}
709
710
711proc sprint_executing {{ include_args 1 }} {
712
713  # Return a string that looks something like this:
714  # #(CST) 2017/11/28 15:08:03.261466 -    0.015214 - Executing: proc1 hi
715
716  # Description of argument(s):
717  # include_args                    Indicates whether proc args should be
718  #                                 included in the result.
719
720  set stack_ix_adjust [calc_wrap_stack_ix_adjust]
721  set level [expr -(2 + $stack_ix_adjust)]
722  return "[sprint_time]Executing: [get_stack_proc_name $level $include_args]\n"
723
724}
725
726
727proc sprint_issuing { { cmd_buf "" } { test_mode 0 } } {
728
729  # Return a line indicating a command that the program is about to execute.
730
731  # Sample output for a cmd_buf of "ls"
732
733  # #(CDT) 2016/08/25 17:57:36 - Issuing: ls
734
735  # Description of arg(s):
736  # cmd_buf                         The command to be executed by caller.  If
737  #                                 this is blank, this procedure will search
738  #                                 up the stack for the first cmd_buf value
739  #                                 to use.
740  # test_mode                       With test_mode set, your output will look
741  #                                 like this:
742
743  # #(CDT) 2016/08/25 17:57:36 - (test_mode) Issuing: ls
744
745  if { $cmd_buf == "" } {
746    set cmd_buf [get_stack_var cmd_buf {} 2]
747  }
748
749  append buffer [sprint_time]
750  if { $test_mode } {
751    append buffer "(test_mode) "
752  }
753  append buffer "Issuing: ${cmd_buf}\n"
754
755  return $buffer
756
757}
758
759
760proc sprint_call_stack { { indent 0 } } {
761
762  # Return a call stack report for the given point in the program with line
763  # numbers, procedure names and procedure parameters and arguments.
764
765  # Sample output:
766
767  # ---------------------------------------------------------------------------
768  # TCL procedure call stack
769
770  # Line # Procedure name and arguments
771  # ------ --------------------------------------------------------------------
772  #     21 print_call_stack
773  #     32 proc1 257
774  # ---------------------------------------------------------------------------
775
776  # Description of arguments:
777  # indent                          The number of characters to indent each
778  #                                 line of output.
779
780  append buffer "[sprint_dashes ${indent}]"
781  append buffer "[string repeat " " $indent]TCL procedure call stack\n\n"
782  append buffer "[string repeat " " $indent]"
783  append buffer "Line # Procedure name and arguments\n"
784  append buffer "[sprint_dashes $indent 6 0] [sprint_dashes 0 73]"
785
786  for {set ix [expr [info level]-1]} {$ix > 0} {incr ix -1} {
787    set frame_dict [info frame $ix]
788    set line_num [dict get $frame_dict line]
789    set proc_name_plus_args [dict get $frame_dict cmd]
790    append buffer [format "%-${indent}s%6i %s\n" "" $line_num\
791      $proc_name_plus_args]
792  }
793  append buffer "[sprint_dashes $indent]"
794
795  return $buffer
796
797}
798
799
800proc sprint_tcl_version {} {
801
802  # Return the name and value of tcl_version in a formatted way.
803
804  global tcl_version
805
806  return [sprint_var tcl_version]
807
808}
809
810
811proc sprint_error_report { { error_text "\n" } { indent 0 } } {
812
813  # Return a string with a standardized report which includes the caller's
814  # error text, the call stack and the program header.
815
816  # Description of arg(s):
817  # error_text                      The error text to be included in the
818  #                                 report.  The caller should include any
819  #                                 needed linefeeds.
820  # indent                          The number of characters to indent each
821  #                                 line of output.
822
823  set width 120
824  set char "="
825  set line_feed 1
826  append buffer [sprint_dashes $indent $width $line_feed $char]
827  append buffer [string repeat " " $indent][sprint_error $error_text]
828  append buffer "\n"
829  append buffer [sprint_call_stack $indent]
830  append buffer [sprint_pgm_header $indent]
831  append buffer [sprint_dashes $indent $width $line_feed $char]
832
833  return $buffer
834
835}
836
837
838proc sprint_pgm_header { {indent 0} {linefeed 1} } {
839
840  # Return a standardized header that programs should print at the beginning
841  # of the run.  It includes useful information like command line, pid,
842  # userid, program parameters, etc.
843
844  # Description of arguments:
845  # indent                          The number of characters to indent each
846  #                                 line of output.
847  # linefeed                        Indicates whether a line feed be included
848  #                                 at the beginning and end of the report.
849
850  global program_name
851  global pgm_name_var_name
852  global argv0
853  global argv
854  global env
855  global _gtp_default_print_var_width_
856
857  set_var_default indent 0
858
859  set indent_str [string repeat " " $indent]
860  set width [expr $_gtp_default_print_var_width_ + $indent]
861
862  # Get variable values for output.
863  set command_line "$argv0 $argv"
864  set pid_var_name ${pgm_name_var_name}_pid
865  set $pid_var_name [pid]
866  set uid [get_var ::env(USER) 0]
867  set host_name [get_var ::env(HOSTNAME) 0]
868  set DISPLAY [get_var ::env(DISPLAY) 0]
869
870  # Generate the report.
871  if { $linefeed } { append buffer "\n" }
872  append buffer ${indent_str}[sprint_timen "Running ${program_name}."]
873  append buffer ${indent_str}[sprint_timen "Program parameter values, etc.:\n"]
874  append buffer [sprint_var command_line $indent $width]
875  append buffer [sprint_var $pid_var_name $indent $width]
876  append buffer [sprint_var uid $indent $width]
877  append buffer [sprint_var host_name $indent $width]
878  append buffer [sprint_var DISPLAY $indent $width]
879
880  # Print caller's parm names/values.
881  global longoptions
882  global pos_parms
883
884  regsub -all ":" "${longoptions} ${pos_parms}" {} parm_names
885
886  foreach parm_name $parm_names {
887    set cmd_buf "global $parm_name ; append buffer"
888    append cmd_buf " \[sprint_var $parm_name $indent $width\]"
889    eval $cmd_buf
890  }
891
892  if { $linefeed } { append buffer "\n" }
893
894  return $buffer
895
896}
897
898
899proc sprint_pgm_footer {} {
900
901  # Return a standardized footer that programs should print at the end of the
902  # program run.  It includes useful information like total run time, etc.
903
904  global program_name
905  global pgm_name_var_name
906  global start_time
907
908  # Calculate total runtime.
909  set total_time_micro [expr [clock microseconds] - $start_time]
910  # Break the left and right of the decimal point.
911  set total_seconds [expr $total_time_micro / 1000000]
912  set total_decimal_micro [expr $total_time_micro % 1000000]
913  set total_time_float [format "%i.%06i" ${total_seconds}\
914    ${total_decimal_micro}]
915  set total_time_string [format "%0.6f" $total_time_float]
916  set runtime_var_name ${pgm_name_var_name}_runtime
917  set $runtime_var_name $total_time_string
918
919  append buffer [sprint_timen "Finished running ${program_name}."]
920  append buffer "\n"
921  append buffer [sprint_var $runtime_var_name]
922  append buffer "\n"
923
924  return $buffer
925
926}
927
928
929proc sprint_arg_desc { arg_title arg_desc { indent 0 } { col1_width 25 }\
930  { line_width 80 } } {
931
932  # Return a formatted argument description.
933
934  # Example:
935  #
936  # set desc "When in the Course of human events, it becomes necessary for
937  # one people to dissolve the political bands which have connected them with
938  # another, and to assume among the powers of the earth, the separate and
939  # equal station to which the Laws of Nature and of Nature's God entitle
940  # them, a decent respect to the opinions of mankind requires that they
941  # should declare the causes which impel them to the separation."
942
943  # set buffer [sprint_arg_desc "--declaration" $desc]
944  # puts $buffer
945
946  # Resulting output:
947  # --declaration            When in the Course of human events, it becomes
948  #                          necessary for one people to dissolve the
949  #                          political bands which have connected them with
950  #                          another, and to assume among the powers of the
951  #                          earth, the separate and equal station to which
952  #                          the Laws of Nature and of Nature's God entitle
953  #                          them, a decent respect to the opinions of mankind
954  #                          requires that they should declare the causes
955  #                          which impel them to the separation.
956
957  # Description of argument(s):
958  # arg_title                       The content that you want to appear on the
959  #                                 first line in column 1.
960  # arg_desc                        The text that describes the argument.
961  # indent                          The number of characters to indent.
962  # col1_width                      The width of column 1, which is the column
963  #                                 containing the arg_title.
964  # line_width                      The total max width of each line of output.
965
966  set fold_width [expr $line_width - $col1_width]
967  set escaped_arg_desc [escape_bash_quotes "${arg_desc}"]
968
969  set cmd_buf "echo '${escaped_arg_desc}' | fold --spaces --width="
970  append cmd_buf "${fold_width} | sed -re 's/\[ \]+$//g'"
971  set out_buf [eval exec bash -c {$cmd_buf}]
972
973  set help_lines [split $out_buf "\n"]
974
975  set buffer {}
976
977  set line_num 1
978  foreach help_line $help_lines {
979    if { $line_num == 1 } {
980      if { [string length $arg_title] > $col1_width } {
981        # If the arg_title is already wider than column1, print it on its own
982        # line.
983        append buffer [format "%${indent}s%-${col1_width}s\n" ""\
984          "$arg_title"]
985        append buffer [format "%${indent}s%-${col1_width}s%s\n" "" ""\
986          "${help_line}"]
987      } else {
988        append buffer [format "%${indent}s%-${col1_width}s%s\n" ""\
989          "$arg_title" "${help_line}"]
990      }
991    } else {
992      append buffer [format "%${indent}s%-${col1_width}s%s\n" "" ""\
993        "${help_line}"]
994    }
995    incr line_num
996  }
997
998  return $buffer
999
1000}
1001
1002
1003# Define the create_print_wrapper_procs to help us create print wrappers.
1004# First, create templates.
1005# Notes:
1006# - The resulting procedures will replace all registered passwords.
1007# - The resulting "quiet" and "debug" print procedures will search the stack
1008#   for quiet and debug, respectively.  That means that the if a procedure
1009#   calls qprint_var and the procedure has a local version of quiet set to 1,
1010#   the print will not occur, even if there is a global version of quiet set
1011#   to 0.
1012set print_proc_template "  puts -nonewline<output_stream> \[replace_passwords"
1013append print_proc_template " \[<base_proc_name> {*}\$args\]\]\n}\n"
1014set qprint_proc_template "  set quiet \[get_stack_var quiet 0\]\n  if {"
1015append qprint_proc_template " \$quiet } { return }\n${print_proc_template}"
1016set dprint_proc_template "  set debug \[get_stack_var debug 0\]\n  if { !"
1017append dprint_proc_template " \$debug } { return }\n${print_proc_template}"
1018
1019# Put each template into the print_proc_templates array.
1020set print_proc_templates(p) $print_proc_template
1021set print_proc_templates(q) $qprint_proc_template
1022set print_proc_templates(d) $dprint_proc_template
1023proc create_print_wrapper_procs {proc_names {stderr_proc_names {}} } {
1024
1025  # Generate code for print wrapper procs and return the generated code as a
1026  # string.
1027
1028  # To illustrate, suppose there is a "print_foo_bar" proc in the proc_names
1029  # list.
1030  # This proc will...
1031  # - Expect that there is an sprint_foo_bar proc already in existence.
1032  # - Create a print_foo_bar proc which calls sprint_foo_bar and prints the
1033  #   result.
1034  # - Create a qprint_foo_bar proc which calls upon sprint_foo_bar only if
1035  #   global value quiet is 0.
1036  # - Create a dprint_foo_bar proc which calls upon sprint_foo_bar only if
1037  #   global value debug is 1.
1038
1039  # Also, code will be generated to define aliases for each proc as well.
1040  # Each alias will be created by replacing "print_" in the proc name with "p"
1041  # For example, the alias for print_foo_bar will be pfoo_bar.
1042
1043  # Description of argument(s):
1044  # proc_names                      A list of procs for which print wrapper
1045  #                                 proc code is to be generated.
1046  # stderr_proc_names               A list of procs whose generated code
1047  #                                 should print to stderr rather than to
1048  #                                 stdout.
1049
1050  global print_proc_template
1051  global print_proc_templates
1052
1053  foreach proc_name $proc_names {
1054
1055    if { [expr [lsearch $stderr_proc_names $proc_name] == -1] } {
1056      set replace_dict(output_stream) ""
1057    } else {
1058      set replace_dict(output_stream) " stderr"
1059    }
1060
1061    set base_proc_name "s${proc_name}"
1062    set replace_dict(base_proc_name) $base_proc_name
1063
1064    set wrap_proc_names(p) $proc_name
1065    set wrap_proc_names(q) q${proc_name}
1066    set wrap_proc_names(d) d${proc_name}
1067
1068    foreach template_key [list p q d] {
1069      set wrap_proc_name $wrap_proc_names($template_key)
1070      set call_line "proc ${wrap_proc_name} \{args\} \{\n"
1071      set proc_body $print_proc_templates($template_key)
1072      set proc_def ${call_line}${proc_body}
1073      foreach {key value} [array get replace_dict] {
1074        regsub -all "<$key>" $proc_def $value proc_def
1075      }
1076      regsub "print_" $wrap_proc_name "p" alias_proc_name
1077      regsub "${wrap_proc_name}" $proc_def $alias_proc_name alias_def
1078      append buffer "${proc_def}${alias_def}"
1079    }
1080  }
1081
1082  return $buffer
1083
1084}
1085
1086
1087# Get this file's path.
1088set frame_dict [info frame 0]
1089set file_path [dict get $frame_dict file]
1090# Get a list of this file's sprint procs.
1091set sprint_procs [get_file_proc_names $file_path sprint]
1092# Create a corresponding list of print_procs.
1093set proc_names [list_map $sprint_procs {[string range $x 1 end]}]
1094# Sort them for ease of debugging.
1095set proc_names [lsort $proc_names]
1096
1097set stderr_proc_names [list print_error print_error_report]
1098
1099set proc_def [create_print_wrapper_procs $proc_names $stderr_proc_names]
1100if { $GEN_PRINT_DEBUG } { puts $proc_def }
1101eval "${proc_def}"
1102