diff --git a/scriptlib/2048.tcl b/scriptlib/2048.tcl new file mode 100644 index 00000000..9189f562 --- /dev/null +++ b/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 . + 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 +} diff --git a/scriptlib/aloupe.tcl b/scriptlib/aloupe.tcl new file mode 100644 index 00000000..9981565b --- /dev/null +++ b/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 { } { + bind $w $k "\ + if {{$::tcl_platform(platform)} eq {windows}} { \ + event generate $w \ + } else { \ + event generate $w -keysym ISO_Left_Tab \ + }" + } + foreach k { } { + bind $w $k "event generate $w -keysym Tab" + } + foreach k { } { + bind $w $k "event generate $w -keysym space" + } + } + bind $data(LABEL) {::aloupe::my::PickColor %W %X %Y} + bind $data(WDISP) ::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 {::aloupe::my::DragStart %W %X %Y %x %y} + bind $canvas {::aloupe::my::Drag %W %X %Y} + bind $canvas {::aloupe::my::DragEnd %W} + bind $canvas {::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" diff --git a/scriptlib/b1.tcl b/scriptlib/b1.tcl index 2ad4d135..6de6960b 100644 --- a/scriptlib/b1.tcl +++ b/scriptlib/b1.tcl @@ -23,7 +23,7 @@ puts "close curly }" test puts done -puts [list -a -b -] +#puts [list +#a +#b +#] diff --git a/scriptlib/hello.tcl b/scriptlib/hello.tcl index 9426b3d3..c7b37510 100644 --- a/scriptlib/hello.tcl +++ 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 + diff --git a/scriptlib/hello_exit.tcl b/scriptlib/hello_exit.tcl new file mode 100644 index 00000000..3427c585 --- /dev/null +++ b/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 + + + diff --git a/scriptlib/help.tcl b/scriptlib/help.tcl new file mode 100644 index 00000000..6e1a0489 --- /dev/null +++ b/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 diff --git a/scriptlib/help_exit.tcl b/scriptlib/help_exit.tcl new file mode 100644 index 00000000..0ef0abfc --- /dev/null +++ b/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 diff --git a/scriptlib/netbox.tcl b/scriptlib/netbox.tcl new file mode 100644 index 00000000..bf43283e --- /dev/null +++ b/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] \ No newline at end of file diff --git a/scriptlib/pdf2text.tcl b/scriptlib/pdf2text.tcl index 83259d66..c29f0ff9 100644 --- a/scriptlib/pdf2text.tcl +++ b/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 diff --git a/scriptlib/punklogo.tcl b/scriptlib/punklogo.tcl new file mode 100644 index 00000000..742df928 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/scriptlib/requiremath.tcl b/scriptlib/requiremath.tcl index b3a6eb46..d5c255ec 100644 --- a/scriptlib/requiremath.tcl +++ b/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 diff --git a/scriptlib/showargs.tcl b/scriptlib/showargs.tcl index 31802c4f..50b60fa0 100644 --- a/scriptlib/showargs.tcl +++ b/scriptlib/showargs.tcl @@ -1,8 +1,13 @@ -#puts -nonewline stdout "info script\r\n" -#puts stdout "[info script]" -puts stdout "argc: $::argc" -puts stdout "argv one arg per line, each line followed by dotted line." -foreach a $::argv { - puts stdout $a - puts stdout [string repeat - 40] -} +#puts -nonewline stdout "info script\r\n" +#puts stdout "[info script]" +puts stdout "argc: $::argc" +puts stdout "argv one arg per line, each line followed by dotted line." +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 + diff --git a/scriptlib/stdout_per_second.tcl b/scriptlib/stdout_per_second.tcl index 2d4d3ccc..9e9ee4da 100644 --- a/scriptlib/stdout_per_second.tcl +++ b/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"]} { - 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 + + set chunk [string map [list \r\n \n \r \n] $chunk] + set chunklines [split $chunk \n] + foreach ln [lrange $chunklines 0 end-1] { + append b [string trim $ln] + if {[string tolower $b] eq "q"} { + set ::forever_stdout_per_second 0 + chan event $chan readable {} + puts stderr "cancelling" + if {$::ms > 500} { + after 0 ::the_end } } 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 "" - } else { - append b $chunk + append b [lindex $chunklines end] + } } if {[chan eof $chan]} { diff --git a/scriptlib/test1.tcl b/scriptlib/test1.tcl index 01003326..db1df669 100644 --- a/scriptlib/test1.tcl +++ b/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 { -puts stdout "-no stdin data read-" -} - + #chan configure stdin -encoding utf-32 + #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-" +#} diff --git a/scriptlib/tests/adhoc/aliases.tcl b/scriptlib/tests/adhoc/aliases.tcl index 2e023205..1a36b2c9 100644 --- a/scriptlib/tests/adhoc/aliases.tcl +++ b/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 diff --git a/scriptlib/tests/first_assign.tcl b/scriptlib/tests/first_assign.tcl index 9e7b8c18..d7201fcc 100644 --- a/scriptlib/tests/first_assign.tcl +++ b/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 "} diff --git a/scriptlib/tests/listbuilder.tcl b/scriptlib/tests/listbuilder.tcl index 7fd1a96f..81a1cb11 100644 --- a/scriptlib/tests/listbuilder.tcl +++ 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:" diff --git a/scriptlib/thread_interp.tcl b/scriptlib/thread_interp.tcl index cb2aa9cd..7ba06461 100644 --- a/scriptlib/thread_interp.tcl +++ b/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" -package require Thread -code1 eval {package require Thread} -code2 eval {package require Thread} +set tversion_code1 [code1 eval {package require Thread}] +set tversion_code2 [code2 eval {package require Thread}] +set tversion_parent [package require Thread] +#puts stdout "Thread version in parent interp: $tversion_parent" -puts stderr "establishing ::testfunc proc in all 3 interps" -code1 eval {proc ::testfunc {args} {puts stderr "evaluated in code1 interp: $args"}} -code2 eval {proc ::testfunc {args} {puts stderr "evaluated in code2 interp: $args"}} -proc ::testfunc {args} {puts stderr "evaluated in parent interp: $args"} +puts stdout "establishing ::testfunc proc in all interps" +code1 eval {proc ::testfunc {args} {puts stdout "evaluated in \x1b\[31mcode1\x1b\[m interp: $args"}} +code2 eval {proc ::testfunc {args} {puts stderr "evaluated in \x1b\[33mcode2\x1b\[m 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" -thread::send -async [thread::id] { - ::testfunc script sent from parent interp +puts stdout "sending scripts" + +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 -after 0 {::testfunc after script in parent interp} -code1 eval {after 0 {::testfunc after script in code1 interp}} -code2 eval {after 0 {::testfunc after script in code2 interp}} - +code2 eval { + package require Thread + thread::send -async [thread::id] { + ::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 diff --git a/scriptlib/tkhello.tcl b/scriptlib/tkhello.tcl new file mode 100644 index 00000000..78005071 --- /dev/null +++ b/scriptlib/tkhello.tcl @@ -0,0 +1,5 @@ +if {[catch {package require tk}]} { + package require Tk +} +label .label -text "Hello World" +pack .label diff --git a/scriptlib/tkhello_exit.tcl b/scriptlib/tkhello_exit.tcl new file mode 100644 index 00000000..cfe10ecb --- /dev/null +++ b/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