# <20220211.1652.53>
# This function is to set up a enhanced 'puts' routine (see below)
# which can be globally turned off...
#
#  setupDebug   defines either a dummy or the real function
#
#  parameter  on  1 turns on the debug routine
#                 0 (or {}) makes the debug routine a dummy
#

# This is here to cause auto_mkindex to index us.

proc frputs {args} {}

namespace eval frputs {
  variable ops {proc line}
  variable monitor {}
  variable sources {}
  variable procs {}
  variable nsources {}
  variable nprocs {}
  variable timeStamp 0
  variable recursionLimit 20
  variable setup 0
  variable wvars {}
  variable filePre 0
  variable traceCmd ::frputs::traceCmd
  variable saveout 0
  variable noflush 0
  variable savebuffer {}
  variable pendingMon {}

  proc traceCmd {args} {
    lassign $args ar index
    if {$index != {}} {
      frputs "#2" "@2" ${ar}($index)
    } else {
      frputs "#2" "@2" $ar "[info level] "
    }
  }
}

# The frputsOps calls are {operation value}
# Recognized operations:
# "source"    only calls from source code matching pattern produces output
# "~source"   never include calls from source code matching pattern
# "procs"     only calls from procs code matching pattern produces output
# "~procs"    never include calls from procs matching pattern
# "ops"       these listed "ops" from "info frame" are included in output
# "timeStamp" if true causes a timestamp in frputs output
# "recursionLimit" if one or more routines are being monitored, this is the max
#                  number of resursions allowed.
# "monitor"   is a list of commands to monitor see below. 
# "wtrace"    trace writes to var un-returns (i.e. if only one, this is a resursion limit)
# "monitor"   is a list of commands to monitor see below. 
# "wtrace"    trace writes to var

# In each case "args" (execpt monitor & timeStamp) is a list of patterns
# or values to add or -subtract from the given list. A value preceeded by
# "-" is to be removed. The value "--" means to clear the list.
#
# For "monitor", "args" is a list of commands to monitor.
# Each time one of these is called frputs will ouput the command name and arguments
# 
# For timeStamp the value is taken as a boolean and turns on (T) or off (F)
# generation of a leading timeStamp for each call.
#

