blob: 98cd051adaebdb7177ad604df4affc229c25bab4 [file] [log] [blame]
Michael Walsh37c74f72018-02-15 17:12:25 -06001#!/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
Gunnar Millsacc7c562019-08-20 13:12:46 -0500103 # TODO: Escape metachars in the password_regex.
Michael Walsh37c74f72018-02-15 17:12:25 -0600104 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 }
Michael Walshb21aec12018-03-02 12:00:22 -0600122 if { [get_var ::env(DEBUG_SHOW_PASSWORDS) 0] } { return $buffer }
Michael Walsh37c74f72018-02-15 17:12:25 -0600123
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
Michael Walsh355b8ef2019-07-17 10:37:15 -0500512 # 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 }
Michael Walsh37c74f72018-02-15 17:12:25 -0600525
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
Michael Walsh9dbe6372019-06-24 14:59:56 -05001008# 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.
Michael Walsh37c74f72018-02-15 17:12:25 -06001012set 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
Michael Walsh9dbe6372019-06-24 14:59:56 -05001033 # result.
Michael Walsh37c74f72018-02-15 17:12:25 -06001034 # - Create a qprint_foo_bar proc which calls upon sprint_foo_bar only if
Michael Walsh9dbe6372019-06-24 14:59:56 -05001035 # global value quiet is 0.
Michael Walsh37c74f72018-02-15 17:12:25 -06001036 # - Create a dprint_foo_bar proc which calls upon sprint_foo_bar only if
Michael Walsh9dbe6372019-06-24 14:59:56 -05001037 # global value debug is 1.
Michael Walsh37c74f72018-02-15 17:12:25 -06001038
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}"