# <20240712.1741.57>

# This is a group of helper functions to increase the functionality
# of the filerunner debug package which is built around "frputs".
#
# While this is being developed to aid in filerunner development,
# we make every attempt to make this globally useful.
#
# In general, we will assume that the principle "window" into the
# code is "tkcon". The main implication of this is that we can
# assume that "tk" and all its wonders are available to us.
#
# On to what we do:
#
# frputs can filter it's output to be generated only for given
# enumerated sources (there are other filters we may address later).
# So the first thing we do is build enumerate the possible sources
# the user may want to include. We do this by examining ::auto_path
# for all possible source scripts. We only add a script to the list
# if it contains a call to "frputs". This, of course, means we need to
# have a look at the script. Since Mr. Heisenberg said we can not look
# without disturbing things, we have to admit that this looking may
# change the code, or how it works, in some way. Still, we will be
# careful, in that we will not load an unloaded script to do our
# looking, but rather, read the file. On the other-hand, if the script
# has already been loaded, we can use "info body" to peek at it,
# which ought to be a smidgen faster.
#

namespace eval ::frputs {
  # frputs "where am i " "s [interp slaves] ns [namespace current] "
  variable SourcesList {}
  variable maxSourceLength 30

  # This routine finds the string length of the longest common prefix
  # of the strings in the passed in list.
  proc lengthPrefix {strings} {
    set len [string length [lindex $strings 0]]
    if {[llength $strings] < 2} {
      return $len
    }
    set cur [lindex $strings 0]
    foreach str [lrange $strings 1 end] {
      while {![string equal -length $len $cur $str]} {
	if {[incr len -1] < 1} {return 0}
      }
    }
    return $len
  }
  
  # This may be useful for other searches, we generalize to look for
  # "what" in "script" such that it is followed by { } or {\\}
  # and preceded by either a \n or  "# ;"
  proc findExString {scriptIn what} {
    # we will assume new-lines break things up.
    # we also assume there is a space on the beginning "frputs"
    upvar $scriptIn script
    
    set len  [string length $script]
    set lenW [string length $what]
    set start 0
    while {[set loc [string first $what $script $start]] != -1} {
      update
      update idletasks
      set start [expr {$loc + 1}]
      set next [string index $script $loc+$lenW]
      if {$next != " " && $next != {\\}} {
	# bogus, ignor
	continue
      }
      set pre [string index $script $loc-1]
      if {[string is alnum $pre]} {continue}
      set lastNL [string last \n $script $loc-1]
      set frag [string trim [string range $script $lastNL+1 $loc-1]]
      set nfrag [string last "#" $frag]
      if {$frag == {} || $nfrag == -1} {return 1}
      if {[string first {;} [string range $frag $nfrag end]] == -1} {return 1}
      # Commented out or some such
    }
    return 0
  }
  # Build a list of sources which have procedures that call frputs...
  # Each entry will be the source file name. ? do we want/need a list
  # of procedures? ?
  
