more scriptlib scripts

scriptlib/2048.tcl

@@ -0,0 +1,575 @@
+#! /usr/bin/env tclsh
+# The game 2048 implemented in Tcl.
+# Version 1.0.0.
+#
+# This code is released under the terms of the MIT license.
+# See the file LICENSE for details.
+#
+# More at:
+# - https://github.com/dbohdan/2048.tcl -- Git repository
+# - https://wiki.tcl-lang.org/40557 -- discussion
+
+package require Tcl 8.6 9
+
+namespace eval 2048 {
+    namespace ensemble create
+    namespace export *
+
+    # Utility procs.
+
+    proc vars args {
+        foreach varname $args {
+            uplevel [list variable $varname]
+        }
+    }
+
+    # Pick a random item from the given list.
+    proc pick list {
+        lindex $list [expr {int(rand() * [llength $list])}]
+    }
+
+    # An abstraction representing the game board. Operates at the level of cells
+    # containing numerical values, not movable game tiles.
+    namespace eval board {
+        namespace ensemble create
+        namespace export *
+
+        variable data {}
+        variable size 0
+
+        # Iterate over every cell of the game board and run $script for each.
+        #
+        # The game board is a 2D matrix of a fixed size that consists of
+        # elements called "cells" that each can contain a number.
+        #
+        # - $cellList is a list of cell indexes (coordinates), which are
+        # themselves lists of two numbers each. They each represent the location
+        # of a given cell on the board.
+        # - $varName1 and $varName2 are the names of the variables that will be
+        # assigned the current cell's indexes when running the script.
+        # - $cellVarName is the name of the variable that at each step will
+        # contain the numerical value of the current cell. Assigning to it
+        # will change the cell's value.
+        # - $script is the script to run.
+        proc forcells {cellList varName1 varName2 cellVarName script} {
+            upvar $varName1 i
+            upvar $varName2 j
+            upvar $cellVarName c
+            foreach cell $cellList {
+                lassign $cell i j
+                set c [get-cell $cell]
+
+                try {
+                    uplevel $script
+                } on ok {res opts} - \
+                  on error {res opts} - \
+                  on break {res opts} - \
+                  on continue {res opts} {
+                    return -options $opts $res
+                } on return {res opts} {
+                    return -options [dict replace $opts -level 2] $res
+                }
+
+                set-cell [list $i $j] $c
+            }
+        }
+
+        # Generate a list of cell indexes for every cell of the board. The order
+        # in which the cell indexes appear depends on the value of
+        # $directionVect. E.g., if $directionVect is {1 1} the list will be
+        # {{0 0} {0 1} ... {0 size-1} {1 0} {1 1} ... {size-1 size-1}}
+        proc indexes {{directionVect {1 1}}} {
+            variable size
+
+            lassign $directionVect delta(i) delta(j)
+            foreach varName {i j} {
+                switch -exact -- $delta($varName) {
+                    1 {
+                        set start($varName) 0
+                        set end($varName)   $size
+                    }
+                    -1 {
+                        set start($varName) [expr {$size - 1}]
+                        set end($varName)   -1
+                    }
+                    default {
+                        error "direction vector must be {?-?1 ?-?1}"
+                    }
+                }
+            }
+
+            set list {}
+            for {set i $start(i)} {$i != $end(i)} {incr i $delta(i)} {
+                for {set j $start(j)} {$j != $end(j)} {incr j $delta(j)} {
+                    lappend list [list $i $j]
+                }
+            }
+            return $list
+        }
+
+        # Check if the list $cell represents a valid pair of cell coordinates.
+        proc valid-cell? cell {
+            variable size
+            lassign $cell i j
+            return [expr {(0 <= $i) && ($i < $size) &&
+                          (0 <= $j) && ($j < $size)}]
+        }
+
+        # Prepare the board for use. Must be called before any other board
+        # procs.
+        proc init boardSize {
+            variable data
+            variable size
+            set size $boardSize
+            for {set i 0} {$i < $size} {incr i} {
+                for {set j 0} {$j < $size} {incr j} {
+                    set-cell [list $i $j] 0
+                }
+            }
+        }
+
+        # Get the value of a game board cell.
+        proc get-cell cell {
+            variable data
+            dict get $data $cell
+        }
+
+        # Set the value of a game board cell.
+        proc set-cell {cell value} {
+            variable data
+            dict set data $cell $value
+        }
+
+        # Filter the list of board cell indexes $cellList to only have those
+        # indexes that correspond to empty board cells.
+        proc empty cellList {
+            set resultList {}
+            foreach cell $cellList {
+                if {[get-cell $cell] == 0} {
+                    lappend resultList $cell
+                }
+            }
+            return $resultList
+        }
+
+        # Pretty-print the board. Specify an index in $highlight to highlight a
+        # cell with a "*" after its contents.
+        proc print {{highlight {-1 -1}}} {
+            forcells [indexes] i j cell {
+                if {$j == 0} {
+                    append res \n
+                }
+                append res [
+                    if {$cell != 0} {
+                        if {($i == [lindex $highlight 0]) &&
+                                ($j == [lindex $highlight 1])} {
+                            format {[%3s*]} $cell
+                        } else {
+                            format {[%4s]} $cell
+                        }
+                    } else {
+                        lindex "......"
+                    }
+                ]
+            }
+            append res \n
+        }
+    } ;# namespace board
+
+    # Game logic.
+    namespace eval game-logic {
+        namespace ensemble create
+        namespace export *
+    }
+
+    # Put a "2" into an empty cell on the board.
+    proc spawn-new-tile {} {
+        set emptyCell [pick [board empty [board indexes]]]
+        if {[llength $emptyCell] > 0} {
+            board set-cell $emptyCell 2
+        }
+        return $emptyCell
+    }
+
+    # If $checkOnly is false try to shift all cells one step in the direction of
+    # $directionVect. If $checkOnly is true just say if that move is possible.
+    proc move-all-tiles {directionVect {checkOnly 0}} {
+        set changedCells 0
+        lassign $directionVect di dj
+
+        # Traverse the board in such a way that those tiles that are closer to
+        # the edges are merged first.
+        set indexDirVect [list \
+                [expr {$di == 0 ? 1 : -$di}] [expr {$dj == 0 ? 1 : -$dj}]]
+        board forcells [board indexes $indexDirVect] i j cell {
+            set newIndex [list [expr {$i +  $di}] [expr {$j +  $dj}]]
+            set removedStar 0
+
+            # For every nonempty source cell and valid destination cell...
+            if {$cell != 0 && [board valid-cell? $newIndex]} {
+                if {[board get-cell $newIndex] == 0} {
+                    # The destination is empty.
+                    if {$checkOnly} {
+                        return true
+                    } else {
+                        # Move the tile to the empty cell.
+                        board set-cell $newIndex $cell
+                        set cell 0
+                        incr changedCells
+                    }
+                } elseif {([board get-cell $newIndex] eq $cell) &&
+                          [string first + $cell] == -1} {
+                    # The destination is the same number as the source.
+                    if {$checkOnly} {
+                        return -level 2 true
+                    } else {
+                        # When merging two tiles into one, mark the new tile
+                        # with the marker of "+" to ensure it doesn't get
+                        # combined again this turn.
+                        board set-cell $newIndex [expr {2 * $cell}]+
+                        set cell 0
+                        incr changedCells
+                    }
+                }
+            }
+        }
+
+        if {$checkOnly} {
+            return false
+        }
+
+        # Remove "changed this turn" markers at the end of the turn.
+        if {$changedCells == 0} {
+            board forcells [board indexes] i j cell {
+                set cell [string trim $cell +]
+            }
+        }
+        return $changedCells
+    }
+
+    # Return the sum of the numbers on all tiles.
+    proc score {} {
+        set score 0
+        board forcells [board indexes] i j cell {
+            incr score $cell
+        }
+        return $score
+    }
+
+    # Is it possible to move any tiles in the direction of $directionVect?
+    proc can-move? directionVect {
+        move-all-tiles $directionVect 1
+    }
+
+    # Check the win condition. The player wins when there is a 2048 tile.
+    proc check-win {} {
+        board forcells [board indexes] i j cell {
+            if {$cell == 2048} {
+                variable output "You win!\n"
+                quit-game 0
+            }
+        }
+    }
+
+    # Check the lose condition. The player loses when the win condition isn't
+    # met and there are no possible moves.
+    proc check-lose possibleMoves {
+        # If not all board cells are empty and no possible moves remain...
+        if {![llength $possibleMoves] &&
+                ([board empty [board indexes]] ne [board indexes])} {
+            variable output "You lose.\n"
+            quit-game 0
+        }
+    }
+
+    # Exit the game with an exit status.
+    proc quit-game status {
+        vars done inputMethod inputModeSaved output playing stty_save turns
+
+        if [info exists output] {
+            puts $output[set output {}]
+
+            # Print the total number of turns played.
+            set turnsMessage [list $turns turn]
+            if {($turns % 10 != 1) || ($turns % 100 == 11)} {
+                append turnsMessage s
+            }
+            puts "$turnsMessage. [score] points."
+        }
+
+        switch $inputMethod {
+            twapi {
+                twapi::modify_console_input_mode stdin {*}$inputModeSaved
+            }
+            raw {
+                if {$inputModeSaved ne {}} {
+                    exec stty $inputModeSaved 2>@stderr
+                }
+            }
+        }
+        set done $status
+        exit $status
+    }
+
+    # Event-driven input. Called when the player pressed a key.
+    proc input {} {
+        vars inputMethod output playing
+        variable playerInput [read stdin 1]
+        if {[set charcode [scan $playerInput %c]] in [list 10 {}]} {
+            if {$charcode eq 10 && $inputMethod ne {}} {
+                #this only happens in raw/twapi mode.  add a newline to stdout
+                append output \n
+            }
+            set playerInput {}
+        }
+        after cancel $playing
+        play-user
+    }
+
+    # Process the user input at the start of the game or during play.
+    proc play-user {} {
+        vars controls inputMethod output playerInput playerMove \
+            playType possibleMoves preferences size
+
+        if {!$size} {
+            # The game is starting.
+            set size $playerInput
+            # Handle zero, one and non-digit input.
+            if {$size eq "q"} {
+                quit-game 0
+            }
+            if {![string is digit $size] || $size == 1} {
+                set size 0
+            }
+            if {$size == 0} {
+                return
+            }
+            # Choose the default size on <enter>.
+            if {$size eq {}} {
+                set size 4
+            }
+            # Generate an empty board of a given size.
+            board init $size
+
+            after idle [namespace code start-turn]
+            return
+        }
+
+        switch [scan $playerInput %c] {
+            3 {
+                if {$playType eq {random}} {
+                    set playType user
+                } else {
+                    quit-game 0
+                }
+            }
+        }
+        if {[dict exists $preferences $playerInput]} {
+            switch $playerInput {
+                q {
+                    quit-game 0
+                }
+                r {
+                    set playType random
+                    after idle [namespace code {play-random 0}]
+                    return
+                }
+                R {
+                    set playType random
+                    after idle [namespace code {play-random 1}]
+                    return
+                }
+                s {
+                    append output "Score: [score]\n"
+                }
+                ? {
+                    proc print-msg dictionary {
+                        upvar 1 output output
+                        foreach {key message} $dictionary {
+                            append output "$key: $message\n"
+                        }
+                    }
+                    append output \
+                            "[join [dict keys $controls] {, }]: movement\n"
+                    print-msg $preferences
+                }
+            }
+        } elseif {$playerInput in $possibleMoves} {
+            set playerMove [dict get $controls $playerInput]
+        }
+        complete-turn
+    }
+
+    # Set the user input to a random possible move.
+    proc play-random {continuous} {
+        vars controls playing playerInput possibleMoves
+        variable delay 1000
+        set playerInput [pick $possibleMoves]
+        play-user
+        if {$continuous} {
+            set playing [after $delay [namespace code {play-random 1}]]
+        }
+    }
+
+    # Apply the player's move, if any, and increment the turn counter.
+    proc complete-turn {} {
+        vars playerMove turns
+        if {$playerMove eq {}} {
+            flush stdout
+            start-turn 0
+        } else {
+            incr turns
+            # Apply the current move until no changes occur on the board.
+            while true {
+                if {[move-all-tiles $playerMove] == 0} break
+            }
+            start-turn
+        }
+    }
+
+    # Render board, find possible moves, add new tile, check win/lose.
+    proc start-turn {{makeNewTile 1}} {
+        vars controls inputMethod output ingame newTile
+        variable playerMove {}
+        variable possibleMoves {}
+        # Buffer the output to speed up the rending on slower terminals.
+        if {!$ingame} {
+            puts {Press "?" at any time after entering the board size for help.}
+            puts {Press "q" to quit.}
+            puts {Select board size (4)}
+            set ingame 1
+            return
+        }
+
+        switch $inputMethod {
+            twapi {
+                twapi::clear_console stdout
+                twapi::set_console_cursor_position stdout {0 0}
+            }
+            raw {
+                ::term::ansi::send::clear
+            }
+        }
+
+        # Add a new tile to the board and print the board highlighting that
+        # tile.
+        if {$makeNewTile} {
+            set newTile [spawn-new-tile]
+        } elseif {![info exists newTile]} {
+            set newTile {}
+        }
+        append output \n[board print {*}[list $newTile]]
+        check-win
+
+        # Find the possible moves.
+        foreach {button vector} $controls {
+            if {[can-move? $vector]} {
+                lappend possibleMoves $button
+            }
+        }
+        check-lose $possibleMoves
+
+        append output "\nMove ("
+        foreach {button vector} $controls {
+            if {$button in $possibleMoves} {
+                append output $button
+            }
+        }
+        append output {)? }
+        puts -nonewline $output[set output {}]
+        flush stdout
+    }
+
+    # Set up the game board and the controls.
+    proc init {} {
+        # Board size.
+        variable size 0
+        variable playmode play-user
+        variable cell
+        variable delay 0
+        variable ingame 0
+        variable playing {}
+        variable playType user
+        variable turns 0
+
+        variable inputModeSaved {}
+        variable inputMethod {}
+        chan configure stdin -blocking 0
+
+        try {
+            package require twapi
+
+            set inputModeSaved [twapi::get_console_input_mode stdin]
+            twapi::modify_console_input_mode stdin -lineinput false \
+                -echoinput false
+            set inputMethod twapi
+        } on error _ {
+            catch {
+                set inputModeSaved [exec stty -g 2>@stderr]
+                # TODO: Find other ways to save the state of the
+                # terminal.
+
+                package require term::ansi::ctrl::unix
+                package require term::ansi::send
+                term::ansi::ctrl::unix::raw
+                set inputMethod raw
+            }
+        }
+
+        variable controls {
+            h {0 -1}
+            j {1 0}
+            k {-1 0}
+            l {0 1}
+        }
+
+        variable preferences {
+            q quit
+            r {random move}
+            R {automatic random play (input anything to stop)}
+            s {show score}
+            ? help
+        }
+
+        start-turn
+        chan event stdin readable [namespace code input]
+    }
+
+    proc main {} {
+        variable done
+        interp bgerror {} [namespace code bgerror]
+        after idle [namespace code init]
+        vwait done
+        exit $done
+    }
+
+    # Output error and quit.
+    proc bgerror args {
+        puts stderr $::errorInfo
+        quit-game 1
+    }
+}
+
+# Check if we were run as the primary script by the interpreter.
+# From https://wiki.tcl-lang.org/40097.
+proc main-script? {} {
+    global argv0
+    if {[info exists argv0] && [file exists [info script]] &&
+            [file exists $argv0]} {
+        file stat $argv0 argv0Info
+        file stat [info script] scriptInfo
+
+        # Adjust for running from a network drive on Windows.
+        package require platform
+        set platform [::platform::generic]
+        set windows [string match *win* $platform]
+        expr {($argv0Info(dev) == $scriptInfo(dev)) &&
+                ($windows || ($argv0Info(ino) == $scriptInfo(ino)))}
+    } else {
+        return 0
+    }
+}
+
+if {[main-script?]} {
+    2048 main
+}

