blob: 6458cc46b375de5fafc25e0cb88c9da8b11eb412 [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
103 # TODO: Excape 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 }
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
512 return [sprint_varx $var_name $var_value {*}$args]
513
514}
515
516
517proc sprint_list { var_name args } {
518
519 # Return the name and value of the list variable named in var_name in a
520 # formatted way.
521
522 # This procedure is the equivalent of sprint_var but for lists.
523
524 # Description of argument(s):
525 # var_name The name of the variable whose name and
526 # value are to be printed.
527 # args The args understood by sprint_varx (after
528 # var_name and var_value). See
529 # sprint_varx's prolog for details.
530
531 # Note: In TCL, there is no way to determine that a variable represents a
532 # list vs a string, etc. It is up to the programmer to decide how the data
533 # is to be interpreted. Thus the need for procedures such as this one.
534 # Consider the following code:
535
536 # set my_list {one two three}
537 # print_var my_list
538 # print_list my_list
539
540 # Output from aforementioned code:
541 # my_list: one two three
542 # my_list:
543 # my_list[0]: one
544 # my_list[1]: two
545 # my_list[2]: three
546
547 # As far as print_var is concerned, my_list is a string and is printed
548 # accordingly. By using print_list, the programmer is asking to have the
549 # output shown as a list with list indices, etc.
550
551 # Determine who our caller is and therefore what upvar_level to use.
552 set stack_ix_adjust [calc_wrap_stack_ix_adjust]
553 set upvar_level [expr $stack_ix_adjust + 1]
554 upvar $upvar_level $var_name var_value
555
556 set indent [lindex $args 0]
557 set args [lrange $args 1 end]
558 set_var_default indent 0
559
560 append buffer [format "%-${indent}s%s\n" "" "$var_name:"]
561 incr indent 2
562
563 set index 0
564 foreach element $var_value {
565 append buffer [sprint_varx "${var_name}\[${index}\]" $element $indent\
566 {*}$args]
567 incr index
568 }
569
570 return $buffer
571
572}
573
574
575proc sprint_dict { var_name args } {
576
577 # Return the name and value of the dictionary variable named in var_name in
578 # a formatted way.
579
580 # This procedure is the equivalent of sprint_var but for dictionaries.
581
582 # Description of argument(s):
583 # var_name The name of the variable whose name and
584 # value are to be printed.
585 # args The args understood by sprint_varx (after
586 # var_name and var_value). See
587 # sprint_varx's prolog for details.
588
589 # Note: In TCL, there is no way to determine that a variable represents a
590 # dictionary vs a string, etc. It is up to the programmer to decide how the
591 # data is to be interpreted. Thus the need for procedures such as this one.
592 # Consider the following code:
593
594 # set my_dict [dict create first Joe last Montana age 50]
595 # print_var my_dict
596 # print_dict my_dict
597
598 # Output from aforementioned code:
599 # my_dict: first Joe last Montana
600 # age 50
601 # my_dict:
602 # my_dict[first]: Joe
603 # my_dict[last]: Montana
604 # my_dict[age]: 50
605
606 # As far as print_var is concerned, my_dict is a string and is printed
607 # accordingly. By using print_dict, the programmer is asking to have the
608 # output shown as a dictionary with dictionary keys/values, etc.
609
610 # Determine who our caller is and therefore what upvar_level to use.
611 set stack_ix_adjust [calc_wrap_stack_ix_adjust]
612 set upvar_level [expr $stack_ix_adjust + 1]
613 upvar $upvar_level $var_name var_value
614
615 set indent [lindex $args 0]
616 set args [lrange $args 1 end]
617 set_var_default indent 0
618
619 append buffer [format "%-${indent}s%s\n" "" "$var_name:"]
620 incr indent 2
621
622 foreach {key value} $var_value {
623 append buffer [sprint_varx "${var_name}\[${key}\]" $value $indent {*}$args]
624 incr index
625 }
626
627 return $buffer
628
629}
630
631
632proc sprint_vars { args } {
633
634 # Sprint the values of one or more variables.
635
636 # Description of arg(s):
637 # args: A list of variable names to be printed. The first argument in the
638 # arg list found to be an integer (rather than a variable name) will be
639 # interpreted to be first of several possible sprint_var arguments (e.g.
640 # indent, width, hex). See the prologue for sprint_var above for
641 # descriptions of this variables.
642
643 # Example usage:
644 # set var1 "hello"
645 # set var2 "there"
646 # set indent 2
647 # set buffer [sprint_vars var1 var2]
648 # or...
649 # set buffer [sprint_vars var1 var2 $indent]
650
651 # Look for integer arguments.
652 set first_int_ix [lsearch -regexp $args {^[0-9]+$}]
653 if { $first_int_ix == -1 } {
654 # If none are found, sub_args is set to empty.
655 set sub_args {}
656 } else {
657 # Set sub_args to the portion of the arg list that are integers.
658 set sub_args [lrange $args $first_int_ix end]
659 # Re-set args to exclude the integer values.
660 set args [lrange $args 0 [expr $first_int_ix - 1]]
661 }
662
663 foreach arg $args {
664 append buffer [sprint_var $arg {*}$sub_args]
665 }
666
667 return $buffer
668
669}
670
671
672proc sprint_dashes { { indent 0 } { width 80 } { line_feed 1 } { char "-" } } {
673
674 # Return a string of dashes to the caller.
675
676 # Description of argument(s):
677 # indent The number of characters to indent the
678 # output.
679 # width The width of the string of dashes.
680 # line_feed Indicates whether the output should end
681 # with a line feed.
682 # char The character to be repeated in the output
683 # string. In other words, you can call on
684 # this function to print a string of any
685 # character (e.g. "=", "_", etc.).
686
687 set_var_default indent 0
688 set_var_default width 80
689 set_var_default line_feed 1
690
691 append buffer [string repeat " " $indent][string repeat $char $width]
692 append buffer [string repeat "\n" $line_feed]
693
694 return $buffer
695
696}
697
698
699proc sprint_executing {{ include_args 1 }} {
700
701 # Return a string that looks something like this:
702 # #(CST) 2017/11/28 15:08:03.261466 - 0.015214 - Executing: proc1 hi
703
704 # Description of argument(s):
705 # include_args Indicates whether proc args should be
706 # included in the result.
707
708 set stack_ix_adjust [calc_wrap_stack_ix_adjust]
709 set level [expr -(2 + $stack_ix_adjust)]
710 return "[sprint_time]Executing: [get_stack_proc_name $level $include_args]\n"
711
712}
713
714
715proc sprint_issuing { { cmd_buf "" } { test_mode 0 } } {
716
717 # Return a line indicating a command that the program is about to execute.
718
719 # Sample output for a cmd_buf of "ls"
720
721 # #(CDT) 2016/08/25 17:57:36 - Issuing: ls
722
723 # Description of arg(s):
724 # cmd_buf The command to be executed by caller. If
725 # this is blank, this procedure will search
726 # up the stack for the first cmd_buf value
727 # to use.
728 # test_mode With test_mode set, your output will look
729 # like this:
730
731 # #(CDT) 2016/08/25 17:57:36 - (test_mode) Issuing: ls
732
733 if { $cmd_buf == "" } {
734 set cmd_buf [get_stack_var cmd_buf {} 2]
735 }
736
737 append buffer [sprint_time]
738 if { $test_mode } {
739 append buffer "(test_mode) "
740 }
741 append buffer "Issuing: ${cmd_buf}\n"
742
743 return $buffer
744
745}
746
747
748proc sprint_call_stack { { indent 0 } } {
749
750 # Return a call stack report for the given point in the program with line
751 # numbers, procedure names and procedure parameters and arguments.
752
753 # Sample output:
754
755 # ---------------------------------------------------------------------------
756 # TCL procedure call stack
757
758 # Line # Procedure name and arguments
759 # ------ --------------------------------------------------------------------
760 # 21 print_call_stack
761 # 32 proc1 257
762 # ---------------------------------------------------------------------------
763
764 # Description of arguments:
765 # indent The number of characters to indent each
766 # line of output.
767
768 append buffer "[sprint_dashes ${indent}]"
769 append buffer "[string repeat " " $indent]TCL procedure call stack\n\n"
770 append buffer "[string repeat " " $indent]"
771 append buffer "Line # Procedure name and arguments\n"
772 append buffer "[sprint_dashes $indent 6 0] [sprint_dashes 0 73]"
773
774 for {set ix [expr [info level]-1]} {$ix > 0} {incr ix -1} {
775 set frame_dict [info frame $ix]
776 set line_num [dict get $frame_dict line]
777 set proc_name_plus_args [dict get $frame_dict cmd]
778 append buffer [format "%-${indent}s%6i %s\n" "" $line_num\
779 $proc_name_plus_args]
780 }
781 append buffer "[sprint_dashes $indent]"
782
783 return $buffer
784
785}
786
787
788proc sprint_tcl_version {} {
789
790 # Return the name and value of tcl_version in a formatted way.
791
792 global tcl_version
793
794 return [sprint_var tcl_version]
795
796}
797
798
799proc sprint_error_report { { error_text "\n" } { indent 0 } } {
800
801 # Return a string with a standardized report which includes the caller's
802 # error text, the call stack and the program header.
803
804 # Description of arg(s):
805 # error_text The error text to be included in the
806 # report. The caller should include any
807 # needed linefeeds.
808 # indent The number of characters to indent each
809 # line of output.
810
811 set width 120
812 set char "="
813 set line_feed 1
814 append buffer [sprint_dashes $indent $width $line_feed $char]
815 append buffer [string repeat " " $indent][sprint_error $error_text]
816 append buffer "\n"
817 append buffer [sprint_call_stack $indent]
818 append buffer [sprint_pgm_header $indent]
819 append buffer [sprint_dashes $indent $width $line_feed $char]
820
821 return $buffer
822
823}
824
825
826proc sprint_pgm_header { {indent 0} {linefeed 1} } {
827
828 # Return a standardized header that programs should print at the beginning
829 # of the run. It includes useful information like command line, pid,
830 # userid, program parameters, etc.
831
832 # Description of arguments:
833 # indent The number of characters to indent each
834 # line of output.
835 # linefeed Indicates whether a line feed be included
836 # at the beginning and end of the report.
837
838 global program_name
839 global pgm_name_var_name
840 global argv0
841 global argv
842 global env
843 global _gtp_default_print_var_width_
844
845 set_var_default indent 0
846
847 set indent_str [string repeat " " $indent]
848 set width [expr $_gtp_default_print_var_width_ + $indent]
849
850 # Get variable values for output.
851 set command_line "$argv0 $argv"
852 set pid_var_name ${pgm_name_var_name}_pid
853 set $pid_var_name [pid]
854 set uid [get_var ::env(USER) 0]
855 set host_name [get_var ::env(HOSTNAME) 0]
856 set DISPLAY [get_var ::env(DISPLAY) 0]
857
858 # Generate the report.
859 if { $linefeed } { append buffer "\n" }
860 append buffer ${indent_str}[sprint_timen "Running ${program_name}."]
861 append buffer ${indent_str}[sprint_timen "Program parameter values, etc.:\n"]
862 append buffer [sprint_var command_line $indent $width]
863 append buffer [sprint_var $pid_var_name $indent $width]
864 append buffer [sprint_var uid $indent $width]
865 append buffer [sprint_var host_name $indent $width]
866 append buffer [sprint_var DISPLAY $indent $width]
867
868 # Print caller's parm names/values.
869 global longoptions
870 global pos_parms
871
872 regsub -all ":" "${longoptions} ${pos_parms}" {} parm_names
873
874 foreach parm_name $parm_names {
875 set cmd_buf "global $parm_name ; append buffer"
876 append cmd_buf " \[sprint_var $parm_name $indent $width\]"
877 eval $cmd_buf
878 }
879
880 if { $linefeed } { append buffer "\n" }
881
882 return $buffer
883
884}
885
886
887proc sprint_pgm_footer {} {
888
889 # Return a standardized footer that programs should print at the end of the
890 # program run. It includes useful information like total run time, etc.
891
892 global program_name
893 global pgm_name_var_name
894 global start_time
895
896 # Calculate total runtime.
897 set total_time_micro [expr [clock microseconds] - $start_time]
898 # Break the left and right of the decimal point.
899 set total_seconds [expr $total_time_micro / 1000000]
900 set total_decimal_micro [expr $total_time_micro % 1000000]
901 set total_time_float [format "%i.%06i" ${total_seconds}\
902 ${total_decimal_micro}]
903 set total_time_string [format "%0.6f" $total_time_float]
904 set runtime_var_name ${pgm_name_var_name}_runtime
905 set $runtime_var_name $total_time_string
906
907 append buffer [sprint_timen "Finished running ${program_name}."]
908 append buffer "\n"
909 append buffer [sprint_var $runtime_var_name]
910 append buffer "\n"
911
912 return $buffer
913
914}
915
916
917proc sprint_arg_desc { arg_title arg_desc { indent 0 } { col1_width 25 }\
918 { line_width 80 } } {
919
920 # Return a formatted argument description.
921
922 # Example:
923 #
924 # set desc "When in the Course of human events, it becomes necessary for
925 # one people to dissolve the political bands which have connected them with
926 # another, and to assume among the powers of the earth, the separate and
927 # equal station to which the Laws of Nature and of Nature's God entitle
928 # them, a decent respect to the opinions of mankind requires that they
929 # should declare the causes which impel them to the separation."
930
931 # set buffer [sprint_arg_desc "--declaration" $desc]
932 # puts $buffer
933
934 # Resulting output:
935 # --declaration When in the Course of human events, it becomes
936 # necessary for one people to dissolve the
937 # political bands which have connected them with
938 # another, and to assume among the powers of the
939 # earth, the separate and equal station to which
940 # the Laws of Nature and of Nature's God entitle
941 # them, a decent respect to the opinions of mankind
942 # requires that they should declare the causes
943 # which impel them to the separation.
944
945 # Description of argument(s):
946 # arg_title The content that you want to appear on the
947 # first line in column 1.
948 # arg_desc The text that describes the argument.
949 # indent The number of characters to indent.
950 # col1_width The width of column 1, which is the column
951 # containing the arg_title.
952 # line_width The total max width of each line of output.
953
954 set fold_width [expr $line_width - $col1_width]
955 set escaped_arg_desc [escape_bash_quotes "${arg_desc}"]
956
957 set cmd_buf "echo '${escaped_arg_desc}' | fold --spaces --width="
958 append cmd_buf "${fold_width} | sed -re 's/\[ \]+$//g'"
959 set out_buf [eval exec bash -c {$cmd_buf}]
960
961 set help_lines [split $out_buf "\n"]
962
963 set buffer {}
964
965 set line_num 1
966 foreach help_line $help_lines {
967 if { $line_num == 1 } {
968 if { [string length $arg_title] > $col1_width } {
969 # If the arg_title is already wider than column1, print it on its own
970 # line.
971 append buffer [format "%${indent}s%-${col1_width}s\n" ""\
972 "$arg_title"]
973 append buffer [format "%${indent}s%-${col1_width}s%s\n" "" ""\
974 "${help_line}"]
975 } else {
976 append buffer [format "%${indent}s%-${col1_width}s%s\n" ""\
977 "$arg_title" "${help_line}"]
978 }
979 } else {
980 append buffer [format "%${indent}s%-${col1_width}s%s\n" "" ""\
981 "${help_line}"]
982 }
983 incr line_num
984 }
985
986 return $buffer
987
988}
989
990
991# Define the create_print_wrapper_procs to help us create print wrappers.
992# First, create templates.
993# Notes:
994# - The resulting procedures will replace all registered passwords.
995# - The resulting "quiet" and "debug" print procedures will search the stack
Michael Walsh9dbe6372019-06-24 14:59:56 -0500996# for quiet and debug, respectively. That means that the if a procedure
997# calls qprint_var and the procedure has a local version of quiet set to 1,
998# the print will not occur, even if there is a global version of quiet set
999# to 0.
Michael Walsh37c74f72018-02-15 17:12:25 -06001000set print_proc_template " puts -nonewline<output_stream> \[replace_passwords"
1001append print_proc_template " \[<base_proc_name> {*}\$args\]\]\n}\n"
1002set qprint_proc_template " set quiet \[get_stack_var quiet 0\]\n if {"
1003append qprint_proc_template " \$quiet } { return }\n${print_proc_template}"
1004set dprint_proc_template " set debug \[get_stack_var debug 0\]\n if { !"
1005append dprint_proc_template " \$debug } { return }\n${print_proc_template}"
1006
1007# Put each template into the print_proc_templates array.
1008set print_proc_templates(p) $print_proc_template
1009set print_proc_templates(q) $qprint_proc_template
1010set print_proc_templates(d) $dprint_proc_template
1011proc create_print_wrapper_procs {proc_names {stderr_proc_names {}} } {
1012
1013 # Generate code for print wrapper procs and return the generated code as a
1014 # string.
1015
1016 # To illustrate, suppose there is a "print_foo_bar" proc in the proc_names
1017 # list.
1018 # This proc will...
1019 # - Expect that there is an sprint_foo_bar proc already in existence.
1020 # - Create a print_foo_bar proc which calls sprint_foo_bar and prints the
Michael Walsh9dbe6372019-06-24 14:59:56 -05001021 # result.
Michael Walsh37c74f72018-02-15 17:12:25 -06001022 # - Create a qprint_foo_bar proc which calls upon sprint_foo_bar only if
Michael Walsh9dbe6372019-06-24 14:59:56 -05001023 # global value quiet is 0.
Michael Walsh37c74f72018-02-15 17:12:25 -06001024 # - Create a dprint_foo_bar proc which calls upon sprint_foo_bar only if
Michael Walsh9dbe6372019-06-24 14:59:56 -05001025 # global value debug is 1.
Michael Walsh37c74f72018-02-15 17:12:25 -06001026
1027 # Also, code will be generated to define aliases for each proc as well.
1028 # Each alias will be created by replacing "print_" in the proc name with "p"
1029 # For example, the alias for print_foo_bar will be pfoo_bar.
1030
1031 # Description of argument(s):
1032 # proc_names A list of procs for which print wrapper
1033 # proc code is to be generated.
1034 # stderr_proc_names A list of procs whose generated code
1035 # should print to stderr rather than to
1036 # stdout.
1037
1038 global print_proc_template
1039 global print_proc_templates
1040
1041 foreach proc_name $proc_names {
1042
1043 if { [expr [lsearch $stderr_proc_names $proc_name] == -1] } {
1044 set replace_dict(output_stream) ""
1045 } else {
1046 set replace_dict(output_stream) " stderr"
1047 }
1048
1049 set base_proc_name "s${proc_name}"
1050 set replace_dict(base_proc_name) $base_proc_name
1051
1052 set wrap_proc_names(p) $proc_name
1053 set wrap_proc_names(q) q${proc_name}
1054 set wrap_proc_names(d) d${proc_name}
1055
1056 foreach template_key [list p q d] {
1057 set wrap_proc_name $wrap_proc_names($template_key)
1058 set call_line "proc ${wrap_proc_name} \{args\} \{\n"
1059 set proc_body $print_proc_templates($template_key)
1060 set proc_def ${call_line}${proc_body}
1061 foreach {key value} [array get replace_dict] {
1062 regsub -all "<$key>" $proc_def $value proc_def
1063 }
1064 regsub "print_" $wrap_proc_name "p" alias_proc_name
1065 regsub "${wrap_proc_name}" $proc_def $alias_proc_name alias_def
1066 append buffer "${proc_def}${alias_def}"
1067 }
1068 }
1069
1070 return $buffer
1071
1072}
1073
1074
1075# Get this file's path.
1076set frame_dict [info frame 0]
1077set file_path [dict get $frame_dict file]
1078# Get a list of this file's sprint procs.
1079set sprint_procs [get_file_proc_names $file_path sprint]
1080# Create a corresponding list of print_procs.
1081set proc_names [list_map $sprint_procs {[string range $x 1 end]}]
1082# Sort them for ease of debugging.
1083set proc_names [lsort $proc_names]
1084
1085set stderr_proc_names [list print_error print_error_report]
1086
1087set proc_def [create_print_wrapper_procs $proc_names $stderr_proc_names]
1088if { $GEN_PRINT_DEBUG } { puts $proc_def }
1089eval "${proc_def}"