# This function provides the guts for the 'monitor' functions...
proc ::frputs::frputsMon {args} {
  if {![info exists ::frputs::recur%s]} {
    namespace eval [namespace qualifiers ::frputs::recur%s] set ::frputs::recur%s -1
  }
  
  set RECUR [incr ::frputs::recur%s]
  if {$RECUR > $::frputs::recursionLimit} {
    error "Recursion limit of $::frputs::recursionLimit hit"
  }
  set call [frputs !+ #2 "CALL PROC %s " RECUR args]
  set stars [string repeat *  [llength "$::frputs::pendingMon x"]]
  if {[set live [info body frputs]] != {}} {
    puts "$stars$call"
    flush stdout
  }
  lappend ::frputs::pendingMon "%s args=$args<"
  set r [catch {uplevel %s.RealCmd $args} RETURNS]
    
  set idx [lindex [lsearch -all -glob $::frputs::pendingMon %s*] end]
  set ::frputs::pendingMon [lreplace $::frputs::pendingMon $idx $idx]
  set m ""
  if {$::frputs::timeStamp} {
    set m "at [clock format [clock seconds] -format {%m/%d %T }] "
  }
  # We need to do this here to see the recursive stuff (because we are
  # not leting frputs main do this.
  if {$live != {}} {  
    if {[set len [llength $::frputs::pendingMon]] > 0} {
      puts "In progress:${len}: $::frputs::pendingMon"
    }
    puts -nonewline "$stars${m}RETURNS"
    if {$r != 0} {
      puts " ERROR($r): $RETURNS $::errorInfo"
      flush stdout
      return -code $r $RETURNS
    } else {
      puts "=$RETURNS<"
      flush stdout
    }
  }
  if {[incr ::frputs::recur%s -1] == -1} {
    ## unset ::frputs::recur%s
  }
  return $RETURNS
}

proc frputsOps {op args} {
  set source {}
  set procs {}
  set ops {}
  
  switch -glob $op {
    t*  {set ::frputs::timeStamp $args;return}
    s*  {set add ::frputs::sources}
    p*  {set add ::frputs::procs}
    o*  {set add ::frputs::ops}
    ~p* {set add ::frputs::nprocs}
    ~s* {set add ::frputs::nsources}
    m* {
      foreach arg $args {
	if {$arg == "--"} {
	  foreach cmd $frputs::monitor {
	    rename $cmd {}
	    rename $arg.RealCme ::$cmd
	  }
	  set frputs::monitor {}
	} elseif {[string index $arg 0] == "-"} {
	  set cmd [string replace $arg 0 0]
	  set l [lsearch -exact $frputs::monitor $cmd]
	  if {$l == -1} {continue}
	  set frputs::monitor [lreplace $frputs::monitor $l $l]
	  rename $cmd {}
	  rename $cmd.RealCmd ::$cmd
	} else {
	  set cmd ::${arg}
	  rename $cmd $arg.RealCmd
	  set body [regsub -all {%s} [info body ::frputs::frputsMon] $arg]
	  proc $cmd {args} $body
	  lappend frputs::monitor $arg
	}
      }
      return
    }
    w* {set add ::frputs::wvars}
    default {
      error "First parameter ($op)\
		    must be one of \"source\", \"~source\",\
		     \"procs\", \"~procs\", \"monitor\"\
		      \"timeStamp\" \"wtrace\" or \"ops\""
    }
  }
  foreach val [concat {*}$args] {
    set ::frputsOps $args
    if {$val == "--"} {
      if {$add == "::frputs::wvars"} {
	foreach v [set $add] {
	  trace remove variable [namespace which -var $v]\
	      write $::frputs::traceCmd
	}
      }
      set $add {}
    } elseif {[string index $val 0] == "-"} {
      set new {}
      # don't require it to be in our list...
      if {$add == "::frputs::wvars"} {
	trace remove variable [namespace which -var [string replace $val 0 0]]\
	    write $::frputs::traceCmd
      }
      foreach ent [set $add] {
	if {[string match $val -$ent]} {
	  continue
	}
	lappend new $ent
      }
      set $add $new
    } else {
      if {$add == "::frputs::wvars"} {
	# This allows us to set up traces for yet to be created vars
	set val [regsub {::::} "::$val" {::}]
	trace add variable $val write $::frputs::traceCmd
      }
      lappend $add $val
    }
  }
}

proc addOps {} {
  upvar m m
  upvar info info
  append m "$info(proc) ($info(line))"
  
  foreach en $::frputs::ops {
    # don't double up on proc /line
    if {$en ni {proc line} && [info exists info($en)]} {
      if {$en == "file"} {
	append m " $en=[string range $info($en) $frputs::filePre end]<"
      } else {
	append m " $en=$info($en)<"
      }
    }
  }
  append m " "
}
# filter returns true if the proc or file is in the consider list
# info(proc) is the proc to look for, info(file) is the file
# notProcs set info non-nil will check the "never" include list.
proc filter {{notProcs {}}} {
  upvar info info
  if {$notProcs != {}} {
    set notProcs "n"
  }
  foreach {filterList value} [list ::frputs::${notProcs}procs $info(proc)\
				  ::frputs::${notProcs}sources $info(file)] {
    foreach ent [set $filterList] {
      if {[string match $ent $value]} {return 1}
    }
  }
  return 0
}
proc getInfo {frame} {
  variable ::frputs::indxAry
  upvar info info
  array unset info
  # The incr adjusts for the getInfo frame
  if {[catch {info frame -[incr frame]} ans] != 0} {
    set ans {proc bad-level file bad-level}
  }
  array set info [concat {proc {} file {} line {}} $ans]
  if {[info exists indxAry($info(proc))]} {
    set info(line) [expr {$indxAry($info(proc)) + $info(line)}]
    set info(proc) [regsub {Snit_method} $info(proc) {method }]
    set info(proc) [regsub {Snit_} $info(proc) {}]
  }
}

proc setupDebug {{on 0} args} {
  # if this is our initial setup call and we have already been
  # called, just ignore it.
  foreach {op val} $args {
    frputsOps $op $val
  }
  set ::frputs::on $on
  if {$on == 3 && $::frputs::setup != 0} {
    return
  }
  incr ::frputs::setup
  if {$on > 0} {
    # A smart puts routine.
    
    # Filtering:
    # There are four possible filters, source, proc, nsource and nproc.
    # A filter is present when either the source, nsource, proc orn proc list
    # is not empty. If a filter is on (i.e. present) for source or proc, only
    # calls from those functions matching entries in one or the other
    # filter will be passed. If a caller is from ~source or ~proc, no action
    # will be taken (i.e. immediate return).  Filters are glob patterns for
    # source or proc names. These filters are checked for each "level"
    # (see "@" and "#" below).
    #
    # What we produce:
    # If timeStamp is true each line leads with the time (mm/dd hh:mm:ss )
    
    # Then the name of the calling 'proc' and its line number in its
    # source file is put in the output line, i.e.
    # '<proc name> <(line#)>: '

    # The frame used to evaluate the frputs arguments may be ajusted as follows:
    # any number of "#?" entries may begin the list of arguments
    # to frputs, where "?" is a single digit. the "?" is taken as a frame
    # number where 1 is the calling frame (where frputs was found) and 2 is
    # that frame's caller and so on. (Frame 1 is default.)
    # For each "#?" the frputs::ops are evaluated and added to
    # the output line. In addition the last "@?" sets the level the variables
    # that follow it in the frputs call are fetched and evaluated from.
    # Note, however, "#?" does not set the frame for evaluating arguments.
    # So, for example:
    #
    # frputs "#2" "@1" abc "@2" this
    
    # would print info on the caller's caller
    # the value of "abc" in the caller's frame and
    # the value of "this" in the caller's caller
    # frame.
    # A "#?" also turns off proc & source filtering.
    
    # frputs::ops is taken as a set of return ops for "info frame"
    # and each one, if it exists is put in the ouput line.
    #
    # Then each argument is tested for a trailing blank
    # if there is one, the argument is put in the final string
    # if not, the argument is assumed to be a var name.  If it exists:
    # '<name>=$<name>< ' is put int he final string, if not '<unset> '
    # is used as the value.
    # Finally, the final string is processed to change all
    #  \r \t and \n chars to the backslash equivalents.
    # The characters "!" and "!!" as the first param, change fputs as
    # follows:
    # "!" suppresses the normal "flush" command after each line
    # "!-" restores the "flush" after each line.
    # "!!" suppresses all output until the following command:
    # "!!-" flushes all lines suppressed by the previous line.
    # "!+"  suppresses the given line only, returns the formated line
    # "!!-n" where <n> is a number, flushes the last <n> lines but retains all
    # "!!-0" clears the saved lines without flushing them
    
    proc frputs { args } {
      global ::frputs::noflush
      global ::frputs::saveout
      global ::frputs::savebuffer
      set fmtonly 0
      set m {}
      set nl {
      }
      if {$::frputs::timeStamp} {
	set m [clock format [clock seconds] -format "%m/%d %T "]
      }
      set t 1
      set frame 1
      set doThis [expr {$::frputs::procs == {} && $::frputs::sources == {}}]
      
      while {[set flagChar [string index [set flag [lindex $args 0]] 0]] == "#" ||\
		 $flagChar == "!"} {
	if {$flagChar == "!"} {
	  switch -glob $flag {
	    !   {set ::frputs::noflush 1}
	    !-  {set ::frputs::noflush 0}
	    !+  {set fmtonly 1}
	    !!  {set ::frputs::saveout 1}
	    !!- {set ::frputs::saveout 0}
	    !!-0 {set ::frputs::saveout -1}
	    !!-* {set ::frputs::saveout [string range $flag 3 end]}
	    default {set ::frputs::saveout "huh"}
	  }
	  if {![string is digit -strict $::frputs::saveout]} {
	    set m "*+*+*+ Illegal \"!\" command \"$flag\". +*+*+*"
	    set ::frputs::noflush 0
	    set ::frputs::saveout 0
	  }
	  set args [lassign $args flag]
	  continue
	}
	if {[string length $flag] == 2 &&\
		[string is digit -strict [string index $flag 1]]} {
	  
	  set args [lassign $args flag]
	  set filters 0
	  getInfo [string index $flag 1]
	  # if {[catch {info frame -[string index $flag 1]} ans] != 0} {
	  #   set ans {proc bad-level file bad-level}
	  # }
	  # array set info [concat {proc {} file {} line {}} $ans]
	  if {[filter 1]} {return}
	  set doThis [expr {$doThis || [filter]}]
	  append m $flag " "
	  addOps
	} else {
	  break
	}
	# foreach ent $::frputs::ops {
	#   set info($ent) "<unset>"
	# }
      }
      # Filters ?
      getInfo $frame
      # if {[catch {info frame -$frame} ans] != 0} {
      # 	set ans {proc no-frame file no-frame}
      # }
      # array set info [concat {proc {} file {} line {}} $ans]
      if {[filter 1] || ! ($doThis || [filter])} {return}


      # OK, lets do it...
      # If we are inside of a call monitor (i.e. called but not yet returned)
      # put out the list.
      if {[set ln [llength $::frputs::pendingMon]] != 0 && !$fmtonly} {
	puts "In progress:${ln}: $::frputs::pendingMon"
      }
      addOps
      append m ": "
      foreach ar  $args {
	if {[string index $ar 0] == "@" &&\
		[string length $ar] == 2 &&\
		[string is digit -strict [string index $ar 1]]} {
	  append m $ar " "
	  set frame [string index $ar 1]
	  continue
	}
	set fl 0
	if {[string index $ar end] == "'"} {
	  set ar [string range $ar 0 end-1]
	  incr fl
	}
	if {[string index $ar end] == " " } {
	  append m [string range $ar 0 end]
	} elseif { ! [catch {uplevel $frame info exists $ar} ro] &&  $ro } {
	  if {!$fl} {
	    if {[uplevel $frame array exists $ar]} {
	      append m "$ar=<array><"
	    } else {
	      append m "$ar=[uplevel $frame set $ar]< "
	      # append m "[uplevel $frame info level] $frame "
	    }
	  } else {
	    append m "as list $ar="
	    puts "[set m]"
	    uplevel $frame "lh \[set $ar\]"
	    set m "<"
	  }
	} else {
	  append m "$ar=<unset>< "
	  # append m "-$ro- "
	  # append m "[uplevel $frame info level] $frame "
	}
      }
      regsub -all {\n} $m {\\n} m
      regsub -all {\r} $m {\\r} m
      regsub -all {\t} $m {\\t} m

      if {$fmtonly} {
	return $m
      }
      lappend savebuffer $m
      
      switch -exact $saveout {
	1  {return}
	-1 {
	  set savebuffer [list $m]
	  set saveout 0
	}
	0 {}
	default {
	  set savebuffer [lrange $savebuffer end-$saveout end] 
	}
      } 
      foreach ln $savebuffer {
	puts "$ln"
      }
      set savebuffer {}
      if {!$noflush} {
	flush stdout
      }
    }
  } else {
    proc frputs {args} {}
  }
}
# So you don't need to call setupDebug...
after idle "setupDebug 3"

proc lx {l} {
  foreach e $l {
    append r "$l
"
  }
  return $r
}

# here is a little thing to call from tkcon to print lists
# It puts 'co' elements on a line and outputs the result.
proc lh {list {co {1}}} {
  set idx 0
  if {[catch {llength $list} ln]} {
    puts "$list is not a list: $ln"
    return
  }
  while {$idx < $ln} {
    set li {}
    for {set x $co} {$x > 0} {incr x -1; incr idx} {
      lappend li [lindex $list $idx]
    }     
    puts "$li"
  }
}
# And here it is sorted
proc lhs {list {co {1}}} { 
  if {[catch {llength $list} ln]} {
    puts "$list is not a list: $ln"
    return
  }
  lh [lsort {*}[expr {$co == 1 ? {} : "-stride $co"}] $list] $co
}