scriptlib/aloupe.tcl

@@ -0,0 +1,798 @@
+#! /usr/bin/env tclsh
+###########################################################
+# Name:    aloupe.tcl
+# Author:  Alex Plotnikov  (aplsimple@gmail.com)
+# Date:    Feb 26, 2021
+# Brief:   Handles a screen loupe.
+# License: MIT.
+###########################################################
+
+# _________________________ aloupe ________________________ #
+
+package require Tk
+
+package provide aloupe 1.8.2
+
+namespace eval ::aloupe {
+  variable solo [expr {[info exist ::argv0] && [file normalize $::argv0] eq [file normalize [info script]]}]
+}
+if {$::aloupe::solo} {wm withdraw .}
+
+# _____ Remove installed (perhaps) packages used here _____ #
+
+if {$::aloupe::solo} {
+  foreach _ {apave baltip bartabs hl_tcl ttk::theme::awlight ttk::theme::awdark awthemes} {
+    set __ [package version $_]
+    catch {
+      package forget $_
+      namespace delete ::$_
+      puts "aloupe: clearing $_ $__"
+    }
+    unset __
+  }
+
+  # use TCLLIBPATH variable (some tclkits don't see it)
+  catch {
+    foreach _apave_ [lreverse $::env(TCLLIBPATH)] {
+      set _apave_ [file normalize $_apave_]
+      if {[lsearch -exact $::auto_path $_apave_]<0 && [file exists $_apave_]} {
+        set ::auto_path [linsert $::auto_path 0 $_apave_]
+      }
+    }
+    unset _apave_
+  }
+}
+
+# ________________________ Run solo at need _________________________ #
+
+proc ::aloupe::RunSolo {} {
+  # Runs aloupe as a sole Tcl script.
+  # When aloupe runs from tclkit, it may fail. So try it with tclsh deployed.
+
+  set tclsh [auto_execok tclsh]
+  set tclexe [info nameofexecutable]
+  # tclsh may be sort of "tcl.sh" to run a tclkit
+  if {[file exists $tclsh] && [file size $tclsh]>1024 && $tclsh ne $tclexe} {
+    if {$::aloupe::solo} {set aar $::argv} {set aar {}}
+    exec -- $tclsh $::aloupe::aloupescript {*}$aar &
+  } else {
+    puts "aloupe error: $::aloupe::runerr"
+    tk_messageBox -title Error -icon error -message \
+      "aloupe error:\n\
+      \n$::aloupe::runerr\n\
+      \nProbably, you need to install\
+      \nTk packages treectrl and Img\
+      \nwhose libraries may be named\
+      \n'tktreectrl' and 'libtk-img'."
+  }
+}
+
+proc ::aloupe::GetPackages {{dir .}} {
+  # Gets required packages.
+  #   dir - supposed directory of packages
+
+  set dir [file normalize $dir]
+  set dir1 [lindex [glob -nocomplain [file join $dir treectrl*]] 0]
+  if {[info exists ::auto_path] && $dir1 ne {}} {
+    set dir2 [lindex [glob -nocomplain [file join $dir Img1.*]] 0]
+    if {$dir2 ne {}} {lappend ::auto_path $dir1 $dir2}
+  }
+  return [catch {package require treectrl; package require Img} ::aloupe::runerr]
+}
+
+proc ::aloupe::FindPackages {} {
+  # Tries to find required packages in an upper bin directory.
+
+  set dirs [file split [file dirname [file normalize $::aloupe::aloupescript]]]
+  while 1 {
+    set dir [file join {*}$dirs bin]
+    if {[file exists $dir]} {
+      if {![set ::aloupe::starterr [::aloupe::GetPackages $dir]]} {
+        return yes
+      }
+    }
+    if {[set dirs [lreplace $dirs end end]] eq {}} break
+  }
+  return no
+}
+
+set ::aloupe::aloupescript [info script]
+set ::aloupe::starterr [::aloupe::GetPackages]
+if {$::aloupe::solo && $::aloupe::starterr && ![::aloupe::FindPackages]} {
+  ::aloupe::RunSolo
+  exit
+}
+
+# ________________________ Variables _________________________ #
+
+::msgcat::mcload [file join [file dirname [info script]] msgs]
+
+namespace eval ::aloupe {
+  variable filename {}
+  namespace eval my {
+    variable HOMEDIR ~
+    if {[info exists ::env(HOME)]} {set HOMEDIR $::env(HOME)}
+    variable size 26
+    variable zoom 8
+    variable pause 0
+    variable data
+    array set data [list \
+      -size $size \
+      -zoom $zoom \
+      -pause $pause \
+      -alpha 0.3 \
+      -background #ff40ff \
+      -exit yes \
+      -command "" \
+      -commandname "" \
+      -ontop yes \
+      -geometry "" \
+      -parent "" \
+      -save yes \
+      -inifile [file join $HOMEDIR .config aloupe.conf] \
+      -locale "" \
+      -apavedir "" \
+      -cs -2 \
+      -fcgeom {} \
+    ]
+  }
+}
+
+# ___________________________ Common procs ____________________________ #
+
+proc ::aloupe::my::Synopsis {} {
+  # Short info about usage.
+
+  variable data
+  puts "
+Syntax:
+  tclsh aloupe.tcl ?option value ...?
+where 'option' may be [array names $data(DEFAULTS)].
+"
+  exit
+}
+#_______________________
+
+proc ::aloupe::my::Message {args} {
+  # Displays a message, with the loupe hidden.
+
+  variable data
+  wm withdraw $data(WLOUP)
+  tk_messageBox -parent $data(WDISP) -type ok {*}$args
+  wm deiconify $data(WLOUP)
+}
+#_______________________
+
+proc ::aloupe::my::InvertBg {color} {
+  # Gets fg color (white/black) for a bg color.
+  #  color - bg color
+
+  lassign [winfo rgb . $color] r g b
+  if {($r%256+$b%256)<15 && ($g%256)>180} {
+    set res black
+  } elseif {$r+1.5*$g+0.5*$b > 100000} {
+    set res black
+  } else {
+    set res white
+  }
+  return $res
+}
+
+# ________________________ Main and loop windows _________________________ #
+
+proc ::aloupe::my::CreateDisplay {start} {
+  # Creates the displaying window.
+  #   start - yes, if called at start
+
+  variable data
+  set sZ [expr {2*$data(-size)*$data(-zoom)}]
+  set data(IMAGE) [image create photo -width $sZ -height $sZ]
+  toplevel $data(WDISP)
+  wm title $data(WDISP) [::msgcat::mc Loupe]
+  set fg [ttk::style configure . -foreground]
+  set bg [ttk::style configure . -background]
+  set opts [ttk::style config TButton]
+  catch {set fg [dict get $opts -foreground]}
+  catch {set bg [dict get $opts -background]}
+  $data(WDISP) configure -background $bg
+  grid [label $data(WDISP).l -fg $fg -bg $bg] -row 0 -columnspan 3 -sticky we
+  pack [label $data(WDISP).l.lab1 -text " [::msgcat::mc Size]" -fg $fg -bg $bg] -side left -anchor e -expand 1
+  pack [ttk::spinbox $data(WDISP).l.sp1 -from 8 -to 500 -justify center \
+    -width 4 -textvariable ::aloupe::my::size -command ::aloupe::my::ShowLoupe \
+    -validate focus -validatecommand {::aloupe::my::Valid size 8 500 25}] -side left
+  pack [label $data(WDISP).l.lab2 -text " [::msgcat::mc Zoom]" -fg $fg -bg $bg] -side left -anchor e -expand 1
+  pack [ttk::spinbox $data(WDISP).l.sp2 -from 1 -to 50 -justify center \
+    -width 2 -textvariable ::aloupe::my::zoom -validate focus \
+    -validatecommand {::aloupe::my::Valid zoom 1 50 10}] -side left
+  pack [label $data(WDISP).l.lab3 -text " [::msgcat::mc Pause]" -fg $fg -bg $bg] -side left -anchor e -expand 1
+  pack [ttk::spinbox $data(WDISP).l.sp3 -from 0 -to 60 -justify center \
+    -width 2 -textvariable ::aloupe::my::pause \
+    -validate focus -validatecommand {::aloupe::my::Valid pause 0 60 0}] -side left
+  grid [ttk::separator $data(WDISP).sep1 -orient horizontal] -row 1 -columnspan 3 -sticky we -pady 2
+  grid [ttk::label $data(LABEL) -image $data(IMAGE) -relief flat] -row 2 -columnspan 3 -padx 2
+  set data(BUT0) $data(WDISP).but0
+  set data(BUT1) $data(WDISP).but1
+  set data(BUT2) $data(WDISP).but2
+  if {[set but1text $data(-commandname)] eq ""} {
+    set but1text [::msgcat::mc "To clipboard"]
+  }
+  grid [button $data(BUT0) -text [::msgcat::mc "Refresh"] \
+    -command ::aloupe::my::Refresh -fg $fg -bg $bg -font TkFixedFont] \
+    -row 3 -column 0 -sticky ew
+  grid [button $data(BUT1) -text $but1text \
+    -command ::aloupe::my::Button2Click -font TkFixedFont] \
+    -row 3 -column 1 -sticky ew
+  grid [button $data(BUT2) -text [::msgcat::mc Save] \
+    -command ::aloupe::my::Save -fg $fg -bg $bg -font TkFixedFont] \
+    -row 3 -column 2 -sticky ew
+  set data(-geometry) [regexp -inline \\+.* $data(-geometry)]
+  if {$data(-geometry) ne ""} {
+    wm geometry $data(WDISP) $data(-geometry)
+  } elseif {$data(-parent) ne ""} {
+    ::tk::PlaceWindow $data(WDISP) widget $data(-parent)
+  } else {
+    ::tk::PlaceWindow $data(WDISP)
+  }
+  if {$start} {
+    set defargs [list -foreground $fg -background $bg]
+    set data(BUTCFG) [StyleButton2 {*}$defargs]
+    lappend data(BUTCFG) {*}$defargs -text $but1text
+  }
+  foreach w {BUT0 BUT1 BUT2} {
+    set w $data($w)
+    foreach k {<Up> <Left>} {
+      bind $w $k "\
+        if {{$::tcl_platform(platform)} eq {windows}} { \
+          event generate $w <Shift-Tab> \
+        } else { \
+          event generate $w <Key> -keysym ISO_Left_Tab \
+        }"
+    }
+    foreach k {<Down> <Right>} {
+      bind $w $k "event generate $w <Key> -keysym Tab"
+    }
+    foreach k {<Return> <KP_Enter>} {
+      bind $w $k "event generate $w <Key> -keysym space"
+    }
+  }
+  bind $data(LABEL) <ButtonPress-1> {::aloupe::my::PickColor %W %X %Y}
+  bind $data(WDISP) <Escape> ::aloupe::my::Exit
+  wm resizable $data(WDISP) 0 0
+  wm protocol $data(WDISP) WM_DELETE_WINDOW ::aloupe::my::Exit
+  if {$data(-ontop)} {wm attributes $data(WDISP) -topmost 1}
+}
+#_______________________
+
+proc ::aloupe::my::CreateLoupe {{geom ""}} {
+  # Creates the loupe window.
+  #   geom - the predefined geometry
+
+  variable data
+  frame $data(WLOUP)
+  wm manage $data(WLOUP)
+  wm withdraw $data(WLOUP)
+  wm overrideredirect $data(WLOUP) 1
+  set canvas $data(WLOUP).c
+  canvas $canvas -width 100 -height 100 -background $data(-background) \
+    -relief flat -bd 0 -highlightthickness 1 -highlightbackground red
+  pack $canvas -fill both -expand true
+  bind $canvas <ButtonPress-1>   {::aloupe::my::DragStart %W %X %Y %x %y}
+  bind $canvas <B1-Motion>       {::aloupe::my::Drag %W %X %Y}
+  bind $canvas <ButtonRelease-1> {::aloupe::my::DragEnd %W}
+  bind $canvas <Escape>          {::aloupe::my::Exit}
+  after 50 "
+    ::aloupe::my::InitGeometry $geom
+    wm deiconify $data(WLOUP)
+    wm attributes $data(WLOUP) -topmost 1 -alpha $data(-alpha)
+    "
+}
+#_______________________
+
+proc ::aloupe::my::Theme {} {
+  # Themes the utility
+
+  variable data
+  if {$data(-apavedir) eq {}} return
+  source [file join $data(-apavedir) apave.tcl]
+  ::apave::initWM -cs $data(-cs) -theme alt
+  if {$data(-fcgeom) ne {}} {
+    ::apave::obj chooserGeomVars {} ::aloupe::my::data(-fcgeom)
+  }
+}
+#_______________________
+
+proc ::aloupe::my::Create {start} {
+  # Initializes and creates the utility's windows.
+  #   start - yes, if called at start
+
+  variable data
+  catch {destroy $data(WLOUP)}
+  catch {destroy $data(WDISP)}
+  catch {image delete $data(IMAGE)}
+  if {[set wgr [grab current]] ne ""} {grab release $wgr}
+  CreateDisplay $start
+  CreateLoupe
+  set data(PREVZOOM) $data(-zoom)
+  set data(PREVSIZE) $data(-size)
+  focus $data(WDISP)
+}
+#_______________________
+
+proc ::aloupe::my::Valid {vnam val1 val2 valdef} {
+  # Validates spinbox's value.
+  #   vnam - variable name
+  #   val1 - "from" value
+  #   val2 - "to" value
+  #   valdef - default value
+
+  set vnam ::aloupe::my::$vnam
+  set val [set $vnam]
+  if {$val<$val1 || $val>$val2} {
+    set $vnam $valdef
+  }
+  return 1
+}
+
+# ________________________ Drag-n-drop _________________________ #
+
+proc ::aloupe::my::DragStart {w X Y x y} {
+  # Initializes the frag-and-drop of the loupe.
+  #   w - the loupe window's path
+  #   X - X-coordinate of the mouse pointer
+  #   Y - Y-coordinate of the mouse pointer
+  #   x - X-coordinate inside the loupe
+  #   y - Y-coordinate inside the loupe
+
+  variable data
+  variable size
+  variable zoom
+  set data(FOCUS) [focus]
+  focus -force $data(WDISP)
+  set data(-size) $size
+  set data(-zoom) $zoom
+  if {$data(PREVZOOM) != $data(-zoom) || $data(PREVSIZE) != $data(-size)} {
+    SaveGeometry
+    Create no
+    catch {unset data(dragX)}  ;# no drag-n-drop, update the loupe only
+    update
+    return
+  }
+  InitButton2
+  set data(x) $x
+  set data(y) $y
+  InitGeometry
+  update
+  set data(dragX) [expr {$X - [winfo rootx $w]}]
+  set data(dragY) [expr {$Y - [winfo rooty $w]}]
+}
+#_______________________
+
+proc ::aloupe::my::InitButton2 {} {
+  # Initializes color ("to clipboard") button.
+
+  variable data
+  set data(COLOR) [set data(CAPTURE) ""]
+  StyleButton2 {*}$data(BUTCFG)
+}
+#_______________________
+
+proc ::aloupe::my::ColorButton2 {} {
+  # Colorizes color ("to clipboard") button.
+
+  variable data
+  if {$data(COLOR) ne ""} {
+    StyleButton2 -background $data(COLOR) -foreground $data(INVCOLOR) \
+      -text $data(COLOR)
+  }
+}
+#_______________________
+
+proc ::aloupe::my::Drag {w X Y} {
+  # Performs the frag-and-drop of the loupe.
+  #   w - the loupe window's path
+  #   X - X-coordinate of the mouse pointer
+  #   Y - Y-coordinate of the mouse pointer
+
+  variable data
+  if {![info exists data(dragX)]} return
+  set dx [expr {$X - $data(dragX)}]
+  set dy [expr {$Y - $data(dragY)}]
+  wm geometry $data(WLOUP) +$dx+$dy
+}
+#_______________________
+
+proc ::aloupe::my::DragEnd {w} {
+  # Ends the frag-and-drop of the loupe and displays its magnified image.
+  #   w - the loupe window's path
+
+  variable pause
+  if {$pause} {
+    after 1000 [list ::aloupe::my::CountDownPause $pause $pause]
+    after [expr {$pause*1000}] [list ::aloupe::my::DisplayImage $w]
+  } else {
+    ::aloupe::my::DisplayImage $w
+  }
+}
+#_______________________
+
+proc ::aloupe::my::CountDownPause {pause p} {
+  # Counts down a pause.
+  #   pause - seconds to count down
+  #   p - remaining seconds to count down
+
+  variable data
+  if {$p} {
+    set ::aloupe::my::pause [incr p -1] ;# shows remaining seconds
+    set msec [expr {$p ? 1000 : 200}]
+    after $msec [list ::aloupe::my::CountDownPause $pause $p]
+  } else {
+    set ::aloupe::my::pause $pause
+  }
+}
+#_______________________
+
+proc ::aloupe::my::DisplayImage {w} {
+  # Ends the frag-and-drop of the loupe and displays its magnified image.
+  #   w - the loupe window's path
+
+  variable data
+  if {![info exists data(dragX)]} return
+  wm attributes $data(WLOUP) -topmost 1 -alpha 0.0
+  wm attributes $data(WDISP) -alpha 0.0
+  wm withdraw $data(WLOUP)
+  wm withdraw $data(WDISP)
+  set curX [winfo rootx $w]
+  set curY [winfo rooty $w]
+  set curW [winfo width $w]
+  set curH [winfo height $w]
+  catch {image delete $data(CAPTURE)}
+  set sz [expr {2*$data(-size)}]
+  set sZ [expr {$sz*$data(-zoom)}]
+  set data(CAPTURE) [image create photo -width $sz -height $sz]
+  set loupe_x [expr {$curX + $sz/2}]
+  set loupe_y [expr {$curY + $sz/2}]
+  after 40 "loupe $data(CAPTURE) $loupe_x $loupe_y $sz $sz 1"
+  after 50
+  update   ;# enough time to hide the window and capture the image
+  after 50
+  catch {
+    $data(IMAGE) copy $data(CAPTURE) -from 0 0 $sz $sz \
+      -to 0 0 $sZ $sZ -zoom $data(-zoom)
+  }
+  wm deiconify $data(WDISP)
+  wm deiconify $data(WLOUP)
+  after idle " \
+    wm attributes $data(WLOUP) -topmost 1 -alpha $data(-alpha);\
+    wm attributes $data(WDISP) -alpha 1.0"
+  focus -force $data(BUT0)
+}
+#_______________________
+
+proc ::aloupe::my::Refresh {} {
+  # Refreshes the loupe image without mouse click.
+
+  variable data
+  InitButton2
+  DragEnd $data(WLOUP)
+}
+
+# ________________________ Geometry _________________________ #
+
+proc ::aloupe::my::ShowLoupe {} {
+  # Re-displays the loupe at changing its size.
+
+  variable data
+  variable size
+  set data(-size) $size
+  lassign [split [wm geometry $data(WLOUP)] +] -> x y
+  set sz [expr {2*$size}]
+  destroy $data(WLOUP)
+  CreateLoupe ${sz}x${sz}+$x+$y
+  ColorButton2
+}
+#_______________________
+
+proc ::aloupe::my::InitGeometry {{geom ""}} {
+  # Gets and sets the geometry of the loupe window,
+  # based on the image label's sizes and the zoom factor.
+  #   geom - the predefined geometry
+
+  variable data
+  if {$geom eq ""} {
+    set sz [expr {2*$data(-size)}]
+    lassign [winfo pointerxy .] x y
+    if {[info exists data(x)]} {set dx $data(x)} {set dx $sz/2}
+    if {[info exists data(y)]} {set dy $data(y)} {set dy $sz/2}
+    set x [expr $x-$dx]
+    set y [expr $y-$dy]
+    set geom ${sz}x${sz}+$x+$y
+  }
+  wm geometry $data(WLOUP) $geom
+}
+#_______________________
+
+proc ::aloupe::my::SaveGeometry {} {
+  # Saves the displaying window's geometry.
+
+  variable data
+  set data(-geometry) ""
+  catch {set data(-geometry) [wm geometry $data(WDISP)]}
+}
+
+# ________________________ Widgets' styles _________________________ #
+
+proc ::aloupe::my::StyleButton2 {args} {
+  # Makes a style for Tbutton.
+  #   args - options ("name value" pairs)
+  # Returns the TButton's configuration options.
+
+  variable data
+  if {[dict exists $args -text]} {
+    $data(BUT1) configure -text [dict get $args -text]
+    set args [dict remove $args -text]
+  }
+  set fg [dict get $args -foreground]
+  set bg [dict get $args -background]
+  $data(BUT1) configure -foreground $fg -background $bg
+  return {}
+}
+
+# ________________________ Capturing image _________________________ #
+
+proc ::aloupe::my::Button2Click {} {
+  # Processes the click on 'Clipboard' button.
+
+  variable data
+  if {$data(COLOR) ne ""} {
+    StyleButton2 -background $data(INVCOLOR) -foreground $data(COLOR)
+    update idletasks
+    after 60 ;# just to make the click visible
+  }
+  if {[HandleColor] && !$data(-exit) && $data(-command) ne ""} {
+    SaveGeometry
+    {*}[string map [list %c $data(COLOR)] $data(-command)]
+  }
+}
+#_______________________
+
+proc ::aloupe::my::IsCapture {} {
+  # Checks if the image was captured.
+
+  variable data
+  if {$data(CAPTURE) eq ""} {
+    Message -title [msgcat::mc {Color of Image}] -icon warning \
+      -message  [msgcat::mc "Click, then drag and drop\nthe loupe to get the image."]
+    return no
+  }
+  return yes
+}
+#_______________________
+
+proc ::aloupe::my::HandleColor {{doclb yes}} {
+  # Processes the image color under the mouse pointer,
+  # optionally saving it to the clipboard.
+  #   doclb - if 'yes', means "put the color into the clipboard"
+  # Returns 'yes' if the color was chosen.
+
+  variable data
+  set res no
+  if {[IsCapture]} {
+    if {$data(COLOR) eq ""} {
+      Message -title [msgcat::mc {Color of Image}] -icon warning \
+        -message [msgcat::mc "Click the magnified image\nto get a pixel's color.\n\nThen hit this button."]
+    } else {
+      if {$doclb && $data(-commandname) eq ""} {
+        clipboard clear
+        clipboard append -type STRING $data(COLOR)
+      }
+      ColorButton2
+      set res yes
+    }
+  }
+  return $res
+}
+#_______________________
+
+proc ::aloupe::my::PickColor {w X Y} {
+  # Gets the image color under the mouse pointer.
+  #   w - the image label's path
+  #   X - X-coordinate of the mouse pointer
+  #   Y - Y-coordinate of the mouse pointer
+
+  variable data
+  if {![IsCapture]} return
+  set x [expr {max(($X - [winfo rootx $w] -4),0)}]
+  set y [expr {max(($Y - [winfo rooty $w] -4),0)}]
+  catch {
+    lassign [$data(IMAGE) get $x $y] r g b
+    set data(COLOR) [format "#%02x%02x%02x" $r $g $b]
+    set data(INVCOLOR) [InvertBg $data(COLOR)]
+    HandleColor no
+    set msec [clock milliseconds]
+    if {[info exists data(MSEC)] && [expr {($msec-$data(MSEC))<400}]} {
+      Button2Click
+    }
+    set data(MSEC) $msec
+  }
+}
+#_______________________
+
+proc ::aloupe::my::SaveOptions {} {
+  # Saves options of appearance to a file.
+
+  variable data
+  variable size
+  variable zoom
+  variable pause
+  if {!$data(-save)} return
+  set data(-size) $size
+  set data(-zoom) $zoom
+  set data(-pause) $pause
+  set w $data(WDISP)
+  catch {file mkdir [file dirname $data(-inifile)]}
+  catch {
+    append opts {[options]} \n
+    foreach opt [array names data] {
+      if {$opt in {-size -geometry -background -zoom -pause -alpha -ontop}} {
+        if {$opt eq "-geometry"} {
+          set val [wm geometry $w]
+        } else {
+          set val $data($opt)
+        }
+        append opts "[string range $opt 1 end]=$val" \n
+      }
+    }
+    set chan [open $data(-inifile) w]
+    puts -nonewline $chan $opts
+    close $chan
+  }
+}
+
+# ________________________ Save / restore options _________________________ #
+
+proc ::aloupe::my::RestoreOptions {} {
+  # Restores options of appearance from a file.
+
+  variable data
+  if {!$data(-save)} return
+  if {![file exists $data(-inifile)]} return
+  set chan [open $data(-inifile)]
+  set data(CONFIG) [read $chan]
+  close $chan
+  set svd $data(DEFAULTS)
+  foreach line [split $data(CONFIG) \n] {
+    if {[string match "*=*" $line]} {
+      set opt -[string range $line 0 [string first = $line]-1]
+      set val [string range $line [string length $opt] end]
+      set ${svd}($opt) [set data($opt) $val]
+    }
+  }
+}
+#_______________________
+
+proc ::aloupe::my::Save {} {
+  # Saves the magnified image to a file.
+
+  variable data
+  if {![IsCapture]} return
+  wm withdraw $data(WLOUP)
+  set filetypes { {"PNG Images" .png} {"All Image Files" {.png .gif}} }
+  set file [file tail $::aloupe::filename]
+  set argl [list -parent $data(WDISP) -title [::msgcat::mc "Save the Loupe"] \
+    -filetypes $filetypes -defaultextension .png -initialfile $file]
+  if {$data(-fcgeom) ne {}} {
+    set file [::apave::obj chooser tk_getSaveFile ::aloupe::filename {*}$argl]
+  } else {
+    catch {::apave::obj themeExternal "$data(WLOUP)*"}  ;# theme the file chooser
+    set file [tk_getSaveFile {*}$argl]
+  }
+  if {$file ne ""} {
+    set ::aloupe::filename $file
+    if {![regexp -nocase {\.(png|gif)$} $file -> ext]} {
+      set ext "png"
+      append file ".${ext}"
+    }
+    if {[catch {$data(IMAGE) write $file -format [string tolower $ext]} err]} {
+      Message -title "Error Writing File" -icon error \
+        -message "Error writing to file \"$file\":\n$err"
+    }
+  }
+  ShowLoupe
+}
+#_______________________
+
+proc ::aloupe::my::Exit {} {
+  # Clears all and exits.
+
+  variable data
+  SaveOptions
+  if {$data(-exit)} exit
+  SaveGeometry
+  catch {image delete $data(IMAGE)}
+  catch {image delete $data(CAPTURE)}
+  catch {destroy $data(WDISP)}
+  catch {
+    wm withdraw $data(WLOUP)
+    destroy $data(WLOUP)
+  }
+}
+# __________________________ Interface procs ____________________________ #
+
+proc ::aloupe::option {opt} {
+  # Returns a value of aloupe option.
+  #   opt - the option's name
+
+  variable data
+  return $data($opt)
+}
+#_______________________
+
+proc ::aloupe::run {args} {
+  # Runs the loupe.
+  #  args - options of the loupe
+
+  if {$::aloupe::starterr} {
+    RunSolo
+    return
+  }
+  variable my::data
+  variable my::size
+  variable my::zoom
+  # save the default settings of aloupe
+  set data(-commandname) ""
+  if {![info exists my::data(DEFAULTS)]} {
+    set defar ::aloupe::_DEFAULTS_
+    array set $defar [array get my::data]
+    set my::data(DEFAULTS) $defar
+  }
+  catch {set my::data(-inifile) [dict get $args -inifile]}
+  catch {
+    if {([dict exists $args -save] && [dict get $args -save]) || \
+    (![dict exists $args -save] && $my::data(-save))} {
+      my::RestoreOptions
+    }
+  }
+  # restore the default settings of aloupe (for a 2nd/3rd... run)
+  set svd $my::data(DEFAULTS)
+  foreach an [array names $svd] {
+    set my::data($an) [set ${svd}($an)] ;# "by variable address"
+  }
+  foreach {a v} $args {
+    if {($v ne "" || $a in {-geometry -fcgeom}) && \
+    [info exists my::data($a)] && [string is lower [string index $a 1]]} {
+      set my::data($a) $v
+    } else {
+      puts "Bad option: $a \"$v\""
+      my::Synopsis
+    }
+  }
+  if {$my::data(-locale) ne {}} {
+    catch {
+      ::msgcat::mcload [file join [file dirname [info script]] msgs]
+      ::msgcat::mclocale $my::data(-locale)
+    }
+  }
+  catch {::apave::obj untouchWidgets "*_a_loupe_loup*"}  ;# don't theme the loupe
+  set my::size [set my::data(PREVSIZE) $my::data(-size)]
+  set my::zoom [set my::data(PREVZOOM) $my::data(-zoom)]
+  set my::pause $my::data(-pause)
+  set my::data(WDISP) "$data(-parent)._a_loupe_disp"
+  set my::data(WLOUP) "$data(-parent)._a_loupe_loup"
+  set my::data(LABEL) "$data(WDISP).label"
+  set my::data(COLOR) [set data(CAPTURE) ""]
+  my::Theme
+  my::Create yes
+}
+
+# ___________________________ Stand-alone run ___________________________ #
+
+if {$::aloupe::solo} {
+  wm withdraw .
+  catch {
+    ttk::style config TButton -width 9 -buttonborder 1 -labelborder 0 -padding 1
+  }
+  ::aloupe::run {*}$::argv
+}
+# _________________________________ EOF _________________________________ #
+#-ARGS1: -locale ua -alpha .2 -background "yellow" -ontop 1 -save 1 -commandname "Get"
+#-RUNF1: ~/PG/github/pave/tests/test2_pave.tcl 23 9 12 "small icons"

