Eskil

# Tools
NAGELFAR    = nagelfar

all: setup

SRCFILES = src/eskil.tcl src/clip.tcl src/dirdiff.tcl src/help.tcl src/map.tcl \
	   src/print.tcl src/registry.tcl src/rev.tcl \
	   src/compare.tcl src/merge.tcl src/printobj.tcl src/plugin.tcl \
           src/vcsvfs.tcl src/preprocess.tcl src/startup.tcl src/fourway.tcl

#----------------------------------------------------------------
# Build a dependency tree to other libs needed.
# This is made in a parallell VFS structure, mimicking Eskil's.
# Thus deps.vfs can also be created by downloading an Eskil kit,

spell:
	@cat doc/*.txt | ispell -d british -l | sort -u

CHKFILES = $(SRCFILES) $(wildcard plugins/*.tcl) \
	eskil.vfs/lib/psmenu-1.1.tm \
	eskil.vfs/lib/pstools-1.0.tm \
	eskil.vfs/lib/psdebug-1.0.tm \
	eskil.vfs/lib/psballoon-1.3.tm
NAGELFARFLAGS = -s syntaxdb.tcl -pkgpicky -filter "*Non constant definition*" -quiet -plugin nfplugin.tcl

# Create a common "header" file for all source files.
eskil_h.syntax: $(SRCFILES) src/eskil.syntax nfplugin.tcl
	@echo Creating syntax header file...
	@$(NAGELFAR) $(NAGELFARFLAGS) -header eskil_h.syntax $(SRCFILES)

#---------------------------------------------------------*-tcl-*------
#
#  psdebug.tcl,
#     Helpers for debugging.
#
#  Copyright (c) 2024, Peter Spjuth  (peter.spjuth@gmail.com)
#
#  Permission is granted to use this code under the same terms as
#  for the Tcl core code.
#
#----------------------------------------------------------------------
#  This is used as a Tcl Module. Use it like this:
#  ::tcl::tm::path add <path-to-dir-with-module>
#  package require psdebug
#  namespace import ::_PsDebug::*
#----------------------------------------------------------------------

package provide psdebug 1.0

namespace eval ::_PsDebug {
    variable allcmds
    namespace export debugMenu
}

#-----------------------------------------------------------------------------
# Misc useful stuff
#-----------------------------------------------------------------------------

proc ::_PsDebug::dumpMyMemUsage {str} {
    try {
        set xx [exec ps --pid [pid] --format vsize]
        set mem 0
        regexp {\d+} $xx mem
        puts "$str : memory usage $mem"
    } on error {} {
        puts "$str : memory usage unknown, call to ps failed"
    }
}

#-----------------------------------------------------------------------------
# Tracing
#-----------------------------------------------------------------------------

proc ::_PsDebug::TRenter {cmd op} {
    set fr [info frame -2]
    set line X
    if {[dict exists $fr line]} {
        set line [dict get $fr line]
    }
    puts "Line $line Enter: '$cmd'"
}
proc ::_PsDebug::TRenterstep {cmd op} {
    set fr [info frame -2]
    set line X
    if {[dict exists $fr line]} {
        set line [dict get $fr line]
    }
    puts "Line $line  Enterstep: '$cmd'"
}
proc ::_PsDebug::TRleave {cmd code res op} {
    puts "Leave: '$res'"
}
proc ::_PsDebug::TRleavestep {cmd code res op} {
    puts "Leavestep: '$res'"
}
proc ::_PsDebug::TR {cmd {step 0}} {
    TRoff $cmd
    trace add execution $cmd enter ::_PsDebug::TRenter
    trace add execution $cmd leave ::_PsDebug::TRleave
    if {$step} {
        trace add execution $cmd enterstep ::_PsDebug::TRenterstep
        trace add execution $cmd leavestep ::_PsDebug::TRleavestep
    }
}
proc ::_PsDebug::TRoff {cmd} {
    trace remove execution $cmd enter ::_PsDebug::TRenter
    trace remove execution $cmd leave ::_PsDebug::TRleave
    trace remove execution $cmd enterstep ::_PsDebug::TRenterstep
    trace remove execution $cmd leavestep ::_PsDebug::TRleavestep
}

#-----------------------------------------------------------------------------
# GUI
#-----------------------------------------------------------------------------

proc ::_PsDebug::debugMenu {mW} {
    $mW add cascade -label "Debug" -menu $mW.debug -underline 0
    menu $mW.debug

    if {$::tcl_platform(platform) eq "windows"} {
        $mW.debug add checkbutton -label "Console" -variable ::consoleState \
                -onvalue show -offvalue hide -command {console $::consoleState} \
                -underline 0
        $mW.debug add separator
    }

    $mW.debug add command -label "Edit" -command ::_PsDebug::ProcEditor \
            -underline 0
    $mW.debug add command -label "Windows" -command ::_PsDebug::WindowBrowser \
            -underline 0
    #after 500 ::_PsDebug::DumpStuff
    #after 500 ::_PsDebug::ProcEditor
    return $mW.debug
}

#-----------------------------------------------------------------------------
# Window structure browser
#-----------------------------------------------------------------------------
proc ::_PsDebug::WindowBrowser {} {
    set top .windowbrowser
    destroy $top
    ttk::toplevel $top -padx 3 -pady 3
    wm title $top "Window Browser"
    wm protocol $top WM_DELETE_WINDOW [list ::_PsDebug::WindowBrowserClosed $top]

    ttk::panedwindow $top.pw -orient horizontal
    pack $top.pw -fill both -expand 1
    
    # Widget Tree
    ttk::frame $top.ftree
    set tree $top.ftree.tree
    ttk::treeview $tree -height 20 -selectmode browse -show "tree" \
            -yscrollcommand "$top.ftree.sby set"
    ttk::scrollbar $top.ftree.sby -orient vertical -command "$tree yview"
    $tree column "#0" -minwidth 50 -width 200

    pack $top.ftree.sby -side right -fill y -pady 3 -padx {0 3}
    pack $tree -fill both -expand 1 -pady 3 -padx {3 0}

    # Info Text
    text $top.t -width 80 -wrap word

    set ::_PsDebug::WindowBrowser(treeW) $tree
    set ::_PsDebug::WindowBrowser(textW) $top.t
    bind $tree <<TreeviewSelect>> ::_PsDebug::WindowBrowserSelected

    $top.pw add $top.ftree -weight 1
    $top.pw add $top.t    -weight 2

    set ::_PsDebug::WindowBrowser(deselect) ""
    PopulateWindowBrowser $tree
}

proc ::_PsDebug::WindowBrowserClosed {top} {
    destroy $top
    if {$::_PsDebug::WindowBrowser(deselect) ne ""} {
        {*}$::_PsDebug::WindowBrowser(deselect)
        set ::_PsDebug::WindowBrowser(deselect) ""
    }
}

# An item was selected. Show info
proc ::_PsDebug::WindowBrowserSelected {} {
    $::_PsDebug::WindowBrowser(textW) delete 1.0 end
    if {$::_PsDebug::WindowBrowser(deselect) ne ""} {
        #puts "DESEL: $::_PsDebug::WindowBrowser(deselect)"
        {*}$::_PsDebug::WindowBrowser(deselect)
        set ::_PsDebug::WindowBrowser(deselect) ""
    }
    set tree $::_PsDebug::WindowBrowser(treeW)
    set items [$tree selection]
    if {[llength $items] < 1} return
    set item [lindex $items 0]
    set values [$tree item $item -values]
    set d [lindex $values 0]
    set txt [dict get $d out]
    $::_PsDebug::WindowBrowser(textW) insert end $txt

    set interp [dict get $d interp]
    set i [list interp eval $interp]
    set w [dict get $d w]

    # A few experiments to highlight selection.
    try {

            append cleancmd [list destroy $whl($t)]\;
            frame $whl($t) -background red
        }
        place $whl(1) -x $wx -y $wy -width $ww -height 3
        place $whl(2) -x $wx -y $wy -width 3   -height $wh
        place $whl(3) -x [+ $wx $ww] -y $wy -width 3 -height $wh
        place $whl(4) -x $wx -y [+ $wy $wh] -width $ww   -height 3
        set ::_PsDebug::WindowBrowser(deselect) \
                [list eval $cleancmd]
        return
    } on error {err info} {
        #puts "In $interp"
        #puts "$err"
        #puts "$info"
    }

    try {
        # Reconfiguring class. Does not work with disabled buttons e.g.
        set class [{*}$i winfo class $w]
        set oldstyle [{*}$i $w cget -style]
        if {$oldstyle eq ""} {
            set basestyle $class
        } else {
            set basestyle $oldstyle
        }
        set style HighLightRed.$basestyle
        {*}$i ttk::style configure $style -background red -fieldbackground red
        {*}$i $w configure -style $style
        set ::_PsDebug::WindowBrowser(deselect) \
                [list {*}$i [list $w configure -style $oldstyle]]
        #puts "CLASS $class STYLE $style"
        #puts [{*}$i ttk::style configure $basestyle]
        #puts [{*}$i ttk::style configure $style]
        return
    } on error {err info} {
        #puts "In $interp"
        #puts "$err"
        #puts "$info"
    }
    try {
        # Tk style background change. Only works with Tk.
        set bg [{*}$i $w cget -background]
        {*}$i $w configure -background red
        set ::_PsDebug::WindowBrowser(deselect) \
                [list {*}$i [list $w configure -background $bg]]
        return
    } on error {err info} {
        #puts "In $interp"
        #puts "$err"
        #puts "$info"
    }
    #puts "MOO $w"
}

# Format configure data from a widget for display
proc ::_PsDebug::FormatConfigure {configData} {
    set first ""
    set last ""
    foreach param $configData {
        lassign $param flag _ _ def value
        if {$value ne $def} {
            # List changed values first
            append first "[list $flag $value] "

    if {$last ne ""} {
        append first "Default Parameters:\n" $last
    }
    return [string trim $first]
}

# Populate
proc ::_PsDebug::PopulateWindowBrowser {tree} {
    $tree delete [$tree children {}]
    set todo [list . {}]
    # Outer loop for subinterps TBD
    while {[llength $todo] > 0} {
        set containers {}
        while {[llength $todo] > 0} {
            # POP

}

#-----------------------------------------------------------------------------
# Procedure/method editor
#-----------------------------------------------------------------------------

# An item was selected. Show it and make it editable.
proc ::_PsDebug::ProcEditorSelected {} {
    variable allcmds

    set ::_PsDebug::ProcEditor(current) ""
    set ::_PsDebug::ProcEditor(parent) ""
    set ::_PsDebug::ProcEditor(proc) ""
    set ::_PsDebug::ProcEditor(args) ""
    $::_PsDebug::ProcEditor(bodyW) delete 1.0 end

    set tree $::_PsDebug::ProcEditor(treeW)
    set items [$tree selection]
    if {[llength $items] < 1} return
    set item [lindex $items 0]
    set d $allcmds($item)
    set type [dict get $d type]
    set parent [dict get $d parent]
    set name [dict get $d name]

    set ::_PsDebug::ProcEditor(current) $item
    set ::_PsDebug::ProcEditor(parent) $parent
    set ::_PsDebug::ProcEditor(proc) $name
    set ::_PsDebug::ProcEditor(args) ""
    $::_PsDebug::ProcEditor(bodyW) delete 1.0 end

    set traceState normal
    if {$type eq "proc"} {
        set arglist {}
        foreach i [info args $item] {
            if {[info default $item $i value]} {
                lappend arglist [list $i $value]
            } else {
                lappend arglist [list $i]
            }
        }
        set body [info body $item]
        set ::_PsDebug::ProcEditor(args) $arglist
        $::_PsDebug::ProcEditor(bodyW) insert end $body
    } elseif {$type eq "method"} {
        lassign [info class definition $parent $name] arglist body
        set traceState disabled
        set ::_PsDebug::ProcEditor(args) $arglist
        $::_PsDebug::ProcEditor(bodyW) insert end $body
    } else {
        set traceState disabled
    }
    foreach w $::_PsDebug::ProcEditor(traceWs) {
        $w configure -state $traceState
    }

}

# Redefine currently edited proc/method
proc ::_PsDebug::ProcEditorRedefine {} {
    variable allcmds
    set body [$::_PsDebug::ProcEditor(bodyW) get 1.0 end]
    set body [string trimright $body]

    set item $::_PsDebug::ProcEditor(current)
    set d $allcmds($item)
    set type [dict get $d type]
    set parent [dict get $d parent]
    set name [dict get $d name]

    if {$type eq "proc"} {
        set todo [list proc $item \
                          $::_PsDebug::ProcEditor(args) $body]
        set ::_PsDebug::redefines($item) $todo
        uplevel \#0 $todo
    } elseif {$type eq "method"} {
        set todo [list oo::define $parent method $name \
                          $::_PsDebug::ProcEditor(args) $body]
        set ::_PsDebug::redefines($parent..$name) $todo
        uplevel \#0 $todo
    }
}

proc ::_PsDebug::ProcEditorCopy {} {
    clipboard clear
    foreach item [array names ::_PsDebug::redefines] {
        clipboard append $::_PsDebug::redefines($item)\n
    }
}

# Tracing of commands
proc ::_PsDebug::ProcEditorTrace {level} {
    variable allcmds
    set item $::_PsDebug::ProcEditor(current)
    set d $allcmds($item)
    set type [dict get $d type]
    set parent [dict get $d parent]
    set name [dict get $d name]
    if {$type ni "proc method"} return

    # TODO: methods
    if {$type eq "proc"} {
        if {$level == 1} {
            TR $item
        } elseif {$level == 2} {
            TR $item 1
        } else {
            TRoff $item
        }
    }
}

# Disassemble of current
proc ::_PsDebug::ProcEditorDisas {} {
    variable allcmds
    set item $::_PsDebug::ProcEditor(current)
    set d $allcmds($item)
    set type [dict get $d type]
    set parent [dict get $d parent]
    set name [dict get $d name]
    if {$type ni "proc method"} return

    if {$type eq "proc"} {

    grid columnconfigure $top 0 -weight 1
    grid rowconfigure    $top 0 -weight 1

    $top.t insert end $da
}

# Treeview filtering. React on keystroke
proc ::_PsDebug::ProcEditorFilter {aVal kVal} {
    set f $::_PsDebug::ProcEditor(filter)
    set fx $::_PsDebug::ProcEditor(filterx)
    # Do not react unless changed.
    if {$f eq $fx} {
        return
    }
    set tree $::_PsDebug::ProcEditor(treeW)

    # Recreate the tree.
    # This is easier since the treeview does not have an item hide attribute.
    set pat *$f*
    TreePopulate $tree $pat
    set ::_PsDebug::ProcEditor(filterx) $f
}

# Make sure the hierarchy for a leaf exist, creating if needed.
proc ::_PsDebug::TreeCreatePath {tree path} {
    if {[$tree exists $path]} return
    set d $::_PsDebug::allcmds($path)
    set parent [dict get $d parent]
    if {$path ni {"" ::}} {
        TreeCreatePath $tree $parent
    }
    set text [dict get $d name]
    if {$parent eq "::"} {
        set parent ""
    }

    $tree insert $parent end -id $path -text $text -open 1 \
            -values [list $parent]
}

# Populate the treeview with all known procs and methods
proc ::_PsDebug::TreePopulate {tree {filter *}} {
    $tree delete [$tree children {}]
    foreach cmd [lsort -dictionary [array names ::_PsDebug::allcmds]] {
        set d $::_PsDebug::allcmds($cmd)
        set type [dict get $d type]
        if {$type ni "proc method"} continue
        if { ! [string match -nocase $filter [dict get $d name]]} continue

        set path [dict get $d parent]
        if {$path ne ""} {
            TreeCreatePath $tree $path
        }
        $tree insert $path end -id $cmd \
                -text [dict get $d name] -values [list $path]
    }
}

# Main Proc Editor window
proc ::_PsDebug::ProcEditor {} {
    ::_PsDebug::CollectInfo

    set top .proceditor
    destroy $top
    ttk::toplevel $top -padx 3 -pady 3
    wm title $top "Proc Editor"

    ttk::frame $top.ftree
    set ::_PsDebug::ProcEditor(filter) ""
    set ::_PsDebug::ProcEditor(filterx) ""
    ttk::entry $top.ftree.ef -textvariable ::_PsDebug::ProcEditor(filter)
    addBalloon $top.ftree.ef "Filter"
    bind $top.ftree.ef <KeyRelease> {::_PsDebug::ProcEditorFilter %A %K}
    set tree $top.ftree.tree
    set ::_PsDebug::ProcEditor(treeW) $tree
    ttk::treeview $tree -height 20 -selectmode browse -show "tree" \
            -yscrollcommand "$top.ftree.sby set"
    ttk::scrollbar $top.ftree.sby -orient vertical -command "$tree yview"
    $tree tag configure highlight -background pink
    $tree column "#0" -minwidth 50 -width 200
    pack $top.ftree.ef -side "top" -fill x -padx 3 -pady 3
    pack $top.ftree.sby -side right -fill y -pady 3 -padx {0 3}
    pack $tree -fill both -expand 1 -pady 3 -padx {3 0}
    TreePopulate $tree
    bind $tree <<TreeviewSelect>> ::_PsDebug::ProcEditorSelected

    ttk::label $top.l1a -text "Parent" -anchor w
    ttk::label $top.l1b -textvariable ::_PsDebug::ProcEditor(parent) -anchor w
    ttk::label $top.l2a -text "Proc/Method" -anchor w
    ttk::label $top.l2b -textvariable ::_PsDebug::ProcEditor(proc) -anchor w
    ttk::label $top.l3a -text "Args" -anchor w
    ttk::label $top.l3b -textvariable ::_PsDebug::ProcEditor(args) -anchor w
    ttk::button $top.bc -text "Copy" -command ::_PsDebug::ProcEditorCopy
    addBalloon $top.bc "Put all redefines on clipboard"

    set ::_PsDebug::ProcEditor(bodyW) [text $top.t -yscrollcommand "$top.sby set" \
                                             -width 90]
    ttk::scrollbar $top.sby -orient vertical -command "$top.t yview"

    ttk::frame  $top.fb
    ttk::button $top.b1 -text "Redefine" -command ::_PsDebug::ProcEditorRedefine
    addBalloon $top.b1 "Redefine for this session"
    ttk::button $top.b2 -text "Disas"    -command ::_PsDebug::ProcEditorDisas
    addBalloon $top.b2 "Show byte code"
    ttk::button $top.b3 -text "Trace"    -command "::_PsDebug::ProcEditorTrace 1"
    addBalloon $top.b3 "Enable execution trace"
    ttk::button $top.b4 -text "Tr Step"  -command "::_PsDebug::ProcEditorTrace 2"
    addBalloon $top.b4 "Enable detailed execution trace"
    ttk::button $top.b5 -text "Tr Off"   -command "::_PsDebug::ProcEditorTrace 0"
    addBalloon $top.b5 "Disable execution trace"
    set ::_PsDebug::ProcEditor(traceWs) [list $top.b3 $top.b4 $top.b5]
    grid $top.b1 $top.b2 $top.b3 $top.b4 $top.b5 -in $top.fb
    grid columnconfigure $top.fb all -weight 1 -uniform a

    grid $top.ftree $top.l1a $top.l1b - $top.bc - -padx 3 -pady 3 -sticky news
    grid ^          $top.l2a $top.l2b - -       - -padx 3 -pady 3 -sticky we
    grid ^          $top.l3a $top.l3b - -       - -padx 3 -pady 3 -sticky we
    grid ^          $top.t  -         - -  $top.sby -padx 3 -pady 3 -sticky news

# Conclusion:
# If a namespace is always kept with "::" at the end things are mostly easy.
# "parent" and "children" will work, as well as joining with $parent$tail.
# This cannot be used with "qualifiers", so extra care is needed there.
# The helpers below handles this.

# Parent namespace. Always ends with ::
proc ::_PsDebug::Qualifiers {ns} {
    set ns [string trimright $ns ":"]
    set q [namespace qualifiers $ns]
    if { ! [string match *:: $q]} {
        append q ::
    }
    return $q
}
# Parent namespace. Always ends with ::
proc ::_PsDebug::Parent {ns} {
    set p [namespace parent $ns]
    if { ! [string match *:: $p]} {
        append p ::
    }
    return $p
}

#   type = proc/namespace/class/method/import
#   parent = fullId of parent/class
#   name = leaf name
#   origin = for import

# Collect all info about procedures/method/whatever.
# This is work in progress...
proc ::_PsDebug::CollectInfo {} {
    variable allcmds
    array set allcmds {}

    # Only do this once
    if {[array size allcmds] > 0} return

    # Find all commands in all namespaces
    set todoNs [list ::]
    while {[llength $todoNs] != 0} {
        set nsId [lindex $todoNs 0]
        set todoNs [lrange $todoNs 1 end]

        if {$nsId eq "::_PsDebug::"} continue

        set tail [namespace tail [string trimright $nsId ":"]]
        dict set allcmds($nsId) type   namespace
        dict set allcmds($nsId) parent [Parent $nsId]
        dict set allcmds($nsId) name   ${tail}::

        foreach child [namespace children $nsId] {

            dict set allcmds($id) parent $obj
            dict set allcmds($id) name $m
        }
    }
}

# Debug of debug
proc ::_PsDebug::DumpStuff {} {
    try {
        ::_PsDebug::CollectInfo
    } on error {res i} {
        puts $res
        puts $i
        after 1000
    }

    # Proc
    parray ::_PsDebug::allcmds *updateColors*
    parray ::_PsDebug::allcmds *cleanupAndExit
    # Cmd
    parray ::_PsDebug::allcmds *ttk::paned
    parray ::_PsDebug::allcmds *llength
    # OO class
    parray ::_PsDebug::allcmds *Account*
    # Snit class
    parray ::_PsDebug::allcmds *eskilprint*
    #
    parray ::_PsDebug::allcmds *indexEntry*
    exit
}

#-----------------------------------------------------------------------------
# Test just to include an OO object in the code
#-----------------------------------------------------------------------------
catch {Account destroy}

    package require Tk 8.6-
    catch {package require textSearch}
    package require wcb
    package require snit
    package require tablelist_tile
    package require psmenu
    package require psdebug
    namespace import ::_PsDebug::*

    if {[catch {package require psballoon}]} {
        # Add a dummy if it does not exist.
        proc addBalloon {args} {}
    } else {
        namespace import -force psballoon::addBalloon
    }

    source $srcdir/dirdiff.tcl
    source $srcdir/fourway.tcl
    source $srcdir/help.tcl
    source $srcdir/plugin.tcl
    source $srcdir/printobj.tcl
    source $srcdir/print.tcl
    source $srcdir/rev.tcl


    # Only load vcsvfs if vfs is present
    if { ! [catch {package require vfs}]} {
        source $srcdir/vcsvfs.tcl
    }
}