1# <20190311.1353.00>
2# This function is to set up a enhanced 'puts' routine (see below)
3# which can be globally turned off...
4#
5#  setupDebug   defines either a dummy or the real function
6#
7#  parameter  on  1 turns on the debug routine
8#                 0 (or {}) makes the debug routine a dummy
9#
10
11# This is here to cause auto_mkindex to index us.
12
13proc frputs {args} {}
14
15namespace eval frputs {
16  variable ops {proc line}
17  variable monitor {}
18  variable sources {}
19  variable procs {}
20  variable nsources {}
21  variable nprocs {}
22  variable timeStamp 0
23  variable setup 0
24  variable wvars {}
25  variable filePre 0
26  variable traceCmd ::frputs::traceCmd
27  variable saveout 0
28  variable noflush 0
29  variable savebuffer {}
30
31  proc traceCmd {args} {
32    lassign $args ar index
33    if {$index != {}} {
34      frputs "#2" "@2" ${ar}($index)
35    } else {
36      frputs "#2" "@2" $ar "[info level] "
37    }
38  }
39}
40
41# The frputsOps calls are {operation value}
42# Recognized operations:
43# "source"    only calls from source code matching pattern produces output
44# "~source"   never include calls from source code matching pattern
45# "procs"     only calls from procs code matching pattern produces output
46# "~procs"    never include calls from procs matching pattern
47# "ops"       these listed "ops" from "info frame" are included in output
48# "timeStamp" if true causes a timestamp in frputs output
49# "monitor"   is a list of commands to monitor see below.
50# "wtrace"    trace writes to var
51
52# In each case "args" (execpt monitor & timeStamp) is a list of patterns
53# or values to add or -subtract from the given list. A value preceeded by
54# "-" is to be removed. The value "--" means to clear the list.
55#
56# For "monitor", "args" is a list of commands to monitor.
57# Each time one of these is called frputs will ouput the command name and arguments
58#
59# For timeStamp the value is taken as a boolian and turns on (T) or off (F)
60# generation of a leading timeStamp for each call.
61#
62
63proc frputsOps {op args} {
64  set source {}
65  set procs {}
66  set ops {}
67
68  switch -glob $op {
69    t*  {set ::frputs::timeStamp $args;return}
70    s*  {set add ::frputs::sources}
71    p*  {set add ::frputs::procs}
72    o*  {set add ::frputs::ops}
73    ~p* {set add ::frputs::nprocs}
74    ~s* {set add ::frputs::nsources}
75    m* {
76      foreach arg $args {
77	if {$arg == "--"} {
78	  foreach cmd $frputs::monitor {
79	    rename $cmd {}
80	    rename ::realCmd$arg ::$cmd
81	  }
82	  set frputs::monitor {}
83	} elseif {[string index $arg 0] == "-"} {
84	  set cmd [string replace $arg 0 0]
85	  set l [lsearch -exact $frputs::monitor $cmd]
86	  if {$l == -1} {continue}
87	  set frputs::monitor [lreplace $frputs::monitor $l $l]
88	  rename $cmd {}
89	  rename ::realCmd$cmd ::$cmd
90	} else {
91	  set cmd ::${arg}
92	  rename $cmd ::realCmd$arg
93	  set body \{
94	  append body "set rtn \[uplevel 1 ::realCmd$arg \$args\]"
95	  append body {
96	  }
97	  append body "frputs #2 \"$cmd \" args {returns } rtn"
98	  append body {
99	  }
100	  append body "return \$rtn"
101	  append body \}
102	  proc $cmd {args} {*}$body
103	  lappend frputs::monitor $arg
104	}
105      }
106      return
107    }
108    w* {set add ::frputs::wvars}
109    default {
110      error "First parameter ($op)\
111		    must be one of \"source\", \"~source\",\
112		     \"procs\", \"~procs\", \"monitor\"\
113		      \"timeStamp\" \"wtrace\" or \"ops\""
114    }
115  }
116  foreach val [concat {*}$args] {
117    set ::frputsOps $args
118    if {$val == "--"} {
119      if {$add == "::frputs::wvars"} {
120	foreach v [set $add] {
121	  trace remove variable [namespace which -var $v]\
122	      write $::frputs::traceCmd
123	}
124      }
125      set $add {}
126    } elseif {[string index $val 0] == "-"} {
127      set new {}
128      # don't require it to be in our list...
129      if {$add == "::frputs::wvars"} {
130	trace remove variable [namespace which -var [string replace $val 0 0]]\
131	    write $::frputs::traceCmd
132      }
133      foreach ent [set $add] {
134	if {[string match $val -$ent]} {
135	  continue
136	}
137	lappend new $ent
138      }
139      set $add $new
140    } else {
141      if {$add == "::frputs::wvars"} {
142	# This allows us to set up traces for yet to be created vars
143	set val [regsub {::::} "::$val" {::}]
144	trace add variable $val write $::frputs::traceCmd
145      }
146      lappend $add $val
147    }
148  }
149}
150
151proc addOps {} {
152  upvar m m
153  upvar info info
154  append m "$info(proc) ($info(line))"
155
156  foreach en $::frputs::ops {
157    # don't double up on proc /line
158    if {$en ni {proc line} && [info exists info($en)]} {
159      if {$en == "file"} {
160	append m " $en=[string range $info($en) $frputs::filePre end]<"
161      } else {
162	append m " $en=$info($en)<"
163      }
164    }
165  }
166  append m " "
167}
168# filter returns true if the proc or file is in the consider list
169# info(proc) is the proc to look for, info(file) is the file
170# notProcs set info non-nil will check the "never" include list.
171proc filter {{notProcs {}}} {
172  upvar info info
173  if {$notProcs != {}} {
174    set notProcs "n"
175  }
176  foreach {filterList value} [list ::frputs::${notProcs}procs $info(proc)\
177				  ::frputs::${notProcs}sources $info(file)] {
178    foreach ent [set $filterList] {
179      if {[string match $ent $value]} {return 1}
180    }
181  }
182  return 0
183}
184proc getInfo {frame} {
185  upvar info info
186  array unset info
187  # The incr adjusts for the getInfo frame
188  if {[catch {info frame -[incr frame]} ans] != 0} {
189    set ans {proc bad-level file bad-level}
190  }
191  array set info [concat {proc {} file {} line {}} $ans]
192}
193
194proc setupDebug {{on 0} args} {
195  # if this is our initial setup call and we have already been
196  # called, just ignore it.
197  foreach {op val} $args {
198    frputsOps $op $val
199  }
200  set ::frputs::on $on
201  if {$on == 3 && $::frputs::setup != 0} {
202    return
203  }
204  incr ::frputs::setup
205  if {$on > 0} {
206    # A smart puts routine.
207
208    # Filtering:
209    # There are four possible filters, source, proc, nsource and nproc.
210    # A filter is present when either the source, nsource, proc orn proc list
211    # is not empty. If a filter is on (i.e. present) for source or proc, only
212    # calls from those functions matching entries in one or the other
213    # filter will be passed. If a caller is from ~source or ~proc, no action
214    # will be taken (i.e. immediate return).  Filters are glob patterns for
215    # source or proc names. These filters are checked for each "level"
216    # (see "@" and "#" below).
217    #
218    # What we produce:
219    # If timeStamp is true each line leads with the time (mm/dd hh:mm:ss )
220
221    # Then the name of the calling 'proc' and its line number in its
222    # source file is put in the output line, i.e.
223    # '<proc name> <(line#)>: '
224
225    # The frame used to evaluate the frputs arguments may be ajusted as follows:
226    # any number of "#?" entries may begin the list of arguments
227    # to frputs, where "?" is a single digit. the "?" is taken as a frame
228    # number where 1 is the calling frame (where frputs was found) and 2 is
229    # that frame's caller and so on. (Frame 1 is default.)
230    # For each "#?" the frputs::ops are evaluated and added to
231    # the output line. In addition the last "@?" sets the level the variables
232    # that follow it in the frputs call are fetched and evaluated from.
233    # Note, however, "#?" does not set the frame for evaluating arguments.
234    # So, for example:
235    #
236    # frputs "#2" "@1" abc "@2" this
237
238    # would print info on the caller's caller
239    # the value of "abc" in the caller's frame and
240    # the value of "this" in the caller's caller
241    # frame.
242    # A "#?" also turns off proc & source filtering.
243
244    # frputs::ops is taken as a set of return ops for "info frame"
245    # and each one, if it exists is put in the ouput line.
246    #
247    # Then each argument is tested for a trailing blank
248    # if there is one, the argument is put in the final string
249    # if not, the argument is assumed to be a var name.  If it exists:
250    # '<name>=$<name>< ' is put int he final string, if not '<unset> '
251    # is used as the value.
252    # Finally, the final string is processed to change all
253    #  \r \t and \n chars to the backslash equivalents.
254    # The characters "!" and "!!" as the first param, change fputs as
255    # follows:
256    # "!" suppresses the normal "flush" command after each line
257    # "!-" restores the "flush" after each line.
258    # "!!" suppresses all output until the following command:
259    # "!!-" flushes all lines suppressed by the previous line.
260    # "!!-n" where <n> is a number, flushes the last <n> lines but retains all
261    # "!!-0" clears the saved lines without flushing them
262
263    proc frputs { args } {
264      global ::frputs::noflush
265      global ::frputs::saveout
266      global ::frputs::savebuffer
267      set m {}
268      set nl {
269      }
270      if {$::frputs::timeStamp} {
271	set m [clock format [clock seconds] -format "%m/%d %T "]
272      }
273      set t 1
274      set frame 1
275      set doThis [expr {$::frputs::procs == {} && $::frputs::sources == {}}]
276
277      while {[set flagChar [string index [set flag [lindex $args 0]] 0]] == "#" ||\
278		 $flagChar == "!"} {
279	if {$flagChar == "!"} {
280	  switch -glob $flag {
281	    !   {set ::frputs::noflush 1}
282	    !-  {set ::frputs::noflush 0}
283	    !!  {set ::frputs::saveout 1}
284	    !!- {set ::frputs::saveout 0}
285	    !!-0 {set ::frputs::saveout -1}
286	    !!-* {set ::frputs::saveout [string range $flag 3 end]}
287	    default {set ::frputs::saveout "huh"}
288	  }
289	  if {![string is digit -strict $::frputs::saveout]} {
290	    set m "*+*+*+ Illegal \"!\" command \"$flag\". +*+*+*"
291	    set ::frputs::noflush 0
292	    set ::frputs::saveout 0
293	  }
294	  set args [lassign $args flag]
295	  continue
296	}
297	if {[string length $flag] == 2 &&\
298		[string is digit -strict [string index $flag 1]]} {
299
300	  set args [lassign $args flag]
301	  set filters 0
302	  getInfo [string index $flag 1]
303	  # if {[catch {info frame -[string index $flag 1]} ans] != 0} {
304	  #   set ans {proc bad-level file bad-level}
305	  # }
306	  # array set info [concat {proc {} file {} line {}} $ans]
307	  if {[filter 1]} {return}
308	  set doThis [expr {$doThis || [filter]}]
309	  append m $flag " "
310	  addOps
311	} else {
312	  break
313	}
314	# foreach ent $::frputs::ops {
315	#   set info($ent) "<unset>"
316	# }
317      }
318      # Filters ?
319      getInfo $frame
320      # if {[catch {info frame -$frame} ans] != 0} {
321      # 	set ans {proc no-frame file no-frame}
322      # }
323      # array set info [concat {proc {} file {} line {}} $ans]
324      if {[filter 1] || ! ($doThis || [filter])} {return}
325
326
327      # OK, lets do it...
328      addOps
329      append m ": "
330      foreach ar  $args {
331	if {[string index $ar 0] == "@" &&\
332		[string length $ar] == 2 &&\
333		[string is digit -strict [string index $ar 1]]} {
334	  append m $ar " "
335	  set frame [string index $ar 1]
336	  continue
337	}
338	set fl 0
339	if {[string index $ar end] == "'"} {
340	  set ar [string range $ar 0 end-1]
341	  incr fl
342	}
343	if {[string index $ar end] == " " } {
344	  append m [string range $ar 0 end]
345	} elseif { ! [catch {uplevel $frame info exists $ar} ro] &&  $ro } {
346	  if {!$fl} {
347	    if {[uplevel $frame array exists $ar]} {
348	      append m "$ar=<array><"
349	    } else {
350	      append m "$ar=[uplevel $frame set $ar]< "
351	      # append m "[uplevel $frame info level] $frame "
352	    }
353	  } else {
354	    append m "as list $ar="
355	    puts "[set m]"
356	    uplevel $frame "lh \[set $ar\]"
357	    set m "<"
358	  }
359	} else {
360	  append m "$ar=<unset>< "
361	  # append m "-$ro- "
362	  # append m "[uplevel $frame info level] $frame "
363	}
364      }
365      regsub -all {\n} $m {\\n} m
366      regsub -all {\r} $m {\\r} m
367      regsub -all {\t} $m {\\t} m
368
369      lappend savebuffer $m
370
371      switch -exact $saveout {
372	1  {return}
373	-1 {
374	  set savebuffer [list $m]
375	  set saveout 0
376	}
377	0 {}
378	default {
379	  set savebuffer [lrange $savebuffer end-$saveout end]
380	}
381      }
382      foreach ln $savebuffer {
383	puts "$ln"
384      }
385      set savebuffer {}
386      if {!$noflush} {
387	flush stdout
388      }
389    }
390  } else {
391    proc frputs {args} {}
392  }
393}
394# So you don't need to call setupDebug...
395after idle "setupDebug 3"
396
397proc lx {l} {
398  foreach e $l {
399    append r "$l
400"
401  }
402  return $r
403}
404
405# here is a little thing to call from tkcon to print lists
406# It puts 'co' elements on a line and outputs the result.
407proc lh {list {co {1}}} {
408  set idx 0
409  while {$idx < [llength $list]} {
410    set li {}
411    for {set x $co} {$x > 0} {incr x -1; incr idx} {
412      lappend li [lindex $list $idx]
413    }
414    puts "$li"
415  }
416}
417# And here it is sorted
418proc lhs {list {co {1}}} {
419  lh [lsort {*}[expr {$co == 1 ? {} : "-stride $co"}] $list] $co
420}
421