scriptlib/b1.tcl

@@ -23,7 +23,7 @@ puts "close curly }"
 test
 puts done
 
-puts [list
+#puts [list
-a
+#a
-b
+#b
-]
+#]

scriptlib/hello.tcl

@@ -16,5 +16,8 @@ puts -nonewline stderr "7 hello on stderr no line-ending"
 flush stderr
 set ::tcl_interactive 1
 
+#exit 0
+return abc
+
 
 

scriptlib/hello_exit.tcl

@@ -0,0 +1,22 @@
+chan configure stdout -buffering none
+chan configure stderr -buffering none
+puts -nonewline stderr "1 hello on stderr with crlf newline\r\n"
+flush stderr
+puts -nonewline stdout "2 hello on stdout with crlf newline\r\n"
+flush stdout
+puts -nonewline stderr "3 hello on stderr with unix newline\n"
+flush stderr
+puts -nonewline stdout "4 hello on stdout with unix newline\n"
+flush stdout
+puts -nonewline stderr "5 hello on stderr no line-ending"
+flush stderr
+puts -nonewline stdout "6 hello on stdout no line-ending"
+flush stdout
+puts -nonewline stderr "7 hello on stderr no line-ending"
+flush stderr
+set ::tcl_interactive 1
+
+exit {*}$::argv
+
+
+