  proc findSources {} {
    variable SourcesList {}
    if {![info exists ::MSW] } {return}
    foreach autoEnt $::auto_path {
      # hopefully we will treat this list the way tcl does, i.e.
      # we look at sub dirs (one level) only if it contains a
      # pkgIndex.tcl file. If we find such, we check each source
      # (i.e. *.tcl) file in that dir.
      # As to the first level, we look for tclIndex and process that.
      foreach subDir [glob -path $autoEnt -nocomplain -types d /*] {
	if {[file exists $subDir/.notwindows] && $::MSW} {continue}
	if {[file exists $subDir/.notunix] && !$::MSW} {continue}
	if {[file exists $subDir/pkgIndex.tcl]} {
	  # frputs autoEnt subDir
	  foreach file [glob -path $subDir -nocomplain /*.tcl] {
	    update
	    update idle
	    set fileC [read [set fl [open $file r]]]
	    close $fl
	    if {[findExString fileC frputs]} {
	      lappend SourcesList $file
	    }
	  }
	}
      }
      # We source the tclIndex file. This builds a local 'auto_index'
      # which we work with...
      unset -nocomplain auto_index
      set dir $autoEnt
      if {[catch {source [file join $dir tclIndex]} oops] != 0} {
	#frputs oops
	continue
      }
      foreach {name script} [array get auto_index] {
	lassign $script where file
	#frputs name where file
	if {$where != "source" }   {continue}
	if {$file in $SourcesList} {continue}
	# an unknown.  
	if {[catch {info body $name} bod] != 0 &&\
		$bod != {} &&\
		![namespace exists $name]} {
	  # not yet in memory, 
	  if {[catch {set bod [read [set fl [open $file r]]]} ] != 0} {
	    continue
	  }
	  close $fl
	}
	if {[findExString bod frputs]} {
	  lappend SourcesList $file
	}
      }
    }
    # Here we clean up the list a tad...
    # First remove bgerror if it is there
    set l [lsearch -glob $SourcesList "*bgerror.tcl"]
    if {$l != -1} {
      set SourcesList [lreplace $SourcesList $l $l]
    }
    # Next we replace any common suffix with "*"
    set pre [lengthPrefix $SourcesList]
    set nl {}
    set ::frputs::maxSourceLength 0
    foreach fl $SourcesList {
      set nfl [string cat "*" [string range  $fl $pre end]]
      set ::frputs::maxSourceLength \
	  [expr {max($::frputs::maxSourceLength,[string length $nfl])}]
      lappend nl $nfl
    }
    set frputs::filePre $pre
    set SourcesList [lsort -unique $nl]
  }
  # This routine writes a file into the users home dir containing
  # the current options set for fr. This file is setup so that sourcing
  # it will restore those options. The intent is to source this as
  # part of bringing up tkcon, thus restoring the state when the file
  # was last written.

  proc writeFrBackup {} {
    # we build the file name from the argv0 variable in an attempt to
    # allow this to be used elsewhere (than fr)
    set fileName ~/[file tail $::argv0]FrVars.tcl
    set fid [open $fileName w]
    puts $fid "# This is the frputs state backup file."
    puts $fid "# Written [clock format [clock seconds] -format %+]"
    foreach val {sources nsources procedures nprocs monitor wvars ops timeStamp} {
      set valx "::frputs::$val"
      set op [string index $val 0]
      if {$op == "n"} {
	set op "~[string index $val 1]"
      }
      if {$val ni {monitor timeStamp}} {
	append op " --"
      }
      if {[set $valx] != {}} {
	puts $fid [list frputsOps {*}$op {*}[set $valx]]
      }
    }
    close $fid
  }

  proc getSavedFile {} {
    set fileName ~/[file tail $::argv0]FrVars.tcl
    if {[catch {source $fileName} out] != 0} {
      puts "File $fileName threw error: $out"
    }
  }

  # clear resets to normal start state...
  proc clear {} {
    foreach op {sources ~sources procedures ~procedures wvars} {
      frputsOps $op --
    }
    foreach op $::frputs::monitor {
      frputsOps monitor -$op
    }
    frputsOps ops -- proc line
    frputsOps time 0
  }

  proc help {} {
    destroy .frputshelp
    set hw [toplevel .frputshelp]
    wm title $hw "frputs helper help window"
        set ::frputs::configHelperhelp {}
    if {[winfo exists .tkcon.tab1]} {
      foreach opt {-background -foreground\
		       -selectforeground -selectbackground\
		       -font} {
	lappend  ::frputs::configHelperhelp $opt [.tkcon.tab1 cget $opt]
      }
    }
    set hm $hw.stat
    set r [smart_dialog $hm $hw "Status" \
	       $::frputs::theWord\
	       -1 1\
	       [list\
		    [list {OK} [list -command [list destroy .frputshelp]]]]]
    
    $hm.0 config -width [expr {$::frputs::maxSourceLength * 2}]
    grid $hm -row 0 -sticky ewns -column 0 -columnspan 10
    grid columnconfigure $hw all -weight 1
    grid rowconfigure $hw all -weight 1
  }
  
  # This bit of code provides a read only textvariable by defining a
  # shadow variable. We then do write traces on each and on each
  # trace trigger, refresh the shadow.
  proc sVar {var} {
    set ${var}shad [set $var]
    if {[trace info variable $var] == {}} {
      #frputs "?[trace info variable $var] " var
      trace add variable $var write frputs::shadow
    }
    if {[trace info variable ${var}shad] == {}} {
      trace add variable ${var}shad write frputs::shadow
    }
    return ${var}shad
  }
  proc shadow {var el op} {
    # frputs var
    if {[string range $var end-3 end] == "shad"} {
      set var [string replace $var end-3 end]
    }
    trace remove variable $var write frputs::shadow
    sVar $var
  }
    
  # Here we build a window through which we hope to select things
  # to monitor. We want to be able to dismiss the window when it
  # is not in use, and recover it again when desired.
  proc buildWindow {} {
    variable mw 
    # This code should be called only once (on start up)
    # It builds the root window and sets it up with the bits
    # and pieces
    set mw [toplevel .frputswindow -class Dialog]
    wm title $mw "frputs helper window"
    wm iconname $mw "frputs"
    wm protocol $mw WM_DELETE_WINDOW \
	[list [namespace current]::hideWindow]
    # use tkcon colors and font if we can find them
    set ::frputs::configHelper {}
    if {[winfo exists .tkcon.tab1]} {
      foreach opt {-background -foreground\
		       -selectforeground -selectbackground\
		       -font} {
	lappend  ::frputs::configHelper $opt [.tkcon.tab1 cget $opt]
      }
      set sbmaster .tkcon.tab1
    } else {
      set sbmaster .
    }
    #bind $mw <Destroy> [list [namespace current]::hideWindow]
    # The status widget
    set sm $mw.status
    # frputs sm
    set r [smart_dialog $sm $sbmaster "Status" \
	       {}\
	       -1 14 \
	       [list \
		    [list {sources}            [list -textvariable ::frputs::sources \
						    {*}$frputs::configHelper]]\
		    [list {except sources}     [list -textvariable ::frputs::nsources\
						    {*}$frputs::configHelper]]\
		    [list {procedures}              [list -textvariable ::frputs::procs\
						    {*}$frputs::configHelper]]\
		    [list {except procedures}       [list -textvariable ::frputs::nprocs\
						    {*}$frputs::configHelper]]\
		    [list {monitor}            [list -textvariable\
						    [sVar ::frputs::monitor]\
						    {*}$frputs::configHelper]]\
		    [list {write trace}        [list -textvariable [sVar ::frputs::wvars]\
						    {*}$frputs::configHelper]]\
		    [list {report ops}         [list -textvariable ::frputs::ops \
						    {*}$frputs::configHelper]]\
		    [list {timestamp}          [list -textvariable ::frputs::timeStamp\
						    {*}$frputs::configHelper]]\
		    [list {debug On}           [list -textvariable ::frputs::on\
						    {*}$frputs::configHelper]]\
		    [list {Save State}         [list -command ::frputs::writeFrBackup]]\
		    [list {Recall State}       [list -command ::frputs::getSavedFile]]\
		    [list {Reset}              [list -command ::frputs::clear]]\
		    [list {Help}               [list -command ::frputs::help]]\
		    [list {OK}                 [list -command ::frputs::hideWindow]]\
		    ]\
	       [list scroll 10]\
	       [list -selectforeground red]\
	       $::frputs::configHelper\
	      ]

    grid $sm -row 0 -sticky ewns -column 0 -columnspan 10
    grid columnconfigure $mw all -weight 1
    grid rowconfigure $mw all -weight 1
    
    bind $sm.0 <Double-Button-1> [list frputs::doSources a {} %W]
    bind $sm.1 <Double-Button-1> [list frputs::doSources a n %W]
    bind $sm.2 <Double-Button-1> [list frputs::doProcs   a {} %W]
    bind $sm.3 <Double-Button-1> [list frputs::doProcs   a n %W]
    bind $sm.4 <Double-Button-1> [list frputs::doMonitor a  %W]
    bind $sm.5 <Double-Button-1> [list frputs::doTrace   a  %W]
    bind $sm.6 <Double-Button-1> [list frputs::doOps     a  %W]
    bind $sm.7 <1> [list frputs::toggle frputs::timeStamp]
    bind $sm.8 <1> [list frputs::toggle frputs::on]
    bind $sm.0 <3> [list frputs::doSources r {} %W]
    bind $sm.1 <3> [list frputs::doSources r  n %W]
    bind $sm.2 <3> [list frputs::doProcs   r {} %W]
    bind $sm.3 <3> [list frputs::doProcs   r  n %W]
    bind $sm.4 <3> [list frputs::doMonitor r %W]
    bind $sm.5 <3> [list frputs::doTrace   r %W]
    bind $sm.6 <3> [list frputs::doOps     r %W ]
    bind $sm.7 <3> [list frputs::toggle frputs::timeStamp]
    bind $sm.8 <3> [list frputs::toggle frputs::on]

    realWaitForIdle
    set geoW [lindex  [split [winfo geo $sbmaster] x] 0]
    set top [winfo top $sm]
    frputs top geoW sbmaster sm "[wm geo $top] "
    wm geo $top ${geoW}x[winfo reqheight $top]

    centerWin $top $sbmaster

    
  }
  proc toggle {what} {
    # frputs
    set $what [expr {![set $what]}]
    if {$what == "frputs::on"} {
      setupDebug $frputs::on
    }
    return
  }
  proc hideWindow {} {
    variable mw
    destroy  .frputs_dialog
    frputs $mw.status "[winfo exists $mw.status] "
    destroy $mw.status
    destroy $mw
    destroy .frputshelp
    #wm iconify $mw
  }
  proc showWindow {} {
    variable mw
    # variable SourcesList
    if {![info exists mw] || ![winfo exist $mw]} {
      buildWindow
    }
    raise $mw
    if {[winfo exists .tkcon]} {
      centerWin $mw .tkcon
      wm transient $mw .tkcon
    }
    wm deiconify $mw
    # set SourcesList {}
    # after 200 frputs::findSources
  }
  # This is a real hack, but the way the combobox is defined
  # there is not much choice. The window seems to be created
  # by the Post call...
  
  # proc dropIt {w} {
  #   ttk::combobox::Post $w
  #   after 40 [list $w.popdown.f.l config {*}$::frputs::configHelper]
  # }

  proc dropIt {w} {
    $w open
  }
  # This eliminates the dropdown menu and all the other stuff
  # It needs to first allow the -command (what invoked it) to
  # finish, thus the 'after'.
  proc done {args} {
    after 1 "destroy .frputs_dialog"
  }
  
  proc ask {quest list what ar w} {
    variable mw
    variable SourcesList
    variable ans
    
    while {![info exists SourcesList]} {
      waitForIdle
    }
    
    set ans {}
    frputs frputs::$list
    if {$list == {} || [set ::frputs::$list] == {}} {
      set but [list {} [list -textvariable ::frputs::ans\
                            -width $::frputs::maxSourceLength\
			    {*}$::frputs::configHelper\
			    ]]
      set binPopDown {}
    } else {
      set but [list {} [list -values [set ::frputs::[set list]] \
 			    -textvariable ::frputs::ans\
                            -command ::frputs::done\
			    -width $::frputs::maxSourceLength\
			   ]]
      set binPopDown [list bind \
			  [list .frputs_dialog.0 <Enter> \
			       [list frputs::dropIt .frputs_dialog.0]]]
    }
    frputs ar frputs::$list
    if {$ar != "a" && [set ::frputs::$list] == {}} {
      append quest " -- NOTHING TO REMOVE!"
      set but [list {OK}]
    }
    # frputs but quest
    set r [smart_dialog .frputs_dialog $w "Modify"\
	       [list $quest]\
	       -1 1\
	       [list  \
		    $but\
		   ]\
	       $binPopDown\
 	       $::frputs::configHelper\
	      ]
    set fixWhat [expr {[string index $what 0] == "n" ?\
                           [string replace $what 0 0 "~"] : $what}]
    frputs r ar what frputs::ans
    if {$ar == "a" && $ans != {} && $ans ni [set ::frputs::$what]} {
      frputsOps $fixWhat $ans
      frputs ::frputs::$what
      return
    } elseif {$ar != "a" && $ans != {}} {
      set l [lsearch -exact [set frputs::$what] $ans]
      if {$l < 0} {
  	puts "?? couldn't find $ans in [set frputs::$what]"
      } else {
	frputs what ans
	frputsOps $fixWhat -$ans
	return
      }
    }
    return
  }
  
  proc doSources {ar which w} {
    set slist [expr {$ar == "a" ? "SourcesList" : "${which}sources"}]
    set subList [expr {$which == "n" ? "don't " : ""}]
    set quest [expr {$ar == "a" ? \
  			 "Add to ${subList}monitor sources" : \
  			 "Remove from ${subList}monitored sources"}]
    frputs slist 
    ask $quest $slist ${which}sources $ar $w
    return -code break
  }
  proc doProcs   {ar which w} {
    set subList [expr {$which == "n" ? "don't " : ""}]
    set quest [expr {$ar == "a" ? \
  			 "Add to ${subList}monitor procedures" : \
  			 "Remove from ${subList}monitor procedures"}]
    set slist [expr {$ar == "a" ? "" : "${which}procs"}]
    ask $quest $slist ${which}procs $ar $w
    return -code break
    
  }
  proc doMonitor {ar w} {
    set slist [expr {$ar == "a" ? "" : "monitor"}]
    set quest [expr {$ar == "a" ? \
  			 "Add to monitored commands" : \
  			 "Remove from monitor commands"}]
    ask $quest $slist monitor $ar $w
    return -code break
  }
  proc doTrace   {ar w} {
    set slist [expr {$ar == "a" ? "" : "wvars"}]
    set quest [expr {$ar == "a" ? \
  			 "Add to write trace list" : \
  			 "Remove from write trace list"}]
    ask $quest $slist wvars $ar $w
    return -code break
  }
  proc doOps {ar w} {
    set ::frputs::infoOps [list proc line type file cmd lambda level]
    set slist [expr {$ar == "a" ? "infoOps" : "ops"}]
    set quest [expr {$ar == "a" ? \
  			 "Add to report ops" : \
  			 "Remove report op"}]
    ask $quest $slist ops $ar $w
    return -code break
  }
  proc setup_frputsHelp {count} {
    # We are already sourced, now we need to wiggle our way into
    # the <3> menu for tkcon..
    after 200 frputs::findSources
    if {[catch {lassign [bind .tkcon.tab1 <3>] fun w}] == 0 &&\
	    [ winfo exists $w]} {
    } elseif {[catch {winfo exists [set w $::tkcon::PRIV(popup)]}] == 0} {
    } else {
      if {[incr count] < 50} {
	after 50 [list frputs::setup_frputsHelp $count]
      } else {
	puts "Failed to add frputs-help to <3> tkcon menu"
      }
      return
    }    
    set index 0
    while {[incr index] <= [$w index end]} {
      if {[$w entrycget $index -label] == "frputs help"} {
	# Log "already in memu"
	# already in the menu
	return
      }
    }
    if {[catch [list $w add command\
		    -label "frputs help"\
		    -command frputs::showWindow] wh ] == 0} {
      return
    }
  }
}

# after 50 [list frputs::setup_frputsHelp 1]
::frputs::setup_frputsHelp 1

set ::frputs::theWord [list\
{This\
     window is a 'help' window for 'frputs' debug command and to the\
     'frputs help'sub-window for tkcon (referred to below as 'the parent GUI').\
     The intent of 'frputs' is to provide an intelligent\
     replacement for 'puts'. Over time it has developed to this interface\
     and these features it makes easily accessible.
}\
{How to use:
}\
{Put calls to 'frputs' in your code at locations you think might\
     help you figure out what is going on. See 'Syntax for frputs lines' below.
}\
{Other useful info:
}\
{'frputs' proceeds each line of output with information from the\
     'info frame' command. By default the 'proc' name and 'line' number\
     of the 'frputs' call are included, however, all of the frame info is\
     available. (This is accessed and controlled with the 'report ops' line\
     in the parent GUI.) For the seekers: you can also chose which frame to look at,\
     but that is done in the 'frputs' call itself,(See Syntax for frputs lines: below)\
     not with this GUI.
}\
{The filtering:
}\
    {Turning off 'frputs' ('debug On' set to 0 in the parent GUI)\
	 produces nothing, in fact, usually 'frputs'\
     redefines itself to an empty command. In addition you can control\
     which sources and/or 'procedures' will be included in the output. This is\
      controlled by the first 4 entries in the parent GUI.
}\
{The rules:
}\
{If the call comes from one of the entries in an 'except' list, it is\
     not reported. If there are entries in either the 'source' or 'proc'\
     list, one of them must match or the call is not reported. If these\
     lists are both empty, all calls are reported (save calls from 'execpt'\
     source or proc lists).
}\
{Monitor entries:
}\
{Commands can be monitored. If a command name is in the 'monitor' list\
     'frputs' reports where it is called from and what its return value is.
Variable writes can be traced, just put the variables name in the 'write trace'\
     list.
Timestamp, if on, causes 'frputs' to add a timestamp to each line.
}\
{Using the GUI:
}\
{Mouse <Double-1> on an entry brings up a 'combobox' which will offer a\
     drop down of some possible entries (source & except source) offers\
     sources. You can always override the suggestions. Mouse <3> is used\
     to remove entries.\
  You can dismiss the GUI (OK or upper right corner) and recall it when needed.
}\
{Syntax for frputs lines:
}\
{A bare word is taken as a variable and its value is printed preceded by "="\
     and followed by "<". If the variable is an array <array> is printed instead\
     of its value. If the word ends in "'" the "'" is removed and the value,\
     taken as a list, is printed one list entry per line.

"#n" where "n" is a single digit, prints "report ops" values from level "n". The caller\
     is at level 1, his caller at level 2 and so forth. There may be more than one\
     "#n" but they must all be before anything else in the line. This also turns off\
     source and proc filtering. Variables are evaluated at level 1 (except see "@n").\

"@n" Changes the level used to evaluate the following variables at level "n". The "@n"\
     itself is put in the line to make it easier to understand the output.

     A string ending in " " is copied to the output line (e.g. "[array get foo] ")

     In the event that the frputs "flush" time is interfering with the execution:
  
     "!"    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.
     "!!-n" where <n> is a number, flushes the last <n> lines but retains all
     "!!-0" clears the saved lines without flushing them

All tabs, carriage returns and line feeds are replaced by \t, \r or \n}
  
  
]
set ok "ok" 