scriptlib/help.tcl

@@ -0,0 +1,5 @@
+package require punk
+package require punk::config
+punk::config::init
+package require punk::args::moduledoc::tclcore
+punk::help {*}$::argv

scriptlib/help_exit.tcl

@@ -0,0 +1,6 @@
+package require punk
+package require punk::config
+punk::config::init
+package require punk::args::moduledoc::tclcore
+punk::help {*}$::argv
+exit 0

scriptlib/netbox.tcl

@@ -0,0 +1,7 @@
+package require punk::ns
+package require punk::nav::ns
+package require punk::netbox
+package require punk::netbox::man
+punk::netbox::init
+puts [punk::netbox::man::about Description Version]
+puts -nonewline stdout [punk::ns::pkguse ::punk::netbox::man]

scriptlib/pdf2text.tcl

@@ -1,5 +1,12 @@
 
 
+
+#---------------
+#debug/test only - don't output to stdout/stderr in production code
+#puts stdout "pdf2text.tcl: converting PDF to text"
+#puts stdout "::argv: $::argv"
+#---------------
+
 package require tclMuPDF
 package require punk::args
 package require punk::ansi
@@ -7,8 +14,23 @@ package require punk::lib
 package require textblock
 package require punk::pdf
 
+if {$::tcl_interactive} {
+    if {[catch {
+        package require punk::nav::ns
+        punk::nav::ns::ns/ // punk::pdf
+    } err eopts]} {
+        puts stdout "Error loading/navigating to punk::nav::ns: $err"
+    }  else {
+        namespace eval ::punk::pdf {
+            set text [punk::pdf::text -outchannel return {*}$::argv]
+            puts stdout $text
+        }
+    }
+} else {
+    #default -outchannel stdout.
+    punk::pdf::text {*}$::argv
+}
 
-punk::pdf::text {*}$::argv
 return
 
 

scriptlib/punklogo.tcl

@@ -0,0 +1,12 @@
+package require patternpunk
+package require punk::ansi
+package require textblock
+apply { {} {
+    set l "[punk::ansi::a+ term-blue][>punk . logo2][punk::ansi::a]"
+    set f [textblock::frame -type arc -ansiborder [punk::ansi::a+ green] $l]
+    set info "\n[info patchlevel]\n[>punk . version]"
+    puts -nonewline stdout \n[textblock::join -- $f " " $info]
+} }
+#puts -nonewline stdout [n/new ::[set ::tcl_platform(user)]]
+puts -nonewline stdout [punk::nav::ns::newns ::[set ::tcl_platform(user)]]
+#mode raw

scriptlib/requiremath.tcl

@@ -30,8 +30,8 @@ package require struct::record
 package require snit
 package require fileutil::magic::filetype
 
-catch {package require math::nonexistant}
+#catch {package require math::nonexistant}
 #catch {package require frobnozzle}
 
 
-exit 0
+#exit 0

scriptlib/showargs.tcl

@@ -6,3 +6,8 @@ foreach a $::argv {
     puts stdout $a
     puts stdout [string repeat - 40]
 }
+
+#it can be useful to have a shutdown delay when testing with a launch mechanism that doesn't capture the output of the launched process - so that we can see the output before the process exits.
+#(e.g running from windows explorer to test the arguments in the registry for file associations and shell open commands)
+#after 10000
+

scriptlib/stdout_per_second.tcl

@@ -54,6 +54,7 @@ proc the_end {} {
     puts stderr "-done-"
     flush stderr
     flush stdout
+    chan event stdin readable {}
     set ::done_stdout_per_second 1
 }
 
@@ -81,7 +82,7 @@ chan event stdin readable [list apply {{chan} {
     upvar ::cmdbuffer b
     set chunk [chan read $chan]
     if {[string length $chunk]} {
-        if {[string match "*q*" [string tolower $chunk]]} {
+        if {[string tolower $chunk] eq "q"} {
             set ::forever_stdout_per_second 0
             chan event $chan readable {}
             puts stderr "cancelling"
@@ -95,32 +96,45 @@ chan event stdin readable [list apply {{chan} {
             } _err]} {
                 puts stderr $chunk
             }
-        }
+
-        if {$chunk in [list "\r" "\n" "\r\n"]} {
+            set chunk [string map [list \r\n \n \r \n] $chunk]
-            if {[string is double -strict $b]} {
+            set chunklines [split $chunk \n]
-                if {$b == 0} {
+            foreach ln [lrange $chunklines 0 end-1] {
-                    puts stderr "ms must be > 0"
+                append b [string trim $ln]
-                    set ::ms 1
+                if {[string tolower $b] eq "q"} {
-                }
+                    set ::forever_stdout_per_second 0
-                set ::ms [expr {round(1000 / $b)}]
+                    chan event $chan readable {}
-                set ::nl_every [expr {round($b * $::newline_every_x_seconds)}]
+                    puts stderr "cancelling"
-                puts stderr "ms: $::ms"
+                    if {$::ms > 500} {
-            } else {
+                        after 0 ::the_end
-                if {[string match "!*" $b]} {
-                    set cmd [string range $b 1 end]
-                    if {[catch {eval $cmd} result]} {
-                        puts stderr "error: $result"
-                    } else {
-                        puts stderr "ok"
-                        puts stderr $result
                     }
                 } else {
-                    puts stderr "cmd: '$b' not understood - use 'q' to quit"
+                    if {[string is double -strict $b]} {
+                        if {$b == 0} {
+                            puts stderr "ms must be > 0"
+                            set ::ms 1
+                        }
+                        set ::ms [expr {round(1000 / $b)}]
+                        set ::nl_every [expr {round($b * $::newline_every_x_seconds)}]
+                        puts stderr "ms: $::ms"
+                    } else {
+                        if {[string match "!*" $b]} {
+                            set cmd [string range $b 1 end]
+                            if {[catch {eval $cmd} result]} {
+                                puts stderr "error: $result"
+                            } else {
+                                puts stderr "ok"
+                                puts stderr $result
+                            }
+                        } else {
+                            puts stderr "cmd: '$b' not understood - use 'q' to quit"
+                        }
+                    }
                 }
+                set b ""
             }
-            set b ""
+            append b [lindex $chunklines end]
-        } else {
+
-            append b $chunk
         }
     }
     if {[chan eof $chan]} {

scriptlib/test1.tcl

@@ -1,3 +1,5 @@
+puts stdout [chan configure stdin]
+chan configure stdin -buffersize 0
 puts -nonewline stdout "info script\r\n"
 puts stdout "[info script]"
 puts stdout "::argc"
@@ -7,6 +9,7 @@ puts stdout "$::argv"
 puts stdout "NS"
 puts stdout "[namespace current]"
 
+after 100 
 if {[info exists ::test]} {
     puts stdout "::test has existing value"
     puts stdout "$::test"
@@ -14,19 +17,33 @@ if {[info exists ::test]} {
 
 puts stdout "setting ::test to showargs-ran"
 set ::test "showargs-ran"
-puts stdout "doing basic check of stdin for data"
+#puts stdout "doing basic check of stdin for data"
 chan configure stdin -blocking 0
 set indata ""
 if {![chan eof stdin]} {
-    #set indata [read stdin]
+    set indata [read stdin 5]
+} else {
+    puts stdout "stdin eof"
 }
-if {[string length $indata]} {
+#if {[string length $indata]} {
     puts stdout "read from stdin:"
     puts stdout $indata
-} else {
+    #chan configure stdin -encoding utf-32
-puts stdout "-no stdin data read-"
+    #chan configure stdin -encoding utf-32be -blocking 0
-}
+    #chan close stdin
-
+    puts stdout 1-[read stdin 10]
+    set i 100
+    while {$i > 0} {
+        incr i -1
+        after 10
+    }
+    chan configure stdin -blocking 1 -encoding utf-32
+    #puts stdout 2-[read stdin 10]
+    #chan close stdin read
+    exit 42
+#} else {
+#puts stdout "-no stdin data read-"
+#}
 
 
 

scriptlib/tests/adhoc/aliases.tcl

@@ -1,3 +1,6 @@
+package require punk
+package require shellrun 
+
 set sepline [string repeat - 40]
 puts stdout "testing some aliases"
 puts stdout $sepline

scriptlib/tests/first_assign.tcl

@@ -1,6 +1,6 @@
 #experiment with the dangers of substitution in the first position after = in pipelines
 puts stderr "Relevant for consideration if attempting to build pipelines parametrically"
-
+package require punk
 
 puts stdout {set i {"a b "}}
 set i {"a b "}

scriptlib/tests/listbuilder.tcl

@@ -60,7 +60,7 @@ k4
         etc blah
         dir {[pwd]}
     }
-" |> finald,rtkey/@@runtimedir.= {
+" |> inspect |> finald,rtkey/@@runtimedir.= {
     #a very impure script block!
     set origdir [pwd]
     set parent [file dirname [pwd]]
@@ -68,7 +68,7 @@ k4
     dict set data runtimedir [pwd]
     cd $origdir
     set data
-}  |@@k4/dir> <| extrakey [pwd] anotherkey foo
+}  |/@0/0/@@k4/dir> <| extrakey [pwd] anotherkey foo
 
 
 puts stdout "dictpipe:"

scriptlib/thread_interp.tcl

@@ -3,16 +3,23 @@ set arg1 [lindex $::argv 0]
 interp create code1
 interp create code2
 
+puts stdout "Testing target interpreter of thread::send."
+puts stdout "For tcl 8.6 (?) The target interp can vary depending on which interp first called a thread function such as thread::id."
+puts stdout "For tcl 9 - there is a difference between -async and non-async target interp *when sending to own thread*"
+puts stdout "loading Thread package in all interps"
+puts stdout "auto_path in parent interp: $::auto_path"
+code1 eval [list set ::auto_path $::auto_path]
+code2 eval [list set ::auto_path $::auto_path]
 
-puts stderr "loading Thread package in all 3 interps"
+set tversion_code1  [code1 eval {package require Thread}]
-package require Thread
+set tversion_code2  [code2 eval {package require Thread}]
-code1 eval {package require Thread}
+set tversion_parent [package require Thread]
-code2 eval {package require Thread}
+#puts stdout "Thread version in parent interp: $tversion_parent"
 
-puts stderr "establishing ::testfunc proc in all 3 interps"
+puts stdout "establishing ::testfunc proc in all interps"
-code1 eval {proc ::testfunc {args}  {puts stderr "evaluated in code1  interp: $args"}}
+code1 eval {proc ::testfunc {args}  {puts stdout "evaluated in \x1b\[31mcode1\x1b\[m interp: $args"}}
-code2 eval {proc ::testfunc {args}  {puts stderr "evaluated in code2  interp: $args"}}
+code2 eval {proc ::testfunc {args}  {puts stderr "evaluated in \x1b\[33mcode2\x1b\[m  interp: $args"}}
-proc ::testfunc {args}              {puts stderr "evaluated in parent interp: $args"}
+proc ::testfunc {args}              {puts stdout "evaluated in \x1b\[32mparent\x1b\[m interp: $args"}
 
 
 puts stderr "Calling a thread function in nominated interp '$arg1' first"
@@ -28,41 +35,94 @@ switch -- $arg1 {
         code2 eval {thread::id}
     }
     default {
-        puts stderr "Usage thread_interp.tcl parent|code1|code2"
+        #puts stderr "Usage thread_interp.tcl parent|code1|code2"
+        puts stderr "Usage thread_interp.tcl parent|code1"
         exit 1
     }
 }
 
 
-puts stderr "sending scripts"
+puts stdout "sending scripts"
-thread::send -async [thread::id] {
+
-    ::testfunc script sent from parent interp
+puts stdout "send to own thread::id from child interp"
+puts stdout "----------------------------------------"
+#sending to own thread from child interp.
+code1 eval {
+    thread::send  [thread::id] {
+        ::testfunc script sent from code1 interp
+    }
 }
 code1 eval {
+    package require Thread
     thread::send -async [thread::id] {
-        ::testfunc script sent from code1 interp
+        ::testfunc script sent from code1 interp with -async
     }
 }
+
+code1 eval {
+    thread::send [thread::id] {}
+}
+after 1000
+puts stdout "----------------------------------------"
+flush stdout
+
 code2 eval {
-    thread::send -async [thread::id] {
+    thread::send  [thread::id] {
         ::testfunc script sent from code2 interp
     }
 }
-#test
+code2 eval {
-after 0                 {::testfunc after script in parent interp}
+    package require Thread
-code1 eval  {after 0    {::testfunc after script in code1 interp}}
+    thread::send -async [thread::id] {
-code2 eval  {after 0    {::testfunc after script in code2 interp}}
+        ::testfunc script sent from code2 interp with -async
-
+    }
+}
 
 code1 eval {
     set workertid [thread::create]
     thread::send $workertid {package require Thread}
-    thread::send $workertid [list thread::send -async [thread::id] {
+    thread::send -async $workertid [list thread::send [thread::id] {
             ::testfunc script sent from code1 interp via worker
     }]
 }
+code1 eval {
+    set workertid [thread::create]
+    thread::send $workertid {package require Thread}
+    thread::send $workertid [list thread::send -async [thread::id] {
+            ::testfunc script sent from code1 interp via worker -async
+    }]
+}
+
+
+set workertid [thread::create -preserved]
+thread::send -async $workertid [list set ::auto_path $::auto_path]
+#thread::send -async $workertid {package require Thread}
+thread::send -async $workertid {interp create code1}
+thread::send $workertid [list code1 eval [list set ::auto_path $::auto_path]]
+thread::send $workertid [list code1 eval {package require Thread}]
+#thread::send -async $workertid {puts --------------------; flush stdout}
+thread::send -async $workertid [list code1 eval {puts stdout "workerthread: [thread::id]"}]
+thread::send -async $workertid [list code1 eval [list thread::send [thread::id] {
+    ::testfunc script sent from worker
+}]]
+after idle {set ::done 1}
+vwait ::done
+#exit 1
+thread::send -async $workertid [list thread::send -async [thread::id] {
+    ::testfunc script sent from parent interp via worker -async
+}]
+thread::send [thread::id] {
+    ::testfunc script sent from parent interp
+}
+thread::send -async [thread::id] {
+    ::testfunc script sent from parent interp with -async
+}
+puts stdout "done sending scripts"
+flush stdout
+
 
 after idle {set ::done 1}
+#after 1000 {set ::done 1}
 vwait ::done
 
 

scriptlib/tkhello.tcl

@@ -0,0 +1,5 @@
+if {[catch {package require tk}]} {
+    package require Tk
+}
+label .label -text "Hello World"
+pack .label

scriptlib/tkhello_exit.tcl

@@ -0,0 +1,7 @@
+if {[catch {package require tk}]} {
+    package require Tk
+}
+label .label -text "Hello World"
+pack .label
+
+exit 0