Julian Noble
2 months ago
60 changed files with 88641 additions and 3 deletions
@ -0,0 +1,259 @@ |
|||||||
|
|
||||||
|
# Tcl parser for optional arguments in function calls and |
||||||
|
# commandline arguments |
||||||
|
# |
||||||
|
# (c) 2001 Bastien Chevreux |
||||||
|
|
||||||
|
# Index of exported commands |
||||||
|
# - argp::registerArgs |
||||||
|
# - argp::setArgDefaults |
||||||
|
# - argp::setArgsNeeded |
||||||
|
# - argp::parseArgs |
||||||
|
|
||||||
|
# Internal commands |
||||||
|
# - argp::CheckValues |
||||||
|
|
||||||
|
# See end of file for an example on how to use |
||||||
|
|
||||||
|
package provide argp 0.2 |
||||||
|
|
||||||
|
namespace eval argp { |
||||||
|
variable Optstore |
||||||
|
variable Opttypes { |
||||||
|
boolean integer double string |
||||||
|
} |
||||||
|
|
||||||
|
namespace export {[a-z]*} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc argp::registerArgs { func arglist } { |
||||||
|
variable Opttypes |
||||||
|
variable Optstore |
||||||
|
|
||||||
|
set parentns [string range [uplevel 1 [list namespace current]] 2 end] |
||||||
|
if { $parentns != "" } { |
||||||
|
append caller $parentns :: $func |
||||||
|
} else { |
||||||
|
set caller $func |
||||||
|
} |
||||||
|
set cmangled [string map {:: _} $caller] |
||||||
|
|
||||||
|
#puts $parentns |
||||||
|
#puts $caller |
||||||
|
#puts $cmangled |
||||||
|
|
||||||
|
set Optstore(keys,$cmangled) {} |
||||||
|
set Optstore(deflist,$cmangled) {} |
||||||
|
set Optstore(argneeded,$cmangled) {} |
||||||
|
|
||||||
|
foreach arg $arglist { |
||||||
|
foreach {opt type default allowed} $arg { |
||||||
|
set optindex [lsearch -glob $Opttypes $type*] |
||||||
|
if { $optindex < 0} { |
||||||
|
return -code error "$caller, unknown type $type while registering arguments.\nAllowed types: [string trim $Opttypes]" |
||||||
|
} |
||||||
|
set type [lindex $Opttypes $optindex] |
||||||
|
|
||||||
|
lappend Optstore(keys,$cmangled) $opt |
||||||
|
set Optstore(type,$opt,$cmangled) $type |
||||||
|
set Optstore(default,$opt,$cmangled) $default |
||||||
|
set Optstore(allowed,$opt,$cmangled) $allowed |
||||||
|
lappend Optstore(deflist,$cmangled) $opt $default |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if { [catch {CheckValues $caller $cmangled $Optstore(deflist,$cmangled)} res]} { |
||||||
|
return -code error "Error in declaration of optional arguments.\n$res" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc argp::setArgDefaults { func arglist } { |
||||||
|
variable Optstore |
||||||
|
|
||||||
|
set parentns [string range [uplevel 1 [list namespace current]] 2 end] |
||||||
|
if { $parentns != "" } { |
||||||
|
append caller $parentns :: $func |
||||||
|
} else { |
||||||
|
set caller $func |
||||||
|
} |
||||||
|
set cmangled [string map {:: _} $caller] |
||||||
|
|
||||||
|
if {![info exists Optstore(deflist,$cmangled)]} { |
||||||
|
return -code error "Arguments for $caller not registered yet." |
||||||
|
} |
||||||
|
set Optstore(deflist,$cmangled) {} |
||||||
|
foreach {opt default} $arglist { |
||||||
|
if {![info exists Optstore(default,$opt,$cmangled)]} { |
||||||
|
return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)" |
||||||
|
} |
||||||
|
set Optstore(default,$opt,$cmangled) $default |
||||||
|
} |
||||||
|
|
||||||
|
# set the new defaultlist |
||||||
|
foreach opt $Optstore(keys,$cmangled) { |
||||||
|
lappend Optstore(deflist,$cmangled) $opt $Optstore(default,$opt,$cmangled) |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc argp::setArgsNeeded { func arglist } { |
||||||
|
variable Optstore |
||||||
|
|
||||||
|
set parentns [string range [uplevel 1 [list namespace current]] 2 end] |
||||||
|
if { $parentns != "" } { |
||||||
|
append caller $parentns :: $func |
||||||
|
} else { |
||||||
|
set caller $func |
||||||
|
} |
||||||
|
set cmangled [string map {:: _} $caller] |
||||||
|
|
||||||
|
#append caller $parentns :: $func |
||||||
|
#set cmangled ${parentns}_$func |
||||||
|
|
||||||
|
if {![info exists Optstore(deflist,$cmangled)]} { |
||||||
|
return -code error "Arguments for $caller not registered yet." |
||||||
|
} |
||||||
|
|
||||||
|
set Optstore(argneeded,$cmangled) {} |
||||||
|
foreach opt $arglist { |
||||||
|
if {![info exists Optstore(default,$opt,$cmangled)]} { |
||||||
|
return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)" |
||||||
|
} |
||||||
|
lappend Optstore(argneeded,$cmangled) $opt |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc argp::parseArgs { args } { |
||||||
|
variable Optstore |
||||||
|
|
||||||
|
if {[llength $args] == 0} { |
||||||
|
upvar args a opts o |
||||||
|
} else { |
||||||
|
upvar args a [lindex $args 0] o |
||||||
|
} |
||||||
|
|
||||||
|
if { [ catch { set caller [lindex [info level -1] 0]}]} { |
||||||
|
set caller "main program" |
||||||
|
set cmangled "" |
||||||
|
} else { |
||||||
|
set cmangled [string map {:: _} $caller] |
||||||
|
} |
||||||
|
|
||||||
|
if {![info exists Optstore(deflist,$cmangled)]} { |
||||||
|
return -code error "Arguments for $caller not registered yet." |
||||||
|
} |
||||||
|
|
||||||
|
# set the defaults |
||||||
|
array set o $Optstore(deflist,$cmangled) |
||||||
|
|
||||||
|
# but unset the needed arguments |
||||||
|
foreach key $Optstore(argneeded,$cmangled) { |
||||||
|
catch { unset o($key) } |
||||||
|
} |
||||||
|
|
||||||
|
foreach {key val} $a { |
||||||
|
if {![info exists Optstore(type,$key,$cmangled)]} { |
||||||
|
return -code error "$caller, unknown option $key, must be one of: $Optstore(keys,$cmangled)" |
||||||
|
} |
||||||
|
switch -exact -- $Optstore(type,$key,$cmangled) { |
||||||
|
boolean - |
||||||
|
integer { |
||||||
|
if { $val == "" } { |
||||||
|
return -code error "$caller, $key empty string is not $Optstore(type,$key,$cmangled) value." |
||||||
|
} |
||||||
|
if { ![string is $Optstore(type,$key,$cmangled) $val]} { |
||||||
|
return -code error "$caller, $key $val is not $Optstore(type,$key,$cmangled) value." |
||||||
|
} |
||||||
|
} |
||||||
|
double { |
||||||
|
if { $val == "" } { |
||||||
|
return -code error "$caller, $key empty string is not double value." |
||||||
|
} |
||||||
|
if { ![string is double $val]} { |
||||||
|
return -code error "$caller, $key $val is not double value." |
||||||
|
} |
||||||
|
if { [string is integer $val]} { |
||||||
|
set val [expr {$val + .0}] |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
} |
||||||
|
} |
||||||
|
set o($key) $val |
||||||
|
} |
||||||
|
|
||||||
|
foreach key $Optstore(argneeded,$cmangled) { |
||||||
|
if {![info exists o($key)]} { |
||||||
|
return -code error "$caller, needed argument $key was not given." |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if { [catch { CheckValues $caller $cmangled [array get o]} err]} { |
||||||
|
return -code error $err |
||||||
|
} |
||||||
|
|
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc argp::CheckValues { caller cmangled checklist } { |
||||||
|
variable Optstore |
||||||
|
|
||||||
|
#puts "Checking $checklist" |
||||||
|
|
||||||
|
foreach {key val} $checklist { |
||||||
|
if { [llength $Optstore(allowed,$key,$cmangled)] > 0 } { |
||||||
|
switch -exact -- $Optstore(type,$key,$cmangled) { |
||||||
|
string { |
||||||
|
if { [lsearch $Optstore(allowed,$key,$cmangled) $val] < 0} { |
||||||
|
return -code error "$caller, $key $val is not in allowed values: $Optstore(allowed,$key,$cmangled)" |
||||||
|
} |
||||||
|
} |
||||||
|
double - |
||||||
|
integer { |
||||||
|
set found 0 |
||||||
|
foreach range $Optstore(allowed,$key,$cmangled) { |
||||||
|
if {[llength $range] == 1} { |
||||||
|
if { $val == [lindex $range 0] } { |
||||||
|
set found 1 |
||||||
|
break |
||||||
|
} |
||||||
|
} elseif {[llength $range] == 2} { |
||||||
|
set low [lindex $range 0] |
||||||
|
set high [lindex $range 1] |
||||||
|
|
||||||
|
if { ![string is integer $low] \ |
||||||
|
&& [string compare "-" $low] != 0} { |
||||||
|
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a lower value range that is not integer and not \u00b4-\u00b4: $range" |
||||||
|
} |
||||||
|
if { ![string is integer $high] \ |
||||||
|
&& [string compare "+" $high] != 0} { |
||||||
|
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a upper value range that is not integer and not \u00b4+\u00b4: $range" |
||||||
|
} |
||||||
|
if {[string compare "-" $low] == 0} { |
||||||
|
if { [string compare "+" $high] == 0 \ |
||||||
|
|| $val <= $high } { |
||||||
|
set found 1 |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
if { $val >= $low } { |
||||||
|
if {[string compare "+" $high] == 0 \ |
||||||
|
|| $val <= $high } { |
||||||
|
set found 1 |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has an allowed value range containing more than 2 elements: $range" |
||||||
|
} |
||||||
|
} |
||||||
|
if { $found == 0 } { |
||||||
|
return -code error "$caller, $key $val is not covered by allowed ranges: $Optstore(allowed,$key,$cmangled)" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
@ -0,0 +1,306 @@ |
|||||||
|
# Debug - a debug narrative logger. |
||||||
|
# -- Colin McCormack / originally Wub server utilities |
||||||
|
# |
||||||
|
# Debugging areas of interest are represented by 'tokens' which have |
||||||
|
# independantly settable levels of interest (an integer, higher is more detailed) |
||||||
|
# |
||||||
|
# Debug narrative is provided as a tcl script whose value is [subst]ed in the |
||||||
|
# caller's scope if and only if the current level of interest matches or exceeds |
||||||
|
# the Debug call's level of detail. This is useful, as one can place arbitrarily |
||||||
|
# complex narrative in code without unnecessarily evaluating it. |
||||||
|
# |
||||||
|
# TODO: potentially different streams for different areas of interest. |
||||||
|
# (currently only stderr is used. there is some complexity in efficient |
||||||
|
# cross-threaded streams.) |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## Requisites |
||||||
|
|
||||||
|
package require Tcl 8.5- |
||||||
|
|
||||||
|
namespace eval ::debug { |
||||||
|
namespace export -clear \ |
||||||
|
define on off prefix suffix header trailer \ |
||||||
|
names 2array level setting parray pdict \ |
||||||
|
nl tab hexl |
||||||
|
namespace ensemble create -subcommands {} |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## API & Implementation |
||||||
|
|
||||||
|
proc ::debug::noop {args} {} |
||||||
|
|
||||||
|
proc ::debug::debug {tag message {level 1}} { |
||||||
|
variable detail |
||||||
|
if {$detail($tag) < $level} { |
||||||
|
#puts stderr "$tag @@@ $detail($tag) >= $level" |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
variable prefix |
||||||
|
variable suffix |
||||||
|
variable header |
||||||
|
variable trailer |
||||||
|
variable fds |
||||||
|
|
||||||
|
if {[info exists fds($tag)]} { |
||||||
|
set fd $fds($tag) |
||||||
|
} else { |
||||||
|
set fd stderr |
||||||
|
} |
||||||
|
|
||||||
|
# Assemble the shown text from the user message and the various |
||||||
|
# prefixes and suffices (global + per-tag). |
||||||
|
|
||||||
|
set themessage "" |
||||||
|
if {[info exists prefix(::)]} { append themessage $prefix(::) } |
||||||
|
if {[info exists prefix($tag)]} { append themessage $prefix($tag) } |
||||||
|
append themessage $message |
||||||
|
if {[info exists suffix($tag)]} { append themessage $suffix($tag) } |
||||||
|
if {[info exists suffix(::)]} { append themessage $suffix(::) } |
||||||
|
|
||||||
|
# Resolve variables references and command invokations embedded |
||||||
|
# into the message with plain text. |
||||||
|
set code [catch { |
||||||
|
set smessage [uplevel 1 [list ::subst -nobackslashes $themessage]] |
||||||
|
set sheader [uplevel 1 [list ::subst -nobackslashes $header]] |
||||||
|
set strailer [uplevel 1 [list ::subst -nobackslashes $trailer]] |
||||||
|
} __ eo] |
||||||
|
|
||||||
|
# And dump an internal error if that resolution failed. |
||||||
|
if {$code} { |
||||||
|
if {[catch { |
||||||
|
set caller [info level -1] |
||||||
|
}]} { set caller GLOBAL } |
||||||
|
if {[string length $caller] >= 1000} { |
||||||
|
set caller "[string range $caller 0 200]...[string range $caller end-200 end]" |
||||||
|
} |
||||||
|
foreach line [split $caller \n] { |
||||||
|
puts -nonewline $fd "@@(DebugError from $tag ($eo): $line)" |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# From here we have a good message to show. We only shorten it a |
||||||
|
# bit if its a bit excessive in size. |
||||||
|
|
||||||
|
if {[string length $smessage] > 4096} { |
||||||
|
set head [string range $smessage 0 2048] |
||||||
|
set tail [string range $smessage end-2048 end] |
||||||
|
set smessage "${head}...(truncated)...$tail" |
||||||
|
} |
||||||
|
|
||||||
|
foreach line [split $smessage \n] { |
||||||
|
puts $fd "$sheader$tag | $line$strailer" |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# names - return names of debug tags |
||||||
|
proc ::debug::names {} { |
||||||
|
variable detail |
||||||
|
return [lsort [array names detail]] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::2array {} { |
||||||
|
variable detail |
||||||
|
set result {} |
||||||
|
foreach n [lsort [array names detail]] { |
||||||
|
if {[interp alias {} debug.$n] ne "::debug::noop"} { |
||||||
|
lappend result $n $detail($n) |
||||||
|
} else { |
||||||
|
lappend result $n -$detail($n) |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
# level - set level and fd for tag |
||||||
|
proc ::debug::level {tag {level ""} {fd {}}} { |
||||||
|
variable detail |
||||||
|
# TODO: Force level >=0. |
||||||
|
if {$level ne ""} { |
||||||
|
set detail($tag) $level |
||||||
|
} |
||||||
|
|
||||||
|
if {![info exists detail($tag)]} { |
||||||
|
set detail($tag) 1 |
||||||
|
} |
||||||
|
|
||||||
|
variable fds |
||||||
|
if {$fd ne {}} { |
||||||
|
set fds($tag) $fd |
||||||
|
} |
||||||
|
|
||||||
|
return $detail($tag) |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::header {text} { variable header $text } |
||||||
|
proc ::debug::trailer {text} { variable trailer $text } |
||||||
|
|
||||||
|
proc ::debug::define {tag} { |
||||||
|
if {[interp alias {} debug.$tag] ne {}} return |
||||||
|
off $tag |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# Set a prefix/suffix to use for tag. |
||||||
|
# The global (tag-independent) prefix/suffix is adressed through tag '::'. |
||||||
|
# This works because colon (:) is an illegal character for user-specified tags. |
||||||
|
|
||||||
|
proc ::debug::prefix {tag {theprefix {}}} { |
||||||
|
variable prefix |
||||||
|
set prefix($tag) $theprefix |
||||||
|
|
||||||
|
if {[interp alias {} debug.$tag] ne {}} return |
||||||
|
off $tag |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::suffix {tag {theprefix {}}} { |
||||||
|
variable suffix |
||||||
|
set suffix($tag) $theprefix |
||||||
|
|
||||||
|
if {[interp alias {} debug.$tag] ne {}} return |
||||||
|
off $tag |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# turn on debugging for tag |
||||||
|
proc ::debug::on {tag {level ""} {fd {}}} { |
||||||
|
variable active |
||||||
|
set active($tag) 1 |
||||||
|
level $tag $level $fd |
||||||
|
interp alias {} debug.$tag {} ::debug::debug $tag |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# turn off debugging for tag |
||||||
|
proc ::debug::off {tag {level ""} {fd {}}} { |
||||||
|
variable active |
||||||
|
set active($tag) 1 |
||||||
|
level $tag $level $fd |
||||||
|
interp alias {} debug.$tag {} ::debug::noop |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::setting {args} { |
||||||
|
if {[llength $args] == 1} { |
||||||
|
set args [lindex $args 0] |
||||||
|
} |
||||||
|
set fd stderr |
||||||
|
if {[llength $args] % 2} { |
||||||
|
set fd [lindex $args end] |
||||||
|
set args [lrange $args 0 end-1] |
||||||
|
} |
||||||
|
foreach {tag level} $args { |
||||||
|
if {$level > 0} { |
||||||
|
level $tag $level $fd |
||||||
|
interp alias {} debug.$tag {} ::debug::debug $tag |
||||||
|
} else { |
||||||
|
level $tag [expr {-$level}] $fd |
||||||
|
interp alias {} debug.$tag {} ::debug::noop |
||||||
|
} |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## Convenience commands. |
||||||
|
# Format arrays and dicts as multi-line message. |
||||||
|
# Insert newlines and tabs. |
||||||
|
|
||||||
|
proc ::debug::nl {} { return \n } |
||||||
|
proc ::debug::tab {} { return \t } |
||||||
|
|
||||||
|
proc ::debug::parray {a {pattern *}} { |
||||||
|
upvar 1 $a array |
||||||
|
if {![array exists array]} { |
||||||
|
error "\"$a\" isn't an array" |
||||||
|
} |
||||||
|
pdict [array get array] $pattern |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::pdict {dict {pattern *}} { |
||||||
|
set maxl 0 |
||||||
|
set names [lsort -dict [dict keys $dict $pattern]] |
||||||
|
foreach name $names { |
||||||
|
if {[string length $name] > $maxl} { |
||||||
|
set maxl [string length $name] |
||||||
|
} |
||||||
|
} |
||||||
|
set maxl [expr {$maxl + 2}] |
||||||
|
set lines {} |
||||||
|
foreach name $names { |
||||||
|
set nameString [format (%s) $name] |
||||||
|
lappend lines [format "%-*s = %s" \ |
||||||
|
$maxl $nameString \ |
||||||
|
[dict get $dict $name]] |
||||||
|
} |
||||||
|
return [join $lines \n] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::hexl {data {prefix {}}} { |
||||||
|
set r {} |
||||||
|
|
||||||
|
# Convert the data to hex and to characters. |
||||||
|
binary scan $data H*@0a* hexa asciia |
||||||
|
|
||||||
|
# Replace non-printing characters in the data with dots. |
||||||
|
regsub -all -- {[^[:graph:] ]} $asciia {.} asciia |
||||||
|
|
||||||
|
# Pad with spaces to a full multiple of 32/16. |
||||||
|
set n [expr {[string length $hexa] % 32}] |
||||||
|
if {$n < 32} { append hexa [string repeat { } [expr {32-$n}]] } |
||||||
|
#puts "pad H [expr {32-$n}]" |
||||||
|
|
||||||
|
set n [expr {[string length $asciia] % 32}] |
||||||
|
if {$n < 16} { append asciia [string repeat { } [expr {16-$n}]] } |
||||||
|
#puts "pad A [expr {32-$n}]" |
||||||
|
|
||||||
|
# Reassemble formatted, in groups of 16 bytes/characters. |
||||||
|
# The hex part is handled in groups of 32 nibbles. |
||||||
|
set addr 0 |
||||||
|
while {[string length $hexa]} { |
||||||
|
# Get front group of 16 bytes each. |
||||||
|
set hex [string range $hexa 0 31] |
||||||
|
set ascii [string range $asciia 0 15] |
||||||
|
# Prep for next iteration |
||||||
|
set hexa [string range $hexa 32 end] |
||||||
|
set asciia [string range $asciia 16 end] |
||||||
|
|
||||||
|
# Convert the hex to pairs of hex digits |
||||||
|
regsub -all -- {..} $hex {& } hex |
||||||
|
|
||||||
|
# Add the hex and latin-1 data to the result buffer |
||||||
|
append r $prefix [format %04x $addr] { | } $hex { |} $ascii |\n |
||||||
|
incr addr 16 |
||||||
|
} |
||||||
|
|
||||||
|
# And done |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
|
||||||
|
namespace eval debug { |
||||||
|
variable detail ; # map: TAG -> level of interest |
||||||
|
variable prefix ; # map: TAG -> message prefix to use |
||||||
|
variable suffix ; # map: TAG -> message suffix to use |
||||||
|
variable fds ; # map: TAG -> handle of open channel to log to. |
||||||
|
variable header {} ; # per-line heading, subst'ed |
||||||
|
variable trailer {} ; # per-line ending, subst'ed |
||||||
|
|
||||||
|
# Notes: |
||||||
|
# - The tag '::' is reserved. "prefix" and "suffix" use it to store |
||||||
|
# the global message prefix / suffix. |
||||||
|
# - prefix and suffix are applied per message. |
||||||
|
# - header and trailer are per line. And should not generate multiple lines! |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## Ready |
||||||
|
|
||||||
|
package provide debug 1.0.6 |
||||||
|
return |
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,322 @@ |
|||||||
|
package provide funcl [namespace eval funcl { |
||||||
|
variable version |
||||||
|
set version 0.1 |
||||||
|
}] |
||||||
|
#funcl = function list (nested call structure) |
||||||
|
# |
||||||
|
#a basic functional composition o combinator |
||||||
|
#o(f,g)(x) == f(g(x)) |
||||||
|
|
||||||
|
namespace eval funcl { |
||||||
|
|
||||||
|
#from punk |
||||||
|
proc arg_is_script_shaped {arg} { |
||||||
|
if {[string first " " $arg] >= 0} { |
||||||
|
return 1 |
||||||
|
} elseif {[string first \n $arg] >= 0} { |
||||||
|
return 1 |
||||||
|
} elseif {[string first ";" $arg] >= 0} { |
||||||
|
return 1 |
||||||
|
} elseif {[string first \t $arg] >= 0} { |
||||||
|
return 1 |
||||||
|
} else { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc o args { |
||||||
|
set closing [string repeat {]} [expr [llength $args]-1]] |
||||||
|
set body "[join $args { [}] \$data $closing" |
||||||
|
return $body |
||||||
|
} |
||||||
|
|
||||||
|
proc o_ args { |
||||||
|
set body "" |
||||||
|
set tails [lrepeat [llength $args] ""] |
||||||
|
puts stdout "tails: $tails" |
||||||
|
|
||||||
|
set end [lindex $args end] |
||||||
|
if {[llength $end] == 1 && [arg_is_script_shaped $end]} { |
||||||
|
set endfunc [string map "<end> $end" {uplevel 1 [list if 1 <end> ]}] |
||||||
|
} else { |
||||||
|
set endfunc $end |
||||||
|
} |
||||||
|
if {[llength $args] == 1} { |
||||||
|
return $endfunc |
||||||
|
} |
||||||
|
|
||||||
|
set wrap { [} |
||||||
|
append wrap $endfunc |
||||||
|
append wrap { ]} |
||||||
|
|
||||||
|
set i 0 |
||||||
|
foreach cmdlist [lrange $args 0 end-1] { |
||||||
|
set is_script 0 |
||||||
|
if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} { |
||||||
|
set is_script 1 |
||||||
|
set script [lindex $cmdlist 0] |
||||||
|
} |
||||||
|
set t "" |
||||||
|
if {$i > 0} { |
||||||
|
append body { [} |
||||||
|
} |
||||||
|
set posn [lsearch $cmdlist _] |
||||||
|
if {$posn <= 0} { |
||||||
|
append body $cmdlist |
||||||
|
if {$i == [expr {[llength $args] -2}]} { |
||||||
|
#append body " \$data" |
||||||
|
append body " $wrap" |
||||||
|
} |
||||||
|
if {$i > 0} { |
||||||
|
set t {]} |
||||||
|
} |
||||||
|
} else { |
||||||
|
append body [lrange $cmdlist 0 $posn-1] |
||||||
|
if {$i == [expr {[llength $args] -2}]} { |
||||||
|
#append body " \$data" |
||||||
|
append body " $wrap" |
||||||
|
} |
||||||
|
set t [lrange $cmdlist $posn+1 end] |
||||||
|
if {$i > 0} { |
||||||
|
append t { ]} |
||||||
|
} |
||||||
|
} |
||||||
|
lset tails $i $t |
||||||
|
incr i |
||||||
|
} |
||||||
|
append body [join [lreverse $tails] " "] |
||||||
|
puts stdout "tails: $tails" |
||||||
|
|
||||||
|
return $body |
||||||
|
} |
||||||
|
|
||||||
|
#review - consider _call -- if count > 1 then they must all be callable cmdlists(?) |
||||||
|
# what does it mean to have additional _fn wrapper with no other elements? (no actual function) |
||||||
|
#e.g _fn 2 5 6 somefunc {_fn 1 3 {_call 1 3 xxx}} {_fn 1 4 command {_fn ...}} |
||||||
|
# what type indicates running subtrees in parallel vs sequentially? |
||||||
|
# any reason to have _call count other than 1? Presumably the parent node indicates the parallelism/sequentialism etc. |
||||||
|
# |
||||||
|
# |
||||||
|
# accept or return a funcl (or funcltree if multiple funcls in one commandlist) |
||||||
|
# also accept/return a call - return empty list if passed a call |
||||||
|
proc next_funcl {funcl_or_tree} { |
||||||
|
if {[lindex $funcl_or_tree 0] eq "_call"} { |
||||||
|
return [list] |
||||||
|
} |
||||||
|
if {[lindex $funcl_or_tree 0] in [list "_fn" "_call"]} { |
||||||
|
set funcl $funcl_or_tree |
||||||
|
} else { |
||||||
|
error "funcltree not implemented" |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
set count [lindex $funcl 1] |
||||||
|
if {$count == 0} { |
||||||
|
#null funcl.. what is it? metadata/placeholder? |
||||||
|
return $funcl |
||||||
|
} |
||||||
|
set indices [lrange $funcl 2 [expr {1 + $count}]] |
||||||
|
set i 0 |
||||||
|
foreach idx $indices { |
||||||
|
if {$i > 0} { |
||||||
|
#todo - return a funcltree |
||||||
|
error "multi funcl not implemented" |
||||||
|
} |
||||||
|
set next [lindex $funcl $idx] |
||||||
|
incr i |
||||||
|
} |
||||||
|
|
||||||
|
return $next |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
#convert a funcl to a tcl script |
||||||
|
proc funcl_script {funcl} { |
||||||
|
if {![llength $funcl]} { |
||||||
|
return "" |
||||||
|
} |
||||||
|
set body "" |
||||||
|
set tails [list] |
||||||
|
|
||||||
|
set type [lindex $funcl 0] |
||||||
|
if {$type ni [list "_fn" "_call"]} { |
||||||
|
#todo - handle funcltree |
||||||
|
error "type $type not implemented" |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#only count of 1 with index 3 supported(?) |
||||||
|
if {$type eq "_call"} { |
||||||
|
#leaf |
||||||
|
set cmdlist [lindex $funcl 3] |
||||||
|
return $cmdlist |
||||||
|
} |
||||||
|
|
||||||
|
#we will use next_funcl to walk the nodes.. todo support treefuncl response from next_funcl which could branch multiple times. |
||||||
|
#by continually passing back the resulting treefuncl/funcl to next_funcl we can process in correct order (?) |
||||||
|
# we would still need to maintain state to stitch it back together once returned from a subtree.. |
||||||
|
# ie multiple tail parts |
||||||
|
set count [lindex $funcl 1] |
||||||
|
|
||||||
|
if {$count == 1} { |
||||||
|
set idx [lindex $funcl 2] |
||||||
|
if {$idx == 3} { |
||||||
|
set cmdlist_pre [list] |
||||||
|
} else { |
||||||
|
set cmdlist_pre [lrange $funcl 3 $idx-1] |
||||||
|
} |
||||||
|
append body $cmdlist_pre |
||||||
|
set t [lrange $funcl $idx+1 end] |
||||||
|
lappend tails $t |
||||||
|
} else { |
||||||
|
#?? |
||||||
|
error "funcl_script branching not yet supported" |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
set get_next 1 |
||||||
|
set i 1 |
||||||
|
while {$get_next} { |
||||||
|
set funcl [next_funcl $funcl] |
||||||
|
if {![llength $funcl]} { |
||||||
|
set get_next 0 |
||||||
|
} |
||||||
|
lassign $funcl type count idx ;#todo support count > 1 |
||||||
|
if {$type eq "_call"} { |
||||||
|
set get_next 0 |
||||||
|
} |
||||||
|
set t "" |
||||||
|
if {$type eq "_call"} { |
||||||
|
append body { [} |
||||||
|
append body [lindex $funcl $idx] |
||||||
|
append body { ]} |
||||||
|
} else { |
||||||
|
append body { [} |
||||||
|
if {$idx == 3} { |
||||||
|
set cmdlist_pre [list] |
||||||
|
} else { |
||||||
|
set cmdlist_pre [lrange $funcl 3 $idx-1] |
||||||
|
} |
||||||
|
append body $cmdlist_pre |
||||||
|
set t [lrange $funcl $idx+1 end] |
||||||
|
lappend tails $t |
||||||
|
lappend tails { ]} |
||||||
|
} |
||||||
|
incr i |
||||||
|
} |
||||||
|
append body [join [lreverse $tails] " "] |
||||||
|
#puts stdout "tails: $tails" |
||||||
|
|
||||||
|
return $body |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
interp alias "" o_of "" funcl::o_of_n 1 |
||||||
|
|
||||||
|
#o_of_n |
||||||
|
#tcl list rep o combinator |
||||||
|
# |
||||||
|
# can take lists of ordinary commandlists, scripts and funcls |
||||||
|
# _fn 1 x where 1 indicates number of subfuncls and where x indicates next funcl position (_fn list or _arg) |
||||||
|
# _fn 0 indicates next item is an unwrapped commandlist (terminal command) |
||||||
|
# |
||||||
|
#o_of is equivalent to o_of_n 1 (1 argument o combinator) |
||||||
|
#last n args are passed to the prior function |
||||||
|
#e.g for n=1 f a b = f(a(b)) |
||||||
|
#e.g for n=2, e f a b = e(f(a b)) |
||||||
|
proc o_of_n {n args} { |
||||||
|
puts stdout "o_of_n '$args'" |
||||||
|
if {$n != 1} { |
||||||
|
error "o_of_n only implemented for 1 sub-funcl" |
||||||
|
} |
||||||
|
set comp [list] ;#composition list |
||||||
|
set end [lindex $args end] |
||||||
|
if {[lindex $end 0] in {_fn _call}]} { |
||||||
|
#is_funcl |
||||||
|
set endfunc [lindex $args end] |
||||||
|
} else { |
||||||
|
if {[llength $end] == 1 && [arg_is_script_shaped $end]} { |
||||||
|
#set endfunc [string map [list <end> $end] {uplevel 1 [list if 1 <end> ]}] |
||||||
|
set endfunc [list _call 1 3 [list uplevel 1 [list if 1 [lindex $end 0]]]] |
||||||
|
} else { |
||||||
|
set endfunc [list _call 1 3 [list {*}$end]] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {[llength $args] == 1} { |
||||||
|
return $endfunc |
||||||
|
} |
||||||
|
set comp $endfunc |
||||||
|
set revlist [lreverse [lrange $args 0 end-1]] |
||||||
|
foreach cmdlist $revlist { |
||||||
|
puts stderr "o_of_n >>-- $cmdlist" |
||||||
|
if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} { |
||||||
|
set is_script 1 |
||||||
|
set script [lindex $cmdlist 0] |
||||||
|
set arglist [list data] |
||||||
|
|
||||||
|
set comp [list _fn 1 6 call_script $script $arglist $comp] |
||||||
|
} else { |
||||||
|
set posn1 [expr {[llength $cmdlist] + 2 + $n}] |
||||||
|
set comp [list _fn $n $posn1 {*}$cmdlist $comp] |
||||||
|
} |
||||||
|
} |
||||||
|
return $comp |
||||||
|
} |
||||||
|
proc call_script {script argnames args} { |
||||||
|
uplevel 3 [list if 1 [list apply [list $argnames $script] {*}$args]] |
||||||
|
} |
||||||
|
proc funcl_script_test {scr} { |
||||||
|
do_funcl_script_test $scr |
||||||
|
} |
||||||
|
proc do_funcl_script_test {scr} { |
||||||
|
#set j "in do_funcl_script_test" |
||||||
|
#set data "xxx" |
||||||
|
#puts '$scr' |
||||||
|
if 1 $scr |
||||||
|
} |
||||||
|
|
||||||
|
#standard o_ with no script-handling |
||||||
|
proc o_plain args { |
||||||
|
set body "" |
||||||
|
set i 0 |
||||||
|
set tails [lrepeat [llength $args] ""] |
||||||
|
#puts stdout "tails: $tails" |
||||||
|
foreach cmdlist $args { |
||||||
|
set t "" |
||||||
|
if {$i > 0} { |
||||||
|
append body { [} |
||||||
|
} |
||||||
|
set posn [lsearch $cmdlist _] |
||||||
|
if {$posn <= 0} { |
||||||
|
append body $cmdlist |
||||||
|
if {$i == [expr {[llength $args] -1}]} { |
||||||
|
append body " \$data" |
||||||
|
} |
||||||
|
if {$i > 0} { |
||||||
|
set t {]} |
||||||
|
} |
||||||
|
} else { |
||||||
|
append body [lrange $cmdlist 0 $posn-1] |
||||||
|
if {$i == [expr {[llength $args] -1}]} { |
||||||
|
append body " \$data" |
||||||
|
} |
||||||
|
set t [lrange $cmdlist $posn+1 end] |
||||||
|
if {$i > 0} { |
||||||
|
append t { ]} |
||||||
|
} |
||||||
|
} |
||||||
|
lset tails $i $t |
||||||
|
incr i |
||||||
|
} |
||||||
|
append body [join [lreverse $tails] " "] |
||||||
|
#puts stdout "tails: $tails" |
||||||
|
|
||||||
|
return $body |
||||||
|
} |
||||||
|
#timings suggest no faster to split out the first item from the cmdlist loop |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,645 @@ |
|||||||
|
package provide patterncmd [namespace eval patterncmd { |
||||||
|
variable version |
||||||
|
|
||||||
|
set version 1.2.4 |
||||||
|
}] |
||||||
|
|
||||||
|
|
||||||
|
namespace eval pattern { |
||||||
|
variable idCounter 1 ;#used by pattern::uniqueKey |
||||||
|
|
||||||
|
namespace eval cmd { |
||||||
|
namespace eval util { |
||||||
|
package require overtype |
||||||
|
variable colwidths_lib [dict create] |
||||||
|
variable colwidths_lib_default 15 |
||||||
|
|
||||||
|
dict set colwidths_lib "library" [list ch " " num 21 head "|" tail ""] |
||||||
|
dict set colwidths_lib "version" [list ch " " num 7 head "|" tail ""] |
||||||
|
dict set colwidths_lib "type" [list ch " " num 9 head "|" tail ""] |
||||||
|
dict set colwidths_lib "note" [list ch " " num 31 head "|" tail "|"] |
||||||
|
|
||||||
|
proc colhead {type args} { |
||||||
|
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths |
||||||
|
set line "" |
||||||
|
foreach colname [dict keys $colwidths] { |
||||||
|
append line "[col $type $colname [string totitle $colname] {*}$args]" |
||||||
|
} |
||||||
|
return $line |
||||||
|
} |
||||||
|
proc colbreak {type} { |
||||||
|
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths |
||||||
|
set line "" |
||||||
|
foreach colname [dict keys $colwidths] { |
||||||
|
append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]" |
||||||
|
} |
||||||
|
return $line |
||||||
|
} |
||||||
|
proc col {type col val args} { |
||||||
|
# args -head bool -tail bool ? |
||||||
|
#---------------------------------------------------------------------------- |
||||||
|
set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify] |
||||||
|
dict set default -backchar "" |
||||||
|
dict set default -headchar "" |
||||||
|
dict set default -tailchar "" |
||||||
|
dict set default -headoverridechar "" |
||||||
|
dict set default -tailoverridechar "" |
||||||
|
dict set default -justify "left" |
||||||
|
if {([llength $args] % 2) != 0} { |
||||||
|
error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' " |
||||||
|
} |
||||||
|
foreach {k v} $args { |
||||||
|
if {$k ni $known_opts} { |
||||||
|
error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'" |
||||||
|
} |
||||||
|
} |
||||||
|
set opts [dict merge $default $args] |
||||||
|
set backchar [dict get $opts -backchar] |
||||||
|
set headchar [dict get $opts -headchar] |
||||||
|
set tailchar [dict get $opts -tailchar] |
||||||
|
set headoverridechar [dict get $opts -headoverridechar] |
||||||
|
set tailoverridechar [dict get $opts -tailoverridechar] |
||||||
|
set justify [dict get $opts -justify] |
||||||
|
#---------------------------------------------------------------------------- |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths |
||||||
|
#calculate headwidths |
||||||
|
set headwidth 0 |
||||||
|
set tailwidth 0 |
||||||
|
foreach {key def} $colwidths { |
||||||
|
set thisheadlen [string length [dict get $def head]] |
||||||
|
if {$thisheadlen > $headwidth} { |
||||||
|
set headwidth $thisheadlen |
||||||
|
} |
||||||
|
set thistaillen [string length [dict get $def tail]] |
||||||
|
if {$thistaillen > $tailwidth} { |
||||||
|
set tailwidth $thistaillen |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
set spec [dict get $colwidths $col] |
||||||
|
if {[string length $backchar]} { |
||||||
|
set ch $backchar |
||||||
|
} else { |
||||||
|
set ch [dict get $spec ch] |
||||||
|
} |
||||||
|
set num [dict get $spec num] |
||||||
|
set headchar [dict get $spec head] |
||||||
|
set tailchar [dict get $spec tail] |
||||||
|
|
||||||
|
if {[string length $headchar]} { |
||||||
|
set headchar $headchar |
||||||
|
} |
||||||
|
if {[string length $tailchar]} { |
||||||
|
set tailchar $tailchar |
||||||
|
} |
||||||
|
#overrides only apply if the head/tail has a length |
||||||
|
if {[string length $headchar]} { |
||||||
|
if {[string length $headoverridechar]} { |
||||||
|
set headchar $headoverridechar |
||||||
|
} |
||||||
|
} |
||||||
|
if {[string length $tailchar]} { |
||||||
|
if {[string length $tailoverridechar]} { |
||||||
|
set tailchar $tailoverridechar |
||||||
|
} |
||||||
|
} |
||||||
|
set head [string repeat $headchar $headwidth] |
||||||
|
set tail [string repeat $tailchar $tailwidth] |
||||||
|
|
||||||
|
set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]] |
||||||
|
if {$justify eq "left"} { |
||||||
|
set left_done [overtype::left $base "$head$val"] |
||||||
|
return [overtype::right $left_done "$tail"] |
||||||
|
} elseif {$justify in {centre center}} { |
||||||
|
set mid_done [overtype::centre $base $val] |
||||||
|
set left_mid_done [overtype::left $mid_done $head] |
||||||
|
return [overtype::right $left_mid_done $tail] |
||||||
|
} else { |
||||||
|
set right_done [overtype::right $base "$val$tail"] |
||||||
|
return [overtype::left $right_done $head] |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
#package require pattern |
||||||
|
|
||||||
|
proc ::pattern::libs {} { |
||||||
|
set libs [list \ |
||||||
|
pattern {-type core -note "alternative:pattern2"}\ |
||||||
|
pattern2 {-type core -note "alternative:pattern"}\ |
||||||
|
patterncmd {-type core}\ |
||||||
|
metaface {-type core}\ |
||||||
|
patternpredator2 {-type core}\ |
||||||
|
patterndispatcher {-type core}\ |
||||||
|
patternlib {-type core}\ |
||||||
|
patterncipher {-type optional -note optional}\ |
||||||
|
] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
package require overtype |
||||||
|
set result "" |
||||||
|
|
||||||
|
append result "[cmd::util::colbreak lib]\n" |
||||||
|
append result "[cmd::util::colhead lib -justify centre]\n" |
||||||
|
append result "[cmd::util::colbreak lib]\n" |
||||||
|
foreach libname [dict keys $libs] { |
||||||
|
set libinfo [dict get $libs $libname] |
||||||
|
|
||||||
|
append result [cmd::util::col lib library $libname] |
||||||
|
if {[catch [list package present $libname] ver]} { |
||||||
|
append result [cmd::util::col lib version "N/A"] |
||||||
|
} else { |
||||||
|
append result [cmd::util::col lib version $ver] |
||||||
|
} |
||||||
|
append result [cmd::util::col lib type [dict get $libinfo -type]] |
||||||
|
|
||||||
|
if {[dict exists $libinfo -note]} { |
||||||
|
set note [dict get $libinfo -note] |
||||||
|
} else { |
||||||
|
set note "" |
||||||
|
} |
||||||
|
append result [cmd::util::col lib note $note] |
||||||
|
append result "\n" |
||||||
|
} |
||||||
|
append result "[cmd::util::colbreak lib]\n" |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
proc ::pattern::record {recname fields} { |
||||||
|
if {[uplevel 1 [list namespace which $recname]] ne ""} { |
||||||
|
error "(pattern::record) Can't create command '$recname': A command of that name already exists" |
||||||
|
} |
||||||
|
|
||||||
|
set index -1 |
||||||
|
set accessor [list ::apply { |
||||||
|
{index rec args} |
||||||
|
{ |
||||||
|
if {[llength $args] == 0} { |
||||||
|
return [lindex $rec $index] |
||||||
|
} |
||||||
|
if {[llength $args] == 1} { |
||||||
|
return [lreplace $rec $index $index [lindex $args 0]] |
||||||
|
} |
||||||
|
error "Invalid number of arguments." |
||||||
|
} |
||||||
|
|
||||||
|
}] |
||||||
|
|
||||||
|
set map {} |
||||||
|
foreach field $fields { |
||||||
|
dict set map $field [linsert $accessor end [incr index]] |
||||||
|
} |
||||||
|
uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] |
||||||
|
} |
||||||
|
proc ::pattern::record2 {recname fields} { |
||||||
|
if {[uplevel 1 [list namespace which $recname]] ne ""} { |
||||||
|
error "(pattern::record) Can't create command '$recname': A command of that name already exists" |
||||||
|
} |
||||||
|
|
||||||
|
set index -1 |
||||||
|
set accessor [list ::apply] |
||||||
|
|
||||||
|
set template { |
||||||
|
{rec args} |
||||||
|
{ |
||||||
|
if {[llength $args] == 0} { |
||||||
|
return [lindex $rec %idx%] |
||||||
|
} |
||||||
|
if {[llength $args] == 1} { |
||||||
|
return [lreplace $rec %idx% %idx% [lindex $args 0]] |
||||||
|
} |
||||||
|
error "Invalid number of arguments." |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set map {} |
||||||
|
foreach field $fields { |
||||||
|
set body [string map [list %idx% [incr index]] $template] |
||||||
|
dict set map $field [list ::apply $body] |
||||||
|
} |
||||||
|
uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::argstest {args} { |
||||||
|
package require cmdline |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
proc ::pattern::objects {} { |
||||||
|
set result [::list] |
||||||
|
|
||||||
|
foreach ns [namespace children ::pp] { |
||||||
|
#lappend result [::list [namespace tail $ns] [set ${ns}::(self)]] |
||||||
|
set ch [namespace tail $ns] |
||||||
|
if {[string range $ch 0 2] eq "Obj"} { |
||||||
|
set OID [string range $ch 3 end] ;#OID need not be digits (!?) |
||||||
|
lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
proc ::pattern::name {num} { |
||||||
|
#!todo - fix |
||||||
|
#set ::p::${num}::(self) |
||||||
|
|
||||||
|
lassign [interp alias {} ::p::$num] _predator info |
||||||
|
if {![string length $_predator$info]} { |
||||||
|
error "No object found for num:$num (no interp alias for ::p::$num)" |
||||||
|
} |
||||||
|
set invocants [dict get $info i] |
||||||
|
set invocants_with_role_this [dict get $invocants this] |
||||||
|
set invocant_this [lindex $invocants_with_role_this 0] |
||||||
|
|
||||||
|
|
||||||
|
#lassign $invocant_this id info |
||||||
|
#set map [dict get $info map] |
||||||
|
#set fields [lindex $map 0] |
||||||
|
lassign $invocant_this _id _ns _defaultmethod name _etc |
||||||
|
return $name |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::pattern::with {cmd script} { |
||||||
|
foreach c [info commands ::p::-1::*] { |
||||||
|
interp alias {} [namespace tail $c] {} $c $cmd |
||||||
|
} |
||||||
|
interp alias {} . {} $cmd . |
||||||
|
interp alias {} .. {} $cmd .. |
||||||
|
|
||||||
|
return [uplevel 1 $script] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#system diagnostics etc |
||||||
|
|
||||||
|
proc ::pattern::varspace_list {IID} { |
||||||
|
namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables |
||||||
|
|
||||||
|
set varspaces [list] |
||||||
|
dict for {vname vdef} $o_variables { |
||||||
|
set vs [dict get $vdef varspace] |
||||||
|
if {$vs ni $varspaces} { |
||||||
|
lappend varspaces $vs |
||||||
|
} |
||||||
|
} |
||||||
|
if {$o_varspace ni $varspaces} { |
||||||
|
lappend varspaces $o_varspace |
||||||
|
} |
||||||
|
return $varspaces |
||||||
|
} |
||||||
|
|
||||||
|
proc ::pattern::check_interfaces {} { |
||||||
|
foreach ns [namespace children ::p] { |
||||||
|
set IID [namespace tail $ns] |
||||||
|
if {[string is digit $IID]} { |
||||||
|
foreach ref [array names ${ns}::_iface::o_usedby] { |
||||||
|
set OID [string range $ref 1 end] |
||||||
|
if {![namespace exists ::p::${OID}::_iface]} { |
||||||
|
puts -nonewline stdout "\r\nPROBLEM!!!!!!!!! nonexistant/invalid object $OID referenced by Interface $IID\r\n" |
||||||
|
} else { |
||||||
|
puts -nonewline stdout . |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#if {![info exists ::p::${OID}::(self)]} { |
||||||
|
# puts "PROBLEM!!!!!!!!! nonexistant object $OID referenced by Interface $IID" |
||||||
|
#} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
puts -nonewline stdout "\r\n" |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#from: http://wiki.tcl.tk/8766 (Introspection on aliases) |
||||||
|
#usedby: metaface-1.1.6+ |
||||||
|
#required because aliases can be renamed. |
||||||
|
#A renamed alias will still return it's target with 'interp alias {} oldname' |
||||||
|
# - so given newname - we require which_alias to return the same info. |
||||||
|
proc ::pattern::which_alias {cmd} { |
||||||
|
uplevel 1 [list ::trace add execution $cmd enterstep ::error] |
||||||
|
catch {uplevel 1 $cmd} res |
||||||
|
uplevel 1 [list ::trace remove execution $cmd enterstep ::error] |
||||||
|
#puts stdout "which_alias $cmd returning '$res'" |
||||||
|
return $res |
||||||
|
} |
||||||
|
# [info args] like proc following an alias recursivly until it reaches |
||||||
|
# the proc it originates from or cannot determine it. |
||||||
|
# accounts for default parameters set by interp alias |
||||||
|
# |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
proc ::pattern::aliasargs {cmd} { |
||||||
|
set orig $cmd |
||||||
|
|
||||||
|
set defaultargs [list] |
||||||
|
|
||||||
|
# loop until error or return occurs |
||||||
|
while {1} { |
||||||
|
# is it a proc already? |
||||||
|
if {[string equal [info procs $cmd] $cmd]} { |
||||||
|
set result [info args $cmd] |
||||||
|
# strip off the interp set default args |
||||||
|
return [lrange $result [llength $defaultargs] end] |
||||||
|
} |
||||||
|
# is it a built in or extension command we can get no args for? |
||||||
|
if {![string equal [info commands $cmd] $cmd]} { |
||||||
|
error "\"$orig\" isn't a procedure" |
||||||
|
} |
||||||
|
|
||||||
|
# catch bogus cmd names |
||||||
|
if {[lsearch [interp aliases {}] $cmd]==-1} { |
||||||
|
if {[catch {::pattern::which_alias $cmd} alias]} { |
||||||
|
error "\"$orig\" isn't a procedure or alias or command" |
||||||
|
} |
||||||
|
#set cmd [lindex $alias 0] |
||||||
|
if {[llength $alias]>1} { |
||||||
|
set cmd [lindex $alias 0] |
||||||
|
set defaultargs [concat [lrange $alias 1 end] $defaultargs] |
||||||
|
} else { |
||||||
|
set cmd $alias |
||||||
|
} |
||||||
|
} else { |
||||||
|
|
||||||
|
if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { |
||||||
|
# check if it is aliased in from another interpreter |
||||||
|
if {[catch {interp target {} $cmd} msg]} { |
||||||
|
error "Cannot resolve \"$orig\", alias leads to another interpreter." |
||||||
|
} |
||||||
|
if {$msg != {} } { |
||||||
|
error "Not recursing into slave interpreter \"$msg\".\ |
||||||
|
\"$orig\" could not be resolved." |
||||||
|
} |
||||||
|
# check if defaults are set for the alias |
||||||
|
if {[llength $cmdargs]>1} { |
||||||
|
set cmd [lindex $cmdargs 0] |
||||||
|
set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] |
||||||
|
} else { |
||||||
|
set cmd $cmdargs |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
proc ::pattern::aliasbody {cmd} { |
||||||
|
set orig $cmd |
||||||
|
|
||||||
|
set defaultargs [list] |
||||||
|
|
||||||
|
# loop until error or return occurs |
||||||
|
while {1} { |
||||||
|
# is it a proc already? |
||||||
|
if {[string equal [info procs $cmd] $cmd]} { |
||||||
|
set result [info body $cmd] |
||||||
|
# strip off the interp set default args |
||||||
|
return $result |
||||||
|
#return [lrange $result [llength $defaultargs] end] |
||||||
|
} |
||||||
|
# is it a built in or extension command we can get no args for? |
||||||
|
if {![string equal [info commands $cmd] $cmd]} { |
||||||
|
error "\"$orig\" isn't a procedure" |
||||||
|
} |
||||||
|
|
||||||
|
# catch bogus cmd names |
||||||
|
if {[lsearch [interp aliases {}] $cmd]==-1} { |
||||||
|
if {[catch {::pattern::which_alias $cmd} alias]} { |
||||||
|
error "\"$orig\" isn't a procedure or alias or command" |
||||||
|
} |
||||||
|
#set cmd [lindex $alias 0] |
||||||
|
if {[llength $alias]>1} { |
||||||
|
set cmd [lindex $alias 0] |
||||||
|
set defaultargs [concat [lrange $alias 1 end] $defaultargs] |
||||||
|
} else { |
||||||
|
set cmd $alias |
||||||
|
} |
||||||
|
} else { |
||||||
|
|
||||||
|
if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { |
||||||
|
# check if it is aliased in from another interpreter |
||||||
|
if {[catch {interp target {} $cmd} msg]} { |
||||||
|
error "Cannot resolve \"$orig\", alias leads to another interpreter." |
||||||
|
} |
||||||
|
if {$msg != {} } { |
||||||
|
error "Not recursing into slave interpreter \"$msg\".\ |
||||||
|
\"$orig\" could not be resolved." |
||||||
|
} |
||||||
|
# check if defaults are set for the alias |
||||||
|
if {[llength $cmdargs]>1} { |
||||||
|
set cmd [lindex $cmdargs 0] |
||||||
|
set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] |
||||||
|
} else { |
||||||
|
set cmd $cmdargs |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
proc ::pattern::uniqueKey2 {} { |
||||||
|
#!todo - something else?? |
||||||
|
return [clock seconds]-[incr ::pattern::idCounter] |
||||||
|
} |
||||||
|
|
||||||
|
#used by patternlib package |
||||||
|
proc ::pattern::uniqueKey {} { |
||||||
|
return [incr ::pattern::idCounter] |
||||||
|
#uuid with tcllibc is about 30us compared with 2us |
||||||
|
# for large datasets, e.g about 100K inserts this would be pretty noticable! |
||||||
|
#!todo - uuid pool with background thread to repopulate when idle? |
||||||
|
#return [uuid::uuid generate] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#------------------------------------------------------------------------------------------------------------------------- |
||||||
|
|
||||||
|
proc ::pattern::test1 {} { |
||||||
|
set msg "OK" |
||||||
|
|
||||||
|
puts stderr "next line should say:'--- saystuff:$msg" |
||||||
|
::>pattern .. Create ::>thing |
||||||
|
|
||||||
|
::>thing .. PatternMethod saystuff args { |
||||||
|
puts stderr "--- saystuff: $args" |
||||||
|
} |
||||||
|
::>thing .. Create ::>jjj |
||||||
|
|
||||||
|
::>jjj . saystuff $msg |
||||||
|
::>jjj .. Destroy |
||||||
|
::>thing .. Destroy |
||||||
|
} |
||||||
|
|
||||||
|
proc ::pattern::test2 {} { |
||||||
|
set msg "OK" |
||||||
|
|
||||||
|
puts stderr "next line should say:'--- property 'stuff' value:$msg" |
||||||
|
::>pattern .. Create ::>thing |
||||||
|
|
||||||
|
::>thing .. PatternProperty stuff $msg |
||||||
|
|
||||||
|
::>thing .. Create ::>jjj |
||||||
|
|
||||||
|
puts stderr "--- property 'stuff' value:[::>jjj . stuff]" |
||||||
|
::>jjj .. Destroy |
||||||
|
::>thing .. Destroy |
||||||
|
} |
||||||
|
|
||||||
|
proc ::pattern::test3 {} { |
||||||
|
set msg "OK" |
||||||
|
|
||||||
|
puts stderr "next line should say:'--- property 'stuff' value:$msg" |
||||||
|
::>pattern .. Create ::>thing |
||||||
|
|
||||||
|
::>thing .. Property stuff $msg |
||||||
|
|
||||||
|
puts stderr "--- property 'stuff' value:[::>thing . stuff]" |
||||||
|
::>thing .. Destroy |
||||||
|
} |
||||||
|
|
||||||
|
#--------------------------------- |
||||||
|
#unknown/obsolete |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args} |
||||||
|
if {0} { |
||||||
|
proc ::p::internals::new_interface {{usedbylist {}}} { |
||||||
|
set OID [incr ::p::ID] |
||||||
|
::p::internals::new_object ::p::ifaces::>$OID "" $OID |
||||||
|
puts "obsolete >> new_interface created object $OID" |
||||||
|
foreach usedby $usedbylist { |
||||||
|
set ::p::${OID}::_iface::o_usedby(i$usedby) 1 |
||||||
|
} |
||||||
|
set ::p::${OID}::_iface::o_varspace "" ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace) |
||||||
|
#NOTE - o_varspace is only the default varspace for when new methods/properties are added. |
||||||
|
# it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value. |
||||||
|
|
||||||
|
set ::p::${OID}::_iface::o_constructor [list] |
||||||
|
set ::p::${OID}::_iface::o_variables [list] |
||||||
|
set ::p::${OID}::_iface::o_properties [dict create] |
||||||
|
set ::p::${OID}::_iface::o_methods [dict create] |
||||||
|
array set ::p::${OID}::_iface::o_definition [list] |
||||||
|
set ::p::${OID}::_iface::o_open 1 ;#open for extending |
||||||
|
return $OID |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#temporary way to get OID - assumes single 'this' invocant |
||||||
|
#!todo - make generic. |
||||||
|
proc ::pattern::get_oid {_ID_} { |
||||||
|
#puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]" |
||||||
|
return [lindex [dict get $_ID_ i this] 0 0] |
||||||
|
|
||||||
|
#set invocants [dict get $_ID_ i] |
||||||
|
#set invocant_roles [dict keys $invocants] |
||||||
|
#set role_members [dict get $invocants this] |
||||||
|
##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list. |
||||||
|
#set this_invocant [lindex [dict get $_ID_ i this] 0] ; |
||||||
|
#lassign $this_invocant OID this_info |
||||||
|
# |
||||||
|
#return $OID |
||||||
|
} |
||||||
|
|
||||||
|
#compile the uncompiled level1 interface |
||||||
|
#assert: no more than one uncompiled interface present at level1 |
||||||
|
proc ::p::meta::PatternCompile {self} { |
||||||
|
???? |
||||||
|
|
||||||
|
upvar #0 $self SELFMAP |
||||||
|
set ID [lindex $SELFMAP 0 0] |
||||||
|
|
||||||
|
set patterns [lindex $SELFMAP 1 1] ;#list of level1 interfaces |
||||||
|
|
||||||
|
set iid -1 |
||||||
|
foreach i $patterns { |
||||||
|
if {[set ::p::${i}::_iface::o_open]} { |
||||||
|
set iid $i ;#found it |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {$iid > -1} { |
||||||
|
#!todo |
||||||
|
|
||||||
|
::p::compile_interface $iid |
||||||
|
set ::p::${iid}::_iface::o_open 0 |
||||||
|
} else { |
||||||
|
#no uncompiled interface present at level 1. Do nothing. |
||||||
|
return |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::p::meta::Def {self} { |
||||||
|
error ::p::meta::Def |
||||||
|
|
||||||
|
upvar #0 $self SELFMAP |
||||||
|
set self_ID [lindex $SELFMAP 0 0] |
||||||
|
set IFID [lindex $SELFMAP 1 0 end] |
||||||
|
|
||||||
|
set maxc1 0 |
||||||
|
set maxc2 0 |
||||||
|
|
||||||
|
set arrName ::p::${IFID}:: |
||||||
|
|
||||||
|
upvar #0 $arrName state |
||||||
|
|
||||||
|
array set methods {} |
||||||
|
|
||||||
|
foreach nm [array names state] { |
||||||
|
if {[regexp {^m-1,name,(.+)} $nm _match mname]} { |
||||||
|
set methods($mname) [set state($nm)] |
||||||
|
|
||||||
|
if {[string length $mname] > $maxc1} { |
||||||
|
set maxc1 [string length $mname] |
||||||
|
} |
||||||
|
if {[string length [set state($nm)]] > $maxc2} { |
||||||
|
set maxc2 [string length [set state($nm)]] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
set bg1 [string repeat " " [expr {$maxc1 + 2}]] |
||||||
|
set bg2 [string repeat " " [expr {$maxc2 + 2}]] |
||||||
|
|
||||||
|
|
||||||
|
set r {} |
||||||
|
foreach nm [lsort -dictionary [array names methods]] { |
||||||
|
set arglist $state(m-1,args,$nm) |
||||||
|
append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n" |
||||||
|
} |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,754 @@ |
|||||||
|
package provide patternpredator2 1.2.4 |
||||||
|
|
||||||
|
proc ::p::internals::jaws {OID _ID_ args} { |
||||||
|
#puts stderr ">>>(patternpredator2 lib)jaws called with _ID_:$_ID_ args: $args" |
||||||
|
#set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid |
||||||
|
|
||||||
|
yield |
||||||
|
set w 1 |
||||||
|
|
||||||
|
set stack [list] |
||||||
|
set wordcount [llength $args] |
||||||
|
set terminals [list . .. , # @ !] ;#tokens which require the current stack to be evaluated first |
||||||
|
set unsupported 0 |
||||||
|
set operator "" |
||||||
|
set operator_prev "" ;#used only by argprotect to revert to previous operator |
||||||
|
|
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
#!DO NOT use upvar here for MAP! (calling set on a MAP in another iteration/call will overwrite a map for another object!) |
||||||
|
#upvar #0 ::p::${OID}::_meta::map MAP |
||||||
|
set MAP [set ::p::${OID}::_meta::map] |
||||||
|
} else { |
||||||
|
# error "jaws - OID = 'null' ???" |
||||||
|
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] ;#MAP taken from _ID_ will be missing 'interfaces' key |
||||||
|
} |
||||||
|
set invocantdata [dict get $MAP invocantdata] |
||||||
|
lassign $invocantdata OID alias default_method object_command wrapped |
||||||
|
|
||||||
|
set finished_args 0 ;#whether we've completely processed all args in the while loop and therefor don't need to peform the final word processing code |
||||||
|
|
||||||
|
#don't use 'foreach word $args' - we sometimes need to backtrack a little by manipulating $w |
||||||
|
while {$w < $wordcount} { |
||||||
|
set word [lindex $args [expr {$w -1}]] |
||||||
|
#puts stdout "w:$w word:$word stack:$stack" |
||||||
|
|
||||||
|
if {$operator eq "argprotect"} { |
||||||
|
set operator $operator_prev |
||||||
|
lappend stack $word |
||||||
|
incr w |
||||||
|
} else { |
||||||
|
if {[llength $stack]} { |
||||||
|
if {$word in $terminals} { |
||||||
|
set reduction [list 0 $_ID_ {*}$stack ] |
||||||
|
#puts stderr ">>>jaws yielding value: $reduction triggered by word $word in position:$w" |
||||||
|
|
||||||
|
|
||||||
|
set _ID_ [yield $reduction] |
||||||
|
set stack [list] |
||||||
|
#set OID [::pattern::get_oid $_ID_] |
||||||
|
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid |
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
set MAP [set ::p::${OID}::_meta::map] ;#Do not use upvar here! |
||||||
|
} else { |
||||||
|
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces [list level0 {} level1 {}]] |
||||||
|
#puts stderr "WARNING REVIEW: jaws-branch - leave empty??????" |
||||||
|
} |
||||||
|
|
||||||
|
#review - 2018. switched to _ID_ instead of MAP |
||||||
|
lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command |
||||||
|
#lassign [dict get $MAP invocantdata] OID alias default_method object_command |
||||||
|
|
||||||
|
|
||||||
|
#puts stdout "---->>> yielded _ID_: $_ID_ OID:$OID alias:$alias default_method:$default_method object_command:$object_command" |
||||||
|
set operator $word |
||||||
|
#don't incr w |
||||||
|
#incr w |
||||||
|
} else { |
||||||
|
if {$operator eq "argprotect"} { |
||||||
|
set operator $operator_prev |
||||||
|
set operator_prev "" |
||||||
|
lappend stack $word |
||||||
|
} else { |
||||||
|
#only look for leading argprotect chacter (-) if we're not already in argprotect mode |
||||||
|
if {$word eq "--"} { |
||||||
|
set operator_prev $operator |
||||||
|
set operator "argprotect" |
||||||
|
#Don't add the plain argprotector to the stack |
||||||
|
} elseif {[string match "-*" $word]} { |
||||||
|
#argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) |
||||||
|
set operator_prev $operator |
||||||
|
set operator "argprotect" |
||||||
|
lappend stack $word |
||||||
|
} else { |
||||||
|
lappend stack $word |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
incr w |
||||||
|
} |
||||||
|
} else { |
||||||
|
#no stack |
||||||
|
switch -- $word {.} { |
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
#we know next word is a property or method of a pattern object |
||||||
|
incr w |
||||||
|
set nextword [lindex $args [expr {$w - 1}]] |
||||||
|
set command ::p::${OID}::$nextword |
||||||
|
set stack [list $command] ;#2018 j |
||||||
|
set operator . |
||||||
|
if {$w eq $wordcount} { |
||||||
|
set finished_args 1 |
||||||
|
} |
||||||
|
} else { |
||||||
|
# don't incr w |
||||||
|
#set nextword [lindex $args [expr {$w - 1}]] |
||||||
|
set command $object_command ;#taken from the MAP |
||||||
|
set stack [list "_exec_" $command] |
||||||
|
set operator . |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
} {..} { |
||||||
|
incr w |
||||||
|
set nextword [lindex $args [expr {$w -1}]] |
||||||
|
set command ::p::-1::$nextword |
||||||
|
#lappend stack $command ;#lappend a small number of items to an empty list is slower than just setting the list. |
||||||
|
set stack [list $command] ;#faster, and intent is clearer than lappend. |
||||||
|
set operator .. |
||||||
|
if {$w eq $wordcount} { |
||||||
|
set finished_args 1 |
||||||
|
} |
||||||
|
} {,} { |
||||||
|
#puts stdout "Stackless comma!" |
||||||
|
|
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
set command ::p::${OID}::$default_method |
||||||
|
} else { |
||||||
|
set command [list $default_method $object_command] |
||||||
|
#object_command in this instance presumably be a list and $default_method a list operation |
||||||
|
#e.g "lindex {A B C}" |
||||||
|
} |
||||||
|
#lappend stack $command |
||||||
|
set stack [list $command] |
||||||
|
set operator , |
||||||
|
} {--} { |
||||||
|
set operator_prev $operator |
||||||
|
set operator argprotect |
||||||
|
#no stack - |
||||||
|
} {!} { |
||||||
|
set command $object_command |
||||||
|
set stack [list "_exec_" $object_command] |
||||||
|
#puts stdout "!!!! !!!! $stack" |
||||||
|
set operator ! |
||||||
|
} default { |
||||||
|
if {$operator eq ""} { |
||||||
|
if {$OID ne "null"} { |
||||||
|
set command ::p::${OID}::$default_method |
||||||
|
} else { |
||||||
|
set command [list $default_method $object_command] |
||||||
|
} |
||||||
|
set stack [list $command] |
||||||
|
set operator , |
||||||
|
lappend stack $word |
||||||
|
} else { |
||||||
|
#no stack - so we don't expect to be in argprotect mode already. |
||||||
|
if {[string match "-*" $word]} { |
||||||
|
#argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) |
||||||
|
set operator_prev $operator |
||||||
|
set operator "argprotect" |
||||||
|
lappend stack $word |
||||||
|
} else { |
||||||
|
lappend stack $word |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
} |
||||||
|
incr w |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
} ;#end while |
||||||
|
|
||||||
|
#process final word outside of loop |
||||||
|
#assert $w == $wordcount |
||||||
|
#trailing operators or last argument |
||||||
|
if {!$finished_args} { |
||||||
|
set word [lindex $args [expr {$w -1}]] |
||||||
|
if {$operator eq "argprotect"} { |
||||||
|
set operator $operator_prev |
||||||
|
set operator_prev "" |
||||||
|
|
||||||
|
lappend stack $word |
||||||
|
incr w |
||||||
|
} else { |
||||||
|
|
||||||
|
|
||||||
|
switch -- $word {.} { |
||||||
|
if {![llength $stack]} { |
||||||
|
#set stack [list "_result_" [::p::internals::ref_to_object $_ID_]] |
||||||
|
yieldto return [::p::internals::ref_to_object $_ID_] |
||||||
|
error "assert: never gets here" |
||||||
|
|
||||||
|
} else { |
||||||
|
#puts stdout "==== $stack" |
||||||
|
#assert - whenever _ID_ changed in this proc - we have updated the $OID variable |
||||||
|
yieldto return [::p::internals::ref_to_stack $OID $_ID_ $stack] |
||||||
|
error "assert: never gets here" |
||||||
|
} |
||||||
|
set operator . |
||||||
|
|
||||||
|
} {..} { |
||||||
|
#trailing .. after chained call e.g >x . item 0 .. |
||||||
|
#puts stdout "$$$$$$$$$$$$ [list 0 $_ID_ {*}$stack] $$$$" |
||||||
|
#set reduction [list 0 $_ID_ {*}$stack] |
||||||
|
yieldto return [yield [list 0 $_ID_ {*}$stack]] |
||||||
|
} {#} { |
||||||
|
set unsupported 1 |
||||||
|
} {,} { |
||||||
|
set unsupported 1 |
||||||
|
} {&} { |
||||||
|
set unsupported 1 |
||||||
|
} {@} { |
||||||
|
set unsupported 1 |
||||||
|
} {--} { |
||||||
|
|
||||||
|
#set reduction [list 0 $_ID_ {*}$stack[set stack [list]]] |
||||||
|
#puts stdout " -> -> -> about to call yield $reduction <- <- <-" |
||||||
|
set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]] ] |
||||||
|
#set OID [::pattern::get_oid $_ID_] |
||||||
|
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid |
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! |
||||||
|
} else { |
||||||
|
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}} ] |
||||||
|
} |
||||||
|
yieldto return $MAP |
||||||
|
} {!} { |
||||||
|
#error "untested branch" |
||||||
|
set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]]] |
||||||
|
#set OID [::pattern::get_oid $_ID_] |
||||||
|
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid |
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! |
||||||
|
} else { |
||||||
|
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] |
||||||
|
} |
||||||
|
lassign [dict get $MAP invocantdata] OID alias default_command object_command |
||||||
|
set command $object_command |
||||||
|
set stack [list "_exec_" $command] |
||||||
|
set operator ! |
||||||
|
} default { |
||||||
|
if {$operator eq ""} { |
||||||
|
#error "untested branch" |
||||||
|
lassign [dict get $MAP invocantdata] OID alias default_command object_command |
||||||
|
#set command ::p::${OID}::item |
||||||
|
set command ::p::${OID}::$default_command |
||||||
|
lappend stack $command |
||||||
|
set operator , |
||||||
|
|
||||||
|
} |
||||||
|
#do not look for argprotect items here (e.g -option) as the final word can't be an argprotector anyway. |
||||||
|
lappend stack $word |
||||||
|
} |
||||||
|
if {$unsupported} { |
||||||
|
set unsupported 0 |
||||||
|
error "trailing '$word' not supported" |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
#if {$operator eq ","} { |
||||||
|
# incr wordcount 2 |
||||||
|
# set stack [linsert $stack end-1 . item] |
||||||
|
#} |
||||||
|
incr w |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#final = 1 |
||||||
|
#puts stderr ">>>jaws final return value: [list 1 $_ID_ {*}$stack]" |
||||||
|
|
||||||
|
return [list 1 $_ID_ {*}$stack] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#trailing. directly after object |
||||||
|
proc ::p::internals::ref_to_object {_ID_} { |
||||||
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
||||||
|
upvar #0 ::p::${OID}::_meta::map MAP |
||||||
|
lassign [dict get $MAP invocantdata] OID alias default_method object_command |
||||||
|
set refname ::p::${OID}::_ref::__OBJECT |
||||||
|
|
||||||
|
array set $refname [list] ;#important to initialise the variable as an array here - or initial read attempts on elements will not fire traces |
||||||
|
|
||||||
|
set traceCmd [list ::p::predator::object_read_trace $OID $_ID_] |
||||||
|
if {[list {read} $traceCmd] ni [trace info variable $refname]} { |
||||||
|
#puts stdout "adding read trace on variable '$refname' - traceCmd:'$traceCmd'" |
||||||
|
trace add variable $refname {read} $traceCmd |
||||||
|
} |
||||||
|
set traceCmd [list ::p::predator::object_array_trace $OID $_ID_] |
||||||
|
if {[list {array} $traceCmd] ni [trace info variable $refname]} { |
||||||
|
trace add variable $refname {array} $traceCmd |
||||||
|
} |
||||||
|
|
||||||
|
set traceCmd [list ::p::predator::object_write_trace $OID $_ID_] |
||||||
|
if {[list {write} $traceCmd] ni [trace info variable $refname]} { |
||||||
|
trace add variable $refname {write} $traceCmd |
||||||
|
} |
||||||
|
|
||||||
|
set traceCmd [list ::p::predator::object_unset_trace $OID $_ID_] |
||||||
|
if {[list {unset} $traceCmd] ni [trace info variable $refname]} { |
||||||
|
trace add variable $refname {unset} $traceCmd |
||||||
|
} |
||||||
|
return $refname |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::p::internals::create_or_update_reference {OID _ID_ refname command} { |
||||||
|
#if {[lindex $fullstack 0] eq "_exec_"} { |
||||||
|
# #strip it. This instruction isn't relevant for a reference. |
||||||
|
# set commandstack [lrange $fullstack 1 end] |
||||||
|
#} else { |
||||||
|
# set commandstack $fullstack |
||||||
|
#} |
||||||
|
#set argstack [lassign $commandstack command] |
||||||
|
#set field [string map {> __OBJECT_} [namespace tail $command]] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
set reftail [namespace tail $refname] |
||||||
|
set argstack [lassign [split $reftail +] field] |
||||||
|
set field [string map {> __OBJECT_} [namespace tail $command]] |
||||||
|
|
||||||
|
#puts stderr "refname:'$refname' command: $command field:$field" |
||||||
|
|
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
upvar #0 ::p::${OID}::_meta::map MAP |
||||||
|
} else { |
||||||
|
#set map [dict get [lindex [dict get $_ID_ i this] 0 1] map] |
||||||
|
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}}] |
||||||
|
} |
||||||
|
lassign [dict get $MAP invocantdata] OID alias default_method object_command |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
interp alias {} $refname {} $command $_ID_ {*}$argstack |
||||||
|
} else { |
||||||
|
interp alias {} $refname {} $command {*}$argstack |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#set iflist [lindex $map 1 0] |
||||||
|
set iflist [dict get $MAP interfaces level0] |
||||||
|
#set iflist [dict get $MAP interfaces level0] |
||||||
|
set field_is_property_like 0 |
||||||
|
foreach IFID [lreverse $iflist] { |
||||||
|
#tcl (braced) expr has lazy evaluation for &&, || & ?: operators - so this should be reasonably efficient. |
||||||
|
if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} { |
||||||
|
set field_is_property_like 1 |
||||||
|
#There is a setter or getter (but not necessarily an entry in the o_properties dict) |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#whether field is a property or a method - remove any commandrefMisuse_TraceHandler |
||||||
|
foreach tinfo [trace info variable $refname] { |
||||||
|
#puts "-->removing traces on $refname: $tinfo" |
||||||
|
if {[lindex $tinfo 1 0] eq "::p::internals::commandrefMisuse_TraceHandler"} { |
||||||
|
trace remove variable $refname {*}$tinfo |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {$field_is_property_like} { |
||||||
|
#property reference |
||||||
|
|
||||||
|
|
||||||
|
set this_invocantdata [lindex [dict get $_ID_ i this] 0] |
||||||
|
lassign $this_invocantdata OID _alias _defaultmethod object_command |
||||||
|
#get fully qualified varspace |
||||||
|
|
||||||
|
# |
||||||
|
set propdict [$object_command .. GetPropertyInfo $field] |
||||||
|
if {[dict exist $propdict $field]} { |
||||||
|
set field_is_a_property 1 |
||||||
|
set propinfo [dict get $propdict $field] |
||||||
|
set varspace [dict get $propinfo varspace] |
||||||
|
if {$varspace eq ""} { |
||||||
|
set full_varspace ::p::${OID} |
||||||
|
} else { |
||||||
|
if {[::string match "::*" $varspace]} { |
||||||
|
set full_varspace $varspace |
||||||
|
} else { |
||||||
|
set full_varspace ::p::${OID}::$varspace |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
set field_is_a_property 0 |
||||||
|
#no propertyinfo - this field was probably established as a PropertyRead and/or PropertyWrite without a Property |
||||||
|
#this is ok - and we still set the trace infrastructure below (app may convert it to a normal Property later) |
||||||
|
set full_varspace ::p::${OID} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#We only trace on entire property.. not array elements (if references existed to both the array and an element both traces would be fired -(entire array trace first)) |
||||||
|
set Hndlr [::list ::p::predator::propvar_write_TraceHandler $OID $field] |
||||||
|
if { [::list {write} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { |
||||||
|
trace add variable ${full_varspace}::o_${field} {write} $Hndlr |
||||||
|
} |
||||||
|
set Hndlr [::list ::p::predator::propvar_unset_TraceHandler $OID $field] |
||||||
|
if { [::list {unset} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { |
||||||
|
trace add variable ${full_varspace}::o_${field} {unset} $Hndlr |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#supply all data in easy-access form so that propref_trace_read is not doing any extra work. |
||||||
|
set get_cmd ::p::${OID}::(GET)$field |
||||||
|
set traceCmd [list ::p::predator::propref_trace_read $get_cmd $_ID_ $refname $field $argstack] |
||||||
|
|
||||||
|
if {[list {read} $traceCmd] ni [trace info variable $refname]} { |
||||||
|
set fieldvarname ${full_varspace}::o_${field} |
||||||
|
|
||||||
|
|
||||||
|
#synch the refvar with the real var if it exists |
||||||
|
#catch {set $refname [$refname]} |
||||||
|
if {[array exists $fieldvarname]} { |
||||||
|
if {![llength $argstack]} { |
||||||
|
#unindexed reference |
||||||
|
array set $refname [array get $fieldvarname] |
||||||
|
#upvar $fieldvarname $refname |
||||||
|
} else { |
||||||
|
set s0 [lindex $argstack 0] |
||||||
|
#refs to nonexistant array members common? (catch vs 'info exists') |
||||||
|
if {[info exists ${fieldvarname}($s0)]} { |
||||||
|
set $refname [set ${fieldvarname}($s0)] |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
#refs to uninitialised props actually should be *very* common. |
||||||
|
#If we use 'catch', it means retrieving refs to non-initialised props is slower. Fired catches can be relatively expensive. |
||||||
|
#Because it's common to get a ref to uninitialised props (e.g for initial setting of their value) - we will use 'info exists' instead of catch. |
||||||
|
|
||||||
|
#set errorInfo_prev $::errorInfo ;#preserve errorInfo across catches! |
||||||
|
|
||||||
|
#puts stdout " ---->>!!! ref to uninitialised prop $field $argstack !!!<------" |
||||||
|
|
||||||
|
|
||||||
|
if {![llength $argstack]} { |
||||||
|
#catch {set $refname [set ::p::${OID}::o_$field]} |
||||||
|
if {[info exists $fieldvarname]} { |
||||||
|
set $refname [set $fieldvarname] |
||||||
|
#upvar $fieldvarname $refname |
||||||
|
} |
||||||
|
} else { |
||||||
|
if {[llength $argstack] == 1} { |
||||||
|
#catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $argstack 0]]} |
||||||
|
if {[info exists $fieldvarname]} { |
||||||
|
set $refname [lindex [set $fieldvarname] [lindex $argstack 0]] |
||||||
|
} |
||||||
|
|
||||||
|
} else { |
||||||
|
#catch {set $refname [lindex [set ::p::${OID}::o_$field] $argstack]} |
||||||
|
if {[info exists $fieldvarname]} { |
||||||
|
set $refname [lindex [set $fieldvarname] $argstack] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#! what if someone has put a trace on ::errorInfo?? |
||||||
|
#set ::errorInfo $errorInfo_prev |
||||||
|
} |
||||||
|
trace add variable $refname {read} $traceCmd |
||||||
|
|
||||||
|
set traceCmd [list ::p::predator::propref_trace_write $_ID_ $OID $full_varspace $refname] |
||||||
|
trace add variable $refname {write} $traceCmd |
||||||
|
|
||||||
|
set traceCmd [list ::p::predator::propref_trace_unset $_ID_ $OID $refname] |
||||||
|
trace add variable $refname {unset} $traceCmd |
||||||
|
|
||||||
|
|
||||||
|
set traceCmd [list ::p::predator::propref_trace_array $_ID_ $OID $refname] |
||||||
|
# puts "**************** installing array variable trace on ref:$refname - cmd:$traceCmd" |
||||||
|
trace add variable $refname {array} $traceCmd |
||||||
|
} |
||||||
|
|
||||||
|
} else { |
||||||
|
#puts "$refname ====> adding refMisuse_traceHandler $alias $field" |
||||||
|
#matching variable in order to detect attempted use as property and throw error |
||||||
|
|
||||||
|
#2018 |
||||||
|
#Note that we are adding a trace on a variable (the refname) which does not exist. |
||||||
|
#this is fine - except that the trace won't fire for attempt to write it as an array using syntax such as set $ref(someindex) |
||||||
|
#we could set the ref to an empty array - but then we have to also undo this if a property with matching name is added |
||||||
|
##array set $refname {} ;#empty array |
||||||
|
# - the empty array would mean a slightly better error message when misusing a command ref as an array |
||||||
|
#but this seems like a code complication for little benefit |
||||||
|
#review |
||||||
|
|
||||||
|
trace add variable $refname {read write unset array} [list ::p::internals::commandrefMisuse_TraceHandler $OID $field] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#trailing. after command/property |
||||||
|
proc ::p::internals::ref_to_stack {OID _ID_ fullstack} { |
||||||
|
if {[lindex $fullstack 0] eq "_exec_"} { |
||||||
|
#strip it. This instruction isn't relevant for a reference. |
||||||
|
set commandstack [lrange $fullstack 1 end] |
||||||
|
} else { |
||||||
|
set commandstack $fullstack |
||||||
|
} |
||||||
|
set argstack [lassign $commandstack command] |
||||||
|
set field [string map {> __OBJECT_} [namespace tail $command]] |
||||||
|
|
||||||
|
|
||||||
|
#!todo? |
||||||
|
# - make every object's OID unpredictable and sparse (UUID) and modify 'namespace child' etc to prevent iteration/inspection of ::p namespace. |
||||||
|
# - this would only make sense for an environment where any meta methods taking a code body (e.g .. Method .. PatternMethod etc) are restricted. |
||||||
|
|
||||||
|
|
||||||
|
#references created under ::p::${OID}::_ref are effectively inside a 'varspace' within the object itself. |
||||||
|
# - this would in theory allow a set of interface functions on the object which have direct access to the reference variables. |
||||||
|
|
||||||
|
|
||||||
|
set refname ::p::${OID}::_ref::[join [concat $field $argstack] +] |
||||||
|
|
||||||
|
if {[llength [info commands $refname]]} { |
||||||
|
#todo - review - what if the field changed to/from a property/method? |
||||||
|
#probably should fix that where such a change is made and leave this short circuit here to give reasonable performance for existing refs |
||||||
|
return $refname |
||||||
|
} |
||||||
|
::p::internals::create_or_update_reference $OID $_ID_ $refname $command |
||||||
|
return $refname |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
namespace eval pp { |
||||||
|
variable operators [list .. . -- - & @ # , !] |
||||||
|
variable operators_notin_args "" |
||||||
|
foreach op $operators { |
||||||
|
append operators_notin_args "({$op} ni \$args) && " |
||||||
|
} |
||||||
|
set operators_notin_args [string trimright $operators_notin_args " &"] ;#trim trailing spaces and ampersands |
||||||
|
#set operators_notin_args {({.} ni $args) && ({,} ni $args) && ({..} ni $args)} |
||||||
|
} |
||||||
|
interp alias {} strmap {} string map ;#stop code editor from mono-colouring our big string mapped code blocks! |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# 2017 ::p::predator2 is the development version - intended for eventual use as the main dispatch mechanism. |
||||||
|
#each map is a 2 element list of lists. |
||||||
|
# form: {$commandinfo $interfaceinfo} |
||||||
|
# commandinfo is of the form: {ID Namespace defaultmethod commandname _?} |
||||||
|
|
||||||
|
#2018 |
||||||
|
#each map is a dict. |
||||||
|
#form: {invocantdata {ID Namespace defaultmethod commandname _?} interfaces {level0 {} level1 {}}} |
||||||
|
|
||||||
|
|
||||||
|
#OID = Object ID (integer for now - could in future be a uuid) |
||||||
|
proc ::p::predator2 {_ID_ args} { |
||||||
|
#puts stderr "predator2: _ID_:'$_ID_' args:'$args'" |
||||||
|
#set invocants [dict get $_ID_ i] |
||||||
|
#set invocant_roles [dict keys $invocants] |
||||||
|
|
||||||
|
#For now - we are 'this'-centric (single dispatch). todo - adapt for multiple roles, multimethods etc. |
||||||
|
#set this_role_members [dict get $invocants this] |
||||||
|
#set this_invocant [lindex [dict get $_ID_ i this] 0] ;#for the role 'this' we assume only one invocant in the list. |
||||||
|
#lassign $this_invocant this_OID this_info_dict |
||||||
|
|
||||||
|
set this_OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid |
||||||
|
|
||||||
|
|
||||||
|
set cheat 1 ;# |
||||||
|
#------- |
||||||
|
#Optimise the next most common use case. A single . followed by args which contain no other operators (non-chained call) |
||||||
|
#(it should be functionally equivalent to remove this shortcut block) |
||||||
|
if {$cheat} { |
||||||
|
if { ([lindex $args 0] eq {.}) && ([llength $args] > 1) && ([llength [lsearch -all -inline $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args) && ({!} ni $args)} { |
||||||
|
|
||||||
|
set remaining_args [lassign $args dot method_or_prop] |
||||||
|
|
||||||
|
#how will we do multiple apis? (separate interface stacks) apply? apply [list [list _ID_ {*}$arglist] ::p::${stackid?}::$method_or_prop ::p::${this_OID}] ??? |
||||||
|
set command ::p::${this_OID}::$method_or_prop |
||||||
|
#REVIEW! |
||||||
|
#e.g what if the method is named "say hello" ?? (hint - it will break because we will look for 'say') |
||||||
|
#if {[llength $command] > 1} { |
||||||
|
# error "methods with spaces not included in test suites - todo fix!" |
||||||
|
#} |
||||||
|
#Dont use {*}$command - (so we can support methods with spaces) |
||||||
|
#if {![llength [info commands $command]]} {} |
||||||
|
if {[namespace which $command] eq ""} { |
||||||
|
if {[namespace which ::p::${this_OID}::(UNKNOWN)] ne ""} { |
||||||
|
#lset command 0 ::p::${this_OID}::(UNKNOWN) ;#seems wrong - command could have spaces |
||||||
|
set command ::p::${this_OID}::(UNKNOWN) |
||||||
|
#tailcall {*}$command $_ID_ $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||||
|
tailcall $command $_ID_ $method_or_prop {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||||
|
} else { |
||||||
|
return -code error -errorinfo "(::p::predator2) error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$method_or_prop' not found" |
||||||
|
} |
||||||
|
} else { |
||||||
|
#tailcall {*}$command $_ID_ {*}$remaining_args |
||||||
|
tailcall $command $_ID_ {*}$remaining_args |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
#------------ |
||||||
|
|
||||||
|
|
||||||
|
if {([llength $args] == 1) && ([lindex $args 0] eq "..")} { |
||||||
|
return $_ID_ |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#puts stderr "pattern::predator (test version) called with: _ID_:$_ID_ args:$args" |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#puts stderr "this_info_dict: $this_info_dict" |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
if {![llength $args]} { |
||||||
|
#should return some sort of public info.. i.e probably not the ID which is an implementation detail |
||||||
|
#return cmd |
||||||
|
return [lindex [dict get [set ::p::${this_OID}::_meta::map] invocantdata] 0] ;#Object ID |
||||||
|
|
||||||
|
#return a dict keyed on object command name - (suitable as use for a .. Create 'target') |
||||||
|
#lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method object_command wrapped |
||||||
|
#return [list $object_command [list -id $this_OID ]] |
||||||
|
} elseif {[llength $args] == 1} { |
||||||
|
#short-circuit the single index case for speed. |
||||||
|
if {[lindex $args 0] ni {.. . -- - & @ # , !}} { |
||||||
|
#lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method |
||||||
|
lassign [lindex [dict get $_ID_ i this] 0] this_OID alias default_method |
||||||
|
|
||||||
|
tailcall ::p::${this_OID}::$default_method $_ID_ [lindex $args 0] |
||||||
|
} elseif {[lindex $args 0] eq {--}} { |
||||||
|
|
||||||
|
#!todo - we could hide the invocant by only allowing this call from certain uplevel procs.. |
||||||
|
# - combined with using UUIDs for $OID, and a secured/removed metaface on the object |
||||||
|
# - (and also hiding of [interp aliases] command so they can't iterate and examine all aliases) |
||||||
|
# - this could effectively hide the object's namespaces,vars etc from the caller (?) |
||||||
|
return [set ::p::${this_OID}::_meta::map] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#upvar ::p::coroutine_instance c ;#coroutine names must be unique per call to predator (not just per object - or we could get a clash during some cyclic calls) |
||||||
|
#incr c |
||||||
|
#set reduce ::p::reducer${this_OID}_$c |
||||||
|
set reduce ::p::reducer${this_OID}_[incr ::p::coroutine_instance] |
||||||
|
#puts stderr "..................creating reducer $reduce with args $this_OID _ID_ $args" |
||||||
|
coroutine $reduce ::p::internals::jaws $this_OID $_ID_ {*}$args |
||||||
|
|
||||||
|
|
||||||
|
set current_ID_ $_ID_ |
||||||
|
|
||||||
|
set final 0 |
||||||
|
set result "" |
||||||
|
while {$final == 0} { |
||||||
|
#the argument given here to $reduce will be returned by 'yield' within the coroutine context (jaws) |
||||||
|
set reduction_args [lassign [$reduce $current_ID_[set current_ID_ [list]] ] final current_ID_ command] |
||||||
|
#puts stderr "..> final:$final current_ID_:'$current_ID_' command:'$command' reduction_args:'$reduction_args'" |
||||||
|
#if {[string match *Destroy $command]} { |
||||||
|
# puts stdout " calling Destroy reduction_args:'$reduction_args'" |
||||||
|
#} |
||||||
|
if {$final == 1} { |
||||||
|
|
||||||
|
if {[llength $command] == 1} { |
||||||
|
if {$command eq "_exec_"} { |
||||||
|
tailcall {*}$reduction_args |
||||||
|
} |
||||||
|
if {[llength [info commands $command]]} { |
||||||
|
tailcall {*}$command $current_ID_ {*}$reduction_args |
||||||
|
} |
||||||
|
set cmdname [namespace tail $command] |
||||||
|
set this_OID [lindex [dict get $current_ID_ i this] 0 0] |
||||||
|
if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { |
||||||
|
lset command 0 ::p::${this_OID}::(UNKNOWN) |
||||||
|
tailcall {*}$command $current_ID_ $cmdname {*}$reduction_args ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||||
|
} else { |
||||||
|
return -code error -errorinfo "1)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" |
||||||
|
} |
||||||
|
|
||||||
|
} else { |
||||||
|
#e.g lindex {a b c} |
||||||
|
tailcall {*}$command {*}$reduction_args |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
} else { |
||||||
|
if {[lindex $command 0] eq "_exec_"} { |
||||||
|
set result [uplevel 1 [list {*}[lrange $command 1 end] {*}$reduction_args]] |
||||||
|
|
||||||
|
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {} ] |
||||||
|
} else { |
||||||
|
if {[llength $command] == 1} { |
||||||
|
if {![llength [info commands $command]]} { |
||||||
|
set cmdname [namespace tail $command] |
||||||
|
set this_OID [lindex [dict get $current_ID_ i this] 0 0] |
||||||
|
if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { |
||||||
|
|
||||||
|
lset command 0 ::p::${this_OID}::(UNKNOWN) |
||||||
|
set result [uplevel 1 [list {*}$command $current_ID_ $cmdname {*}$reduction_args]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||||
|
} else { |
||||||
|
return -code error -errorinfo "2)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" |
||||||
|
} |
||||||
|
} else { |
||||||
|
#set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] |
||||||
|
set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] |
||||||
|
|
||||||
|
} |
||||||
|
} else { |
||||||
|
set result [uplevel 1 [list {*}$command {*}$reduction_args]] |
||||||
|
} |
||||||
|
|
||||||
|
if {[llength [info commands $result]]} { |
||||||
|
if {([llength $result] == 1) && ([string first ">" [namespace tail $result]] == 0)} { |
||||||
|
#looks like a pattern command |
||||||
|
set current_ID_ [$result .. INVOCANTDATA] |
||||||
|
|
||||||
|
|
||||||
|
#todo - determine if plain .. INVOCANTDATA is sufficient instead of .. UPDATEDINVOCANTDATA |
||||||
|
#if {![catch {$result .. INVOCANTDATA} result_invocantdata]} { |
||||||
|
# set current_ID_ $result_invocantdata |
||||||
|
#} else { |
||||||
|
# return -code error -errorinfo "3)error running command:'$command' argstack:'$reduction_args'\n - Failed to access result:'$result' as a pattern object." "Failed to access result:'$result' as a pattern object" |
||||||
|
#} |
||||||
|
} else { |
||||||
|
#non-pattern command |
||||||
|
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] |
||||||
|
} |
||||||
|
} else { |
||||||
|
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] |
||||||
|
#!todo - allow further operations on non-command values. e.g dicts, lists & strings (treat strings as lists) |
||||||
|
|
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
} |
||||||
|
error "Assert: Shouldn't get here (end of ::p::predator2)" |
||||||
|
#return $result |
||||||
|
} |
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,272 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::aliascore 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin shellspy_module_punk::aliascore 0 0.1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::aliascore] |
||||||
|
#[keywords module] |
||||||
|
#[description] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of punk::aliascore |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by punk::aliascore |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#tcl::namespace::eval punk::aliascore::class { |
||||||
|
# #*** !doctools |
||||||
|
# #[subsection {Namespace punk::aliascore::class}] |
||||||
|
# #[para] class definitions |
||||||
|
# if {[info commands [namespace current]::interface_sample1] eq ""} { |
||||||
|
# #*** !doctools |
||||||
|
# #[list_begin enumerated] |
||||||
|
# |
||||||
|
# # oo::class create interface_sample1 { |
||||||
|
# # #*** !doctools |
||||||
|
# # #[enum] CLASS [class interface_sample1] |
||||||
|
# # #[list_begin definitions] |
||||||
|
# |
||||||
|
# # method test {arg1} { |
||||||
|
# # #*** !doctools |
||||||
|
# # #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# # #[para] test method |
||||||
|
# # puts "test: $arg1" |
||||||
|
# # } |
||||||
|
# |
||||||
|
# # #*** !doctools |
||||||
|
# # #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# # } |
||||||
|
# |
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {--- end class enumeration ---}] |
||||||
|
# } |
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::aliascore { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
variable aliases |
||||||
|
#use absolute ns ie must be prefixed with :: |
||||||
|
#single element commands are imported if source command already exists, otherwise aliased. multi element commands are aliased |
||||||
|
|
||||||
|
#functions must be in export list of their source namespace |
||||||
|
set aliases [tcl::dict::create\ |
||||||
|
tstr ::punk::lib::tstr\ |
||||||
|
list_as_lines ::punk::lib::list_as_lines\ |
||||||
|
lines_as_list ::punk::lib::lines_as_list\ |
||||||
|
linelist ::punk::lib::linelist\ |
||||||
|
linesort ::punk::lib::linesort\ |
||||||
|
pdict ::punk::lib::pdict\ |
||||||
|
plist {::punk::lib::pdict -roottype list}\ |
||||||
|
showlist {::punk::lib::showdict -roottype list}\ |
||||||
|
showdict ::punk::lib::showdict\ |
||||||
|
ansistrip ::punk::ansi::ansistrip\ |
||||||
|
stripansi ::punk::ansi::ansistrip\ |
||||||
|
ansiwrap ::punk::ansi::ansiwrap\ |
||||||
|
colour ::punk::console::colour\ |
||||||
|
ansi ::punk::console::ansi\ |
||||||
|
color ::punk::console::colour\ |
||||||
|
a+ ::punk::console::code_a+\ |
||||||
|
A+ {::punk::console::code_a+ forcecolour}\ |
||||||
|
a ::punk::console::code_a\ |
||||||
|
A {::punk::console::code_a forcecolour}\ |
||||||
|
a? ::punk::console::code_a?\ |
||||||
|
A? {::punk::console::code_a? forcecolor}\ |
||||||
|
smcup ::punk::console::enable_alt_screen\ |
||||||
|
rmcup ::punk::console::disable_alt_screen\ |
||||||
|
] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::aliascore}] |
||||||
|
#[para] Core API functions for punk::aliascore |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#proc sample1 {p1 n args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||||
|
# #[para]Description of sample1 |
||||||
|
# #[para] Arguments: |
||||||
|
# # [list_begin arguments] |
||||||
|
# # [arg_def tring p1] A description of string argument p1. |
||||||
|
# # [arg_def integer n] A description of integer argument n. |
||||||
|
# # [list_end] |
||||||
|
# return "ok" |
||||||
|
#} |
||||||
|
|
||||||
|
#todo - options as to whether we should raise an error if collisions found, undo aliases etc? |
||||||
|
proc init {args} { |
||||||
|
set defaults {-force 0} |
||||||
|
set opts [dict merge $defaults $args] |
||||||
|
set opt_force [dict get $opts -force] |
||||||
|
|
||||||
|
variable aliases |
||||||
|
if {!$opt_force} { |
||||||
|
set existing [list] |
||||||
|
set conflicts [list] |
||||||
|
foreach {a cmd} $aliases { |
||||||
|
if {[tcl::info::commands ::$a] ne ""} { |
||||||
|
lappend existing $a |
||||||
|
if {[llength $cmd] > 1} { |
||||||
|
#use alias mechanism |
||||||
|
set existing_target [interp alias "" $a] |
||||||
|
} else { |
||||||
|
#using namespace import |
||||||
|
#check origin |
||||||
|
set existing_target [tcl::namespace::origin $cmd] |
||||||
|
} |
||||||
|
if {$existing_target ne $cmd} { |
||||||
|
#command exists in global ns but doesn't match our defined aliases/imports |
||||||
|
lappend conflicts $a |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
if {[llength $conflicts]} { |
||||||
|
error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts" |
||||||
|
} |
||||||
|
} |
||||||
|
set tempns ::temp_[info cmdcount] ;#temp ns for renames |
||||||
|
dict for {a cmd} $aliases { |
||||||
|
#puts "aliascore $a -> $cmd" |
||||||
|
if {[llength $cmd] > 1} { |
||||||
|
interp alias {} $a {} {*}$cmd |
||||||
|
} else { |
||||||
|
if {[tcl::info::commands $cmd] ne ""} { |
||||||
|
#todo - ensure exported? noclobber? |
||||||
|
if {[tcl::namespace::tail $a] eq [tcl::namespace::tail $cmd]} { |
||||||
|
#puts stderr "importing $cmd" |
||||||
|
tcl::namespace::eval :: [list namespace import $cmd] |
||||||
|
} else { |
||||||
|
#target command name differs from exported name |
||||||
|
#e.g stripansi -> punk::ansi::ansistrip |
||||||
|
#import and rename |
||||||
|
#puts stderr "importing $cmd (with rename to ::$a)" |
||||||
|
tcl::namespace::eval $tempns [list namespace import $cmd] |
||||||
|
catch {rename ${tempns}::[namespace tail $cmd] ::$a} |
||||||
|
} |
||||||
|
} else { |
||||||
|
interp alias {} $a {} {*}$cmd |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
#tcl::namespace::delete $tempns |
||||||
|
return [dict keys $aliases] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::aliascore ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#interp alias {} list_as_lines {} punk::lib::list_as_lines |
||||||
|
#interp alias {} lines_as_list {} punk::lib::lines_as_list |
||||||
|
#interp alias {} ansistrip {} punk::ansi::ansistrip ;#review |
||||||
|
#interp alias {} linelist {} punk::lib::linelist ;#critical for = assignment features |
||||||
|
#interp alias {} linesort {} punk::lib::linesort |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::aliascore::lib { |
||||||
|
namespace export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
namespace path [namespace parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::aliascore::lib}] |
||||||
|
#[para] Secondary functions that are part of the API |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
#proc utility1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of utility1 |
||||||
|
# return 1 |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::aliascore::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
namespace eval punk::aliascore::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::aliascore::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::aliascore [namespace eval punk::aliascore { |
||||||
|
variable pkg punk::aliascore |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
@ -0,0 +1,475 @@ |
|||||||
|
|
||||||
|
tcl::namespace::eval punk::config { |
||||||
|
variable loaded |
||||||
|
variable startup ;#include env overrides |
||||||
|
variable running |
||||||
|
variable punk_env_vars |
||||||
|
variable other_env_vars |
||||||
|
|
||||||
|
variable vars |
||||||
|
|
||||||
|
namespace export {[a-z]*} |
||||||
|
|
||||||
|
#todo - XDG_DATA_HOME etc |
||||||
|
#https://specifications.freedesktop.org/basedir-spec/latest/ |
||||||
|
# see also: http://hiphish.github.io/blog/2020/08/30/dotfiles-were-a-mistake/ |
||||||
|
|
||||||
|
proc init {} { |
||||||
|
variable defaults |
||||||
|
variable startup |
||||||
|
variable running |
||||||
|
variable punk_env_vars |
||||||
|
variable punk_env_vars_config |
||||||
|
variable other_env_vars |
||||||
|
variable other_env_vars_config |
||||||
|
|
||||||
|
set exename "" |
||||||
|
catch { |
||||||
|
#catch for safe interps |
||||||
|
#safe base will return empty string, ordinary safe interp will raise error |
||||||
|
set exename [tcl::info::nameofexecutable] |
||||||
|
} |
||||||
|
if {$exename ne ""} { |
||||||
|
set exefolder [file dirname $exename] |
||||||
|
#default file logs to logs folder at same level as exe if writable, or empty string |
||||||
|
set log_folder [file normalize $exefolder/../logs] |
||||||
|
#tcl::dict::set startup scriptlib $exefolder/scriptlib |
||||||
|
#tcl::dict::set startup apps $exefolder/../../punkapps |
||||||
|
|
||||||
|
#todo - use punk main.tcl location instead - exefolder doesn't work if system tclsh used etc |
||||||
|
set default_scriptlib $exefolder/scriptlib |
||||||
|
set default_apps $exefolder/../../punkapps |
||||||
|
if {[file isdirectory $log_folder] && [file writable $log_folder]} { |
||||||
|
#tcl::dict::set startup logfile_stdout $log_folder/repl-exec-stdout.txt |
||||||
|
#tcl::dict::set startup logfile_stderr $log_folder/repl-exec-stderr.txt |
||||||
|
set default_logfile_stdout $log_folder/repl-exec-stdout.txt |
||||||
|
set default_logfile_stderr $log_folder/repl-exec-stderr.txt |
||||||
|
} else { |
||||||
|
set default_logfile_stdout "" |
||||||
|
set default_logfile_stderr "" |
||||||
|
} |
||||||
|
} else { |
||||||
|
#probably a safe interp - which cannot access info nameofexecutable even if access given to the location via punk::island |
||||||
|
#review - todo? |
||||||
|
#tcl::dict::set startup scriptlib "" |
||||||
|
#tcl::dict::set startup apps "" |
||||||
|
set default_scriptlib "" |
||||||
|
set default_apps "" |
||||||
|
set default_logfile_stdout "" |
||||||
|
set default_logfile_stderr "" |
||||||
|
} |
||||||
|
|
||||||
|
# auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run |
||||||
|
|
||||||
|
#optional channel transforms on stdout/stderr. |
||||||
|
#can sometimes be useful to distinguish eventloop stdout/stderr writes compared to those triggered directly from repl commands |
||||||
|
#If no distinction necessary - should use default_color_<chan> |
||||||
|
#The counterpart: default_color_<chan>_repl is a transform that is added and removed with each repl evaluation. |
||||||
|
#startup color_stdout - parameters as suitable for punk::ansi::a+ (test with 'punk::ansi::a?') e.g "cyan bold" ;#not a good idea to default |
||||||
|
set default_color_stdout brightwhite ;#stdout colour including background calls (after etc) |
||||||
|
set default_color_stdout_repl "" ;#stdout colour applied during direct repl call only |
||||||
|
#This wraps the stderr stream as it comes in with Ansi - probably best to default to empty.. but it's useful. |
||||||
|
#set default_color_stderr "red bold" |
||||||
|
#set default_color_stderr "web-lightsalmon" |
||||||
|
set default_color_stderr yellow ;#limit to basic colours for wider terminal support. yellow = term-olive |
||||||
|
set default_color_stderr_repl "" ;#during repl call only |
||||||
|
|
||||||
|
set homedir "" |
||||||
|
if {[catch { |
||||||
|
#depending on which build of tcl - some safe interps prior to bugfix https://core.tcl-lang.org/tcl/info/3aa487993f will return a homedir value in an unmodified safe interp |
||||||
|
#other 'safe' interps may have explicitly made this available - we shouldn't override that decision here using interp issafe so we can't compensate for versions which shouldn't really be returning this in the safe interp |
||||||
|
set homedir [file home] |
||||||
|
} errM]} { |
||||||
|
#tcl 8.6 doesn't have file home.. try again |
||||||
|
if {[info exists ::env(HOME)]} { |
||||||
|
set homedir $::env(HOME) |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# per user xdg vars |
||||||
|
# --- |
||||||
|
set default_xdg_config_home "" ;#config data - portable |
||||||
|
set default_xdg_data_home "" ;#data the user likely to want to be portable |
||||||
|
set default_xdg_cache_home "" ;#local cache |
||||||
|
set default_xdg_state_home "" ;#persistent user data such as logs, but not as important or as portable as those in xdg_data_home |
||||||
|
# --- |
||||||
|
set default_xdg_data_dirs "" ;#non-user specific |
||||||
|
#xdg_config_dirs ? |
||||||
|
#xdg_runtime_dir ? |
||||||
|
|
||||||
|
|
||||||
|
#review. we are assuming if we can't get a home dir - then all the xdg vars including xdg_data_dirs aren't likely to be useful (as presumably filesystem access is absent) |
||||||
|
#(safe interp generally won't have access to ::env either) |
||||||
|
#This coupling doesn't necessarily hold - its possible the relevant env vars were copied to a safe interp - although that would be a policy that would make disabling 'info home' inconsistent. |
||||||
|
if {$homedir ne ""} { |
||||||
|
if {"windows" eq $::tcl_platform(platform)} { |
||||||
|
#as much as I'd prefer to use ~/.local/share and ~/.config to keep them more consistent with unixlike platforms - the vast majority of apps put them where microsoft wants them. |
||||||
|
#we have a choice of LOCALAPPDATA vs APPDATA (local to machine vs potentially roaming/redirected in a corporate environment) |
||||||
|
#using the roaming location should not impact users who aren't using a domain controller but is potentially much more convenient for those who do. |
||||||
|
if {[info exists ::env(APPDATA)]} { |
||||||
|
set default_xdg_config_home $::env(APPDATA) |
||||||
|
set default_xdg_data_home $::env(APPDATA) |
||||||
|
} |
||||||
|
|
||||||
|
#The xdg_cache_home should be kept local |
||||||
|
if {[info exists ::env(LOCALAPPDATA)]} { |
||||||
|
set default_xdg_cache_home $::env(LOCALAPPDATA) |
||||||
|
set default_xdg_state_home $::env(LOCALAPPDATA) |
||||||
|
} |
||||||
|
|
||||||
|
if {[info exists ::env(PROGRAMDATA)]} { |
||||||
|
#- equiv env(ALLUSERSPROFILE) ? |
||||||
|
set default_xdg_data_dirs $::env(PROGRAMDATA) |
||||||
|
} |
||||||
|
|
||||||
|
} else { |
||||||
|
#follow defaults as specified on freedesktop.org e.g https://specifications.freedesktop.org/basedir-spec/latest/ar01s03.html |
||||||
|
set default_xdg_config_home [file join $homedir .config] |
||||||
|
set default_xdg_data_home [file join $homedir .local share] |
||||||
|
set default_xdg_cache_home [file join $homedir .cache] |
||||||
|
set default_xdg_state_home [file join $homedir .local state] |
||||||
|
set default_xdg_data_dirs /usr/local/share |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set defaults [dict create\ |
||||||
|
apps $default_apps\ |
||||||
|
config ""\ |
||||||
|
configset ".punkshell"\ |
||||||
|
scriptlib $default_scriptlib\ |
||||||
|
color_stdout $default_color_stdout\ |
||||||
|
color_stdout_repl $default_color_stdout_repl\ |
||||||
|
color_stderr $default_color_stderr\ |
||||||
|
color_stderr_repl $default_color_stderr_repl\ |
||||||
|
logfile_stdout $default_logfile_stdout\ |
||||||
|
logfile_stderr $default_logfile_stderr\ |
||||||
|
logfile_active 0\ |
||||||
|
syslog_stdout "127.0.0.1:514"\ |
||||||
|
syslog_stderr "127.0.0.1:514"\ |
||||||
|
syslog_active 0\ |
||||||
|
auto_exec_mechanism exec\ |
||||||
|
auto_noexec 0\ |
||||||
|
xdg_config_home $default_xdg_config_home\ |
||||||
|
xdg_data_home $default_xdg_data_home\ |
||||||
|
xdg_cache_home $default_xdg_cache_home\ |
||||||
|
xdg_state_home $default_xdg_state_home\ |
||||||
|
xdg_data_dirs $default_xdg_data_dirs\ |
||||||
|
theme_posh_override ""\ |
||||||
|
posh_theme ""\ |
||||||
|
posh_themes_path ""\ |
||||||
|
] |
||||||
|
|
||||||
|
set startup $defaults |
||||||
|
#load values from saved config file - $xdg_config_home/punk/punk.config ? |
||||||
|
#typically we want env vars to override the stored config - as env vars conventionally used on some commandlines. |
||||||
|
#that's possibly ok for the PUNK_ vars |
||||||
|
#however.. others like the xdg vars and NOCOLOR may apply to other apps.. and we may want to override them from the saved config? |
||||||
|
#making some env vars override saved config values and some not would be potentially confusing. may need one/more specific settings or env vars to determine which takes precedence? |
||||||
|
#simpler is probably just to let env vars take precedence - and warn when saving or viewing config that the saved values are being overridden |
||||||
|
#- requiring user to manually unset any unwanted env vars when launching? |
||||||
|
|
||||||
|
#we are likely to want the saved configs for subshells/decks to override them however. |
||||||
|
|
||||||
|
#todo - load/save config file |
||||||
|
|
||||||
|
#todo - define which configvars are settable in env |
||||||
|
#list of varname varinfo where varinfo is a sub dictionary (type key is mandatory, with value from: string,pathlist,boolean) |
||||||
|
set punk_env_vars_config [dict create \ |
||||||
|
PUNK_APPS {type pathlist}\ |
||||||
|
PUNK_CONFIG {type string}\ |
||||||
|
PUNK_CONFIGSET {type string}\ |
||||||
|
PUNK_SCRIPTLIB {type string}\ |
||||||
|
PUNK_AUTO_EXEC_MECHANISM {type string}\ |
||||||
|
PUNK_AUTO_NOEXEC {type string default 0 help "set 1 to set Tcl's ::auto_noexec true.\nStops 'unknown' from running external programs"}\ |
||||||
|
PUNK_COLOR_STDERR {type string help "stderr colour transform. Use 'punk::ansi::a?' to see colour names"}\ |
||||||
|
PUNK_COLOR_STDERR_REPL {type string help "stderr colour transform only while command running (not active during 'after')"}\ |
||||||
|
PUNK_COLOR_STDOUT {type string help "stdout colour transform. Use 'punk::ansi::a?' to see colour names"}\ |
||||||
|
PUNK_COLOR_STDOUT_REPL {type string help "stdout colour transform only while command running (not active during 'after')"}\ |
||||||
|
PUNK_LOGFILE_STDOUT {type string}\ |
||||||
|
PUNK_LOGFILE_STDERR {type string}\ |
||||||
|
PUNK_LOGFILE_ACTIVE {type string}\ |
||||||
|
PUNK_SYSLOG_STDOUT {type string}\ |
||||||
|
PUNK_SYSLOG_STDERR {type string}\ |
||||||
|
PUNK_SYSLOG_ACTIVE {type string}\ |
||||||
|
PUNK_THEME_POSH_OVERRIDE {type string}\ |
||||||
|
] |
||||||
|
set punk_env_vars [dict keys $punk_env_vars_config] |
||||||
|
|
||||||
|
#override with env vars if set |
||||||
|
foreach {evar varinfo} $punk_env_vars_config { |
||||||
|
if {[info exists ::env($evar)]} { |
||||||
|
set vartype [dict get $varinfo type] |
||||||
|
set f [set ::env($evar)] |
||||||
|
if {$f ne "default"} { |
||||||
|
#e.g PUNK_SCRIPTLIB -> scriptlib |
||||||
|
set varname [tcl::string::tolower [tcl::string::range $evar 5 end]] |
||||||
|
if {$vartype eq "pathlist"} { |
||||||
|
#colon vs semicolon path sep is problematic for windows environments where unix-like systems such as cygwin/wsl are used and a variable may be set for either the native path separator or the unix-like system |
||||||
|
#Even without the colon vs semicolon issue, native vs unix-like paths on windows mixed environment systems can cause grief. |
||||||
|
#For now at least, we will simply respect the platform pathSeparator and hope the user manages the environment variables appropriately. |
||||||
|
#some programs do automatic translation - which is a nice idea in principle - but is also prone to error as we don't know if it's already occurred or not depending on how things are launched. |
||||||
|
#An example of where this sort of thing can go wrong is env(TCLLIBPATH) - which is defined as a space separated list not requiring further splitting |
||||||
|
# - but some programs have been known to split this value on colon anyway, which breaks things on windows. |
||||||
|
set paths [split $f $::tcl_platform(pathSeparator)] |
||||||
|
set final [list] |
||||||
|
#eliminate empty values (leading or trailing or extraneous separators) |
||||||
|
foreach p $paths { |
||||||
|
if {[tcl::string::trim $p] ne ""} { |
||||||
|
lappend final $p |
||||||
|
} |
||||||
|
} |
||||||
|
tcl::dict::set startup $varname $final |
||||||
|
} else { |
||||||
|
tcl::dict::set startup $varname $f |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# https://no-color.org |
||||||
|
#if {[info exists ::env(NO_COLOR)]} { |
||||||
|
# if {$::env(NO_COLOR) ne ""} { |
||||||
|
# set colour_disabled 1 |
||||||
|
# } |
||||||
|
#} |
||||||
|
set other_env_vars_config [dict create\ |
||||||
|
NO_COLOR {type string}\ |
||||||
|
XDG_CONFIG_HOME {type string}\ |
||||||
|
XDG_DATA_HOME {type string}\ |
||||||
|
XDG_CACHE_HOME {type string}\ |
||||||
|
XDG_STATE_HOME {type string}\ |
||||||
|
XDG_DATA_DIRS {type pathlist}\ |
||||||
|
POSH_THEME {type string}\ |
||||||
|
POSH_THEMES_PATH {type string}\ |
||||||
|
TCLLIBPATH {type string}\ |
||||||
|
] |
||||||
|
lassign [split [info tclversion] .] tclmajorv tclminorv |
||||||
|
#don't rely on lseq or punk::lib for now.. |
||||||
|
set relevant_minors [list] |
||||||
|
for {set i 0} {$i <= $tclminorv} {incr i} { |
||||||
|
lappend relevant_minors $i |
||||||
|
} |
||||||
|
foreach minor $relevant_minors { |
||||||
|
set vname TCL${tclmajorv}_${minor}_TM_PATH |
||||||
|
if {$minor eq $tclminorv || [info exists ::env($vname)]} { |
||||||
|
dict set other_env_vars_config $vname {type string} |
||||||
|
} |
||||||
|
} |
||||||
|
set other_env_vars [dict keys $other_env_vars_config] |
||||||
|
|
||||||
|
foreach {evar varinfo} $other_env_vars_config { |
||||||
|
if {[info exists ::env($evar)]} { |
||||||
|
set vartype [dict get $varinfo type] |
||||||
|
set f [set ::env($evar)] |
||||||
|
if {$f ne "default"} { |
||||||
|
set varname [tcl::string::tolower $evar] |
||||||
|
if {$vartype eq "pathlist"} { |
||||||
|
set paths [split $f $::tcl_platform(pathSeparator)] |
||||||
|
set final [list] |
||||||
|
#eliminate empty values (leading or trailing or extraneous separators) |
||||||
|
foreach p $paths { |
||||||
|
if {[tcl::string::trim $p] ne ""} { |
||||||
|
lappend final $p |
||||||
|
} |
||||||
|
} |
||||||
|
tcl::dict::set startup $varname $final |
||||||
|
} else { |
||||||
|
tcl::dict::set startup $varname $f |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#unset -nocomplain vars |
||||||
|
|
||||||
|
#todo |
||||||
|
set running [tcl::dict::create] |
||||||
|
set running [tcl::dict::merge $running $startup] |
||||||
|
} |
||||||
|
init |
||||||
|
|
||||||
|
#todo |
||||||
|
proc Apply {config} { |
||||||
|
puts stderr "punk::config::Apply partially implemented" |
||||||
|
set configname [string map {-config ""} $config] |
||||||
|
if {$configname in {startup running}} { |
||||||
|
upvar ::punk::config::$configname applyconfig |
||||||
|
|
||||||
|
if {[dict exists $applyconfig auto_noexec]} { |
||||||
|
set auto [dict get $applyconfig auto_noexec] |
||||||
|
if {![string is boolean -strict $auto]} { |
||||||
|
error "config::Apply error - invalid data for auto_noexec:'$auto' - expected boolean" |
||||||
|
} |
||||||
|
if {$auto} { |
||||||
|
set ::auto_noexec 1 |
||||||
|
} else { |
||||||
|
#puts "auto_noexec false" |
||||||
|
unset -nocomplain ::auto_noexec |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} else { |
||||||
|
error "no config named '$config' found" |
||||||
|
} |
||||||
|
return "apply done" |
||||||
|
} |
||||||
|
Apply startup |
||||||
|
|
||||||
|
#todo - consider how to divide up settings, categories, 'devices', decks etc |
||||||
|
proc get_running_global {varname} { |
||||||
|
variable running |
||||||
|
if {[dict exists $running $varname]} { |
||||||
|
return [dict get $running $varname] |
||||||
|
} |
||||||
|
error "No such global configuration item '$varname' found in running config" |
||||||
|
} |
||||||
|
proc get_startup_global {varname} { |
||||||
|
variable startup |
||||||
|
if {[dict exists $startup $varname]} { |
||||||
|
return [dict get $startup $varname] |
||||||
|
} |
||||||
|
error "No such global configuration item '$varname' found in startup config" |
||||||
|
} |
||||||
|
|
||||||
|
proc get {whichconfig {globfor *}} { |
||||||
|
variable startup |
||||||
|
variable running |
||||||
|
switch -- $whichconfig { |
||||||
|
config - startup - startup-config - startup-configuration { |
||||||
|
#show *startup* config - different behaviour may be confusing to those used to router startup and running configs |
||||||
|
set configdata $startup |
||||||
|
} |
||||||
|
running - running-config - running-configuration { |
||||||
|
set configdata $running |
||||||
|
} |
||||||
|
default { |
||||||
|
error "Unknown config name '$whichconfig' - try startup or running" |
||||||
|
} |
||||||
|
} |
||||||
|
if {$globfor eq "*"} { |
||||||
|
return $configdata |
||||||
|
} else { |
||||||
|
set keys [dict keys $configdata [string tolower $globfor]] |
||||||
|
set filtered [dict create] |
||||||
|
foreach k $keys { |
||||||
|
dict set filtered $k [dict get $configdata $k] |
||||||
|
} |
||||||
|
return $filtered |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc configure {args} { |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
|
||||||
|
whichconfig -type string -choices {startup running} |
||||||
|
} $args] |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
proc show {whichconfig {globfor *}} { |
||||||
|
#todo - tables for console |
||||||
|
set configdata [punk::config::get $whichconfig $globfor] |
||||||
|
return [punk::lib::showdict $configdata] |
||||||
|
} |
||||||
|
|
||||||
|
#e.g |
||||||
|
# copy running-config startup-config |
||||||
|
# copy startup-config test-config.cfg |
||||||
|
# copy backup-config.cfg running-config |
||||||
|
#review - consider the merge vs overwrite feature of some routers.. where copy to running-config does a merge rather than an overwrite |
||||||
|
#This is to allow partial configs to be loaded to running, whereas a save of running to any target is always a complete configuration |
||||||
|
proc copy {args} { |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
*proc -name punk::config::copy -help "Copy a partial or full configuration from one config to another |
||||||
|
If a target config has additional settings, then the source config can be considered to be partial with regards to the target. |
||||||
|
" |
||||||
|
-type -default "" -choices {replace merge} -help "Defaults to merge when target is running-config |
||||||
|
Defaults to replace when source is running-config" |
||||||
|
*values -min 2 -max 2 |
||||||
|
fromconfig -help "running or startup or file name (not fully implemented)" |
||||||
|
toconfig -help "running or startup or file name (not fully implemented)" |
||||||
|
} $args] |
||||||
|
set fromconfig [dict get $argd values fromconfig] |
||||||
|
set toconfig [dict get $argd values toconfig] |
||||||
|
set fromconfig [string map {-config ""} $fromconfig] |
||||||
|
set toconfig [string map {-config ""} $toconfig] |
||||||
|
|
||||||
|
set copytype [dict get $argd opts -type] |
||||||
|
|
||||||
|
|
||||||
|
#todo - warn & prompt if doing merge copy to startup |
||||||
|
switch -exact -- $fromconfig-$toconfig { |
||||||
|
running-startup { |
||||||
|
if {$copytype eq ""} { |
||||||
|
set copytype replace ;#full configuration |
||||||
|
} |
||||||
|
if {$copytype eq "replace"} { |
||||||
|
error "punk::config::copy error. full configuration copy from running to startup config not yet supported" |
||||||
|
} else { |
||||||
|
error "punk::config::copy error. merge configuration copy from running to startup config not yet supported" |
||||||
|
} |
||||||
|
} |
||||||
|
startup-running { |
||||||
|
#default type merge - even though it's not always what is desired |
||||||
|
if {$copytype eq ""} { |
||||||
|
set copytype merge ;#load in a partial configuration |
||||||
|
} |
||||||
|
|
||||||
|
#warn/prompt either way |
||||||
|
if {$copytype eq "replace"} { |
||||||
|
#some routers require use of a separate command for this branch. |
||||||
|
#presumably to ensure the user doesn't accidentally load partials onto a running system |
||||||
|
# |
||||||
|
error "punk::config::copy error. full configuration copy from startup to overwrite running config not supported" |
||||||
|
} else { |
||||||
|
error "punk::config::copy error. merge copy from possibly partial configuration: startup to running config not currently supported" |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
error "punk::config::copy error. copy must from running to startup or startup to running. File sources/targets not yet supported" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#todo - move to cli? |
||||||
|
::tcl::namespace::eval punk::config { |
||||||
|
#todo - something better - 'previous' rather than reverting to startup |
||||||
|
proc channelcolors {{onoff {}}} { |
||||||
|
variable running |
||||||
|
variable startup |
||||||
|
|
||||||
|
if {![string length $onoff]} { |
||||||
|
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] |
||||||
|
} else { |
||||||
|
if {![string is boolean $onoff]} { |
||||||
|
error "channelcolors: invalid value $onoff - expected boolean: true|false|on|off|1|0|yes|no" |
||||||
|
} |
||||||
|
if {$onoff} { |
||||||
|
dict set running color_stdout [dict get $startup color_stdout] |
||||||
|
dict set running color_stderr [dict get $startup color_stderr] |
||||||
|
} else { |
||||||
|
dict set running color_stdout "" |
||||||
|
dict set running color_stderr "" |
||||||
|
} |
||||||
|
} |
||||||
|
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
package provide punk::config [tcl::namespace::eval punk::config { |
||||||
|
variable version |
||||||
|
set version 0.1 |
||||||
|
|
||||||
|
}] |
@ -0,0 +1,164 @@ |
|||||||
|
#punkapps app manager |
||||||
|
# deck cli |
||||||
|
|
||||||
|
namespace eval punk::mod::cli { |
||||||
|
namespace export help list run |
||||||
|
namespace ensemble create |
||||||
|
|
||||||
|
# namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown |
||||||
|
if 0 { |
||||||
|
proc _unknown {ns args} { |
||||||
|
puts stderr "punk::mod::cli::_unknown '$ns' '$args'" |
||||||
|
puts stderr "punk::mod::cli::help $args" |
||||||
|
puts stderr "arglen:[llength $args]" |
||||||
|
punk::mod::cli::help {*}$args |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#cli must have _init method - usually used to load commandsets lazily |
||||||
|
# |
||||||
|
variable initialised 0 |
||||||
|
proc _init {args} { |
||||||
|
variable initialised |
||||||
|
if {$initialised} { |
||||||
|
return |
||||||
|
} |
||||||
|
#... |
||||||
|
set initialised 1 |
||||||
|
} |
||||||
|
|
||||||
|
proc help {args} { |
||||||
|
set basehelp [punk::mix::base help {*}$args] |
||||||
|
#namespace export |
||||||
|
return $basehelp |
||||||
|
} |
||||||
|
proc getraw {appname} { |
||||||
|
upvar ::punk::config::running running_config |
||||||
|
set app_folders [dict get $running_config apps] |
||||||
|
#todo search each app folder |
||||||
|
set bases [::list] |
||||||
|
set versions [::list] |
||||||
|
set mains [::list] |
||||||
|
set appinfo [::list bases {} mains {} versions {}] |
||||||
|
|
||||||
|
foreach containerfolder $app_folders { |
||||||
|
lappend bases $containerfolder |
||||||
|
if {[file exists $containerfolder]} { |
||||||
|
if {[file exists $containerfolder/$appname/main.tcl]} { |
||||||
|
#exact match - only return info for the exact one specified |
||||||
|
set namematches $appname |
||||||
|
set parts [split $appname -] |
||||||
|
} else { |
||||||
|
set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*] |
||||||
|
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? |
||||||
|
} |
||||||
|
foreach nm $namematches { |
||||||
|
set mainfile $containerfolder/$nm/main.tcl |
||||||
|
set parts [split $nm -] |
||||||
|
if {[llength $parts] == 1} { |
||||||
|
set ver "" |
||||||
|
} else { |
||||||
|
set ver [lindex $parts end] |
||||||
|
} |
||||||
|
if {$ver ni $versions} { |
||||||
|
lappend versions $ver |
||||||
|
lappend mains $ver $mainfile |
||||||
|
} else { |
||||||
|
puts stderr "punk::apps::app version '$ver' of app '$appname' already encountered at $mainfile. (will use earliest encountered in running-config apps and ignore others of same version)" |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config" |
||||||
|
} |
||||||
|
} |
||||||
|
dict set appinfo versions $versions |
||||||
|
#todo - natsort! |
||||||
|
set sorted_versions [lsort $versions] |
||||||
|
set latest [lindex $sorted_versions 0] |
||||||
|
if {$latest eq "" && [llength $sorted_versions] > 1} { |
||||||
|
set latest [lindex $sorted_versions 1 |
||||||
|
} |
||||||
|
dict set appinfo latest $latest |
||||||
|
|
||||||
|
dict set appinfo bases $bases |
||||||
|
dict set appinfo mains $mains |
||||||
|
return $appinfo |
||||||
|
} |
||||||
|
|
||||||
|
proc list {{glob *}} { |
||||||
|
upvar ::punk::config::running running_config |
||||||
|
set apps_folder [dict get $running_config apps] |
||||||
|
if {[file exists $apps_folder]} { |
||||||
|
if {[file exists $apps_folder/$glob]} { |
||||||
|
#tailcall source $apps_folder/$glob/main.tcl |
||||||
|
return $glob |
||||||
|
} |
||||||
|
set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob] |
||||||
|
if {[llength $apps] == 0} { |
||||||
|
if {[string first * $glob] <0 && [string first ? $glob] <0} { |
||||||
|
#no glob chars supplied - only launch if exact match for name part |
||||||
|
set namematches [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*] |
||||||
|
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? |
||||||
|
if {[llength $namematches] > 0} { |
||||||
|
set latest [lindex $namematches end] |
||||||
|
lassign $latest nm ver |
||||||
|
#tailcall source $apps_folder/$latest/main.tcl |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
return $apps |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#todo - way to launch as separate process |
||||||
|
# solo-opts only before appname - args following appname are passed to the app |
||||||
|
proc run {args} { |
||||||
|
set nameposn [lsearch -not $args -*] |
||||||
|
if {$nameposn < 0} { |
||||||
|
error "punkapp::run unable to determine application name" |
||||||
|
} |
||||||
|
set appname [lindex $args $nameposn] |
||||||
|
set controlargs [lrange $args 0 $nameposn-1] |
||||||
|
set appargs [lrange $args $nameposn+1 end] |
||||||
|
|
||||||
|
set appinfo [punk::mod::cli::getraw $appname] |
||||||
|
if {[llength [dict get $appinfo versions]]} { |
||||||
|
set ver [dict get $appinfo latest] |
||||||
|
puts stdout "info: $appinfo" |
||||||
|
set ::argc [llength $appargs] |
||||||
|
set ::argv $appargs |
||||||
|
source [dict get $appinfo mains $ver] |
||||||
|
if {"-hideconsole" in $controlargs} { |
||||||
|
puts stderr "attempting console hide" |
||||||
|
#todo - something better - a callback when window mapped? |
||||||
|
after 500 {::punkapp::hide_console} |
||||||
|
} |
||||||
|
return $appinfo |
||||||
|
} else { |
||||||
|
error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
namespace eval punk::mod::cli { |
||||||
|
proc _cli {args} { |
||||||
|
#don't use tailcall - base uses info level to determine caller |
||||||
|
::punk::mix::base::_cli {*}$args |
||||||
|
} |
||||||
|
variable default_command help |
||||||
|
package require punk::mix::base |
||||||
|
package require punk::overlay |
||||||
|
punk::overlay::custom_from_base [namespace current] ::punk::mix::base |
||||||
|
} |
||||||
|
|
||||||
|
package provide punk::mod [namespace eval punk::mod { |
||||||
|
variable version |
||||||
|
set version 0.1 |
||||||
|
|
||||||
|
}] |
||||||
|
|
||||||
|
|
||||||
|
|
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,259 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::repl::codethread 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin shellspy_module_punk::repl::codethread 0 0.1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::repl::codethread] |
||||||
|
#[keywords module] |
||||||
|
#[description] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of punk::repl::codethread |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by punk::repl::codethread |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
package require punk::config |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#tcl::namespace::eval punk::repl::codethread::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::repl::codethread::class}] |
||||||
|
#[para] class definitions |
||||||
|
#if {[info commands [tcl::namespace::current]::interface_sample1] eq ""} { |
||||||
|
#*** !doctools |
||||||
|
#[list_begin enumerated] |
||||||
|
|
||||||
|
# oo::class create interface_sample1 { |
||||||
|
# #*** !doctools |
||||||
|
# #[enum] CLASS [class interface_sample1] |
||||||
|
# #[list_begin definitions] |
||||||
|
|
||||||
|
# method test {arg1} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# #[para] test method |
||||||
|
# puts "test: $arg1" |
||||||
|
# } |
||||||
|
|
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# } |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end class enumeration ---}] |
||||||
|
#} |
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::repl::codethread { |
||||||
|
tcl::namespace::export * |
||||||
|
variable replthread |
||||||
|
variable replthread_cond |
||||||
|
variable running 0 |
||||||
|
|
||||||
|
variable output_stdout "" |
||||||
|
variable output_stderr "" |
||||||
|
|
||||||
|
#variable xyz |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::repl::codethread}] |
||||||
|
#[para] Core API functions for punk::repl::codethread |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#proc sample1 {p1 n args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||||
|
# #[para]Description of sample1 |
||||||
|
# #[para] Arguments: |
||||||
|
# # [list_begin arguments] |
||||||
|
# # [arg_def tring p1] A description of string argument p1. |
||||||
|
# # [arg_def integer n] A description of integer argument n. |
||||||
|
# # [list_end] |
||||||
|
# return "ok" |
||||||
|
#} |
||||||
|
|
||||||
|
proc is_running {} { |
||||||
|
variable running |
||||||
|
return $running |
||||||
|
} |
||||||
|
proc runscript {script} { |
||||||
|
#puts stderr "->runscript" |
||||||
|
variable replthread_cond |
||||||
|
variable output_stdout "" |
||||||
|
variable output_stderr "" |
||||||
|
#expecting to be called from a thread::send in parent repl - ie in the toplevel interp so that the sub-interp "code" is available |
||||||
|
#if a thread::send is done from the commandline in a codethread - Tcl will |
||||||
|
if {"code" ni [interp children] || ![info exists replthread_cond]} { |
||||||
|
#in case someone tries calling from codethread directly - don't do anything or change any state |
||||||
|
#(direct caller could create an interp named code at the level "" -> "code" -"code" and add a replthread_cond value to avoid this check - but it probably won't do anything useful) |
||||||
|
#if called directly - the context will be within the first 'code' interp. |
||||||
|
#inappropriate caller could add superfluous entries to shellfilter stack if function errors out |
||||||
|
#inappropriate caller could affect tsv vars (if their interp allows that anyway) |
||||||
|
puts stderr "runscript is meant to be called from the parent repl thread via a thread::send to the codethread" |
||||||
|
return |
||||||
|
} |
||||||
|
set outstack [list] |
||||||
|
set errstack [list] |
||||||
|
upvar ::punk::config::running running_config |
||||||
|
if {[string length [dict get $running_config color_stdout_repl]] && [interp eval code punk::console::colour]} { |
||||||
|
lappend outstack [interp eval code [list shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout_repl]]]] |
||||||
|
} |
||||||
|
lappend outstack [interp eval code [list shellfilter::stack::add stdout tee_to_var -settings {-varname ::punk::repl::codethread::output_stdout}]] |
||||||
|
|
||||||
|
if {[string length [dict get $running_config color_stderr_repl]] && [interp eval code punk::console::colour]} { |
||||||
|
lappend errstack [interp eval code [list shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr_repl]]]] |
||||||
|
# #lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour cyan]] |
||||||
|
} |
||||||
|
lappend errstack [interp eval code [list shellfilter::stack::add stderr tee_to_var -settings {-varname ::punk::repl::codethread::output_stderr}]] |
||||||
|
|
||||||
|
#an experiment |
||||||
|
#set errhandle [shellfilter::stack::item_tophandle stderr] |
||||||
|
#interp transfer "" $errhandle code |
||||||
|
|
||||||
|
set scope [interp eval code [list set ::punk::ns::ns_current]] |
||||||
|
set status [catch { |
||||||
|
interp eval code [list tcl::namespace::inscope $scope $script] |
||||||
|
} result] |
||||||
|
|
||||||
|
|
||||||
|
flush stdout |
||||||
|
flush stderr |
||||||
|
|
||||||
|
#interp transfer code $errhandle "" |
||||||
|
#flush $errhandle |
||||||
|
set lastoutchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stdout]] end] |
||||||
|
set lasterrchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stderr]] end] |
||||||
|
#puts stderr "-->[ansistring VIEW -lf 1 $lastoutchar$lasterrchar]" |
||||||
|
|
||||||
|
set tid [thread::id] |
||||||
|
tsv::set codethread_$tid info [list lastoutchar $lastoutchar lasterrchar $lasterrchar] |
||||||
|
tsv::set codethread_$tid status $status |
||||||
|
tsv::set codethread_$tid result $result |
||||||
|
tsv::set codethread_$tid errorcode $::errorCode |
||||||
|
|
||||||
|
|
||||||
|
#only remove from shellfilter::stack the items we added to stack in this function |
||||||
|
foreach s [lreverse $outstack] { |
||||||
|
interp eval code [list shellfilter::stack::remove stdout $s] |
||||||
|
} |
||||||
|
foreach s [lreverse $errstack] { |
||||||
|
interp eval code [list shellfilter::stack::remove stderr $s] |
||||||
|
} |
||||||
|
thread::cond notify $replthread_cond |
||||||
|
} |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::repl::codethread ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::repl::codethread::lib { |
||||||
|
tcl::namespace::export * |
||||||
|
tcl::namespace::path [tcl::namespace::parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::repl::codethread::lib}] |
||||||
|
#[para] Secondary functions that are part of the API |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
#proc utility1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of utility1 |
||||||
|
# return 1 |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::repl::codethread::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
tcl::namespace::eval punk::repl::codethread::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::repl::codethread::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::repl::codethread [tcl::namespace::eval punk::repl::codethread { |
||||||
|
variable pkg punk::repl::codethread |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
@ -0,0 +1,237 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::unixywindows 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
#for illegalname_test |
||||||
|
package require punk::winpath |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::unixywindows { |
||||||
|
#'cached' name to make obvious it could be out of date - and to distinguish from unixyroot arg |
||||||
|
variable cachedunixyroot "" |
||||||
|
|
||||||
|
|
||||||
|
#----------------- |
||||||
|
#e.g something like c:/Users/geek/scoop/apps/msys2/current c:/msys2 |
||||||
|
proc get_unixyroot {} { |
||||||
|
variable cachedunixyroot |
||||||
|
if {![string length $cachedunixyroot]} { |
||||||
|
if {![catch { |
||||||
|
set result [exec cygpath -m /] ;# -m gives result with forward-slashes - which is ok for windows paths in a Tcl context. |
||||||
|
set cachedunixyroot [punk::objclone $result] |
||||||
|
file pathtype $cachedunixyroot; #this call causes the int-rep to be path |
||||||
|
#set ::punk::last_run_display [list] ;#hack - review shouldn't really be necessary.. but because we call winpath from ./ - the repl looks for last_run_display |
||||||
|
} errM]} { |
||||||
|
|
||||||
|
} else { |
||||||
|
puts stderr "Warning: Failed to determine base for unix-like paths - using default of c:/msys2" |
||||||
|
file pathtype [set cachedunixyroot [punk::objclone "c:/msys2"]] |
||||||
|
} |
||||||
|
} |
||||||
|
#will have been shimmered from string to 'path' internal rep by 'file pathtype' call |
||||||
|
|
||||||
|
#let's return a different copy as it's so easy to lose path-rep |
||||||
|
set copy [punk::objclone $cachedunixyroot] |
||||||
|
return $copy |
||||||
|
} |
||||||
|
proc refresh_unixyroot {} { |
||||||
|
variable cachedunixyroot |
||||||
|
set result [exec cygpath -m /] ;# -m gives result with forward-slashes - which is ok for windows paths in a Tcl context. |
||||||
|
set cachedunixyroot [punk::objclone $result] |
||||||
|
file pathtype $cachedunixyroot; #this call causes the int-rep to be path |
||||||
|
|
||||||
|
set copy [punk::objclone $cachedunixyroot] |
||||||
|
return $copy |
||||||
|
} |
||||||
|
proc set_unixyroot {windows_path} { |
||||||
|
variable cachedunixyroot |
||||||
|
file pathtype $windows_path |
||||||
|
set cachedunixyroot [punk::objclone $windows_path] |
||||||
|
#return the original - but probably int-rep will have shimmered to path even if started out as string |
||||||
|
#- that's probably what we want. Caller can use as string or path without affecting cachedunixyroot |
||||||
|
return $windows_path |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc windir {path} { |
||||||
|
if {$path eq "~"} { |
||||||
|
#as the tilde hasn't been normalized.. we can't assume we're running on the actual platform |
||||||
|
return ~/.. |
||||||
|
} |
||||||
|
return [file dirname [towinpath $path]] |
||||||
|
} |
||||||
|
|
||||||
|
#REVIEW high-coupling |
||||||
|
proc cdwin {path} { |
||||||
|
set path [towinpath $path] |
||||||
|
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||||
|
if {[llength [info commands ::punk::console::titleset]]} { |
||||||
|
::punk::console::titleset $path |
||||||
|
} |
||||||
|
} |
||||||
|
cd $path |
||||||
|
} |
||||||
|
proc cdwindir {path} { |
||||||
|
set path [towinpath $path] |
||||||
|
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||||
|
if {[llength [info commands ::punk::console::titleset]]} { |
||||||
|
::punk::console::titleset $path |
||||||
|
} |
||||||
|
} |
||||||
|
cd [file dirname $path] |
||||||
|
} |
||||||
|
|
||||||
|
#NOTE - this is an expensive operation - avoid where possible. |
||||||
|
#review - is this intended to be useful/callable on non-windows platforms? |
||||||
|
#it should in theory be useable from another platform that wants to create a path for use on windows. |
||||||
|
#In this case - we shouldn't examine what volumes exist (assume A: .. Z: are valid) |
||||||
|
#review zipfs:// other uri schemes? |
||||||
|
proc towinpath {unixypath {unixyroot ""}} { |
||||||
|
#NOTE: tcl file exists gives different answers on windows for paths like /c depending on cwd (presumably based on file pathtype of volumerelative) |
||||||
|
#(Tcl is also somewhat broken as at 2023 as far as volume relative paths - process can get out of sync with tcl if cd to a vol relative path is used) |
||||||
|
#This is add odds with attempting to navigate on a windows system which has cygwin, wsl etc... It also makes it difficult for functions intended to operate independent of CWD. |
||||||
|
#e.g there is potential confusion when there is a c folder on c: drive (c:/c) |
||||||
|
#I will attempt to provide a coherent operation for winpath ./ ../ etc , but it may disallow for example; change to /something or /x where these don't match a driveletter or /mnt |
||||||
|
#whereas tcl may allow cd to /something if a something folder happens to exist on the current volume based on cwd. |
||||||
|
#I think it's preferable to require an explicit driveletter /x or /mnt when using unix-like paths on windows - but practical considerations may prove me wrong.. |
||||||
|
#It's possible that this function should also ignore the current set of driveletters - and operate completely independent of whether a path actually exists |
||||||
|
#This makes it hard to use things like 'file normalize' - which also looks at things like current volume. |
||||||
|
# |
||||||
|
#Note for example the results of 'which' grep on windows can produce a path like /c/Users/somewhere/bin/grep |
||||||
|
#which tcl's file normalize may change to C:/c/Users or X:/c/Users - based on current volumen. Given that C:/c might exist - this can be problematic in a couple of ways. |
||||||
|
#The mixing of unix-like and windows commands on the same machine is a large part of the problem.. but this mix is now common |
||||||
|
# |
||||||
|
#convert /c/etc to C:/etc |
||||||
|
set re_slash_x_slash {^/([[:alpha:]]){1}/.*} |
||||||
|
set re_slash_else {^/([[:alpha:]]*)(.*)} |
||||||
|
set volumes [file volumes] |
||||||
|
#exclude things like //zipfs:/ ?? |
||||||
|
set driveletters [list] |
||||||
|
foreach v $volumes { |
||||||
|
if {[regexp {^([[:alpha:]]){1}:/$} $v _ letter]} { |
||||||
|
lappend driveletters $letter |
||||||
|
} |
||||||
|
} |
||||||
|
#puts stderr "->$driveletters" |
||||||
|
|
||||||
|
set path [punk::objclone $unixypath] ;#take another copy that we can deliberatley shimmer to path and know is separate to the supplied argument |
||||||
|
set supplied_pathtype [file pathtype $path] ;#we don't care about the pathtype so much as the act of making this call shimmers to a path internal-rep |
||||||
|
|
||||||
|
#copy of var that we can treat as a string without affecting path rep |
||||||
|
#Note that some but not all read operations will lose path rep e.g 'string length $x' will lose any path-rep $x had, (but 'string equal $x something' won't) |
||||||
|
#Todo - make int-rep tests to check stability of these behaviours across Tcl versions! |
||||||
|
set strcopy_path [punk::objclone $path] |
||||||
|
|
||||||
|
set str_newpath "" |
||||||
|
|
||||||
|
set have_pathobj 0 |
||||||
|
|
||||||
|
if {[regexp $re_slash_x_slash $strcopy_path _ letter]} { |
||||||
|
#upper case appears to be windows canonical form |
||||||
|
set str_newpath [string toupper $letter]:/[string range $strcopy_path 3 end] |
||||||
|
} elseif {[regexp {^/mnt/([[:alpha:]]){1}/.*} [string tolower $strcopy_path] _ letter]} { |
||||||
|
set str_newpath [string toupper $letter]:/[string range $strcopy_path 7 end] |
||||||
|
} elseif {[regexp {^/mnt/([[:alpha:]]){1}$} [string tolower $strcopy_path] _ letter]} { |
||||||
|
set str_newpath [string toupper $letter]:/ |
||||||
|
} elseif {[regexp $re_slash_else $strcopy_path _ firstpart remainder]} { |
||||||
|
#could be for example /c or /something/users |
||||||
|
if {[string length $firstpart] == 1} { |
||||||
|
set letter $firstpart |
||||||
|
set str_newpath [string toupper $letter]:/ |
||||||
|
} else { |
||||||
|
#according to regex we have a single leading slash |
||||||
|
set str_tail [string range $strcopy_path 1 end] |
||||||
|
if {$unixyroot eq ""} { |
||||||
|
set unixyroot [get_unixyroot] |
||||||
|
} else { |
||||||
|
file pathtype $unixyroot; #side-effect generates int-rep of type path ) |
||||||
|
} |
||||||
|
set pathobj [file join $unixyroot $str_tail] |
||||||
|
file pathtype $pathobj |
||||||
|
set have_pathobj 1 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {!$have_pathobj} { |
||||||
|
if {$str_newpath eq ""} { |
||||||
|
#dunno - pass through |
||||||
|
set pathobj $path |
||||||
|
} else { |
||||||
|
set pathobj [punk::objclone $str_newpath] |
||||||
|
file pathtype $pathobj |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#puts stderr "=> $path" |
||||||
|
#things like 'which' seem to return a path minus the .exe - so we'll just test the containing folder |
||||||
|
# |
||||||
|
#By now file normalize shouldn't do too many shannanigans related to cwd.. |
||||||
|
#We want it to look at cwd for relative paths.. |
||||||
|
#but we don't consider things like /c/Users to be relative even on windows where it would normally mean a volume-relative path e.g c:/c/Users if cwd happens to be somewhere on C: at the time. |
||||||
|
#if {![file exists [file dirname $path]]} { |
||||||
|
# set path [file normalize $path] |
||||||
|
# #may still not exist.. that's ok. |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#file normalize may change backslashes to forward slashes.. including things like the special \\?\ prefix which is intended to stop windows api from parsing a name |
||||||
|
#2023 - this is ok as //?/ also seems to work.. but it is unclear if that is because Tcl is re-converting to backslashes |
||||||
|
if {[punk::winpath::illegalname_test $pathobj]} { |
||||||
|
set pathobj [punk::winpath::illegalname_fix $pathobj] |
||||||
|
} |
||||||
|
|
||||||
|
return $pathobj |
||||||
|
} |
||||||
|
|
||||||
|
#---------------------------------------------- |
||||||
|
#leave the unixywindows related aliases available on all platforms |
||||||
|
#interp alias {} cdwin {} punk::unixywindows::cdwin |
||||||
|
#interp alias {} cdwindir {} punk::unixywindoes::cdwindir |
||||||
|
#interp alias {} towinpath {} punk::unixywindows::towinpath |
||||||
|
#interp alias {} windir {} punk::unixywindows::windir |
||||||
|
#---------------------------------------------- |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::unixywindows [namespace eval punk::unixywindows { |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
@ -0,0 +1,239 @@ |
|||||||
|
#utilities for punk apps to call |
||||||
|
|
||||||
|
package provide punkapp [namespace eval punkapp { |
||||||
|
variable version |
||||||
|
set version 0.1 |
||||||
|
}] |
||||||
|
|
||||||
|
namespace eval punkapp { |
||||||
|
variable result |
||||||
|
variable waiting "no" |
||||||
|
proc hide_dot_window {} { |
||||||
|
#alternative to wm withdraw . |
||||||
|
#see https://wiki.tcl-lang.org/page/wm+withdraw |
||||||
|
wm geometry . 1x1+0+0 |
||||||
|
wm overrideredirect . 1 |
||||||
|
wm transient . |
||||||
|
} |
||||||
|
proc is_toplevel {w} { |
||||||
|
if {![llength [info commands winfo]]} { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
expr {[winfo toplevel $w] eq $w && ![catch {$w cget -menu}]} |
||||||
|
} |
||||||
|
proc get_toplevels {{w .}} { |
||||||
|
if {![llength [info commands winfo]]} { |
||||||
|
return [list] |
||||||
|
} |
||||||
|
set list {} |
||||||
|
if {[is_toplevel $w]} { |
||||||
|
lappend list $w |
||||||
|
} |
||||||
|
foreach w [winfo children $w] { |
||||||
|
lappend list {*}[get_toplevels $w] |
||||||
|
} |
||||||
|
return $list |
||||||
|
} |
||||||
|
|
||||||
|
proc make_toplevel_next {prefix} { |
||||||
|
set top [get_toplevel_next $prefix] |
||||||
|
return [toplevel $top] |
||||||
|
} |
||||||
|
#possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime |
||||||
|
#todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase? |
||||||
|
#can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix |
||||||
|
proc get_toplevel_next {prefix} { |
||||||
|
set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> "" |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
proc exit {{toplevel ""}} { |
||||||
|
variable waiting |
||||||
|
variable result |
||||||
|
variable default_result |
||||||
|
set toplevels [get_toplevels] |
||||||
|
if {[string length $toplevel]} { |
||||||
|
set wposn [lsearch $toplevels $toplevel] |
||||||
|
if {$wposn > 0} { |
||||||
|
destroy $toplevel |
||||||
|
} |
||||||
|
} else { |
||||||
|
#review |
||||||
|
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||||
|
puts stderr "punkapp::exit called without toplevel - showing console" |
||||||
|
show_console |
||||||
|
return 0 |
||||||
|
} else { |
||||||
|
puts stderr "punkapp::exit called without toplevel - exiting" |
||||||
|
if {$waiting ne "no"} { |
||||||
|
if {[info exists result(shell)]} { |
||||||
|
set temp [set result(shell)] |
||||||
|
unset result(shell) |
||||||
|
set waiting $temp |
||||||
|
} else { |
||||||
|
set waiting "" |
||||||
|
} |
||||||
|
} else { |
||||||
|
::exit |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set controllable [get_user_controllable_toplevels] |
||||||
|
if {![llength $controllable]} { |
||||||
|
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||||
|
show_console |
||||||
|
} else { |
||||||
|
if {$waiting ne "no"} { |
||||||
|
if {[info exists result(shell)]} { |
||||||
|
set temp [set result(shell)] |
||||||
|
unset result(shell) |
||||||
|
set waiting $temp |
||||||
|
} elseif {[info exists result($toplevel)]} { |
||||||
|
set temp [set result($toplevel)] |
||||||
|
unset result($toplevel) |
||||||
|
set waiting $temp |
||||||
|
} elseif {[info exists default_result]} { |
||||||
|
set temp $default_result |
||||||
|
unset default_result |
||||||
|
set waiting $temp |
||||||
|
} else { |
||||||
|
set waiting "" |
||||||
|
} |
||||||
|
} else { |
||||||
|
::exit |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
proc close_window {toplevel} { |
||||||
|
wm withdraw $toplevel |
||||||
|
if {![llength [get_user_controllable_toplevels]]} { |
||||||
|
punkapp::exit $toplevel |
||||||
|
} |
||||||
|
destroy $toplevel |
||||||
|
} |
||||||
|
proc wait {args} { |
||||||
|
variable waiting |
||||||
|
variable default_result |
||||||
|
if {[dict exists $args -defaultresult]} { |
||||||
|
set default_result [dict get $args -defaultresult] |
||||||
|
} |
||||||
|
foreach t [punkapp::get_toplevels] { |
||||||
|
if {[wm protocol $t WM_DELETE_WINDOW] eq ""} { |
||||||
|
wm protocol $t WM_DELETE_WINDOW [list punkapp::close_window $t] |
||||||
|
} |
||||||
|
} |
||||||
|
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||||
|
puts stderr "repl eventloop seems to be running - punkapp::wait not required" |
||||||
|
} else { |
||||||
|
if {$waiting eq "no"} { |
||||||
|
set waiting "waiting" |
||||||
|
vwait ::punkapp::waiting |
||||||
|
return $::punkapp::waiting |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#A window can be 'visible' according to this - but underneath other windows etc |
||||||
|
#REVIEW - change name? |
||||||
|
proc get_visible_toplevels {{w .}} { |
||||||
|
if {![llength [info commands winfo]]} { |
||||||
|
return [list] |
||||||
|
} |
||||||
|
set list [get_toplevels $w] |
||||||
|
set mapped [lmap v $list {expr {[winfo ismapped $v] ? $v : {}}}] |
||||||
|
set mapped [concat {*}$mapped] ;#ignore {} |
||||||
|
set visible [list] |
||||||
|
foreach m $mapped { |
||||||
|
if {[wm overrideredirect $m] == 0 } { |
||||||
|
lappend visible $m |
||||||
|
} else { |
||||||
|
if {[winfo height $m] >1 && [winfo width $m] > 1} { |
||||||
|
#technically even a 1x1 is visible.. but in practice even a 10x10 is hardly likely to be noticeable when overrideredirect == 1 |
||||||
|
#as a convention - 1x1 with no controls is used to make a window invisible so we'll treat anything larger as visible |
||||||
|
lappend visible $m |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $visible |
||||||
|
} |
||||||
|
proc get_user_controllable_toplevels {{w .}} { |
||||||
|
set visible [get_visible_toplevels $w] |
||||||
|
set controllable [list] |
||||||
|
foreach v $visible { |
||||||
|
if {[wm overrideredirect $v] == 0} { |
||||||
|
lappend controllable $v |
||||||
|
} |
||||||
|
} |
||||||
|
#only return visible windows with overrideredirect == 0 because there exists some user control. |
||||||
|
#todo - review.. consider checking if position is outside screen areas? Technically controllable.. but not easily |
||||||
|
return $controllable |
||||||
|
} |
||||||
|
proc hide_console {args} { |
||||||
|
set opts [dict create -force 0] |
||||||
|
if {([llength $args] % 2) != 0} { |
||||||
|
error "hide_console expects pairs of arguments. e.g -force 1" |
||||||
|
} |
||||||
|
#set known_opts [dict keys $defaults] |
||||||
|
foreach {k v} $args { |
||||||
|
switch -- $k { |
||||||
|
-force { |
||||||
|
dict set opts $k $v |
||||||
|
} |
||||||
|
default { |
||||||
|
error "Unrecognised options '$k' known options: [dict keys $opts]" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
set force [dict get $opts -force] |
||||||
|
|
||||||
|
if {!$force} { |
||||||
|
if {![llength [get_user_controllable_toplevels]]} { |
||||||
|
puts stderr "Cannot hide console while no user-controllable windows available" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} |
||||||
|
if {$::tcl_platform(platform) eq "windows"} { |
||||||
|
#hide won't work for certain consoles cush as conemu,wezterm - and doesn't really make sense for tabbed windows anyway. |
||||||
|
#It would be nice if we could tell the console window to hide just the relevant tab - or the whole window if only one tab present - but this is unlikely to be possible in any standard way. |
||||||
|
#an ordinary cmd.exe or pwsh.exe or powershell.exe window can be hidden ok though. |
||||||
|
#(but with wezterm - process is cmd.exe - but it has style popup and can't be hidden with a twapi::hide_window call) |
||||||
|
package require twapi |
||||||
|
set h [twapi::get_console_window] |
||||||
|
set pid [twapi::get_window_process $h] |
||||||
|
set pinfo [twapi::get_process_info $pid -name] |
||||||
|
set pname [dict get $pinfo -name] |
||||||
|
set wstyle [twapi::get_window_style $h] |
||||||
|
#tclkitsh/tclsh? |
||||||
|
if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} { |
||||||
|
twapi::hide_window $h |
||||||
|
return 1 |
||||||
|
} else { |
||||||
|
puts stderr "punkapp::hide_console unable to hide this type of console window" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} else { |
||||||
|
#todo |
||||||
|
puts stderr "punkapp::hide_console unimplemented on this platform (todo)" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc show_console {} { |
||||||
|
if {$::tcl_platform(platform) eq "windows"} { |
||||||
|
package require twapi |
||||||
|
if {![catch {set h [twapi::get_console_window]} errM]} { |
||||||
|
twapi::show_window $h -activate -normal |
||||||
|
} else { |
||||||
|
#no console - assume launched from something like wish? |
||||||
|
catch {console show} |
||||||
|
} |
||||||
|
} else { |
||||||
|
#todo |
||||||
|
puts stderr "punkapp::show_console unimplemented on this platform" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
@ -0,0 +1,333 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punkcheck::cli 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
package require punk::mix::util |
||||||
|
|
||||||
|
namespace eval punkcheck::cli { |
||||||
|
namespace ensemble create |
||||||
|
#package require punk::overlay |
||||||
|
#punk::overlay::import_commandset debug. ::punk:mix::commandset::debug |
||||||
|
|
||||||
|
#init proc required - used for lazy loading of commandsets |
||||||
|
variable initialised 0 |
||||||
|
proc _init {args} { |
||||||
|
variable initialised |
||||||
|
if {$initialised} { |
||||||
|
return |
||||||
|
} |
||||||
|
puts stderr "punkcheck::cli::init $args" |
||||||
|
|
||||||
|
set initialised 1 |
||||||
|
} |
||||||
|
|
||||||
|
proc help {args} { |
||||||
|
set basehelp [punk::mix::base help {*}$args] |
||||||
|
return $basehelp |
||||||
|
} |
||||||
|
|
||||||
|
proc paths {{path {}}} { |
||||||
|
if {$path eq {}} { set path [pwd] } |
||||||
|
set search_from $path |
||||||
|
set bottom_to_top [list] |
||||||
|
while {[string length [set pcheck_file [punkcheck::cli::lib::find_nearest_file $search_from]]]} { |
||||||
|
set pcheck_folder [file dirname $pcheck_file] |
||||||
|
lappend bottom_to_top $pcheck_file |
||||||
|
set search_from [file dirname $pcheck_folder] |
||||||
|
} |
||||||
|
return $bottom_to_top |
||||||
|
} |
||||||
|
#todo! - group by fileset |
||||||
|
proc status {{path {}}} { |
||||||
|
if {$path eq {}} { set path [pwd] } |
||||||
|
set fullpath [file normalize $path] |
||||||
|
|
||||||
|
set ftype [file type $fullpath] |
||||||
|
|
||||||
|
|
||||||
|
set files [list] |
||||||
|
if {$ftype eq "file"} { |
||||||
|
set container [file dirname $fullpath] |
||||||
|
lappend files $fullpath |
||||||
|
} else { |
||||||
|
set container $fullpath |
||||||
|
#vfs can mask mounted files - so we can't just use 'file type' or glob with -type f |
||||||
|
##set files [glob -nocomplain -dir $fullpath -type f *] |
||||||
|
package require punk::nav::fs |
||||||
|
set folderinfo [punk::nav::fs::dirfiles_dict $fullpath] |
||||||
|
set files [concat [dict get $folderinfo files] [dict get $folderinfo underlayfiles]] |
||||||
|
} |
||||||
|
set punkcheck_files [paths $container] |
||||||
|
set repodict [punk::repo::find_repo $container] |
||||||
|
|
||||||
|
if {![llength $punkcheck_files]} { |
||||||
|
puts stderr "No .punkcheck files found at or above this folder" |
||||||
|
} |
||||||
|
|
||||||
|
set table "" |
||||||
|
set files_with_records [list] |
||||||
|
foreach p $punkcheck_files { |
||||||
|
set basedir [file dirname $p] |
||||||
|
set recordlist [punkcheck::load_records_from_file $p] |
||||||
|
set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist] |
||||||
|
|
||||||
|
foreach f $files { |
||||||
|
set relpath [punkcheck::lib::path_relative $basedir $f] |
||||||
|
|
||||||
|
if {[dict exists $tgt_dict $relpath]} { |
||||||
|
set filerec [dict get $tgt_dict $relpath] |
||||||
|
set records [punkcheck::dict_getwithdefault $filerec body [list]] |
||||||
|
if {$ftype eq "file"} { |
||||||
|
if {![llength $records]} { |
||||||
|
set pcheck "(has file record but no installation entries)" |
||||||
|
} else { |
||||||
|
set pcheck \n |
||||||
|
foreach irec $records { |
||||||
|
append pcheck [punk::tdl::prettyprint [list $irec] 1] \n |
||||||
|
#append pcheck " $irec" \n |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
if {![llength $records]} { |
||||||
|
set pcheck "(has file record but no installation entries)" |
||||||
|
} else { |
||||||
|
set display_records [list] |
||||||
|
set pcheck \n |
||||||
|
set latest_install_record [punkcheck::recordlist::file_record_latest_installrecord $filerec] |
||||||
|
if {[llength $latest_install_record]} { |
||||||
|
lappend display_records $latest_install_record |
||||||
|
} |
||||||
|
if {$latest_install_record ne [lindex $records end]} { |
||||||
|
lappend display_records [lindex $records end] |
||||||
|
} |
||||||
|
foreach irec $display_records { |
||||||
|
append pcheck "[format %-14s [dict get $irec tag]] [punkcheck::dict_getwithdefault $irec -tsiso "no-timestamp"]" |
||||||
|
set bodyrecords [punkcheck::dict_getwithdefault $irec body [list]] |
||||||
|
set source_files [list] |
||||||
|
set source_files_changed [list] |
||||||
|
set source_folders [list] |
||||||
|
set source_folders_changed [list] |
||||||
|
foreach r $bodyrecords { |
||||||
|
if {[dict get $r tag] eq "SOURCE"} { |
||||||
|
set path [dict get $r -path] |
||||||
|
set changed [dict get $r -changed] |
||||||
|
switch -- [dict get $r -type] { |
||||||
|
file { |
||||||
|
lappend source_files $path |
||||||
|
if {$changed} { |
||||||
|
lappend source_files_changed $path |
||||||
|
} |
||||||
|
} |
||||||
|
directory { |
||||||
|
lappend source_folders $path |
||||||
|
if {$changed} { |
||||||
|
lappend source_folders_changed $path |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
if {[llength $source_files]} { |
||||||
|
append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])" |
||||||
|
} |
||||||
|
if {[llength $source_folders]} { |
||||||
|
append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])" |
||||||
|
} |
||||||
|
append pcheck \n |
||||||
|
|
||||||
|
#append pcheck [punk::tdl::prettyprint [list $irec] 1] \n |
||||||
|
#append pcheck " $irec" \n |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
append table "$f $pcheck" \n |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $table |
||||||
|
} |
||||||
|
proc status_by_file {{path {}}} { |
||||||
|
if {$path eq {}} { set path [pwd] } |
||||||
|
set fullpath [file normalize $path] |
||||||
|
set ftype [file type $fullpath] |
||||||
|
set files [list] |
||||||
|
if {$ftype eq "file"} { |
||||||
|
set container [file dirname $fullpath] |
||||||
|
lappend files $fullpath |
||||||
|
} else { |
||||||
|
set container $fullpath |
||||||
|
set files [glob -nocomplain -dir $fullpath -type f *] |
||||||
|
} |
||||||
|
set punkcheck_files [paths $container] |
||||||
|
set repodict [punk::repo::find_repo $container] |
||||||
|
|
||||||
|
if {![llength $punkcheck_files]} { |
||||||
|
puts stderr "No .punkcheck files found at or above this folder" |
||||||
|
} |
||||||
|
|
||||||
|
set table "" |
||||||
|
set files_with_records [list] |
||||||
|
foreach p $punkcheck_files { |
||||||
|
set basedir [file dirname $p] |
||||||
|
set recordlist [punkcheck::load_records_from_file $p] |
||||||
|
set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist] |
||||||
|
foreach f $files { |
||||||
|
set relpath [punkcheck::lib::path_relative $basedir $f] |
||||||
|
|
||||||
|
if {[dict exists $tgt_dict $relpath]} { |
||||||
|
set filerec [dict get $tgt_dict $relpath] |
||||||
|
set records [punkcheck::dict_getwithdefault $filerec body [list]] |
||||||
|
if {$ftype eq "file"} { |
||||||
|
if {![llength $records]} { |
||||||
|
set pcheck "(has file record but no installation entries)" |
||||||
|
} else { |
||||||
|
set pcheck \n |
||||||
|
foreach irec $records { |
||||||
|
append pcheck [punk::tdl::prettyprint [list $irec] 1] \n |
||||||
|
#append pcheck " $irec" \n |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
if {![llength $records]} { |
||||||
|
set pcheck "(has file record but no installation entries)" |
||||||
|
} else { |
||||||
|
set display_records [list] |
||||||
|
set pcheck \n |
||||||
|
set latest_install_record [punkcheck::recordlist::file_record_latest_installrecord $filerec] |
||||||
|
lappend display_records $latest_install_record |
||||||
|
if {$latest_install_record ne [lindex $records end]} { |
||||||
|
lappend display_records [lindex $records end] |
||||||
|
} |
||||||
|
foreach irec $display_records { |
||||||
|
append pcheck "[format %-14s [dict get $irec tag]] [punkcheck::dict_getwithdefault $irec -tsiso "no-timestamp"]" |
||||||
|
set bodyrecords [punkcheck::dict_getwithdefault $irec body [list]] |
||||||
|
set source_files [list] |
||||||
|
set source_files_changed [list] |
||||||
|
set source_folders [list] |
||||||
|
set source_folders_changed [list] |
||||||
|
foreach r $bodyrecords { |
||||||
|
if {[dict get $r tag] eq "SOURCE"} { |
||||||
|
set path [dict get $r -path] |
||||||
|
set changed [dict get $r -changed] |
||||||
|
switch -- [dict get $r -type] { |
||||||
|
file { |
||||||
|
lappend source_files $path |
||||||
|
if {$changed} { |
||||||
|
lappend source_files_changed $path |
||||||
|
} |
||||||
|
} |
||||||
|
directory { |
||||||
|
lappend source_folders $path |
||||||
|
if {$changed} { |
||||||
|
lappend source_folders_changed $path |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
if {[llength $source_files]} { |
||||||
|
append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])" |
||||||
|
} |
||||||
|
if {[llength $source_folders]} { |
||||||
|
append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])" |
||||||
|
} |
||||||
|
append pcheck \n |
||||||
|
|
||||||
|
#append pcheck [punk::tdl::prettyprint [list $irec] 1] \n |
||||||
|
#append pcheck " $irec" \n |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
append table "$f $pcheck" \n |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $table |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punkcheck::cli::lib { |
||||||
|
namespace path ::punk::mix::util ;#askuser, do_in_path, foreach-file etc |
||||||
|
|
||||||
|
proc find_nearest_file {{path {}}} { |
||||||
|
if {$path eq {}} { set path [pwd] } |
||||||
|
set folder [lib::scanup $path lib::is_punkchecked_folder] |
||||||
|
if {$folder eq ""} { |
||||||
|
return "" |
||||||
|
} else { |
||||||
|
return [file join $folder .punkcheck] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc is_punkchecked_folder {{path {}}} { |
||||||
|
if {$path eq {}} { set path [pwd] } |
||||||
|
foreach control { |
||||||
|
.punkcheck |
||||||
|
} { |
||||||
|
set control [file join $path $control] |
||||||
|
if {[file isfile $control]} {return 1} |
||||||
|
} |
||||||
|
return 0 |
||||||
|
} |
||||||
|
|
||||||
|
proc scanup {path cmd} { |
||||||
|
if {$path eq {}} { set path [pwd] } |
||||||
|
#based on kettle::path::scanup |
||||||
|
if {[file pathtype $path] eq "relative"} { |
||||||
|
set path [file normalize $path] |
||||||
|
} |
||||||
|
while {1} { |
||||||
|
# Found the proper directory, per the predicate. |
||||||
|
if {[{*}$cmd $path]} { return $path } |
||||||
|
|
||||||
|
# Not found, walk to parent |
||||||
|
set new [file dirname $path] |
||||||
|
|
||||||
|
# Stop when reaching the root. |
||||||
|
if {$new eq $path} { return {} } |
||||||
|
if {$new eq {}} { return {} } |
||||||
|
|
||||||
|
# Ok, truly walk up. |
||||||
|
set path $new |
||||||
|
} |
||||||
|
return {} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punkcheck::cli { |
||||||
|
proc _cli {args} { |
||||||
|
#don't use tailcall - base uses info level to determine caller |
||||||
|
::punk::mix::base::_cli {*}$args |
||||||
|
} |
||||||
|
variable default_command status |
||||||
|
package require punk::mix::base |
||||||
|
package require punk::overlay |
||||||
|
punk::overlay::custom_from_base [namespace current] ::punk::mix::base |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punkcheck::cli [namespace eval punkcheck::cli { |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
|
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,259 @@ |
|||||||
|
|
||||||
|
# Tcl parser for optional arguments in function calls and |
||||||
|
# commandline arguments |
||||||
|
# |
||||||
|
# (c) 2001 Bastien Chevreux |
||||||
|
|
||||||
|
# Index of exported commands |
||||||
|
# - argp::registerArgs |
||||||
|
# - argp::setArgDefaults |
||||||
|
# - argp::setArgsNeeded |
||||||
|
# - argp::parseArgs |
||||||
|
|
||||||
|
# Internal commands |
||||||
|
# - argp::CheckValues |
||||||
|
|
||||||
|
# See end of file for an example on how to use |
||||||
|
|
||||||
|
package provide argp 0.2 |
||||||
|
|
||||||
|
namespace eval argp { |
||||||
|
variable Optstore |
||||||
|
variable Opttypes { |
||||||
|
boolean integer double string |
||||||
|
} |
||||||
|
|
||||||
|
namespace export {[a-z]*} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc argp::registerArgs { func arglist } { |
||||||
|
variable Opttypes |
||||||
|
variable Optstore |
||||||
|
|
||||||
|
set parentns [string range [uplevel 1 [list namespace current]] 2 end] |
||||||
|
if { $parentns != "" } { |
||||||
|
append caller $parentns :: $func |
||||||
|
} else { |
||||||
|
set caller $func |
||||||
|
} |
||||||
|
set cmangled [string map {:: _} $caller] |
||||||
|
|
||||||
|
#puts $parentns |
||||||
|
#puts $caller |
||||||
|
#puts $cmangled |
||||||
|
|
||||||
|
set Optstore(keys,$cmangled) {} |
||||||
|
set Optstore(deflist,$cmangled) {} |
||||||
|
set Optstore(argneeded,$cmangled) {} |
||||||
|
|
||||||
|
foreach arg $arglist { |
||||||
|
foreach {opt type default allowed} $arg { |
||||||
|
set optindex [lsearch -glob $Opttypes $type*] |
||||||
|
if { $optindex < 0} { |
||||||
|
return -code error "$caller, unknown type $type while registering arguments.\nAllowed types: [string trim $Opttypes]" |
||||||
|
} |
||||||
|
set type [lindex $Opttypes $optindex] |
||||||
|
|
||||||
|
lappend Optstore(keys,$cmangled) $opt |
||||||
|
set Optstore(type,$opt,$cmangled) $type |
||||||
|
set Optstore(default,$opt,$cmangled) $default |
||||||
|
set Optstore(allowed,$opt,$cmangled) $allowed |
||||||
|
lappend Optstore(deflist,$cmangled) $opt $default |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if { [catch {CheckValues $caller $cmangled $Optstore(deflist,$cmangled)} res]} { |
||||||
|
return -code error "Error in declaration of optional arguments.\n$res" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc argp::setArgDefaults { func arglist } { |
||||||
|
variable Optstore |
||||||
|
|
||||||
|
set parentns [string range [uplevel 1 [list namespace current]] 2 end] |
||||||
|
if { $parentns != "" } { |
||||||
|
append caller $parentns :: $func |
||||||
|
} else { |
||||||
|
set caller $func |
||||||
|
} |
||||||
|
set cmangled [string map {:: _} $caller] |
||||||
|
|
||||||
|
if {![info exists Optstore(deflist,$cmangled)]} { |
||||||
|
return -code error "Arguments for $caller not registered yet." |
||||||
|
} |
||||||
|
set Optstore(deflist,$cmangled) {} |
||||||
|
foreach {opt default} $arglist { |
||||||
|
if {![info exists Optstore(default,$opt,$cmangled)]} { |
||||||
|
return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)" |
||||||
|
} |
||||||
|
set Optstore(default,$opt,$cmangled) $default |
||||||
|
} |
||||||
|
|
||||||
|
# set the new defaultlist |
||||||
|
foreach opt $Optstore(keys,$cmangled) { |
||||||
|
lappend Optstore(deflist,$cmangled) $opt $Optstore(default,$opt,$cmangled) |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc argp::setArgsNeeded { func arglist } { |
||||||
|
variable Optstore |
||||||
|
|
||||||
|
set parentns [string range [uplevel 1 [list namespace current]] 2 end] |
||||||
|
if { $parentns != "" } { |
||||||
|
append caller $parentns :: $func |
||||||
|
} else { |
||||||
|
set caller $func |
||||||
|
} |
||||||
|
set cmangled [string map {:: _} $caller] |
||||||
|
|
||||||
|
#append caller $parentns :: $func |
||||||
|
#set cmangled ${parentns}_$func |
||||||
|
|
||||||
|
if {![info exists Optstore(deflist,$cmangled)]} { |
||||||
|
return -code error "Arguments for $caller not registered yet." |
||||||
|
} |
||||||
|
|
||||||
|
set Optstore(argneeded,$cmangled) {} |
||||||
|
foreach opt $arglist { |
||||||
|
if {![info exists Optstore(default,$opt,$cmangled)]} { |
||||||
|
return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)" |
||||||
|
} |
||||||
|
lappend Optstore(argneeded,$cmangled) $opt |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc argp::parseArgs { args } { |
||||||
|
variable Optstore |
||||||
|
|
||||||
|
if {[llength $args] == 0} { |
||||||
|
upvar args a opts o |
||||||
|
} else { |
||||||
|
upvar args a [lindex $args 0] o |
||||||
|
} |
||||||
|
|
||||||
|
if { [ catch { set caller [lindex [info level -1] 0]}]} { |
||||||
|
set caller "main program" |
||||||
|
set cmangled "" |
||||||
|
} else { |
||||||
|
set cmangled [string map {:: _} $caller] |
||||||
|
} |
||||||
|
|
||||||
|
if {![info exists Optstore(deflist,$cmangled)]} { |
||||||
|
return -code error "Arguments for $caller not registered yet." |
||||||
|
} |
||||||
|
|
||||||
|
# set the defaults |
||||||
|
array set o $Optstore(deflist,$cmangled) |
||||||
|
|
||||||
|
# but unset the needed arguments |
||||||
|
foreach key $Optstore(argneeded,$cmangled) { |
||||||
|
catch { unset o($key) } |
||||||
|
} |
||||||
|
|
||||||
|
foreach {key val} $a { |
||||||
|
if {![info exists Optstore(type,$key,$cmangled)]} { |
||||||
|
return -code error "$caller, unknown option $key, must be one of: $Optstore(keys,$cmangled)" |
||||||
|
} |
||||||
|
switch -exact -- $Optstore(type,$key,$cmangled) { |
||||||
|
boolean - |
||||||
|
integer { |
||||||
|
if { $val == "" } { |
||||||
|
return -code error "$caller, $key empty string is not $Optstore(type,$key,$cmangled) value." |
||||||
|
} |
||||||
|
if { ![string is $Optstore(type,$key,$cmangled) $val]} { |
||||||
|
return -code error "$caller, $key $val is not $Optstore(type,$key,$cmangled) value." |
||||||
|
} |
||||||
|
} |
||||||
|
double { |
||||||
|
if { $val == "" } { |
||||||
|
return -code error "$caller, $key empty string is not double value." |
||||||
|
} |
||||||
|
if { ![string is double $val]} { |
||||||
|
return -code error "$caller, $key $val is not double value." |
||||||
|
} |
||||||
|
if { [string is integer $val]} { |
||||||
|
set val [expr {$val + .0}] |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
} |
||||||
|
} |
||||||
|
set o($key) $val |
||||||
|
} |
||||||
|
|
||||||
|
foreach key $Optstore(argneeded,$cmangled) { |
||||||
|
if {![info exists o($key)]} { |
||||||
|
return -code error "$caller, needed argument $key was not given." |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if { [catch { CheckValues $caller $cmangled [array get o]} err]} { |
||||||
|
return -code error $err |
||||||
|
} |
||||||
|
|
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc argp::CheckValues { caller cmangled checklist } { |
||||||
|
variable Optstore |
||||||
|
|
||||||
|
#puts "Checking $checklist" |
||||||
|
|
||||||
|
foreach {key val} $checklist { |
||||||
|
if { [llength $Optstore(allowed,$key,$cmangled)] > 0 } { |
||||||
|
switch -exact -- $Optstore(type,$key,$cmangled) { |
||||||
|
string { |
||||||
|
if { [lsearch $Optstore(allowed,$key,$cmangled) $val] < 0} { |
||||||
|
return -code error "$caller, $key $val is not in allowed values: $Optstore(allowed,$key,$cmangled)" |
||||||
|
} |
||||||
|
} |
||||||
|
double - |
||||||
|
integer { |
||||||
|
set found 0 |
||||||
|
foreach range $Optstore(allowed,$key,$cmangled) { |
||||||
|
if {[llength $range] == 1} { |
||||||
|
if { $val == [lindex $range 0] } { |
||||||
|
set found 1 |
||||||
|
break |
||||||
|
} |
||||||
|
} elseif {[llength $range] == 2} { |
||||||
|
set low [lindex $range 0] |
||||||
|
set high [lindex $range 1] |
||||||
|
|
||||||
|
if { ![string is integer $low] \ |
||||||
|
&& [string compare "-" $low] != 0} { |
||||||
|
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a lower value range that is not integer and not \u00b4-\u00b4: $range" |
||||||
|
} |
||||||
|
if { ![string is integer $high] \ |
||||||
|
&& [string compare "+" $high] != 0} { |
||||||
|
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a upper value range that is not integer and not \u00b4+\u00b4: $range" |
||||||
|
} |
||||||
|
if {[string compare "-" $low] == 0} { |
||||||
|
if { [string compare "+" $high] == 0 \ |
||||||
|
|| $val <= $high } { |
||||||
|
set found 1 |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
if { $val >= $low } { |
||||||
|
if {[string compare "+" $high] == 0 \ |
||||||
|
|| $val <= $high } { |
||||||
|
set found 1 |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has an allowed value range containing more than 2 elements: $range" |
||||||
|
} |
||||||
|
} |
||||||
|
if { $found == 0 } { |
||||||
|
return -code error "$caller, $key $val is not covered by allowed ranges: $Optstore(allowed,$key,$cmangled)" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
@ -0,0 +1,306 @@ |
|||||||
|
# Debug - a debug narrative logger. |
||||||
|
# -- Colin McCormack / originally Wub server utilities |
||||||
|
# |
||||||
|
# Debugging areas of interest are represented by 'tokens' which have |
||||||
|
# independantly settable levels of interest (an integer, higher is more detailed) |
||||||
|
# |
||||||
|
# Debug narrative is provided as a tcl script whose value is [subst]ed in the |
||||||
|
# caller's scope if and only if the current level of interest matches or exceeds |
||||||
|
# the Debug call's level of detail. This is useful, as one can place arbitrarily |
||||||
|
# complex narrative in code without unnecessarily evaluating it. |
||||||
|
# |
||||||
|
# TODO: potentially different streams for different areas of interest. |
||||||
|
# (currently only stderr is used. there is some complexity in efficient |
||||||
|
# cross-threaded streams.) |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## Requisites |
||||||
|
|
||||||
|
package require Tcl 8.5- |
||||||
|
|
||||||
|
namespace eval ::debug { |
||||||
|
namespace export -clear \ |
||||||
|
define on off prefix suffix header trailer \ |
||||||
|
names 2array level setting parray pdict \ |
||||||
|
nl tab hexl |
||||||
|
namespace ensemble create -subcommands {} |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## API & Implementation |
||||||
|
|
||||||
|
proc ::debug::noop {args} {} |
||||||
|
|
||||||
|
proc ::debug::debug {tag message {level 1}} { |
||||||
|
variable detail |
||||||
|
if {$detail($tag) < $level} { |
||||||
|
#puts stderr "$tag @@@ $detail($tag) >= $level" |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
variable prefix |
||||||
|
variable suffix |
||||||
|
variable header |
||||||
|
variable trailer |
||||||
|
variable fds |
||||||
|
|
||||||
|
if {[info exists fds($tag)]} { |
||||||
|
set fd $fds($tag) |
||||||
|
} else { |
||||||
|
set fd stderr |
||||||
|
} |
||||||
|
|
||||||
|
# Assemble the shown text from the user message and the various |
||||||
|
# prefixes and suffices (global + per-tag). |
||||||
|
|
||||||
|
set themessage "" |
||||||
|
if {[info exists prefix(::)]} { append themessage $prefix(::) } |
||||||
|
if {[info exists prefix($tag)]} { append themessage $prefix($tag) } |
||||||
|
append themessage $message |
||||||
|
if {[info exists suffix($tag)]} { append themessage $suffix($tag) } |
||||||
|
if {[info exists suffix(::)]} { append themessage $suffix(::) } |
||||||
|
|
||||||
|
# Resolve variables references and command invokations embedded |
||||||
|
# into the message with plain text. |
||||||
|
set code [catch { |
||||||
|
set smessage [uplevel 1 [list ::subst -nobackslashes $themessage]] |
||||||
|
set sheader [uplevel 1 [list ::subst -nobackslashes $header]] |
||||||
|
set strailer [uplevel 1 [list ::subst -nobackslashes $trailer]] |
||||||
|
} __ eo] |
||||||
|
|
||||||
|
# And dump an internal error if that resolution failed. |
||||||
|
if {$code} { |
||||||
|
if {[catch { |
||||||
|
set caller [info level -1] |
||||||
|
}]} { set caller GLOBAL } |
||||||
|
if {[string length $caller] >= 1000} { |
||||||
|
set caller "[string range $caller 0 200]...[string range $caller end-200 end]" |
||||||
|
} |
||||||
|
foreach line [split $caller \n] { |
||||||
|
puts -nonewline $fd "@@(DebugError from $tag ($eo): $line)" |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# From here we have a good message to show. We only shorten it a |
||||||
|
# bit if its a bit excessive in size. |
||||||
|
|
||||||
|
if {[string length $smessage] > 4096} { |
||||||
|
set head [string range $smessage 0 2048] |
||||||
|
set tail [string range $smessage end-2048 end] |
||||||
|
set smessage "${head}...(truncated)...$tail" |
||||||
|
} |
||||||
|
|
||||||
|
foreach line [split $smessage \n] { |
||||||
|
puts $fd "$sheader$tag | $line$strailer" |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# names - return names of debug tags |
||||||
|
proc ::debug::names {} { |
||||||
|
variable detail |
||||||
|
return [lsort [array names detail]] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::2array {} { |
||||||
|
variable detail |
||||||
|
set result {} |
||||||
|
foreach n [lsort [array names detail]] { |
||||||
|
if {[interp alias {} debug.$n] ne "::debug::noop"} { |
||||||
|
lappend result $n $detail($n) |
||||||
|
} else { |
||||||
|
lappend result $n -$detail($n) |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
# level - set level and fd for tag |
||||||
|
proc ::debug::level {tag {level ""} {fd {}}} { |
||||||
|
variable detail |
||||||
|
# TODO: Force level >=0. |
||||||
|
if {$level ne ""} { |
||||||
|
set detail($tag) $level |
||||||
|
} |
||||||
|
|
||||||
|
if {![info exists detail($tag)]} { |
||||||
|
set detail($tag) 1 |
||||||
|
} |
||||||
|
|
||||||
|
variable fds |
||||||
|
if {$fd ne {}} { |
||||||
|
set fds($tag) $fd |
||||||
|
} |
||||||
|
|
||||||
|
return $detail($tag) |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::header {text} { variable header $text } |
||||||
|
proc ::debug::trailer {text} { variable trailer $text } |
||||||
|
|
||||||
|
proc ::debug::define {tag} { |
||||||
|
if {[interp alias {} debug.$tag] ne {}} return |
||||||
|
off $tag |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# Set a prefix/suffix to use for tag. |
||||||
|
# The global (tag-independent) prefix/suffix is adressed through tag '::'. |
||||||
|
# This works because colon (:) is an illegal character for user-specified tags. |
||||||
|
|
||||||
|
proc ::debug::prefix {tag {theprefix {}}} { |
||||||
|
variable prefix |
||||||
|
set prefix($tag) $theprefix |
||||||
|
|
||||||
|
if {[interp alias {} debug.$tag] ne {}} return |
||||||
|
off $tag |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::suffix {tag {theprefix {}}} { |
||||||
|
variable suffix |
||||||
|
set suffix($tag) $theprefix |
||||||
|
|
||||||
|
if {[interp alias {} debug.$tag] ne {}} return |
||||||
|
off $tag |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# turn on debugging for tag |
||||||
|
proc ::debug::on {tag {level ""} {fd {}}} { |
||||||
|
variable active |
||||||
|
set active($tag) 1 |
||||||
|
level $tag $level $fd |
||||||
|
interp alias {} debug.$tag {} ::debug::debug $tag |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# turn off debugging for tag |
||||||
|
proc ::debug::off {tag {level ""} {fd {}}} { |
||||||
|
variable active |
||||||
|
set active($tag) 1 |
||||||
|
level $tag $level $fd |
||||||
|
interp alias {} debug.$tag {} ::debug::noop |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::setting {args} { |
||||||
|
if {[llength $args] == 1} { |
||||||
|
set args [lindex $args 0] |
||||||
|
} |
||||||
|
set fd stderr |
||||||
|
if {[llength $args] % 2} { |
||||||
|
set fd [lindex $args end] |
||||||
|
set args [lrange $args 0 end-1] |
||||||
|
} |
||||||
|
foreach {tag level} $args { |
||||||
|
if {$level > 0} { |
||||||
|
level $tag $level $fd |
||||||
|
interp alias {} debug.$tag {} ::debug::debug $tag |
||||||
|
} else { |
||||||
|
level $tag [expr {-$level}] $fd |
||||||
|
interp alias {} debug.$tag {} ::debug::noop |
||||||
|
} |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## Convenience commands. |
||||||
|
# Format arrays and dicts as multi-line message. |
||||||
|
# Insert newlines and tabs. |
||||||
|
|
||||||
|
proc ::debug::nl {} { return \n } |
||||||
|
proc ::debug::tab {} { return \t } |
||||||
|
|
||||||
|
proc ::debug::parray {a {pattern *}} { |
||||||
|
upvar 1 $a array |
||||||
|
if {![array exists array]} { |
||||||
|
error "\"$a\" isn't an array" |
||||||
|
} |
||||||
|
pdict [array get array] $pattern |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::pdict {dict {pattern *}} { |
||||||
|
set maxl 0 |
||||||
|
set names [lsort -dict [dict keys $dict $pattern]] |
||||||
|
foreach name $names { |
||||||
|
if {[string length $name] > $maxl} { |
||||||
|
set maxl [string length $name] |
||||||
|
} |
||||||
|
} |
||||||
|
set maxl [expr {$maxl + 2}] |
||||||
|
set lines {} |
||||||
|
foreach name $names { |
||||||
|
set nameString [format (%s) $name] |
||||||
|
lappend lines [format "%-*s = %s" \ |
||||||
|
$maxl $nameString \ |
||||||
|
[dict get $dict $name]] |
||||||
|
} |
||||||
|
return [join $lines \n] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::hexl {data {prefix {}}} { |
||||||
|
set r {} |
||||||
|
|
||||||
|
# Convert the data to hex and to characters. |
||||||
|
binary scan $data H*@0a* hexa asciia |
||||||
|
|
||||||
|
# Replace non-printing characters in the data with dots. |
||||||
|
regsub -all -- {[^[:graph:] ]} $asciia {.} asciia |
||||||
|
|
||||||
|
# Pad with spaces to a full multiple of 32/16. |
||||||
|
set n [expr {[string length $hexa] % 32}] |
||||||
|
if {$n < 32} { append hexa [string repeat { } [expr {32-$n}]] } |
||||||
|
#puts "pad H [expr {32-$n}]" |
||||||
|
|
||||||
|
set n [expr {[string length $asciia] % 32}] |
||||||
|
if {$n < 16} { append asciia [string repeat { } [expr {16-$n}]] } |
||||||
|
#puts "pad A [expr {32-$n}]" |
||||||
|
|
||||||
|
# Reassemble formatted, in groups of 16 bytes/characters. |
||||||
|
# The hex part is handled in groups of 32 nibbles. |
||||||
|
set addr 0 |
||||||
|
while {[string length $hexa]} { |
||||||
|
# Get front group of 16 bytes each. |
||||||
|
set hex [string range $hexa 0 31] |
||||||
|
set ascii [string range $asciia 0 15] |
||||||
|
# Prep for next iteration |
||||||
|
set hexa [string range $hexa 32 end] |
||||||
|
set asciia [string range $asciia 16 end] |
||||||
|
|
||||||
|
# Convert the hex to pairs of hex digits |
||||||
|
regsub -all -- {..} $hex {& } hex |
||||||
|
|
||||||
|
# Add the hex and latin-1 data to the result buffer |
||||||
|
append r $prefix [format %04x $addr] { | } $hex { |} $ascii |\n |
||||||
|
incr addr 16 |
||||||
|
} |
||||||
|
|
||||||
|
# And done |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
|
||||||
|
namespace eval debug { |
||||||
|
variable detail ; # map: TAG -> level of interest |
||||||
|
variable prefix ; # map: TAG -> message prefix to use |
||||||
|
variable suffix ; # map: TAG -> message suffix to use |
||||||
|
variable fds ; # map: TAG -> handle of open channel to log to. |
||||||
|
variable header {} ; # per-line heading, subst'ed |
||||||
|
variable trailer {} ; # per-line ending, subst'ed |
||||||
|
|
||||||
|
# Notes: |
||||||
|
# - The tag '::' is reserved. "prefix" and "suffix" use it to store |
||||||
|
# the global message prefix / suffix. |
||||||
|
# - prefix and suffix are applied per message. |
||||||
|
# - header and trailer are per line. And should not generate multiple lines! |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## Ready |
||||||
|
|
||||||
|
package provide debug 1.0.6 |
||||||
|
return |
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,322 @@ |
|||||||
|
package provide funcl [namespace eval funcl { |
||||||
|
variable version |
||||||
|
set version 0.1 |
||||||
|
}] |
||||||
|
#funcl = function list (nested call structure) |
||||||
|
# |
||||||
|
#a basic functional composition o combinator |
||||||
|
#o(f,g)(x) == f(g(x)) |
||||||
|
|
||||||
|
namespace eval funcl { |
||||||
|
|
||||||
|
#from punk |
||||||
|
proc arg_is_script_shaped {arg} { |
||||||
|
if {[string first " " $arg] >= 0} { |
||||||
|
return 1 |
||||||
|
} elseif {[string first \n $arg] >= 0} { |
||||||
|
return 1 |
||||||
|
} elseif {[string first ";" $arg] >= 0} { |
||||||
|
return 1 |
||||||
|
} elseif {[string first \t $arg] >= 0} { |
||||||
|
return 1 |
||||||
|
} else { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc o args { |
||||||
|
set closing [string repeat {]} [expr [llength $args]-1]] |
||||||
|
set body "[join $args { [}] \$data $closing" |
||||||
|
return $body |
||||||
|
} |
||||||
|
|
||||||
|
proc o_ args { |
||||||
|
set body "" |
||||||
|
set tails [lrepeat [llength $args] ""] |
||||||
|
puts stdout "tails: $tails" |
||||||
|
|
||||||
|
set end [lindex $args end] |
||||||
|
if {[llength $end] == 1 && [arg_is_script_shaped $end]} { |
||||||
|
set endfunc [string map "<end> $end" {uplevel 1 [list if 1 <end> ]}] |
||||||
|
} else { |
||||||
|
set endfunc $end |
||||||
|
} |
||||||
|
if {[llength $args] == 1} { |
||||||
|
return $endfunc |
||||||
|
} |
||||||
|
|
||||||
|
set wrap { [} |
||||||
|
append wrap $endfunc |
||||||
|
append wrap { ]} |
||||||
|
|
||||||
|
set i 0 |
||||||
|
foreach cmdlist [lrange $args 0 end-1] { |
||||||
|
set is_script 0 |
||||||
|
if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} { |
||||||
|
set is_script 1 |
||||||
|
set script [lindex $cmdlist 0] |
||||||
|
} |
||||||
|
set t "" |
||||||
|
if {$i > 0} { |
||||||
|
append body { [} |
||||||
|
} |
||||||
|
set posn [lsearch $cmdlist _] |
||||||
|
if {$posn <= 0} { |
||||||
|
append body $cmdlist |
||||||
|
if {$i == [expr {[llength $args] -2}]} { |
||||||
|
#append body " \$data" |
||||||
|
append body " $wrap" |
||||||
|
} |
||||||
|
if {$i > 0} { |
||||||
|
set t {]} |
||||||
|
} |
||||||
|
} else { |
||||||
|
append body [lrange $cmdlist 0 $posn-1] |
||||||
|
if {$i == [expr {[llength $args] -2}]} { |
||||||
|
#append body " \$data" |
||||||
|
append body " $wrap" |
||||||
|
} |
||||||
|
set t [lrange $cmdlist $posn+1 end] |
||||||
|
if {$i > 0} { |
||||||
|
append t { ]} |
||||||
|
} |
||||||
|
} |
||||||
|
lset tails $i $t |
||||||
|
incr i |
||||||
|
} |
||||||
|
append body [join [lreverse $tails] " "] |
||||||
|
puts stdout "tails: $tails" |
||||||
|
|
||||||
|
return $body |
||||||
|
} |
||||||
|
|
||||||
|
#review - consider _call -- if count > 1 then they must all be callable cmdlists(?) |
||||||
|
# what does it mean to have additional _fn wrapper with no other elements? (no actual function) |
||||||
|
#e.g _fn 2 5 6 somefunc {_fn 1 3 {_call 1 3 xxx}} {_fn 1 4 command {_fn ...}} |
||||||
|
# what type indicates running subtrees in parallel vs sequentially? |
||||||
|
# any reason to have _call count other than 1? Presumably the parent node indicates the parallelism/sequentialism etc. |
||||||
|
# |
||||||
|
# |
||||||
|
# accept or return a funcl (or funcltree if multiple funcls in one commandlist) |
||||||
|
# also accept/return a call - return empty list if passed a call |
||||||
|
proc next_funcl {funcl_or_tree} { |
||||||
|
if {[lindex $funcl_or_tree 0] eq "_call"} { |
||||||
|
return [list] |
||||||
|
} |
||||||
|
if {[lindex $funcl_or_tree 0] in [list "_fn" "_call"]} { |
||||||
|
set funcl $funcl_or_tree |
||||||
|
} else { |
||||||
|
error "funcltree not implemented" |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
set count [lindex $funcl 1] |
||||||
|
if {$count == 0} { |
||||||
|
#null funcl.. what is it? metadata/placeholder? |
||||||
|
return $funcl |
||||||
|
} |
||||||
|
set indices [lrange $funcl 2 [expr {1 + $count}]] |
||||||
|
set i 0 |
||||||
|
foreach idx $indices { |
||||||
|
if {$i > 0} { |
||||||
|
#todo - return a funcltree |
||||||
|
error "multi funcl not implemented" |
||||||
|
} |
||||||
|
set next [lindex $funcl $idx] |
||||||
|
incr i |
||||||
|
} |
||||||
|
|
||||||
|
return $next |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
#convert a funcl to a tcl script |
||||||
|
proc funcl_script {funcl} { |
||||||
|
if {![llength $funcl]} { |
||||||
|
return "" |
||||||
|
} |
||||||
|
set body "" |
||||||
|
set tails [list] |
||||||
|
|
||||||
|
set type [lindex $funcl 0] |
||||||
|
if {$type ni [list "_fn" "_call"]} { |
||||||
|
#todo - handle funcltree |
||||||
|
error "type $type not implemented" |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#only count of 1 with index 3 supported(?) |
||||||
|
if {$type eq "_call"} { |
||||||
|
#leaf |
||||||
|
set cmdlist [lindex $funcl 3] |
||||||
|
return $cmdlist |
||||||
|
} |
||||||
|
|
||||||
|
#we will use next_funcl to walk the nodes.. todo support treefuncl response from next_funcl which could branch multiple times. |
||||||
|
#by continually passing back the resulting treefuncl/funcl to next_funcl we can process in correct order (?) |
||||||
|
# we would still need to maintain state to stitch it back together once returned from a subtree.. |
||||||
|
# ie multiple tail parts |
||||||
|
set count [lindex $funcl 1] |
||||||
|
|
||||||
|
if {$count == 1} { |
||||||
|
set idx [lindex $funcl 2] |
||||||
|
if {$idx == 3} { |
||||||
|
set cmdlist_pre [list] |
||||||
|
} else { |
||||||
|
set cmdlist_pre [lrange $funcl 3 $idx-1] |
||||||
|
} |
||||||
|
append body $cmdlist_pre |
||||||
|
set t [lrange $funcl $idx+1 end] |
||||||
|
lappend tails $t |
||||||
|
} else { |
||||||
|
#?? |
||||||
|
error "funcl_script branching not yet supported" |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
set get_next 1 |
||||||
|
set i 1 |
||||||
|
while {$get_next} { |
||||||
|
set funcl [next_funcl $funcl] |
||||||
|
if {![llength $funcl]} { |
||||||
|
set get_next 0 |
||||||
|
} |
||||||
|
lassign $funcl type count idx ;#todo support count > 1 |
||||||
|
if {$type eq "_call"} { |
||||||
|
set get_next 0 |
||||||
|
} |
||||||
|
set t "" |
||||||
|
if {$type eq "_call"} { |
||||||
|
append body { [} |
||||||
|
append body [lindex $funcl $idx] |
||||||
|
append body { ]} |
||||||
|
} else { |
||||||
|
append body { [} |
||||||
|
if {$idx == 3} { |
||||||
|
set cmdlist_pre [list] |
||||||
|
} else { |
||||||
|
set cmdlist_pre [lrange $funcl 3 $idx-1] |
||||||
|
} |
||||||
|
append body $cmdlist_pre |
||||||
|
set t [lrange $funcl $idx+1 end] |
||||||
|
lappend tails $t |
||||||
|
lappend tails { ]} |
||||||
|
} |
||||||
|
incr i |
||||||
|
} |
||||||
|
append body [join [lreverse $tails] " "] |
||||||
|
#puts stdout "tails: $tails" |
||||||
|
|
||||||
|
return $body |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
interp alias "" o_of "" funcl::o_of_n 1 |
||||||
|
|
||||||
|
#o_of_n |
||||||
|
#tcl list rep o combinator |
||||||
|
# |
||||||
|
# can take lists of ordinary commandlists, scripts and funcls |
||||||
|
# _fn 1 x where 1 indicates number of subfuncls and where x indicates next funcl position (_fn list or _arg) |
||||||
|
# _fn 0 indicates next item is an unwrapped commandlist (terminal command) |
||||||
|
# |
||||||
|
#o_of is equivalent to o_of_n 1 (1 argument o combinator) |
||||||
|
#last n args are passed to the prior function |
||||||
|
#e.g for n=1 f a b = f(a(b)) |
||||||
|
#e.g for n=2, e f a b = e(f(a b)) |
||||||
|
proc o_of_n {n args} { |
||||||
|
puts stdout "o_of_n '$args'" |
||||||
|
if {$n != 1} { |
||||||
|
error "o_of_n only implemented for 1 sub-funcl" |
||||||
|
} |
||||||
|
set comp [list] ;#composition list |
||||||
|
set end [lindex $args end] |
||||||
|
if {[lindex $end 0] in {_fn _call}]} { |
||||||
|
#is_funcl |
||||||
|
set endfunc [lindex $args end] |
||||||
|
} else { |
||||||
|
if {[llength $end] == 1 && [arg_is_script_shaped $end]} { |
||||||
|
#set endfunc [string map [list <end> $end] {uplevel 1 [list if 1 <end> ]}] |
||||||
|
set endfunc [list _call 1 3 [list uplevel 1 [list if 1 [lindex $end 0]]]] |
||||||
|
} else { |
||||||
|
set endfunc [list _call 1 3 [list {*}$end]] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {[llength $args] == 1} { |
||||||
|
return $endfunc |
||||||
|
} |
||||||
|
set comp $endfunc |
||||||
|
set revlist [lreverse [lrange $args 0 end-1]] |
||||||
|
foreach cmdlist $revlist { |
||||||
|
puts stderr "o_of_n >>-- $cmdlist" |
||||||
|
if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} { |
||||||
|
set is_script 1 |
||||||
|
set script [lindex $cmdlist 0] |
||||||
|
set arglist [list data] |
||||||
|
|
||||||
|
set comp [list _fn 1 6 call_script $script $arglist $comp] |
||||||
|
} else { |
||||||
|
set posn1 [expr {[llength $cmdlist] + 2 + $n}] |
||||||
|
set comp [list _fn $n $posn1 {*}$cmdlist $comp] |
||||||
|
} |
||||||
|
} |
||||||
|
return $comp |
||||||
|
} |
||||||
|
proc call_script {script argnames args} { |
||||||
|
uplevel 3 [list if 1 [list apply [list $argnames $script] {*}$args]] |
||||||
|
} |
||||||
|
proc funcl_script_test {scr} { |
||||||
|
do_funcl_script_test $scr |
||||||
|
} |
||||||
|
proc do_funcl_script_test {scr} { |
||||||
|
#set j "in do_funcl_script_test" |
||||||
|
#set data "xxx" |
||||||
|
#puts '$scr' |
||||||
|
if 1 $scr |
||||||
|
} |
||||||
|
|
||||||
|
#standard o_ with no script-handling |
||||||
|
proc o_plain args { |
||||||
|
set body "" |
||||||
|
set i 0 |
||||||
|
set tails [lrepeat [llength $args] ""] |
||||||
|
#puts stdout "tails: $tails" |
||||||
|
foreach cmdlist $args { |
||||||
|
set t "" |
||||||
|
if {$i > 0} { |
||||||
|
append body { [} |
||||||
|
} |
||||||
|
set posn [lsearch $cmdlist _] |
||||||
|
if {$posn <= 0} { |
||||||
|
append body $cmdlist |
||||||
|
if {$i == [expr {[llength $args] -1}]} { |
||||||
|
append body " \$data" |
||||||
|
} |
||||||
|
if {$i > 0} { |
||||||
|
set t {]} |
||||||
|
} |
||||||
|
} else { |
||||||
|
append body [lrange $cmdlist 0 $posn-1] |
||||||
|
if {$i == [expr {[llength $args] -1}]} { |
||||||
|
append body " \$data" |
||||||
|
} |
||||||
|
set t [lrange $cmdlist $posn+1 end] |
||||||
|
if {$i > 0} { |
||||||
|
append t { ]} |
||||||
|
} |
||||||
|
} |
||||||
|
lset tails $i $t |
||||||
|
incr i |
||||||
|
} |
||||||
|
append body [join [lreverse $tails] " "] |
||||||
|
#puts stdout "tails: $tails" |
||||||
|
|
||||||
|
return $body |
||||||
|
} |
||||||
|
#timings suggest no faster to split out the first item from the cmdlist loop |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,645 @@ |
|||||||
|
package provide patterncmd [namespace eval patterncmd { |
||||||
|
variable version |
||||||
|
|
||||||
|
set version 1.2.4 |
||||||
|
}] |
||||||
|
|
||||||
|
|
||||||
|
namespace eval pattern { |
||||||
|
variable idCounter 1 ;#used by pattern::uniqueKey |
||||||
|
|
||||||
|
namespace eval cmd { |
||||||
|
namespace eval util { |
||||||
|
package require overtype |
||||||
|
variable colwidths_lib [dict create] |
||||||
|
variable colwidths_lib_default 15 |
||||||
|
|
||||||
|
dict set colwidths_lib "library" [list ch " " num 21 head "|" tail ""] |
||||||
|
dict set colwidths_lib "version" [list ch " " num 7 head "|" tail ""] |
||||||
|
dict set colwidths_lib "type" [list ch " " num 9 head "|" tail ""] |
||||||
|
dict set colwidths_lib "note" [list ch " " num 31 head "|" tail "|"] |
||||||
|
|
||||||
|
proc colhead {type args} { |
||||||
|
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths |
||||||
|
set line "" |
||||||
|
foreach colname [dict keys $colwidths] { |
||||||
|
append line "[col $type $colname [string totitle $colname] {*}$args]" |
||||||
|
} |
||||||
|
return $line |
||||||
|
} |
||||||
|
proc colbreak {type} { |
||||||
|
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths |
||||||
|
set line "" |
||||||
|
foreach colname [dict keys $colwidths] { |
||||||
|
append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]" |
||||||
|
} |
||||||
|
return $line |
||||||
|
} |
||||||
|
proc col {type col val args} { |
||||||
|
# args -head bool -tail bool ? |
||||||
|
#---------------------------------------------------------------------------- |
||||||
|
set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify] |
||||||
|
dict set default -backchar "" |
||||||
|
dict set default -headchar "" |
||||||
|
dict set default -tailchar "" |
||||||
|
dict set default -headoverridechar "" |
||||||
|
dict set default -tailoverridechar "" |
||||||
|
dict set default -justify "left" |
||||||
|
if {([llength $args] % 2) != 0} { |
||||||
|
error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' " |
||||||
|
} |
||||||
|
foreach {k v} $args { |
||||||
|
if {$k ni $known_opts} { |
||||||
|
error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'" |
||||||
|
} |
||||||
|
} |
||||||
|
set opts [dict merge $default $args] |
||||||
|
set backchar [dict get $opts -backchar] |
||||||
|
set headchar [dict get $opts -headchar] |
||||||
|
set tailchar [dict get $opts -tailchar] |
||||||
|
set headoverridechar [dict get $opts -headoverridechar] |
||||||
|
set tailoverridechar [dict get $opts -tailoverridechar] |
||||||
|
set justify [dict get $opts -justify] |
||||||
|
#---------------------------------------------------------------------------- |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths |
||||||
|
#calculate headwidths |
||||||
|
set headwidth 0 |
||||||
|
set tailwidth 0 |
||||||
|
foreach {key def} $colwidths { |
||||||
|
set thisheadlen [string length [dict get $def head]] |
||||||
|
if {$thisheadlen > $headwidth} { |
||||||
|
set headwidth $thisheadlen |
||||||
|
} |
||||||
|
set thistaillen [string length [dict get $def tail]] |
||||||
|
if {$thistaillen > $tailwidth} { |
||||||
|
set tailwidth $thistaillen |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
set spec [dict get $colwidths $col] |
||||||
|
if {[string length $backchar]} { |
||||||
|
set ch $backchar |
||||||
|
} else { |
||||||
|
set ch [dict get $spec ch] |
||||||
|
} |
||||||
|
set num [dict get $spec num] |
||||||
|
set headchar [dict get $spec head] |
||||||
|
set tailchar [dict get $spec tail] |
||||||
|
|
||||||
|
if {[string length $headchar]} { |
||||||
|
set headchar $headchar |
||||||
|
} |
||||||
|
if {[string length $tailchar]} { |
||||||
|
set tailchar $tailchar |
||||||
|
} |
||||||
|
#overrides only apply if the head/tail has a length |
||||||
|
if {[string length $headchar]} { |
||||||
|
if {[string length $headoverridechar]} { |
||||||
|
set headchar $headoverridechar |
||||||
|
} |
||||||
|
} |
||||||
|
if {[string length $tailchar]} { |
||||||
|
if {[string length $tailoverridechar]} { |
||||||
|
set tailchar $tailoverridechar |
||||||
|
} |
||||||
|
} |
||||||
|
set head [string repeat $headchar $headwidth] |
||||||
|
set tail [string repeat $tailchar $tailwidth] |
||||||
|
|
||||||
|
set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]] |
||||||
|
if {$justify eq "left"} { |
||||||
|
set left_done [overtype::left $base "$head$val"] |
||||||
|
return [overtype::right $left_done "$tail"] |
||||||
|
} elseif {$justify in {centre center}} { |
||||||
|
set mid_done [overtype::centre $base $val] |
||||||
|
set left_mid_done [overtype::left $mid_done $head] |
||||||
|
return [overtype::right $left_mid_done $tail] |
||||||
|
} else { |
||||||
|
set right_done [overtype::right $base "$val$tail"] |
||||||
|
return [overtype::left $right_done $head] |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
#package require pattern |
||||||
|
|
||||||
|
proc ::pattern::libs {} { |
||||||
|
set libs [list \ |
||||||
|
pattern {-type core -note "alternative:pattern2"}\ |
||||||
|
pattern2 {-type core -note "alternative:pattern"}\ |
||||||
|
patterncmd {-type core}\ |
||||||
|
metaface {-type core}\ |
||||||
|
patternpredator2 {-type core}\ |
||||||
|
patterndispatcher {-type core}\ |
||||||
|
patternlib {-type core}\ |
||||||
|
patterncipher {-type optional -note optional}\ |
||||||
|
] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
package require overtype |
||||||
|
set result "" |
||||||
|
|
||||||
|
append result "[cmd::util::colbreak lib]\n" |
||||||
|
append result "[cmd::util::colhead lib -justify centre]\n" |
||||||
|
append result "[cmd::util::colbreak lib]\n" |
||||||
|
foreach libname [dict keys $libs] { |
||||||
|
set libinfo [dict get $libs $libname] |
||||||
|
|
||||||
|
append result [cmd::util::col lib library $libname] |
||||||
|
if {[catch [list package present $libname] ver]} { |
||||||
|
append result [cmd::util::col lib version "N/A"] |
||||||
|
} else { |
||||||
|
append result [cmd::util::col lib version $ver] |
||||||
|
} |
||||||
|
append result [cmd::util::col lib type [dict get $libinfo -type]] |
||||||
|
|
||||||
|
if {[dict exists $libinfo -note]} { |
||||||
|
set note [dict get $libinfo -note] |
||||||
|
} else { |
||||||
|
set note "" |
||||||
|
} |
||||||
|
append result [cmd::util::col lib note $note] |
||||||
|
append result "\n" |
||||||
|
} |
||||||
|
append result "[cmd::util::colbreak lib]\n" |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
proc ::pattern::record {recname fields} { |
||||||
|
if {[uplevel 1 [list namespace which $recname]] ne ""} { |
||||||
|
error "(pattern::record) Can't create command '$recname': A command of that name already exists" |
||||||
|
} |
||||||
|
|
||||||
|
set index -1 |
||||||
|
set accessor [list ::apply { |
||||||
|
{index rec args} |
||||||
|
{ |
||||||
|
if {[llength $args] == 0} { |
||||||
|
return [lindex $rec $index] |
||||||
|
} |
||||||
|
if {[llength $args] == 1} { |
||||||
|
return [lreplace $rec $index $index [lindex $args 0]] |
||||||
|
} |
||||||
|
error "Invalid number of arguments." |
||||||
|
} |
||||||
|
|
||||||
|
}] |
||||||
|
|
||||||
|
set map {} |
||||||
|
foreach field $fields { |
||||||
|
dict set map $field [linsert $accessor end [incr index]] |
||||||
|
} |
||||||
|
uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] |
||||||
|
} |
||||||
|
proc ::pattern::record2 {recname fields} { |
||||||
|
if {[uplevel 1 [list namespace which $recname]] ne ""} { |
||||||
|
error "(pattern::record) Can't create command '$recname': A command of that name already exists" |
||||||
|
} |
||||||
|
|
||||||
|
set index -1 |
||||||
|
set accessor [list ::apply] |
||||||
|
|
||||||
|
set template { |
||||||
|
{rec args} |
||||||
|
{ |
||||||
|
if {[llength $args] == 0} { |
||||||
|
return [lindex $rec %idx%] |
||||||
|
} |
||||||
|
if {[llength $args] == 1} { |
||||||
|
return [lreplace $rec %idx% %idx% [lindex $args 0]] |
||||||
|
} |
||||||
|
error "Invalid number of arguments." |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set map {} |
||||||
|
foreach field $fields { |
||||||
|
set body [string map [list %idx% [incr index]] $template] |
||||||
|
dict set map $field [list ::apply $body] |
||||||
|
} |
||||||
|
uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::argstest {args} { |
||||||
|
package require cmdline |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
proc ::pattern::objects {} { |
||||||
|
set result [::list] |
||||||
|
|
||||||
|
foreach ns [namespace children ::pp] { |
||||||
|
#lappend result [::list [namespace tail $ns] [set ${ns}::(self)]] |
||||||
|
set ch [namespace tail $ns] |
||||||
|
if {[string range $ch 0 2] eq "Obj"} { |
||||||
|
set OID [string range $ch 3 end] ;#OID need not be digits (!?) |
||||||
|
lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
proc ::pattern::name {num} { |
||||||
|
#!todo - fix |
||||||
|
#set ::p::${num}::(self) |
||||||
|
|
||||||
|
lassign [interp alias {} ::p::$num] _predator info |
||||||
|
if {![string length $_predator$info]} { |
||||||
|
error "No object found for num:$num (no interp alias for ::p::$num)" |
||||||
|
} |
||||||
|
set invocants [dict get $info i] |
||||||
|
set invocants_with_role_this [dict get $invocants this] |
||||||
|
set invocant_this [lindex $invocants_with_role_this 0] |
||||||
|
|
||||||
|
|
||||||
|
#lassign $invocant_this id info |
||||||
|
#set map [dict get $info map] |
||||||
|
#set fields [lindex $map 0] |
||||||
|
lassign $invocant_this _id _ns _defaultmethod name _etc |
||||||
|
return $name |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::pattern::with {cmd script} { |
||||||
|
foreach c [info commands ::p::-1::*] { |
||||||
|
interp alias {} [namespace tail $c] {} $c $cmd |
||||||
|
} |
||||||
|
interp alias {} . {} $cmd . |
||||||
|
interp alias {} .. {} $cmd .. |
||||||
|
|
||||||
|
return [uplevel 1 $script] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#system diagnostics etc |
||||||
|
|
||||||
|
proc ::pattern::varspace_list {IID} { |
||||||
|
namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables |
||||||
|
|
||||||
|
set varspaces [list] |
||||||
|
dict for {vname vdef} $o_variables { |
||||||
|
set vs [dict get $vdef varspace] |
||||||
|
if {$vs ni $varspaces} { |
||||||
|
lappend varspaces $vs |
||||||
|
} |
||||||
|
} |
||||||
|
if {$o_varspace ni $varspaces} { |
||||||
|
lappend varspaces $o_varspace |
||||||
|
} |
||||||
|
return $varspaces |
||||||
|
} |
||||||
|
|
||||||
|
proc ::pattern::check_interfaces {} { |
||||||
|
foreach ns [namespace children ::p] { |
||||||
|
set IID [namespace tail $ns] |
||||||
|
if {[string is digit $IID]} { |
||||||
|
foreach ref [array names ${ns}::_iface::o_usedby] { |
||||||
|
set OID [string range $ref 1 end] |
||||||
|
if {![namespace exists ::p::${OID}::_iface]} { |
||||||
|
puts -nonewline stdout "\r\nPROBLEM!!!!!!!!! nonexistant/invalid object $OID referenced by Interface $IID\r\n" |
||||||
|
} else { |
||||||
|
puts -nonewline stdout . |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#if {![info exists ::p::${OID}::(self)]} { |
||||||
|
# puts "PROBLEM!!!!!!!!! nonexistant object $OID referenced by Interface $IID" |
||||||
|
#} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
puts -nonewline stdout "\r\n" |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#from: http://wiki.tcl.tk/8766 (Introspection on aliases) |
||||||
|
#usedby: metaface-1.1.6+ |
||||||
|
#required because aliases can be renamed. |
||||||
|
#A renamed alias will still return it's target with 'interp alias {} oldname' |
||||||
|
# - so given newname - we require which_alias to return the same info. |
||||||
|
proc ::pattern::which_alias {cmd} { |
||||||
|
uplevel 1 [list ::trace add execution $cmd enterstep ::error] |
||||||
|
catch {uplevel 1 $cmd} res |
||||||
|
uplevel 1 [list ::trace remove execution $cmd enterstep ::error] |
||||||
|
#puts stdout "which_alias $cmd returning '$res'" |
||||||
|
return $res |
||||||
|
} |
||||||
|
# [info args] like proc following an alias recursivly until it reaches |
||||||
|
# the proc it originates from or cannot determine it. |
||||||
|
# accounts for default parameters set by interp alias |
||||||
|
# |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
proc ::pattern::aliasargs {cmd} { |
||||||
|
set orig $cmd |
||||||
|
|
||||||
|
set defaultargs [list] |
||||||
|
|
||||||
|
# loop until error or return occurs |
||||||
|
while {1} { |
||||||
|
# is it a proc already? |
||||||
|
if {[string equal [info procs $cmd] $cmd]} { |
||||||
|
set result [info args $cmd] |
||||||
|
# strip off the interp set default args |
||||||
|
return [lrange $result [llength $defaultargs] end] |
||||||
|
} |
||||||
|
# is it a built in or extension command we can get no args for? |
||||||
|
if {![string equal [info commands $cmd] $cmd]} { |
||||||
|
error "\"$orig\" isn't a procedure" |
||||||
|
} |
||||||
|
|
||||||
|
# catch bogus cmd names |
||||||
|
if {[lsearch [interp aliases {}] $cmd]==-1} { |
||||||
|
if {[catch {::pattern::which_alias $cmd} alias]} { |
||||||
|
error "\"$orig\" isn't a procedure or alias or command" |
||||||
|
} |
||||||
|
#set cmd [lindex $alias 0] |
||||||
|
if {[llength $alias]>1} { |
||||||
|
set cmd [lindex $alias 0] |
||||||
|
set defaultargs [concat [lrange $alias 1 end] $defaultargs] |
||||||
|
} else { |
||||||
|
set cmd $alias |
||||||
|
} |
||||||
|
} else { |
||||||
|
|
||||||
|
if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { |
||||||
|
# check if it is aliased in from another interpreter |
||||||
|
if {[catch {interp target {} $cmd} msg]} { |
||||||
|
error "Cannot resolve \"$orig\", alias leads to another interpreter." |
||||||
|
} |
||||||
|
if {$msg != {} } { |
||||||
|
error "Not recursing into slave interpreter \"$msg\".\ |
||||||
|
\"$orig\" could not be resolved." |
||||||
|
} |
||||||
|
# check if defaults are set for the alias |
||||||
|
if {[llength $cmdargs]>1} { |
||||||
|
set cmd [lindex $cmdargs 0] |
||||||
|
set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] |
||||||
|
} else { |
||||||
|
set cmd $cmdargs |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
proc ::pattern::aliasbody {cmd} { |
||||||
|
set orig $cmd |
||||||
|
|
||||||
|
set defaultargs [list] |
||||||
|
|
||||||
|
# loop until error or return occurs |
||||||
|
while {1} { |
||||||
|
# is it a proc already? |
||||||
|
if {[string equal [info procs $cmd] $cmd]} { |
||||||
|
set result [info body $cmd] |
||||||
|
# strip off the interp set default args |
||||||
|
return $result |
||||||
|
#return [lrange $result [llength $defaultargs] end] |
||||||
|
} |
||||||
|
# is it a built in or extension command we can get no args for? |
||||||
|
if {![string equal [info commands $cmd] $cmd]} { |
||||||
|
error "\"$orig\" isn't a procedure" |
||||||
|
} |
||||||
|
|
||||||
|
# catch bogus cmd names |
||||||
|
if {[lsearch [interp aliases {}] $cmd]==-1} { |
||||||
|
if {[catch {::pattern::which_alias $cmd} alias]} { |
||||||
|
error "\"$orig\" isn't a procedure or alias or command" |
||||||
|
} |
||||||
|
#set cmd [lindex $alias 0] |
||||||
|
if {[llength $alias]>1} { |
||||||
|
set cmd [lindex $alias 0] |
||||||
|
set defaultargs [concat [lrange $alias 1 end] $defaultargs] |
||||||
|
} else { |
||||||
|
set cmd $alias |
||||||
|
} |
||||||
|
} else { |
||||||
|
|
||||||
|
if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { |
||||||
|
# check if it is aliased in from another interpreter |
||||||
|
if {[catch {interp target {} $cmd} msg]} { |
||||||
|
error "Cannot resolve \"$orig\", alias leads to another interpreter." |
||||||
|
} |
||||||
|
if {$msg != {} } { |
||||||
|
error "Not recursing into slave interpreter \"$msg\".\ |
||||||
|
\"$orig\" could not be resolved." |
||||||
|
} |
||||||
|
# check if defaults are set for the alias |
||||||
|
if {[llength $cmdargs]>1} { |
||||||
|
set cmd [lindex $cmdargs 0] |
||||||
|
set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] |
||||||
|
} else { |
||||||
|
set cmd $cmdargs |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
proc ::pattern::uniqueKey2 {} { |
||||||
|
#!todo - something else?? |
||||||
|
return [clock seconds]-[incr ::pattern::idCounter] |
||||||
|
} |
||||||
|
|
||||||
|
#used by patternlib package |
||||||
|
proc ::pattern::uniqueKey {} { |
||||||
|
return [incr ::pattern::idCounter] |
||||||
|
#uuid with tcllibc is about 30us compared with 2us |
||||||
|
# for large datasets, e.g about 100K inserts this would be pretty noticable! |
||||||
|
#!todo - uuid pool with background thread to repopulate when idle? |
||||||
|
#return [uuid::uuid generate] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#------------------------------------------------------------------------------------------------------------------------- |
||||||
|
|
||||||
|
proc ::pattern::test1 {} { |
||||||
|
set msg "OK" |
||||||
|
|
||||||
|
puts stderr "next line should say:'--- saystuff:$msg" |
||||||
|
::>pattern .. Create ::>thing |
||||||
|
|
||||||
|
::>thing .. PatternMethod saystuff args { |
||||||
|
puts stderr "--- saystuff: $args" |
||||||
|
} |
||||||
|
::>thing .. Create ::>jjj |
||||||
|
|
||||||
|
::>jjj . saystuff $msg |
||||||
|
::>jjj .. Destroy |
||||||
|
::>thing .. Destroy |
||||||
|
} |
||||||
|
|
||||||
|
proc ::pattern::test2 {} { |
||||||
|
set msg "OK" |
||||||
|
|
||||||
|
puts stderr "next line should say:'--- property 'stuff' value:$msg" |
||||||
|
::>pattern .. Create ::>thing |
||||||
|
|
||||||
|
::>thing .. PatternProperty stuff $msg |
||||||
|
|
||||||
|
::>thing .. Create ::>jjj |
||||||
|
|
||||||
|
puts stderr "--- property 'stuff' value:[::>jjj . stuff]" |
||||||
|
::>jjj .. Destroy |
||||||
|
::>thing .. Destroy |
||||||
|
} |
||||||
|
|
||||||
|
proc ::pattern::test3 {} { |
||||||
|
set msg "OK" |
||||||
|
|
||||||
|
puts stderr "next line should say:'--- property 'stuff' value:$msg" |
||||||
|
::>pattern .. Create ::>thing |
||||||
|
|
||||||
|
::>thing .. Property stuff $msg |
||||||
|
|
||||||
|
puts stderr "--- property 'stuff' value:[::>thing . stuff]" |
||||||
|
::>thing .. Destroy |
||||||
|
} |
||||||
|
|
||||||
|
#--------------------------------- |
||||||
|
#unknown/obsolete |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args} |
||||||
|
if {0} { |
||||||
|
proc ::p::internals::new_interface {{usedbylist {}}} { |
||||||
|
set OID [incr ::p::ID] |
||||||
|
::p::internals::new_object ::p::ifaces::>$OID "" $OID |
||||||
|
puts "obsolete >> new_interface created object $OID" |
||||||
|
foreach usedby $usedbylist { |
||||||
|
set ::p::${OID}::_iface::o_usedby(i$usedby) 1 |
||||||
|
} |
||||||
|
set ::p::${OID}::_iface::o_varspace "" ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace) |
||||||
|
#NOTE - o_varspace is only the default varspace for when new methods/properties are added. |
||||||
|
# it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value. |
||||||
|
|
||||||
|
set ::p::${OID}::_iface::o_constructor [list] |
||||||
|
set ::p::${OID}::_iface::o_variables [list] |
||||||
|
set ::p::${OID}::_iface::o_properties [dict create] |
||||||
|
set ::p::${OID}::_iface::o_methods [dict create] |
||||||
|
array set ::p::${OID}::_iface::o_definition [list] |
||||||
|
set ::p::${OID}::_iface::o_open 1 ;#open for extending |
||||||
|
return $OID |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#temporary way to get OID - assumes single 'this' invocant |
||||||
|
#!todo - make generic. |
||||||
|
proc ::pattern::get_oid {_ID_} { |
||||||
|
#puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]" |
||||||
|
return [lindex [dict get $_ID_ i this] 0 0] |
||||||
|
|
||||||
|
#set invocants [dict get $_ID_ i] |
||||||
|
#set invocant_roles [dict keys $invocants] |
||||||
|
#set role_members [dict get $invocants this] |
||||||
|
##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list. |
||||||
|
#set this_invocant [lindex [dict get $_ID_ i this] 0] ; |
||||||
|
#lassign $this_invocant OID this_info |
||||||
|
# |
||||||
|
#return $OID |
||||||
|
} |
||||||
|
|
||||||
|
#compile the uncompiled level1 interface |
||||||
|
#assert: no more than one uncompiled interface present at level1 |
||||||
|
proc ::p::meta::PatternCompile {self} { |
||||||
|
???? |
||||||
|
|
||||||
|
upvar #0 $self SELFMAP |
||||||
|
set ID [lindex $SELFMAP 0 0] |
||||||
|
|
||||||
|
set patterns [lindex $SELFMAP 1 1] ;#list of level1 interfaces |
||||||
|
|
||||||
|
set iid -1 |
||||||
|
foreach i $patterns { |
||||||
|
if {[set ::p::${i}::_iface::o_open]} { |
||||||
|
set iid $i ;#found it |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {$iid > -1} { |
||||||
|
#!todo |
||||||
|
|
||||||
|
::p::compile_interface $iid |
||||||
|
set ::p::${iid}::_iface::o_open 0 |
||||||
|
} else { |
||||||
|
#no uncompiled interface present at level 1. Do nothing. |
||||||
|
return |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::p::meta::Def {self} { |
||||||
|
error ::p::meta::Def |
||||||
|
|
||||||
|
upvar #0 $self SELFMAP |
||||||
|
set self_ID [lindex $SELFMAP 0 0] |
||||||
|
set IFID [lindex $SELFMAP 1 0 end] |
||||||
|
|
||||||
|
set maxc1 0 |
||||||
|
set maxc2 0 |
||||||
|
|
||||||
|
set arrName ::p::${IFID}:: |
||||||
|
|
||||||
|
upvar #0 $arrName state |
||||||
|
|
||||||
|
array set methods {} |
||||||
|
|
||||||
|
foreach nm [array names state] { |
||||||
|
if {[regexp {^m-1,name,(.+)} $nm _match mname]} { |
||||||
|
set methods($mname) [set state($nm)] |
||||||
|
|
||||||
|
if {[string length $mname] > $maxc1} { |
||||||
|
set maxc1 [string length $mname] |
||||||
|
} |
||||||
|
if {[string length [set state($nm)]] > $maxc2} { |
||||||
|
set maxc2 [string length [set state($nm)]] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
set bg1 [string repeat " " [expr {$maxc1 + 2}]] |
||||||
|
set bg2 [string repeat " " [expr {$maxc2 + 2}]] |
||||||
|
|
||||||
|
|
||||||
|
set r {} |
||||||
|
foreach nm [lsort -dictionary [array names methods]] { |
||||||
|
set arglist $state(m-1,args,$nm) |
||||||
|
append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n" |
||||||
|
} |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,754 @@ |
|||||||
|
package provide patternpredator2 1.2.4 |
||||||
|
|
||||||
|
proc ::p::internals::jaws {OID _ID_ args} { |
||||||
|
#puts stderr ">>>(patternpredator2 lib)jaws called with _ID_:$_ID_ args: $args" |
||||||
|
#set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid |
||||||
|
|
||||||
|
yield |
||||||
|
set w 1 |
||||||
|
|
||||||
|
set stack [list] |
||||||
|
set wordcount [llength $args] |
||||||
|
set terminals [list . .. , # @ !] ;#tokens which require the current stack to be evaluated first |
||||||
|
set unsupported 0 |
||||||
|
set operator "" |
||||||
|
set operator_prev "" ;#used only by argprotect to revert to previous operator |
||||||
|
|
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
#!DO NOT use upvar here for MAP! (calling set on a MAP in another iteration/call will overwrite a map for another object!) |
||||||
|
#upvar #0 ::p::${OID}::_meta::map MAP |
||||||
|
set MAP [set ::p::${OID}::_meta::map] |
||||||
|
} else { |
||||||
|
# error "jaws - OID = 'null' ???" |
||||||
|
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] ;#MAP taken from _ID_ will be missing 'interfaces' key |
||||||
|
} |
||||||
|
set invocantdata [dict get $MAP invocantdata] |
||||||
|
lassign $invocantdata OID alias default_method object_command wrapped |
||||||
|
|
||||||
|
set finished_args 0 ;#whether we've completely processed all args in the while loop and therefor don't need to peform the final word processing code |
||||||
|
|
||||||
|
#don't use 'foreach word $args' - we sometimes need to backtrack a little by manipulating $w |
||||||
|
while {$w < $wordcount} { |
||||||
|
set word [lindex $args [expr {$w -1}]] |
||||||
|
#puts stdout "w:$w word:$word stack:$stack" |
||||||
|
|
||||||
|
if {$operator eq "argprotect"} { |
||||||
|
set operator $operator_prev |
||||||
|
lappend stack $word |
||||||
|
incr w |
||||||
|
} else { |
||||||
|
if {[llength $stack]} { |
||||||
|
if {$word in $terminals} { |
||||||
|
set reduction [list 0 $_ID_ {*}$stack ] |
||||||
|
#puts stderr ">>>jaws yielding value: $reduction triggered by word $word in position:$w" |
||||||
|
|
||||||
|
|
||||||
|
set _ID_ [yield $reduction] |
||||||
|
set stack [list] |
||||||
|
#set OID [::pattern::get_oid $_ID_] |
||||||
|
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid |
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
set MAP [set ::p::${OID}::_meta::map] ;#Do not use upvar here! |
||||||
|
} else { |
||||||
|
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces [list level0 {} level1 {}]] |
||||||
|
#puts stderr "WARNING REVIEW: jaws-branch - leave empty??????" |
||||||
|
} |
||||||
|
|
||||||
|
#review - 2018. switched to _ID_ instead of MAP |
||||||
|
lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command |
||||||
|
#lassign [dict get $MAP invocantdata] OID alias default_method object_command |
||||||
|
|
||||||
|
|
||||||
|
#puts stdout "---->>> yielded _ID_: $_ID_ OID:$OID alias:$alias default_method:$default_method object_command:$object_command" |
||||||
|
set operator $word |
||||||
|
#don't incr w |
||||||
|
#incr w |
||||||
|
} else { |
||||||
|
if {$operator eq "argprotect"} { |
||||||
|
set operator $operator_prev |
||||||
|
set operator_prev "" |
||||||
|
lappend stack $word |
||||||
|
} else { |
||||||
|
#only look for leading argprotect chacter (-) if we're not already in argprotect mode |
||||||
|
if {$word eq "--"} { |
||||||
|
set operator_prev $operator |
||||||
|
set operator "argprotect" |
||||||
|
#Don't add the plain argprotector to the stack |
||||||
|
} elseif {[string match "-*" $word]} { |
||||||
|
#argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) |
||||||
|
set operator_prev $operator |
||||||
|
set operator "argprotect" |
||||||
|
lappend stack $word |
||||||
|
} else { |
||||||
|
lappend stack $word |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
incr w |
||||||
|
} |
||||||
|
} else { |
||||||
|
#no stack |
||||||
|
switch -- $word {.} { |
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
#we know next word is a property or method of a pattern object |
||||||
|
incr w |
||||||
|
set nextword [lindex $args [expr {$w - 1}]] |
||||||
|
set command ::p::${OID}::$nextword |
||||||
|
set stack [list $command] ;#2018 j |
||||||
|
set operator . |
||||||
|
if {$w eq $wordcount} { |
||||||
|
set finished_args 1 |
||||||
|
} |
||||||
|
} else { |
||||||
|
# don't incr w |
||||||
|
#set nextword [lindex $args [expr {$w - 1}]] |
||||||
|
set command $object_command ;#taken from the MAP |
||||||
|
set stack [list "_exec_" $command] |
||||||
|
set operator . |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
} {..} { |
||||||
|
incr w |
||||||
|
set nextword [lindex $args [expr {$w -1}]] |
||||||
|
set command ::p::-1::$nextword |
||||||
|
#lappend stack $command ;#lappend a small number of items to an empty list is slower than just setting the list. |
||||||
|
set stack [list $command] ;#faster, and intent is clearer than lappend. |
||||||
|
set operator .. |
||||||
|
if {$w eq $wordcount} { |
||||||
|
set finished_args 1 |
||||||
|
} |
||||||
|
} {,} { |
||||||
|
#puts stdout "Stackless comma!" |
||||||
|
|
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
set command ::p::${OID}::$default_method |
||||||
|
} else { |
||||||
|
set command [list $default_method $object_command] |
||||||
|
#object_command in this instance presumably be a list and $default_method a list operation |
||||||
|
#e.g "lindex {A B C}" |
||||||
|
} |
||||||
|
#lappend stack $command |
||||||
|
set stack [list $command] |
||||||
|
set operator , |
||||||
|
} {--} { |
||||||
|
set operator_prev $operator |
||||||
|
set operator argprotect |
||||||
|
#no stack - |
||||||
|
} {!} { |
||||||
|
set command $object_command |
||||||
|
set stack [list "_exec_" $object_command] |
||||||
|
#puts stdout "!!!! !!!! $stack" |
||||||
|
set operator ! |
||||||
|
} default { |
||||||
|
if {$operator eq ""} { |
||||||
|
if {$OID ne "null"} { |
||||||
|
set command ::p::${OID}::$default_method |
||||||
|
} else { |
||||||
|
set command [list $default_method $object_command] |
||||||
|
} |
||||||
|
set stack [list $command] |
||||||
|
set operator , |
||||||
|
lappend stack $word |
||||||
|
} else { |
||||||
|
#no stack - so we don't expect to be in argprotect mode already. |
||||||
|
if {[string match "-*" $word]} { |
||||||
|
#argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) |
||||||
|
set operator_prev $operator |
||||||
|
set operator "argprotect" |
||||||
|
lappend stack $word |
||||||
|
} else { |
||||||
|
lappend stack $word |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
} |
||||||
|
incr w |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
} ;#end while |
||||||
|
|
||||||
|
#process final word outside of loop |
||||||
|
#assert $w == $wordcount |
||||||
|
#trailing operators or last argument |
||||||
|
if {!$finished_args} { |
||||||
|
set word [lindex $args [expr {$w -1}]] |
||||||
|
if {$operator eq "argprotect"} { |
||||||
|
set operator $operator_prev |
||||||
|
set operator_prev "" |
||||||
|
|
||||||
|
lappend stack $word |
||||||
|
incr w |
||||||
|
} else { |
||||||
|
|
||||||
|
|
||||||
|
switch -- $word {.} { |
||||||
|
if {![llength $stack]} { |
||||||
|
#set stack [list "_result_" [::p::internals::ref_to_object $_ID_]] |
||||||
|
yieldto return [::p::internals::ref_to_object $_ID_] |
||||||
|
error "assert: never gets here" |
||||||
|
|
||||||
|
} else { |
||||||
|
#puts stdout "==== $stack" |
||||||
|
#assert - whenever _ID_ changed in this proc - we have updated the $OID variable |
||||||
|
yieldto return [::p::internals::ref_to_stack $OID $_ID_ $stack] |
||||||
|
error "assert: never gets here" |
||||||
|
} |
||||||
|
set operator . |
||||||
|
|
||||||
|
} {..} { |
||||||
|
#trailing .. after chained call e.g >x . item 0 .. |
||||||
|
#puts stdout "$$$$$$$$$$$$ [list 0 $_ID_ {*}$stack] $$$$" |
||||||
|
#set reduction [list 0 $_ID_ {*}$stack] |
||||||
|
yieldto return [yield [list 0 $_ID_ {*}$stack]] |
||||||
|
} {#} { |
||||||
|
set unsupported 1 |
||||||
|
} {,} { |
||||||
|
set unsupported 1 |
||||||
|
} {&} { |
||||||
|
set unsupported 1 |
||||||
|
} {@} { |
||||||
|
set unsupported 1 |
||||||
|
} {--} { |
||||||
|
|
||||||
|
#set reduction [list 0 $_ID_ {*}$stack[set stack [list]]] |
||||||
|
#puts stdout " -> -> -> about to call yield $reduction <- <- <-" |
||||||
|
set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]] ] |
||||||
|
#set OID [::pattern::get_oid $_ID_] |
||||||
|
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid |
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! |
||||||
|
} else { |
||||||
|
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}} ] |
||||||
|
} |
||||||
|
yieldto return $MAP |
||||||
|
} {!} { |
||||||
|
#error "untested branch" |
||||||
|
set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]]] |
||||||
|
#set OID [::pattern::get_oid $_ID_] |
||||||
|
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid |
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! |
||||||
|
} else { |
||||||
|
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] |
||||||
|
} |
||||||
|
lassign [dict get $MAP invocantdata] OID alias default_command object_command |
||||||
|
set command $object_command |
||||||
|
set stack [list "_exec_" $command] |
||||||
|
set operator ! |
||||||
|
} default { |
||||||
|
if {$operator eq ""} { |
||||||
|
#error "untested branch" |
||||||
|
lassign [dict get $MAP invocantdata] OID alias default_command object_command |
||||||
|
#set command ::p::${OID}::item |
||||||
|
set command ::p::${OID}::$default_command |
||||||
|
lappend stack $command |
||||||
|
set operator , |
||||||
|
|
||||||
|
} |
||||||
|
#do not look for argprotect items here (e.g -option) as the final word can't be an argprotector anyway. |
||||||
|
lappend stack $word |
||||||
|
} |
||||||
|
if {$unsupported} { |
||||||
|
set unsupported 0 |
||||||
|
error "trailing '$word' not supported" |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
#if {$operator eq ","} { |
||||||
|
# incr wordcount 2 |
||||||
|
# set stack [linsert $stack end-1 . item] |
||||||
|
#} |
||||||
|
incr w |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#final = 1 |
||||||
|
#puts stderr ">>>jaws final return value: [list 1 $_ID_ {*}$stack]" |
||||||
|
|
||||||
|
return [list 1 $_ID_ {*}$stack] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#trailing. directly after object |
||||||
|
proc ::p::internals::ref_to_object {_ID_} { |
||||||
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
||||||
|
upvar #0 ::p::${OID}::_meta::map MAP |
||||||
|
lassign [dict get $MAP invocantdata] OID alias default_method object_command |
||||||
|
set refname ::p::${OID}::_ref::__OBJECT |
||||||
|
|
||||||
|
array set $refname [list] ;#important to initialise the variable as an array here - or initial read attempts on elements will not fire traces |
||||||
|
|
||||||
|
set traceCmd [list ::p::predator::object_read_trace $OID $_ID_] |
||||||
|
if {[list {read} $traceCmd] ni [trace info variable $refname]} { |
||||||
|
#puts stdout "adding read trace on variable '$refname' - traceCmd:'$traceCmd'" |
||||||
|
trace add variable $refname {read} $traceCmd |
||||||
|
} |
||||||
|
set traceCmd [list ::p::predator::object_array_trace $OID $_ID_] |
||||||
|
if {[list {array} $traceCmd] ni [trace info variable $refname]} { |
||||||
|
trace add variable $refname {array} $traceCmd |
||||||
|
} |
||||||
|
|
||||||
|
set traceCmd [list ::p::predator::object_write_trace $OID $_ID_] |
||||||
|
if {[list {write} $traceCmd] ni [trace info variable $refname]} { |
||||||
|
trace add variable $refname {write} $traceCmd |
||||||
|
} |
||||||
|
|
||||||
|
set traceCmd [list ::p::predator::object_unset_trace $OID $_ID_] |
||||||
|
if {[list {unset} $traceCmd] ni [trace info variable $refname]} { |
||||||
|
trace add variable $refname {unset} $traceCmd |
||||||
|
} |
||||||
|
return $refname |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::p::internals::create_or_update_reference {OID _ID_ refname command} { |
||||||
|
#if {[lindex $fullstack 0] eq "_exec_"} { |
||||||
|
# #strip it. This instruction isn't relevant for a reference. |
||||||
|
# set commandstack [lrange $fullstack 1 end] |
||||||
|
#} else { |
||||||
|
# set commandstack $fullstack |
||||||
|
#} |
||||||
|
#set argstack [lassign $commandstack command] |
||||||
|
#set field [string map {> __OBJECT_} [namespace tail $command]] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
set reftail [namespace tail $refname] |
||||||
|
set argstack [lassign [split $reftail +] field] |
||||||
|
set field [string map {> __OBJECT_} [namespace tail $command]] |
||||||
|
|
||||||
|
#puts stderr "refname:'$refname' command: $command field:$field" |
||||||
|
|
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
upvar #0 ::p::${OID}::_meta::map MAP |
||||||
|
} else { |
||||||
|
#set map [dict get [lindex [dict get $_ID_ i this] 0 1] map] |
||||||
|
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}}] |
||||||
|
} |
||||||
|
lassign [dict get $MAP invocantdata] OID alias default_method object_command |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
interp alias {} $refname {} $command $_ID_ {*}$argstack |
||||||
|
} else { |
||||||
|
interp alias {} $refname {} $command {*}$argstack |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#set iflist [lindex $map 1 0] |
||||||
|
set iflist [dict get $MAP interfaces level0] |
||||||
|
#set iflist [dict get $MAP interfaces level0] |
||||||
|
set field_is_property_like 0 |
||||||
|
foreach IFID [lreverse $iflist] { |
||||||
|
#tcl (braced) expr has lazy evaluation for &&, || & ?: operators - so this should be reasonably efficient. |
||||||
|
if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} { |
||||||
|
set field_is_property_like 1 |
||||||
|
#There is a setter or getter (but not necessarily an entry in the o_properties dict) |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#whether field is a property or a method - remove any commandrefMisuse_TraceHandler |
||||||
|
foreach tinfo [trace info variable $refname] { |
||||||
|
#puts "-->removing traces on $refname: $tinfo" |
||||||
|
if {[lindex $tinfo 1 0] eq "::p::internals::commandrefMisuse_TraceHandler"} { |
||||||
|
trace remove variable $refname {*}$tinfo |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {$field_is_property_like} { |
||||||
|
#property reference |
||||||
|
|
||||||
|
|
||||||
|
set this_invocantdata [lindex [dict get $_ID_ i this] 0] |
||||||
|
lassign $this_invocantdata OID _alias _defaultmethod object_command |
||||||
|
#get fully qualified varspace |
||||||
|
|
||||||
|
# |
||||||
|
set propdict [$object_command .. GetPropertyInfo $field] |
||||||
|
if {[dict exist $propdict $field]} { |
||||||
|
set field_is_a_property 1 |
||||||
|
set propinfo [dict get $propdict $field] |
||||||
|
set varspace [dict get $propinfo varspace] |
||||||
|
if {$varspace eq ""} { |
||||||
|
set full_varspace ::p::${OID} |
||||||
|
} else { |
||||||
|
if {[::string match "::*" $varspace]} { |
||||||
|
set full_varspace $varspace |
||||||
|
} else { |
||||||
|
set full_varspace ::p::${OID}::$varspace |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
set field_is_a_property 0 |
||||||
|
#no propertyinfo - this field was probably established as a PropertyRead and/or PropertyWrite without a Property |
||||||
|
#this is ok - and we still set the trace infrastructure below (app may convert it to a normal Property later) |
||||||
|
set full_varspace ::p::${OID} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#We only trace on entire property.. not array elements (if references existed to both the array and an element both traces would be fired -(entire array trace first)) |
||||||
|
set Hndlr [::list ::p::predator::propvar_write_TraceHandler $OID $field] |
||||||
|
if { [::list {write} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { |
||||||
|
trace add variable ${full_varspace}::o_${field} {write} $Hndlr |
||||||
|
} |
||||||
|
set Hndlr [::list ::p::predator::propvar_unset_TraceHandler $OID $field] |
||||||
|
if { [::list {unset} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { |
||||||
|
trace add variable ${full_varspace}::o_${field} {unset} $Hndlr |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#supply all data in easy-access form so that propref_trace_read is not doing any extra work. |
||||||
|
set get_cmd ::p::${OID}::(GET)$field |
||||||
|
set traceCmd [list ::p::predator::propref_trace_read $get_cmd $_ID_ $refname $field $argstack] |
||||||
|
|
||||||
|
if {[list {read} $traceCmd] ni [trace info variable $refname]} { |
||||||
|
set fieldvarname ${full_varspace}::o_${field} |
||||||
|
|
||||||
|
|
||||||
|
#synch the refvar with the real var if it exists |
||||||
|
#catch {set $refname [$refname]} |
||||||
|
if {[array exists $fieldvarname]} { |
||||||
|
if {![llength $argstack]} { |
||||||
|
#unindexed reference |
||||||
|
array set $refname [array get $fieldvarname] |
||||||
|
#upvar $fieldvarname $refname |
||||||
|
} else { |
||||||
|
set s0 [lindex $argstack 0] |
||||||
|
#refs to nonexistant array members common? (catch vs 'info exists') |
||||||
|
if {[info exists ${fieldvarname}($s0)]} { |
||||||
|
set $refname [set ${fieldvarname}($s0)] |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
#refs to uninitialised props actually should be *very* common. |
||||||
|
#If we use 'catch', it means retrieving refs to non-initialised props is slower. Fired catches can be relatively expensive. |
||||||
|
#Because it's common to get a ref to uninitialised props (e.g for initial setting of their value) - we will use 'info exists' instead of catch. |
||||||
|
|
||||||
|
#set errorInfo_prev $::errorInfo ;#preserve errorInfo across catches! |
||||||
|
|
||||||
|
#puts stdout " ---->>!!! ref to uninitialised prop $field $argstack !!!<------" |
||||||
|
|
||||||
|
|
||||||
|
if {![llength $argstack]} { |
||||||
|
#catch {set $refname [set ::p::${OID}::o_$field]} |
||||||
|
if {[info exists $fieldvarname]} { |
||||||
|
set $refname [set $fieldvarname] |
||||||
|
#upvar $fieldvarname $refname |
||||||
|
} |
||||||
|
} else { |
||||||
|
if {[llength $argstack] == 1} { |
||||||
|
#catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $argstack 0]]} |
||||||
|
if {[info exists $fieldvarname]} { |
||||||
|
set $refname [lindex [set $fieldvarname] [lindex $argstack 0]] |
||||||
|
} |
||||||
|
|
||||||
|
} else { |
||||||
|
#catch {set $refname [lindex [set ::p::${OID}::o_$field] $argstack]} |
||||||
|
if {[info exists $fieldvarname]} { |
||||||
|
set $refname [lindex [set $fieldvarname] $argstack] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#! what if someone has put a trace on ::errorInfo?? |
||||||
|
#set ::errorInfo $errorInfo_prev |
||||||
|
} |
||||||
|
trace add variable $refname {read} $traceCmd |
||||||
|
|
||||||
|
set traceCmd [list ::p::predator::propref_trace_write $_ID_ $OID $full_varspace $refname] |
||||||
|
trace add variable $refname {write} $traceCmd |
||||||
|
|
||||||
|
set traceCmd [list ::p::predator::propref_trace_unset $_ID_ $OID $refname] |
||||||
|
trace add variable $refname {unset} $traceCmd |
||||||
|
|
||||||
|
|
||||||
|
set traceCmd [list ::p::predator::propref_trace_array $_ID_ $OID $refname] |
||||||
|
# puts "**************** installing array variable trace on ref:$refname - cmd:$traceCmd" |
||||||
|
trace add variable $refname {array} $traceCmd |
||||||
|
} |
||||||
|
|
||||||
|
} else { |
||||||
|
#puts "$refname ====> adding refMisuse_traceHandler $alias $field" |
||||||
|
#matching variable in order to detect attempted use as property and throw error |
||||||
|
|
||||||
|
#2018 |
||||||
|
#Note that we are adding a trace on a variable (the refname) which does not exist. |
||||||
|
#this is fine - except that the trace won't fire for attempt to write it as an array using syntax such as set $ref(someindex) |
||||||
|
#we could set the ref to an empty array - but then we have to also undo this if a property with matching name is added |
||||||
|
##array set $refname {} ;#empty array |
||||||
|
# - the empty array would mean a slightly better error message when misusing a command ref as an array |
||||||
|
#but this seems like a code complication for little benefit |
||||||
|
#review |
||||||
|
|
||||||
|
trace add variable $refname {read write unset array} [list ::p::internals::commandrefMisuse_TraceHandler $OID $field] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#trailing. after command/property |
||||||
|
proc ::p::internals::ref_to_stack {OID _ID_ fullstack} { |
||||||
|
if {[lindex $fullstack 0] eq "_exec_"} { |
||||||
|
#strip it. This instruction isn't relevant for a reference. |
||||||
|
set commandstack [lrange $fullstack 1 end] |
||||||
|
} else { |
||||||
|
set commandstack $fullstack |
||||||
|
} |
||||||
|
set argstack [lassign $commandstack command] |
||||||
|
set field [string map {> __OBJECT_} [namespace tail $command]] |
||||||
|
|
||||||
|
|
||||||
|
#!todo? |
||||||
|
# - make every object's OID unpredictable and sparse (UUID) and modify 'namespace child' etc to prevent iteration/inspection of ::p namespace. |
||||||
|
# - this would only make sense for an environment where any meta methods taking a code body (e.g .. Method .. PatternMethod etc) are restricted. |
||||||
|
|
||||||
|
|
||||||
|
#references created under ::p::${OID}::_ref are effectively inside a 'varspace' within the object itself. |
||||||
|
# - this would in theory allow a set of interface functions on the object which have direct access to the reference variables. |
||||||
|
|
||||||
|
|
||||||
|
set refname ::p::${OID}::_ref::[join [concat $field $argstack] +] |
||||||
|
|
||||||
|
if {[llength [info commands $refname]]} { |
||||||
|
#todo - review - what if the field changed to/from a property/method? |
||||||
|
#probably should fix that where such a change is made and leave this short circuit here to give reasonable performance for existing refs |
||||||
|
return $refname |
||||||
|
} |
||||||
|
::p::internals::create_or_update_reference $OID $_ID_ $refname $command |
||||||
|
return $refname |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
namespace eval pp { |
||||||
|
variable operators [list .. . -- - & @ # , !] |
||||||
|
variable operators_notin_args "" |
||||||
|
foreach op $operators { |
||||||
|
append operators_notin_args "({$op} ni \$args) && " |
||||||
|
} |
||||||
|
set operators_notin_args [string trimright $operators_notin_args " &"] ;#trim trailing spaces and ampersands |
||||||
|
#set operators_notin_args {({.} ni $args) && ({,} ni $args) && ({..} ni $args)} |
||||||
|
} |
||||||
|
interp alias {} strmap {} string map ;#stop code editor from mono-colouring our big string mapped code blocks! |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# 2017 ::p::predator2 is the development version - intended for eventual use as the main dispatch mechanism. |
||||||
|
#each map is a 2 element list of lists. |
||||||
|
# form: {$commandinfo $interfaceinfo} |
||||||
|
# commandinfo is of the form: {ID Namespace defaultmethod commandname _?} |
||||||
|
|
||||||
|
#2018 |
||||||
|
#each map is a dict. |
||||||
|
#form: {invocantdata {ID Namespace defaultmethod commandname _?} interfaces {level0 {} level1 {}}} |
||||||
|
|
||||||
|
|
||||||
|
#OID = Object ID (integer for now - could in future be a uuid) |
||||||
|
proc ::p::predator2 {_ID_ args} { |
||||||
|
#puts stderr "predator2: _ID_:'$_ID_' args:'$args'" |
||||||
|
#set invocants [dict get $_ID_ i] |
||||||
|
#set invocant_roles [dict keys $invocants] |
||||||
|
|
||||||
|
#For now - we are 'this'-centric (single dispatch). todo - adapt for multiple roles, multimethods etc. |
||||||
|
#set this_role_members [dict get $invocants this] |
||||||
|
#set this_invocant [lindex [dict get $_ID_ i this] 0] ;#for the role 'this' we assume only one invocant in the list. |
||||||
|
#lassign $this_invocant this_OID this_info_dict |
||||||
|
|
||||||
|
set this_OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid |
||||||
|
|
||||||
|
|
||||||
|
set cheat 1 ;# |
||||||
|
#------- |
||||||
|
#Optimise the next most common use case. A single . followed by args which contain no other operators (non-chained call) |
||||||
|
#(it should be functionally equivalent to remove this shortcut block) |
||||||
|
if {$cheat} { |
||||||
|
if { ([lindex $args 0] eq {.}) && ([llength $args] > 1) && ([llength [lsearch -all -inline $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args) && ({!} ni $args)} { |
||||||
|
|
||||||
|
set remaining_args [lassign $args dot method_or_prop] |
||||||
|
|
||||||
|
#how will we do multiple apis? (separate interface stacks) apply? apply [list [list _ID_ {*}$arglist] ::p::${stackid?}::$method_or_prop ::p::${this_OID}] ??? |
||||||
|
set command ::p::${this_OID}::$method_or_prop |
||||||
|
#REVIEW! |
||||||
|
#e.g what if the method is named "say hello" ?? (hint - it will break because we will look for 'say') |
||||||
|
#if {[llength $command] > 1} { |
||||||
|
# error "methods with spaces not included in test suites - todo fix!" |
||||||
|
#} |
||||||
|
#Dont use {*}$command - (so we can support methods with spaces) |
||||||
|
#if {![llength [info commands $command]]} {} |
||||||
|
if {[namespace which $command] eq ""} { |
||||||
|
if {[namespace which ::p::${this_OID}::(UNKNOWN)] ne ""} { |
||||||
|
#lset command 0 ::p::${this_OID}::(UNKNOWN) ;#seems wrong - command could have spaces |
||||||
|
set command ::p::${this_OID}::(UNKNOWN) |
||||||
|
#tailcall {*}$command $_ID_ $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||||
|
tailcall $command $_ID_ $method_or_prop {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||||
|
} else { |
||||||
|
return -code error -errorinfo "(::p::predator2) error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$method_or_prop' not found" |
||||||
|
} |
||||||
|
} else { |
||||||
|
#tailcall {*}$command $_ID_ {*}$remaining_args |
||||||
|
tailcall $command $_ID_ {*}$remaining_args |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
#------------ |
||||||
|
|
||||||
|
|
||||||
|
if {([llength $args] == 1) && ([lindex $args 0] eq "..")} { |
||||||
|
return $_ID_ |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#puts stderr "pattern::predator (test version) called with: _ID_:$_ID_ args:$args" |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#puts stderr "this_info_dict: $this_info_dict" |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
if {![llength $args]} { |
||||||
|
#should return some sort of public info.. i.e probably not the ID which is an implementation detail |
||||||
|
#return cmd |
||||||
|
return [lindex [dict get [set ::p::${this_OID}::_meta::map] invocantdata] 0] ;#Object ID |
||||||
|
|
||||||
|
#return a dict keyed on object command name - (suitable as use for a .. Create 'target') |
||||||
|
#lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method object_command wrapped |
||||||
|
#return [list $object_command [list -id $this_OID ]] |
||||||
|
} elseif {[llength $args] == 1} { |
||||||
|
#short-circuit the single index case for speed. |
||||||
|
if {[lindex $args 0] ni {.. . -- - & @ # , !}} { |
||||||
|
#lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method |
||||||
|
lassign [lindex [dict get $_ID_ i this] 0] this_OID alias default_method |
||||||
|
|
||||||
|
tailcall ::p::${this_OID}::$default_method $_ID_ [lindex $args 0] |
||||||
|
} elseif {[lindex $args 0] eq {--}} { |
||||||
|
|
||||||
|
#!todo - we could hide the invocant by only allowing this call from certain uplevel procs.. |
||||||
|
# - combined with using UUIDs for $OID, and a secured/removed metaface on the object |
||||||
|
# - (and also hiding of [interp aliases] command so they can't iterate and examine all aliases) |
||||||
|
# - this could effectively hide the object's namespaces,vars etc from the caller (?) |
||||||
|
return [set ::p::${this_OID}::_meta::map] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#upvar ::p::coroutine_instance c ;#coroutine names must be unique per call to predator (not just per object - or we could get a clash during some cyclic calls) |
||||||
|
#incr c |
||||||
|
#set reduce ::p::reducer${this_OID}_$c |
||||||
|
set reduce ::p::reducer${this_OID}_[incr ::p::coroutine_instance] |
||||||
|
#puts stderr "..................creating reducer $reduce with args $this_OID _ID_ $args" |
||||||
|
coroutine $reduce ::p::internals::jaws $this_OID $_ID_ {*}$args |
||||||
|
|
||||||
|
|
||||||
|
set current_ID_ $_ID_ |
||||||
|
|
||||||
|
set final 0 |
||||||
|
set result "" |
||||||
|
while {$final == 0} { |
||||||
|
#the argument given here to $reduce will be returned by 'yield' within the coroutine context (jaws) |
||||||
|
set reduction_args [lassign [$reduce $current_ID_[set current_ID_ [list]] ] final current_ID_ command] |
||||||
|
#puts stderr "..> final:$final current_ID_:'$current_ID_' command:'$command' reduction_args:'$reduction_args'" |
||||||
|
#if {[string match *Destroy $command]} { |
||||||
|
# puts stdout " calling Destroy reduction_args:'$reduction_args'" |
||||||
|
#} |
||||||
|
if {$final == 1} { |
||||||
|
|
||||||
|
if {[llength $command] == 1} { |
||||||
|
if {$command eq "_exec_"} { |
||||||
|
tailcall {*}$reduction_args |
||||||
|
} |
||||||
|
if {[llength [info commands $command]]} { |
||||||
|
tailcall {*}$command $current_ID_ {*}$reduction_args |
||||||
|
} |
||||||
|
set cmdname [namespace tail $command] |
||||||
|
set this_OID [lindex [dict get $current_ID_ i this] 0 0] |
||||||
|
if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { |
||||||
|
lset command 0 ::p::${this_OID}::(UNKNOWN) |
||||||
|
tailcall {*}$command $current_ID_ $cmdname {*}$reduction_args ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||||
|
} else { |
||||||
|
return -code error -errorinfo "1)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" |
||||||
|
} |
||||||
|
|
||||||
|
} else { |
||||||
|
#e.g lindex {a b c} |
||||||
|
tailcall {*}$command {*}$reduction_args |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
} else { |
||||||
|
if {[lindex $command 0] eq "_exec_"} { |
||||||
|
set result [uplevel 1 [list {*}[lrange $command 1 end] {*}$reduction_args]] |
||||||
|
|
||||||
|
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {} ] |
||||||
|
} else { |
||||||
|
if {[llength $command] == 1} { |
||||||
|
if {![llength [info commands $command]]} { |
||||||
|
set cmdname [namespace tail $command] |
||||||
|
set this_OID [lindex [dict get $current_ID_ i this] 0 0] |
||||||
|
if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { |
||||||
|
|
||||||
|
lset command 0 ::p::${this_OID}::(UNKNOWN) |
||||||
|
set result [uplevel 1 [list {*}$command $current_ID_ $cmdname {*}$reduction_args]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||||
|
} else { |
||||||
|
return -code error -errorinfo "2)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" |
||||||
|
} |
||||||
|
} else { |
||||||
|
#set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] |
||||||
|
set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] |
||||||
|
|
||||||
|
} |
||||||
|
} else { |
||||||
|
set result [uplevel 1 [list {*}$command {*}$reduction_args]] |
||||||
|
} |
||||||
|
|
||||||
|
if {[llength [info commands $result]]} { |
||||||
|
if {([llength $result] == 1) && ([string first ">" [namespace tail $result]] == 0)} { |
||||||
|
#looks like a pattern command |
||||||
|
set current_ID_ [$result .. INVOCANTDATA] |
||||||
|
|
||||||
|
|
||||||
|
#todo - determine if plain .. INVOCANTDATA is sufficient instead of .. UPDATEDINVOCANTDATA |
||||||
|
#if {![catch {$result .. INVOCANTDATA} result_invocantdata]} { |
||||||
|
# set current_ID_ $result_invocantdata |
||||||
|
#} else { |
||||||
|
# return -code error -errorinfo "3)error running command:'$command' argstack:'$reduction_args'\n - Failed to access result:'$result' as a pattern object." "Failed to access result:'$result' as a pattern object" |
||||||
|
#} |
||||||
|
} else { |
||||||
|
#non-pattern command |
||||||
|
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] |
||||||
|
} |
||||||
|
} else { |
||||||
|
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] |
||||||
|
#!todo - allow further operations on non-command values. e.g dicts, lists & strings (treat strings as lists) |
||||||
|
|
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
} |
||||||
|
error "Assert: Shouldn't get here (end of ::p::predator2)" |
||||||
|
#return $result |
||||||
|
} |
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,272 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::aliascore 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin shellspy_module_punk::aliascore 0 0.1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::aliascore] |
||||||
|
#[keywords module] |
||||||
|
#[description] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of punk::aliascore |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by punk::aliascore |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#tcl::namespace::eval punk::aliascore::class { |
||||||
|
# #*** !doctools |
||||||
|
# #[subsection {Namespace punk::aliascore::class}] |
||||||
|
# #[para] class definitions |
||||||
|
# if {[info commands [namespace current]::interface_sample1] eq ""} { |
||||||
|
# #*** !doctools |
||||||
|
# #[list_begin enumerated] |
||||||
|
# |
||||||
|
# # oo::class create interface_sample1 { |
||||||
|
# # #*** !doctools |
||||||
|
# # #[enum] CLASS [class interface_sample1] |
||||||
|
# # #[list_begin definitions] |
||||||
|
# |
||||||
|
# # method test {arg1} { |
||||||
|
# # #*** !doctools |
||||||
|
# # #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# # #[para] test method |
||||||
|
# # puts "test: $arg1" |
||||||
|
# # } |
||||||
|
# |
||||||
|
# # #*** !doctools |
||||||
|
# # #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# # } |
||||||
|
# |
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {--- end class enumeration ---}] |
||||||
|
# } |
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::aliascore { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
variable aliases |
||||||
|
#use absolute ns ie must be prefixed with :: |
||||||
|
#single element commands are imported if source command already exists, otherwise aliased. multi element commands are aliased |
||||||
|
|
||||||
|
#functions must be in export list of their source namespace |
||||||
|
set aliases [tcl::dict::create\ |
||||||
|
tstr ::punk::lib::tstr\ |
||||||
|
list_as_lines ::punk::lib::list_as_lines\ |
||||||
|
lines_as_list ::punk::lib::lines_as_list\ |
||||||
|
linelist ::punk::lib::linelist\ |
||||||
|
linesort ::punk::lib::linesort\ |
||||||
|
pdict ::punk::lib::pdict\ |
||||||
|
plist {::punk::lib::pdict -roottype list}\ |
||||||
|
showlist {::punk::lib::showdict -roottype list}\ |
||||||
|
showdict ::punk::lib::showdict\ |
||||||
|
ansistrip ::punk::ansi::ansistrip\ |
||||||
|
stripansi ::punk::ansi::ansistrip\ |
||||||
|
ansiwrap ::punk::ansi::ansiwrap\ |
||||||
|
colour ::punk::console::colour\ |
||||||
|
ansi ::punk::console::ansi\ |
||||||
|
color ::punk::console::colour\ |
||||||
|
a+ ::punk::console::code_a+\ |
||||||
|
A+ {::punk::console::code_a+ forcecolour}\ |
||||||
|
a ::punk::console::code_a\ |
||||||
|
A {::punk::console::code_a forcecolour}\ |
||||||
|
a? ::punk::console::code_a?\ |
||||||
|
A? {::punk::console::code_a? forcecolor}\ |
||||||
|
smcup ::punk::console::enable_alt_screen\ |
||||||
|
rmcup ::punk::console::disable_alt_screen\ |
||||||
|
] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::aliascore}] |
||||||
|
#[para] Core API functions for punk::aliascore |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#proc sample1 {p1 n args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||||
|
# #[para]Description of sample1 |
||||||
|
# #[para] Arguments: |
||||||
|
# # [list_begin arguments] |
||||||
|
# # [arg_def tring p1] A description of string argument p1. |
||||||
|
# # [arg_def integer n] A description of integer argument n. |
||||||
|
# # [list_end] |
||||||
|
# return "ok" |
||||||
|
#} |
||||||
|
|
||||||
|
#todo - options as to whether we should raise an error if collisions found, undo aliases etc? |
||||||
|
proc init {args} { |
||||||
|
set defaults {-force 0} |
||||||
|
set opts [dict merge $defaults $args] |
||||||
|
set opt_force [dict get $opts -force] |
||||||
|
|
||||||
|
variable aliases |
||||||
|
if {!$opt_force} { |
||||||
|
set existing [list] |
||||||
|
set conflicts [list] |
||||||
|
foreach {a cmd} $aliases { |
||||||
|
if {[tcl::info::commands ::$a] ne ""} { |
||||||
|
lappend existing $a |
||||||
|
if {[llength $cmd] > 1} { |
||||||
|
#use alias mechanism |
||||||
|
set existing_target [interp alias "" $a] |
||||||
|
} else { |
||||||
|
#using namespace import |
||||||
|
#check origin |
||||||
|
set existing_target [tcl::namespace::origin $cmd] |
||||||
|
} |
||||||
|
if {$existing_target ne $cmd} { |
||||||
|
#command exists in global ns but doesn't match our defined aliases/imports |
||||||
|
lappend conflicts $a |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
if {[llength $conflicts]} { |
||||||
|
error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts" |
||||||
|
} |
||||||
|
} |
||||||
|
set tempns ::temp_[info cmdcount] ;#temp ns for renames |
||||||
|
dict for {a cmd} $aliases { |
||||||
|
#puts "aliascore $a -> $cmd" |
||||||
|
if {[llength $cmd] > 1} { |
||||||
|
interp alias {} $a {} {*}$cmd |
||||||
|
} else { |
||||||
|
if {[tcl::info::commands $cmd] ne ""} { |
||||||
|
#todo - ensure exported? noclobber? |
||||||
|
if {[tcl::namespace::tail $a] eq [tcl::namespace::tail $cmd]} { |
||||||
|
#puts stderr "importing $cmd" |
||||||
|
tcl::namespace::eval :: [list namespace import $cmd] |
||||||
|
} else { |
||||||
|
#target command name differs from exported name |
||||||
|
#e.g stripansi -> punk::ansi::ansistrip |
||||||
|
#import and rename |
||||||
|
#puts stderr "importing $cmd (with rename to ::$a)" |
||||||
|
tcl::namespace::eval $tempns [list namespace import $cmd] |
||||||
|
catch {rename ${tempns}::[namespace tail $cmd] ::$a} |
||||||
|
} |
||||||
|
} else { |
||||||
|
interp alias {} $a {} {*}$cmd |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
#tcl::namespace::delete $tempns |
||||||
|
return [dict keys $aliases] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::aliascore ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#interp alias {} list_as_lines {} punk::lib::list_as_lines |
||||||
|
#interp alias {} lines_as_list {} punk::lib::lines_as_list |
||||||
|
#interp alias {} ansistrip {} punk::ansi::ansistrip ;#review |
||||||
|
#interp alias {} linelist {} punk::lib::linelist ;#critical for = assignment features |
||||||
|
#interp alias {} linesort {} punk::lib::linesort |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::aliascore::lib { |
||||||
|
namespace export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
namespace path [namespace parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::aliascore::lib}] |
||||||
|
#[para] Secondary functions that are part of the API |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
#proc utility1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of utility1 |
||||||
|
# return 1 |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::aliascore::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
namespace eval punk::aliascore::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::aliascore::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::aliascore [namespace eval punk::aliascore { |
||||||
|
variable pkg punk::aliascore |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
@ -0,0 +1,475 @@ |
|||||||
|
|
||||||
|
tcl::namespace::eval punk::config { |
||||||
|
variable loaded |
||||||
|
variable startup ;#include env overrides |
||||||
|
variable running |
||||||
|
variable punk_env_vars |
||||||
|
variable other_env_vars |
||||||
|
|
||||||
|
variable vars |
||||||
|
|
||||||
|
namespace export {[a-z]*} |
||||||
|
|
||||||
|
#todo - XDG_DATA_HOME etc |
||||||
|
#https://specifications.freedesktop.org/basedir-spec/latest/ |
||||||
|
# see also: http://hiphish.github.io/blog/2020/08/30/dotfiles-were-a-mistake/ |
||||||
|
|
||||||
|
proc init {} { |
||||||
|
variable defaults |
||||||
|
variable startup |
||||||
|
variable running |
||||||
|
variable punk_env_vars |
||||||
|
variable punk_env_vars_config |
||||||
|
variable other_env_vars |
||||||
|
variable other_env_vars_config |
||||||
|
|
||||||
|
set exename "" |
||||||
|
catch { |
||||||
|
#catch for safe interps |
||||||
|
#safe base will return empty string, ordinary safe interp will raise error |
||||||
|
set exename [tcl::info::nameofexecutable] |
||||||
|
} |
||||||
|
if {$exename ne ""} { |
||||||
|
set exefolder [file dirname $exename] |
||||||
|
#default file logs to logs folder at same level as exe if writable, or empty string |
||||||
|
set log_folder [file normalize $exefolder/../logs] |
||||||
|
#tcl::dict::set startup scriptlib $exefolder/scriptlib |
||||||
|
#tcl::dict::set startup apps $exefolder/../../punkapps |
||||||
|
|
||||||
|
#todo - use punk main.tcl location instead - exefolder doesn't work if system tclsh used etc |
||||||
|
set default_scriptlib $exefolder/scriptlib |
||||||
|
set default_apps $exefolder/../../punkapps |
||||||
|
if {[file isdirectory $log_folder] && [file writable $log_folder]} { |
||||||
|
#tcl::dict::set startup logfile_stdout $log_folder/repl-exec-stdout.txt |
||||||
|
#tcl::dict::set startup logfile_stderr $log_folder/repl-exec-stderr.txt |
||||||
|
set default_logfile_stdout $log_folder/repl-exec-stdout.txt |
||||||
|
set default_logfile_stderr $log_folder/repl-exec-stderr.txt |
||||||
|
} else { |
||||||
|
set default_logfile_stdout "" |
||||||
|
set default_logfile_stderr "" |
||||||
|
} |
||||||
|
} else { |
||||||
|
#probably a safe interp - which cannot access info nameofexecutable even if access given to the location via punk::island |
||||||
|
#review - todo? |
||||||
|
#tcl::dict::set startup scriptlib "" |
||||||
|
#tcl::dict::set startup apps "" |
||||||
|
set default_scriptlib "" |
||||||
|
set default_apps "" |
||||||
|
set default_logfile_stdout "" |
||||||
|
set default_logfile_stderr "" |
||||||
|
} |
||||||
|
|
||||||
|
# auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run |
||||||
|
|
||||||
|
#optional channel transforms on stdout/stderr. |
||||||
|
#can sometimes be useful to distinguish eventloop stdout/stderr writes compared to those triggered directly from repl commands |
||||||
|
#If no distinction necessary - should use default_color_<chan> |
||||||
|
#The counterpart: default_color_<chan>_repl is a transform that is added and removed with each repl evaluation. |
||||||
|
#startup color_stdout - parameters as suitable for punk::ansi::a+ (test with 'punk::ansi::a?') e.g "cyan bold" ;#not a good idea to default |
||||||
|
set default_color_stdout brightwhite ;#stdout colour including background calls (after etc) |
||||||
|
set default_color_stdout_repl "" ;#stdout colour applied during direct repl call only |
||||||
|
#This wraps the stderr stream as it comes in with Ansi - probably best to default to empty.. but it's useful. |
||||||
|
#set default_color_stderr "red bold" |
||||||
|
#set default_color_stderr "web-lightsalmon" |
||||||
|
set default_color_stderr yellow ;#limit to basic colours for wider terminal support. yellow = term-olive |
||||||
|
set default_color_stderr_repl "" ;#during repl call only |
||||||
|
|
||||||
|
set homedir "" |
||||||
|
if {[catch { |
||||||
|
#depending on which build of tcl - some safe interps prior to bugfix https://core.tcl-lang.org/tcl/info/3aa487993f will return a homedir value in an unmodified safe interp |
||||||
|
#other 'safe' interps may have explicitly made this available - we shouldn't override that decision here using interp issafe so we can't compensate for versions which shouldn't really be returning this in the safe interp |
||||||
|
set homedir [file home] |
||||||
|
} errM]} { |
||||||
|
#tcl 8.6 doesn't have file home.. try again |
||||||
|
if {[info exists ::env(HOME)]} { |
||||||
|
set homedir $::env(HOME) |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# per user xdg vars |
||||||
|
# --- |
||||||
|
set default_xdg_config_home "" ;#config data - portable |
||||||
|
set default_xdg_data_home "" ;#data the user likely to want to be portable |
||||||
|
set default_xdg_cache_home "" ;#local cache |
||||||
|
set default_xdg_state_home "" ;#persistent user data such as logs, but not as important or as portable as those in xdg_data_home |
||||||
|
# --- |
||||||
|
set default_xdg_data_dirs "" ;#non-user specific |
||||||
|
#xdg_config_dirs ? |
||||||
|
#xdg_runtime_dir ? |
||||||
|
|
||||||
|
|
||||||
|
#review. we are assuming if we can't get a home dir - then all the xdg vars including xdg_data_dirs aren't likely to be useful (as presumably filesystem access is absent) |
||||||
|
#(safe interp generally won't have access to ::env either) |
||||||
|
#This coupling doesn't necessarily hold - its possible the relevant env vars were copied to a safe interp - although that would be a policy that would make disabling 'info home' inconsistent. |
||||||
|
if {$homedir ne ""} { |
||||||
|
if {"windows" eq $::tcl_platform(platform)} { |
||||||
|
#as much as I'd prefer to use ~/.local/share and ~/.config to keep them more consistent with unixlike platforms - the vast majority of apps put them where microsoft wants them. |
||||||
|
#we have a choice of LOCALAPPDATA vs APPDATA (local to machine vs potentially roaming/redirected in a corporate environment) |
||||||
|
#using the roaming location should not impact users who aren't using a domain controller but is potentially much more convenient for those who do. |
||||||
|
if {[info exists ::env(APPDATA)]} { |
||||||
|
set default_xdg_config_home $::env(APPDATA) |
||||||
|
set default_xdg_data_home $::env(APPDATA) |
||||||
|
} |
||||||
|
|
||||||
|
#The xdg_cache_home should be kept local |
||||||
|
if {[info exists ::env(LOCALAPPDATA)]} { |
||||||
|
set default_xdg_cache_home $::env(LOCALAPPDATA) |
||||||
|
set default_xdg_state_home $::env(LOCALAPPDATA) |
||||||
|
} |
||||||
|
|
||||||
|
if {[info exists ::env(PROGRAMDATA)]} { |
||||||
|
#- equiv env(ALLUSERSPROFILE) ? |
||||||
|
set default_xdg_data_dirs $::env(PROGRAMDATA) |
||||||
|
} |
||||||
|
|
||||||
|
} else { |
||||||
|
#follow defaults as specified on freedesktop.org e.g https://specifications.freedesktop.org/basedir-spec/latest/ar01s03.html |
||||||
|
set default_xdg_config_home [file join $homedir .config] |
||||||
|
set default_xdg_data_home [file join $homedir .local share] |
||||||
|
set default_xdg_cache_home [file join $homedir .cache] |
||||||
|
set default_xdg_state_home [file join $homedir .local state] |
||||||
|
set default_xdg_data_dirs /usr/local/share |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set defaults [dict create\ |
||||||
|
apps $default_apps\ |
||||||
|
config ""\ |
||||||
|
configset ".punkshell"\ |
||||||
|
scriptlib $default_scriptlib\ |
||||||
|
color_stdout $default_color_stdout\ |
||||||
|
color_stdout_repl $default_color_stdout_repl\ |
||||||
|
color_stderr $default_color_stderr\ |
||||||
|
color_stderr_repl $default_color_stderr_repl\ |
||||||
|
logfile_stdout $default_logfile_stdout\ |
||||||
|
logfile_stderr $default_logfile_stderr\ |
||||||
|
logfile_active 0\ |
||||||
|
syslog_stdout "127.0.0.1:514"\ |
||||||
|
syslog_stderr "127.0.0.1:514"\ |
||||||
|
syslog_active 0\ |
||||||
|
auto_exec_mechanism exec\ |
||||||
|
auto_noexec 0\ |
||||||
|
xdg_config_home $default_xdg_config_home\ |
||||||
|
xdg_data_home $default_xdg_data_home\ |
||||||
|
xdg_cache_home $default_xdg_cache_home\ |
||||||
|
xdg_state_home $default_xdg_state_home\ |
||||||
|
xdg_data_dirs $default_xdg_data_dirs\ |
||||||
|
theme_posh_override ""\ |
||||||
|
posh_theme ""\ |
||||||
|
posh_themes_path ""\ |
||||||
|
] |
||||||
|
|
||||||
|
set startup $defaults |
||||||
|
#load values from saved config file - $xdg_config_home/punk/punk.config ? |
||||||
|
#typically we want env vars to override the stored config - as env vars conventionally used on some commandlines. |
||||||
|
#that's possibly ok for the PUNK_ vars |
||||||
|
#however.. others like the xdg vars and NOCOLOR may apply to other apps.. and we may want to override them from the saved config? |
||||||
|
#making some env vars override saved config values and some not would be potentially confusing. may need one/more specific settings or env vars to determine which takes precedence? |
||||||
|
#simpler is probably just to let env vars take precedence - and warn when saving or viewing config that the saved values are being overridden |
||||||
|
#- requiring user to manually unset any unwanted env vars when launching? |
||||||
|
|
||||||
|
#we are likely to want the saved configs for subshells/decks to override them however. |
||||||
|
|
||||||
|
#todo - load/save config file |
||||||
|
|
||||||
|
#todo - define which configvars are settable in env |
||||||
|
#list of varname varinfo where varinfo is a sub dictionary (type key is mandatory, with value from: string,pathlist,boolean) |
||||||
|
set punk_env_vars_config [dict create \ |
||||||
|
PUNK_APPS {type pathlist}\ |
||||||
|
PUNK_CONFIG {type string}\ |
||||||
|
PUNK_CONFIGSET {type string}\ |
||||||
|
PUNK_SCRIPTLIB {type string}\ |
||||||
|
PUNK_AUTO_EXEC_MECHANISM {type string}\ |
||||||
|
PUNK_AUTO_NOEXEC {type string default 0 help "set 1 to set Tcl's ::auto_noexec true.\nStops 'unknown' from running external programs"}\ |
||||||
|
PUNK_COLOR_STDERR {type string help "stderr colour transform. Use 'punk::ansi::a?' to see colour names"}\ |
||||||
|
PUNK_COLOR_STDERR_REPL {type string help "stderr colour transform only while command running (not active during 'after')"}\ |
||||||
|
PUNK_COLOR_STDOUT {type string help "stdout colour transform. Use 'punk::ansi::a?' to see colour names"}\ |
||||||
|
PUNK_COLOR_STDOUT_REPL {type string help "stdout colour transform only while command running (not active during 'after')"}\ |
||||||
|
PUNK_LOGFILE_STDOUT {type string}\ |
||||||
|
PUNK_LOGFILE_STDERR {type string}\ |
||||||
|
PUNK_LOGFILE_ACTIVE {type string}\ |
||||||
|
PUNK_SYSLOG_STDOUT {type string}\ |
||||||
|
PUNK_SYSLOG_STDERR {type string}\ |
||||||
|
PUNK_SYSLOG_ACTIVE {type string}\ |
||||||
|
PUNK_THEME_POSH_OVERRIDE {type string}\ |
||||||
|
] |
||||||
|
set punk_env_vars [dict keys $punk_env_vars_config] |
||||||
|
|
||||||
|
#override with env vars if set |
||||||
|
foreach {evar varinfo} $punk_env_vars_config { |
||||||
|
if {[info exists ::env($evar)]} { |
||||||
|
set vartype [dict get $varinfo type] |
||||||
|
set f [set ::env($evar)] |
||||||
|
if {$f ne "default"} { |
||||||
|
#e.g PUNK_SCRIPTLIB -> scriptlib |
||||||
|
set varname [tcl::string::tolower [tcl::string::range $evar 5 end]] |
||||||
|
if {$vartype eq "pathlist"} { |
||||||
|
#colon vs semicolon path sep is problematic for windows environments where unix-like systems such as cygwin/wsl are used and a variable may be set for either the native path separator or the unix-like system |
||||||
|
#Even without the colon vs semicolon issue, native vs unix-like paths on windows mixed environment systems can cause grief. |
||||||
|
#For now at least, we will simply respect the platform pathSeparator and hope the user manages the environment variables appropriately. |
||||||
|
#some programs do automatic translation - which is a nice idea in principle - but is also prone to error as we don't know if it's already occurred or not depending on how things are launched. |
||||||
|
#An example of where this sort of thing can go wrong is env(TCLLIBPATH) - which is defined as a space separated list not requiring further splitting |
||||||
|
# - but some programs have been known to split this value on colon anyway, which breaks things on windows. |
||||||
|
set paths [split $f $::tcl_platform(pathSeparator)] |
||||||
|
set final [list] |
||||||
|
#eliminate empty values (leading or trailing or extraneous separators) |
||||||
|
foreach p $paths { |
||||||
|
if {[tcl::string::trim $p] ne ""} { |
||||||
|
lappend final $p |
||||||
|
} |
||||||
|
} |
||||||
|
tcl::dict::set startup $varname $final |
||||||
|
} else { |
||||||
|
tcl::dict::set startup $varname $f |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# https://no-color.org |
||||||
|
#if {[info exists ::env(NO_COLOR)]} { |
||||||
|
# if {$::env(NO_COLOR) ne ""} { |
||||||
|
# set colour_disabled 1 |
||||||
|
# } |
||||||
|
#} |
||||||
|
set other_env_vars_config [dict create\ |
||||||
|
NO_COLOR {type string}\ |
||||||
|
XDG_CONFIG_HOME {type string}\ |
||||||
|
XDG_DATA_HOME {type string}\ |
||||||
|
XDG_CACHE_HOME {type string}\ |
||||||
|
XDG_STATE_HOME {type string}\ |
||||||
|
XDG_DATA_DIRS {type pathlist}\ |
||||||
|
POSH_THEME {type string}\ |
||||||
|
POSH_THEMES_PATH {type string}\ |
||||||
|
TCLLIBPATH {type string}\ |
||||||
|
] |
||||||
|
lassign [split [info tclversion] .] tclmajorv tclminorv |
||||||
|
#don't rely on lseq or punk::lib for now.. |
||||||
|
set relevant_minors [list] |
||||||
|
for {set i 0} {$i <= $tclminorv} {incr i} { |
||||||
|
lappend relevant_minors $i |
||||||
|
} |
||||||
|
foreach minor $relevant_minors { |
||||||
|
set vname TCL${tclmajorv}_${minor}_TM_PATH |
||||||
|
if {$minor eq $tclminorv || [info exists ::env($vname)]} { |
||||||
|
dict set other_env_vars_config $vname {type string} |
||||||
|
} |
||||||
|
} |
||||||
|
set other_env_vars [dict keys $other_env_vars_config] |
||||||
|
|
||||||
|
foreach {evar varinfo} $other_env_vars_config { |
||||||
|
if {[info exists ::env($evar)]} { |
||||||
|
set vartype [dict get $varinfo type] |
||||||
|
set f [set ::env($evar)] |
||||||
|
if {$f ne "default"} { |
||||||
|
set varname [tcl::string::tolower $evar] |
||||||
|
if {$vartype eq "pathlist"} { |
||||||
|
set paths [split $f $::tcl_platform(pathSeparator)] |
||||||
|
set final [list] |
||||||
|
#eliminate empty values (leading or trailing or extraneous separators) |
||||||
|
foreach p $paths { |
||||||
|
if {[tcl::string::trim $p] ne ""} { |
||||||
|
lappend final $p |
||||||
|
} |
||||||
|
} |
||||||
|
tcl::dict::set startup $varname $final |
||||||
|
} else { |
||||||
|
tcl::dict::set startup $varname $f |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#unset -nocomplain vars |
||||||
|
|
||||||
|
#todo |
||||||
|
set running [tcl::dict::create] |
||||||
|
set running [tcl::dict::merge $running $startup] |
||||||
|
} |
||||||
|
init |
||||||
|
|
||||||
|
#todo |
||||||
|
proc Apply {config} { |
||||||
|
puts stderr "punk::config::Apply partially implemented" |
||||||
|
set configname [string map {-config ""} $config] |
||||||
|
if {$configname in {startup running}} { |
||||||
|
upvar ::punk::config::$configname applyconfig |
||||||
|
|
||||||
|
if {[dict exists $applyconfig auto_noexec]} { |
||||||
|
set auto [dict get $applyconfig auto_noexec] |
||||||
|
if {![string is boolean -strict $auto]} { |
||||||
|
error "config::Apply error - invalid data for auto_noexec:'$auto' - expected boolean" |
||||||
|
} |
||||||
|
if {$auto} { |
||||||
|
set ::auto_noexec 1 |
||||||
|
} else { |
||||||
|
#puts "auto_noexec false" |
||||||
|
unset -nocomplain ::auto_noexec |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} else { |
||||||
|
error "no config named '$config' found" |
||||||
|
} |
||||||
|
return "apply done" |
||||||
|
} |
||||||
|
Apply startup |
||||||
|
|
||||||
|
#todo - consider how to divide up settings, categories, 'devices', decks etc |
||||||
|
proc get_running_global {varname} { |
||||||
|
variable running |
||||||
|
if {[dict exists $running $varname]} { |
||||||
|
return [dict get $running $varname] |
||||||
|
} |
||||||
|
error "No such global configuration item '$varname' found in running config" |
||||||
|
} |
||||||
|
proc get_startup_global {varname} { |
||||||
|
variable startup |
||||||
|
if {[dict exists $startup $varname]} { |
||||||
|
return [dict get $startup $varname] |
||||||
|
} |
||||||
|
error "No such global configuration item '$varname' found in startup config" |
||||||
|
} |
||||||
|
|
||||||
|
proc get {whichconfig {globfor *}} { |
||||||
|
variable startup |
||||||
|
variable running |
||||||
|
switch -- $whichconfig { |
||||||
|
config - startup - startup-config - startup-configuration { |
||||||
|
#show *startup* config - different behaviour may be confusing to those used to router startup and running configs |
||||||
|
set configdata $startup |
||||||
|
} |
||||||
|
running - running-config - running-configuration { |
||||||
|
set configdata $running |
||||||
|
} |
||||||
|
default { |
||||||
|
error "Unknown config name '$whichconfig' - try startup or running" |
||||||
|
} |
||||||
|
} |
||||||
|
if {$globfor eq "*"} { |
||||||
|
return $configdata |
||||||
|
} else { |
||||||
|
set keys [dict keys $configdata [string tolower $globfor]] |
||||||
|
set filtered [dict create] |
||||||
|
foreach k $keys { |
||||||
|
dict set filtered $k [dict get $configdata $k] |
||||||
|
} |
||||||
|
return $filtered |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc configure {args} { |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
|
||||||
|
whichconfig -type string -choices {startup running} |
||||||
|
} $args] |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
proc show {whichconfig {globfor *}} { |
||||||
|
#todo - tables for console |
||||||
|
set configdata [punk::config::get $whichconfig $globfor] |
||||||
|
return [punk::lib::showdict $configdata] |
||||||
|
} |
||||||
|
|
||||||
|
#e.g |
||||||
|
# copy running-config startup-config |
||||||
|
# copy startup-config test-config.cfg |
||||||
|
# copy backup-config.cfg running-config |
||||||
|
#review - consider the merge vs overwrite feature of some routers.. where copy to running-config does a merge rather than an overwrite |
||||||
|
#This is to allow partial configs to be loaded to running, whereas a save of running to any target is always a complete configuration |
||||||
|
proc copy {args} { |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
*proc -name punk::config::copy -help "Copy a partial or full configuration from one config to another |
||||||
|
If a target config has additional settings, then the source config can be considered to be partial with regards to the target. |
||||||
|
" |
||||||
|
-type -default "" -choices {replace merge} -help "Defaults to merge when target is running-config |
||||||
|
Defaults to replace when source is running-config" |
||||||
|
*values -min 2 -max 2 |
||||||
|
fromconfig -help "running or startup or file name (not fully implemented)" |
||||||
|
toconfig -help "running or startup or file name (not fully implemented)" |
||||||
|
} $args] |
||||||
|
set fromconfig [dict get $argd values fromconfig] |
||||||
|
set toconfig [dict get $argd values toconfig] |
||||||
|
set fromconfig [string map {-config ""} $fromconfig] |
||||||
|
set toconfig [string map {-config ""} $toconfig] |
||||||
|
|
||||||
|
set copytype [dict get $argd opts -type] |
||||||
|
|
||||||
|
|
||||||
|
#todo - warn & prompt if doing merge copy to startup |
||||||
|
switch -exact -- $fromconfig-$toconfig { |
||||||
|
running-startup { |
||||||
|
if {$copytype eq ""} { |
||||||
|
set copytype replace ;#full configuration |
||||||
|
} |
||||||
|
if {$copytype eq "replace"} { |
||||||
|
error "punk::config::copy error. full configuration copy from running to startup config not yet supported" |
||||||
|
} else { |
||||||
|
error "punk::config::copy error. merge configuration copy from running to startup config not yet supported" |
||||||
|
} |
||||||
|
} |
||||||
|
startup-running { |
||||||
|
#default type merge - even though it's not always what is desired |
||||||
|
if {$copytype eq ""} { |
||||||
|
set copytype merge ;#load in a partial configuration |
||||||
|
} |
||||||
|
|
||||||
|
#warn/prompt either way |
||||||
|
if {$copytype eq "replace"} { |
||||||
|
#some routers require use of a separate command for this branch. |
||||||
|
#presumably to ensure the user doesn't accidentally load partials onto a running system |
||||||
|
# |
||||||
|
error "punk::config::copy error. full configuration copy from startup to overwrite running config not supported" |
||||||
|
} else { |
||||||
|
error "punk::config::copy error. merge copy from possibly partial configuration: startup to running config not currently supported" |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
error "punk::config::copy error. copy must from running to startup or startup to running. File sources/targets not yet supported" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#todo - move to cli? |
||||||
|
::tcl::namespace::eval punk::config { |
||||||
|
#todo - something better - 'previous' rather than reverting to startup |
||||||
|
proc channelcolors {{onoff {}}} { |
||||||
|
variable running |
||||||
|
variable startup |
||||||
|
|
||||||
|
if {![string length $onoff]} { |
||||||
|
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] |
||||||
|
} else { |
||||||
|
if {![string is boolean $onoff]} { |
||||||
|
error "channelcolors: invalid value $onoff - expected boolean: true|false|on|off|1|0|yes|no" |
||||||
|
} |
||||||
|
if {$onoff} { |
||||||
|
dict set running color_stdout [dict get $startup color_stdout] |
||||||
|
dict set running color_stderr [dict get $startup color_stderr] |
||||||
|
} else { |
||||||
|
dict set running color_stdout "" |
||||||
|
dict set running color_stderr "" |
||||||
|
} |
||||||
|
} |
||||||
|
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
package provide punk::config [tcl::namespace::eval punk::config { |
||||||
|
variable version |
||||||
|
set version 0.1 |
||||||
|
|
||||||
|
}] |
@ -0,0 +1,164 @@ |
|||||||
|
#punkapps app manager |
||||||
|
# deck cli |
||||||
|
|
||||||
|
namespace eval punk::mod::cli { |
||||||
|
namespace export help list run |
||||||
|
namespace ensemble create |
||||||
|
|
||||||
|
# namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown |
||||||
|
if 0 { |
||||||
|
proc _unknown {ns args} { |
||||||
|
puts stderr "punk::mod::cli::_unknown '$ns' '$args'" |
||||||
|
puts stderr "punk::mod::cli::help $args" |
||||||
|
puts stderr "arglen:[llength $args]" |
||||||
|
punk::mod::cli::help {*}$args |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#cli must have _init method - usually used to load commandsets lazily |
||||||
|
# |
||||||
|
variable initialised 0 |
||||||
|
proc _init {args} { |
||||||
|
variable initialised |
||||||
|
if {$initialised} { |
||||||
|
return |
||||||
|
} |
||||||
|
#... |
||||||
|
set initialised 1 |
||||||
|
} |
||||||
|
|
||||||
|
proc help {args} { |
||||||
|
set basehelp [punk::mix::base help {*}$args] |
||||||
|
#namespace export |
||||||
|
return $basehelp |
||||||
|
} |
||||||
|
proc getraw {appname} { |
||||||
|
upvar ::punk::config::running running_config |
||||||
|
set app_folders [dict get $running_config apps] |
||||||
|
#todo search each app folder |
||||||
|
set bases [::list] |
||||||
|
set versions [::list] |
||||||
|
set mains [::list] |
||||||
|
set appinfo [::list bases {} mains {} versions {}] |
||||||
|
|
||||||
|
foreach containerfolder $app_folders { |
||||||
|
lappend bases $containerfolder |
||||||
|
if {[file exists $containerfolder]} { |
||||||
|
if {[file exists $containerfolder/$appname/main.tcl]} { |
||||||
|
#exact match - only return info for the exact one specified |
||||||
|
set namematches $appname |
||||||
|
set parts [split $appname -] |
||||||
|
} else { |
||||||
|
set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*] |
||||||
|
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? |
||||||
|
} |
||||||
|
foreach nm $namematches { |
||||||
|
set mainfile $containerfolder/$nm/main.tcl |
||||||
|
set parts [split $nm -] |
||||||
|
if {[llength $parts] == 1} { |
||||||
|
set ver "" |
||||||
|
} else { |
||||||
|
set ver [lindex $parts end] |
||||||
|
} |
||||||
|
if {$ver ni $versions} { |
||||||
|
lappend versions $ver |
||||||
|
lappend mains $ver $mainfile |
||||||
|
} else { |
||||||
|
puts stderr "punk::apps::app version '$ver' of app '$appname' already encountered at $mainfile. (will use earliest encountered in running-config apps and ignore others of same version)" |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config" |
||||||
|
} |
||||||
|
} |
||||||
|
dict set appinfo versions $versions |
||||||
|
#todo - natsort! |
||||||
|
set sorted_versions [lsort $versions] |
||||||
|
set latest [lindex $sorted_versions 0] |
||||||
|
if {$latest eq "" && [llength $sorted_versions] > 1} { |
||||||
|
set latest [lindex $sorted_versions 1 |
||||||
|
} |
||||||
|
dict set appinfo latest $latest |
||||||
|
|
||||||
|
dict set appinfo bases $bases |
||||||
|
dict set appinfo mains $mains |
||||||
|
return $appinfo |
||||||
|
} |
||||||
|
|
||||||
|
proc list {{glob *}} { |
||||||
|
upvar ::punk::config::running running_config |
||||||
|
set apps_folder [dict get $running_config apps] |
||||||
|
if {[file exists $apps_folder]} { |
||||||
|
if {[file exists $apps_folder/$glob]} { |
||||||
|
#tailcall source $apps_folder/$glob/main.tcl |
||||||
|
return $glob |
||||||
|
} |
||||||
|
set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob] |
||||||
|
if {[llength $apps] == 0} { |
||||||
|
if {[string first * $glob] <0 && [string first ? $glob] <0} { |
||||||
|
#no glob chars supplied - only launch if exact match for name part |
||||||
|
set namematches [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*] |
||||||
|
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? |
||||||
|
if {[llength $namematches] > 0} { |
||||||
|
set latest [lindex $namematches end] |
||||||
|
lassign $latest nm ver |
||||||
|
#tailcall source $apps_folder/$latest/main.tcl |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
return $apps |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#todo - way to launch as separate process |
||||||
|
# solo-opts only before appname - args following appname are passed to the app |
||||||
|
proc run {args} { |
||||||
|
set nameposn [lsearch -not $args -*] |
||||||
|
if {$nameposn < 0} { |
||||||
|
error "punkapp::run unable to determine application name" |
||||||
|
} |
||||||
|
set appname [lindex $args $nameposn] |
||||||
|
set controlargs [lrange $args 0 $nameposn-1] |
||||||
|
set appargs [lrange $args $nameposn+1 end] |
||||||
|
|
||||||
|
set appinfo [punk::mod::cli::getraw $appname] |
||||||
|
if {[llength [dict get $appinfo versions]]} { |
||||||
|
set ver [dict get $appinfo latest] |
||||||
|
puts stdout "info: $appinfo" |
||||||
|
set ::argc [llength $appargs] |
||||||
|
set ::argv $appargs |
||||||
|
source [dict get $appinfo mains $ver] |
||||||
|
if {"-hideconsole" in $controlargs} { |
||||||
|
puts stderr "attempting console hide" |
||||||
|
#todo - something better - a callback when window mapped? |
||||||
|
after 500 {::punkapp::hide_console} |
||||||
|
} |
||||||
|
return $appinfo |
||||||
|
} else { |
||||||
|
error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
namespace eval punk::mod::cli { |
||||||
|
proc _cli {args} { |
||||||
|
#don't use tailcall - base uses info level to determine caller |
||||||
|
::punk::mix::base::_cli {*}$args |
||||||
|
} |
||||||
|
variable default_command help |
||||||
|
package require punk::mix::base |
||||||
|
package require punk::overlay |
||||||
|
punk::overlay::custom_from_base [namespace current] ::punk::mix::base |
||||||
|
} |
||||||
|
|
||||||
|
package provide punk::mod [namespace eval punk::mod { |
||||||
|
variable version |
||||||
|
set version 0.1 |
||||||
|
|
||||||
|
}] |
||||||
|
|
||||||
|
|
||||||
|
|
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,259 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::repl::codethread 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin shellspy_module_punk::repl::codethread 0 0.1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::repl::codethread] |
||||||
|
#[keywords module] |
||||||
|
#[description] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of punk::repl::codethread |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by punk::repl::codethread |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
package require punk::config |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#tcl::namespace::eval punk::repl::codethread::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::repl::codethread::class}] |
||||||
|
#[para] class definitions |
||||||
|
#if {[info commands [tcl::namespace::current]::interface_sample1] eq ""} { |
||||||
|
#*** !doctools |
||||||
|
#[list_begin enumerated] |
||||||
|
|
||||||
|
# oo::class create interface_sample1 { |
||||||
|
# #*** !doctools |
||||||
|
# #[enum] CLASS [class interface_sample1] |
||||||
|
# #[list_begin definitions] |
||||||
|
|
||||||
|
# method test {arg1} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# #[para] test method |
||||||
|
# puts "test: $arg1" |
||||||
|
# } |
||||||
|
|
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# } |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end class enumeration ---}] |
||||||
|
#} |
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::repl::codethread { |
||||||
|
tcl::namespace::export * |
||||||
|
variable replthread |
||||||
|
variable replthread_cond |
||||||
|
variable running 0 |
||||||
|
|
||||||
|
variable output_stdout "" |
||||||
|
variable output_stderr "" |
||||||
|
|
||||||
|
#variable xyz |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::repl::codethread}] |
||||||
|
#[para] Core API functions for punk::repl::codethread |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#proc sample1 {p1 n args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||||
|
# #[para]Description of sample1 |
||||||
|
# #[para] Arguments: |
||||||
|
# # [list_begin arguments] |
||||||
|
# # [arg_def tring p1] A description of string argument p1. |
||||||
|
# # [arg_def integer n] A description of integer argument n. |
||||||
|
# # [list_end] |
||||||
|
# return "ok" |
||||||
|
#} |
||||||
|
|
||||||
|
proc is_running {} { |
||||||
|
variable running |
||||||
|
return $running |
||||||
|
} |
||||||
|
proc runscript {script} { |
||||||
|
#puts stderr "->runscript" |
||||||
|
variable replthread_cond |
||||||
|
variable output_stdout "" |
||||||
|
variable output_stderr "" |
||||||
|
#expecting to be called from a thread::send in parent repl - ie in the toplevel interp so that the sub-interp "code" is available |
||||||
|
#if a thread::send is done from the commandline in a codethread - Tcl will |
||||||
|
if {"code" ni [interp children] || ![info exists replthread_cond]} { |
||||||
|
#in case someone tries calling from codethread directly - don't do anything or change any state |
||||||
|
#(direct caller could create an interp named code at the level "" -> "code" -"code" and add a replthread_cond value to avoid this check - but it probably won't do anything useful) |
||||||
|
#if called directly - the context will be within the first 'code' interp. |
||||||
|
#inappropriate caller could add superfluous entries to shellfilter stack if function errors out |
||||||
|
#inappropriate caller could affect tsv vars (if their interp allows that anyway) |
||||||
|
puts stderr "runscript is meant to be called from the parent repl thread via a thread::send to the codethread" |
||||||
|
return |
||||||
|
} |
||||||
|
set outstack [list] |
||||||
|
set errstack [list] |
||||||
|
upvar ::punk::config::running running_config |
||||||
|
if {[string length [dict get $running_config color_stdout_repl]] && [interp eval code punk::console::colour]} { |
||||||
|
lappend outstack [interp eval code [list shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout_repl]]]] |
||||||
|
} |
||||||
|
lappend outstack [interp eval code [list shellfilter::stack::add stdout tee_to_var -settings {-varname ::punk::repl::codethread::output_stdout}]] |
||||||
|
|
||||||
|
if {[string length [dict get $running_config color_stderr_repl]] && [interp eval code punk::console::colour]} { |
||||||
|
lappend errstack [interp eval code [list shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr_repl]]]] |
||||||
|
# #lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour cyan]] |
||||||
|
} |
||||||
|
lappend errstack [interp eval code [list shellfilter::stack::add stderr tee_to_var -settings {-varname ::punk::repl::codethread::output_stderr}]] |
||||||
|
|
||||||
|
#an experiment |
||||||
|
#set errhandle [shellfilter::stack::item_tophandle stderr] |
||||||
|
#interp transfer "" $errhandle code |
||||||
|
|
||||||
|
set scope [interp eval code [list set ::punk::ns::ns_current]] |
||||||
|
set status [catch { |
||||||
|
interp eval code [list tcl::namespace::inscope $scope $script] |
||||||
|
} result] |
||||||
|
|
||||||
|
|
||||||
|
flush stdout |
||||||
|
flush stderr |
||||||
|
|
||||||
|
#interp transfer code $errhandle "" |
||||||
|
#flush $errhandle |
||||||
|
set lastoutchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stdout]] end] |
||||||
|
set lasterrchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stderr]] end] |
||||||
|
#puts stderr "-->[ansistring VIEW -lf 1 $lastoutchar$lasterrchar]" |
||||||
|
|
||||||
|
set tid [thread::id] |
||||||
|
tsv::set codethread_$tid info [list lastoutchar $lastoutchar lasterrchar $lasterrchar] |
||||||
|
tsv::set codethread_$tid status $status |
||||||
|
tsv::set codethread_$tid result $result |
||||||
|
tsv::set codethread_$tid errorcode $::errorCode |
||||||
|
|
||||||
|
|
||||||
|
#only remove from shellfilter::stack the items we added to stack in this function |
||||||
|
foreach s [lreverse $outstack] { |
||||||
|
interp eval code [list shellfilter::stack::remove stdout $s] |
||||||
|
} |
||||||
|
foreach s [lreverse $errstack] { |
||||||
|
interp eval code [list shellfilter::stack::remove stderr $s] |
||||||
|
} |
||||||
|
thread::cond notify $replthread_cond |
||||||
|
} |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::repl::codethread ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::repl::codethread::lib { |
||||||
|
tcl::namespace::export * |
||||||
|
tcl::namespace::path [tcl::namespace::parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::repl::codethread::lib}] |
||||||
|
#[para] Secondary functions that are part of the API |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
#proc utility1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of utility1 |
||||||
|
# return 1 |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::repl::codethread::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
tcl::namespace::eval punk::repl::codethread::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::repl::codethread::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::repl::codethread [tcl::namespace::eval punk::repl::codethread { |
||||||
|
variable pkg punk::repl::codethread |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
@ -0,0 +1,237 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::unixywindows 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
#for illegalname_test |
||||||
|
package require punk::winpath |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::unixywindows { |
||||||
|
#'cached' name to make obvious it could be out of date - and to distinguish from unixyroot arg |
||||||
|
variable cachedunixyroot "" |
||||||
|
|
||||||
|
|
||||||
|
#----------------- |
||||||
|
#e.g something like c:/Users/geek/scoop/apps/msys2/current c:/msys2 |
||||||
|
proc get_unixyroot {} { |
||||||
|
variable cachedunixyroot |
||||||
|
if {![string length $cachedunixyroot]} { |
||||||
|
if {![catch { |
||||||
|
set result [exec cygpath -m /] ;# -m gives result with forward-slashes - which is ok for windows paths in a Tcl context. |
||||||
|
set cachedunixyroot [punk::objclone $result] |
||||||
|
file pathtype $cachedunixyroot; #this call causes the int-rep to be path |
||||||
|
#set ::punk::last_run_display [list] ;#hack - review shouldn't really be necessary.. but because we call winpath from ./ - the repl looks for last_run_display |
||||||
|
} errM]} { |
||||||
|
|
||||||
|
} else { |
||||||
|
puts stderr "Warning: Failed to determine base for unix-like paths - using default of c:/msys2" |
||||||
|
file pathtype [set cachedunixyroot [punk::objclone "c:/msys2"]] |
||||||
|
} |
||||||
|
} |
||||||
|
#will have been shimmered from string to 'path' internal rep by 'file pathtype' call |
||||||
|
|
||||||
|
#let's return a different copy as it's so easy to lose path-rep |
||||||
|
set copy [punk::objclone $cachedunixyroot] |
||||||
|
return $copy |
||||||
|
} |
||||||
|
proc refresh_unixyroot {} { |
||||||
|
variable cachedunixyroot |
||||||
|
set result [exec cygpath -m /] ;# -m gives result with forward-slashes - which is ok for windows paths in a Tcl context. |
||||||
|
set cachedunixyroot [punk::objclone $result] |
||||||
|
file pathtype $cachedunixyroot; #this call causes the int-rep to be path |
||||||
|
|
||||||
|
set copy [punk::objclone $cachedunixyroot] |
||||||
|
return $copy |
||||||
|
} |
||||||
|
proc set_unixyroot {windows_path} { |
||||||
|
variable cachedunixyroot |
||||||
|
file pathtype $windows_path |
||||||
|
set cachedunixyroot [punk::objclone $windows_path] |
||||||
|
#return the original - but probably int-rep will have shimmered to path even if started out as string |
||||||
|
#- that's probably what we want. Caller can use as string or path without affecting cachedunixyroot |
||||||
|
return $windows_path |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc windir {path} { |
||||||
|
if {$path eq "~"} { |
||||||
|
#as the tilde hasn't been normalized.. we can't assume we're running on the actual platform |
||||||
|
return ~/.. |
||||||
|
} |
||||||
|
return [file dirname [towinpath $path]] |
||||||
|
} |
||||||
|
|
||||||
|
#REVIEW high-coupling |
||||||
|
proc cdwin {path} { |
||||||
|
set path [towinpath $path] |
||||||
|
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||||
|
if {[llength [info commands ::punk::console::titleset]]} { |
||||||
|
::punk::console::titleset $path |
||||||
|
} |
||||||
|
} |
||||||
|
cd $path |
||||||
|
} |
||||||
|
proc cdwindir {path} { |
||||||
|
set path [towinpath $path] |
||||||
|
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||||
|
if {[llength [info commands ::punk::console::titleset]]} { |
||||||
|
::punk::console::titleset $path |
||||||
|
} |
||||||
|
} |
||||||
|
cd [file dirname $path] |
||||||
|
} |
||||||
|
|
||||||
|
#NOTE - this is an expensive operation - avoid where possible. |
||||||
|
#review - is this intended to be useful/callable on non-windows platforms? |
||||||
|
#it should in theory be useable from another platform that wants to create a path for use on windows. |
||||||
|
#In this case - we shouldn't examine what volumes exist (assume A: .. Z: are valid) |
||||||
|
#review zipfs:// other uri schemes? |
||||||
|
proc towinpath {unixypath {unixyroot ""}} { |
||||||
|
#NOTE: tcl file exists gives different answers on windows for paths like /c depending on cwd (presumably based on file pathtype of volumerelative) |
||||||
|
#(Tcl is also somewhat broken as at 2023 as far as volume relative paths - process can get out of sync with tcl if cd to a vol relative path is used) |
||||||
|
#This is add odds with attempting to navigate on a windows system which has cygwin, wsl etc... It also makes it difficult for functions intended to operate independent of CWD. |
||||||
|
#e.g there is potential confusion when there is a c folder on c: drive (c:/c) |
||||||
|
#I will attempt to provide a coherent operation for winpath ./ ../ etc , but it may disallow for example; change to /something or /x where these don't match a driveletter or /mnt |
||||||
|
#whereas tcl may allow cd to /something if a something folder happens to exist on the current volume based on cwd. |
||||||
|
#I think it's preferable to require an explicit driveletter /x or /mnt when using unix-like paths on windows - but practical considerations may prove me wrong.. |
||||||
|
#It's possible that this function should also ignore the current set of driveletters - and operate completely independent of whether a path actually exists |
||||||
|
#This makes it hard to use things like 'file normalize' - which also looks at things like current volume. |
||||||
|
# |
||||||
|
#Note for example the results of 'which' grep on windows can produce a path like /c/Users/somewhere/bin/grep |
||||||
|
#which tcl's file normalize may change to C:/c/Users or X:/c/Users - based on current volumen. Given that C:/c might exist - this can be problematic in a couple of ways. |
||||||
|
#The mixing of unix-like and windows commands on the same machine is a large part of the problem.. but this mix is now common |
||||||
|
# |
||||||
|
#convert /c/etc to C:/etc |
||||||
|
set re_slash_x_slash {^/([[:alpha:]]){1}/.*} |
||||||
|
set re_slash_else {^/([[:alpha:]]*)(.*)} |
||||||
|
set volumes [file volumes] |
||||||
|
#exclude things like //zipfs:/ ?? |
||||||
|
set driveletters [list] |
||||||
|
foreach v $volumes { |
||||||
|
if {[regexp {^([[:alpha:]]){1}:/$} $v _ letter]} { |
||||||
|
lappend driveletters $letter |
||||||
|
} |
||||||
|
} |
||||||
|
#puts stderr "->$driveletters" |
||||||
|
|
||||||
|
set path [punk::objclone $unixypath] ;#take another copy that we can deliberatley shimmer to path and know is separate to the supplied argument |
||||||
|
set supplied_pathtype [file pathtype $path] ;#we don't care about the pathtype so much as the act of making this call shimmers to a path internal-rep |
||||||
|
|
||||||
|
#copy of var that we can treat as a string without affecting path rep |
||||||
|
#Note that some but not all read operations will lose path rep e.g 'string length $x' will lose any path-rep $x had, (but 'string equal $x something' won't) |
||||||
|
#Todo - make int-rep tests to check stability of these behaviours across Tcl versions! |
||||||
|
set strcopy_path [punk::objclone $path] |
||||||
|
|
||||||
|
set str_newpath "" |
||||||
|
|
||||||
|
set have_pathobj 0 |
||||||
|
|
||||||
|
if {[regexp $re_slash_x_slash $strcopy_path _ letter]} { |
||||||
|
#upper case appears to be windows canonical form |
||||||
|
set str_newpath [string toupper $letter]:/[string range $strcopy_path 3 end] |
||||||
|
} elseif {[regexp {^/mnt/([[:alpha:]]){1}/.*} [string tolower $strcopy_path] _ letter]} { |
||||||
|
set str_newpath [string toupper $letter]:/[string range $strcopy_path 7 end] |
||||||
|
} elseif {[regexp {^/mnt/([[:alpha:]]){1}$} [string tolower $strcopy_path] _ letter]} { |
||||||
|
set str_newpath [string toupper $letter]:/ |
||||||
|
} elseif {[regexp $re_slash_else $strcopy_path _ firstpart remainder]} { |
||||||
|
#could be for example /c or /something/users |
||||||
|
if {[string length $firstpart] == 1} { |
||||||
|
set letter $firstpart |
||||||
|
set str_newpath [string toupper $letter]:/ |
||||||
|
} else { |
||||||
|
#according to regex we have a single leading slash |
||||||
|
set str_tail [string range $strcopy_path 1 end] |
||||||
|
if {$unixyroot eq ""} { |
||||||
|
set unixyroot [get_unixyroot] |
||||||
|
} else { |
||||||
|
file pathtype $unixyroot; #side-effect generates int-rep of type path ) |
||||||
|
} |
||||||
|
set pathobj [file join $unixyroot $str_tail] |
||||||
|
file pathtype $pathobj |
||||||
|
set have_pathobj 1 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {!$have_pathobj} { |
||||||
|
if {$str_newpath eq ""} { |
||||||
|
#dunno - pass through |
||||||
|
set pathobj $path |
||||||
|
} else { |
||||||
|
set pathobj [punk::objclone $str_newpath] |
||||||
|
file pathtype $pathobj |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#puts stderr "=> $path" |
||||||
|
#things like 'which' seem to return a path minus the .exe - so we'll just test the containing folder |
||||||
|
# |
||||||
|
#By now file normalize shouldn't do too many shannanigans related to cwd.. |
||||||
|
#We want it to look at cwd for relative paths.. |
||||||
|
#but we don't consider things like /c/Users to be relative even on windows where it would normally mean a volume-relative path e.g c:/c/Users if cwd happens to be somewhere on C: at the time. |
||||||
|
#if {![file exists [file dirname $path]]} { |
||||||
|
# set path [file normalize $path] |
||||||
|
# #may still not exist.. that's ok. |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#file normalize may change backslashes to forward slashes.. including things like the special \\?\ prefix which is intended to stop windows api from parsing a name |
||||||
|
#2023 - this is ok as //?/ also seems to work.. but it is unclear if that is because Tcl is re-converting to backslashes |
||||||
|
if {[punk::winpath::illegalname_test $pathobj]} { |
||||||
|
set pathobj [punk::winpath::illegalname_fix $pathobj] |
||||||
|
} |
||||||
|
|
||||||
|
return $pathobj |
||||||
|
} |
||||||
|
|
||||||
|
#---------------------------------------------- |
||||||
|
#leave the unixywindows related aliases available on all platforms |
||||||
|
#interp alias {} cdwin {} punk::unixywindows::cdwin |
||||||
|
#interp alias {} cdwindir {} punk::unixywindoes::cdwindir |
||||||
|
#interp alias {} towinpath {} punk::unixywindows::towinpath |
||||||
|
#interp alias {} windir {} punk::unixywindows::windir |
||||||
|
#---------------------------------------------- |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::unixywindows [namespace eval punk::unixywindows { |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
@ -0,0 +1,239 @@ |
|||||||
|
#utilities for punk apps to call |
||||||
|
|
||||||
|
package provide punkapp [namespace eval punkapp { |
||||||
|
variable version |
||||||
|
set version 0.1 |
||||||
|
}] |
||||||
|
|
||||||
|
namespace eval punkapp { |
||||||
|
variable result |
||||||
|
variable waiting "no" |
||||||
|
proc hide_dot_window {} { |
||||||
|
#alternative to wm withdraw . |
||||||
|
#see https://wiki.tcl-lang.org/page/wm+withdraw |
||||||
|
wm geometry . 1x1+0+0 |
||||||
|
wm overrideredirect . 1 |
||||||
|
wm transient . |
||||||
|
} |
||||||
|
proc is_toplevel {w} { |
||||||
|
if {![llength [info commands winfo]]} { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
expr {[winfo toplevel $w] eq $w && ![catch {$w cget -menu}]} |
||||||
|
} |
||||||
|
proc get_toplevels {{w .}} { |
||||||
|
if {![llength [info commands winfo]]} { |
||||||
|
return [list] |
||||||
|
} |
||||||
|
set list {} |
||||||
|
if {[is_toplevel $w]} { |
||||||
|
lappend list $w |
||||||
|
} |
||||||
|
foreach w [winfo children $w] { |
||||||
|
lappend list {*}[get_toplevels $w] |
||||||
|
} |
||||||
|
return $list |
||||||
|
} |
||||||
|
|
||||||
|
proc make_toplevel_next {prefix} { |
||||||
|
set top [get_toplevel_next $prefix] |
||||||
|
return [toplevel $top] |
||||||
|
} |
||||||
|
#possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime |
||||||
|
#todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase? |
||||||
|
#can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix |
||||||
|
proc get_toplevel_next {prefix} { |
||||||
|
set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> "" |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
proc exit {{toplevel ""}} { |
||||||
|
variable waiting |
||||||
|
variable result |
||||||
|
variable default_result |
||||||
|
set toplevels [get_toplevels] |
||||||
|
if {[string length $toplevel]} { |
||||||
|
set wposn [lsearch $toplevels $toplevel] |
||||||
|
if {$wposn > 0} { |
||||||
|
destroy $toplevel |
||||||
|
} |
||||||
|
} else { |
||||||
|
#review |
||||||
|
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||||
|
puts stderr "punkapp::exit called without toplevel - showing console" |
||||||
|
show_console |
||||||
|
return 0 |
||||||
|
} else { |
||||||
|
puts stderr "punkapp::exit called without toplevel - exiting" |
||||||
|
if {$waiting ne "no"} { |
||||||
|
if {[info exists result(shell)]} { |
||||||
|
set temp [set result(shell)] |
||||||
|
unset result(shell) |
||||||
|
set waiting $temp |
||||||
|
} else { |
||||||
|
set waiting "" |
||||||
|
} |
||||||
|
} else { |
||||||
|
::exit |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set controllable [get_user_controllable_toplevels] |
||||||
|
if {![llength $controllable]} { |
||||||
|
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||||
|
show_console |
||||||
|
} else { |
||||||
|
if {$waiting ne "no"} { |
||||||
|
if {[info exists result(shell)]} { |
||||||
|
set temp [set result(shell)] |
||||||
|
unset result(shell) |
||||||
|
set waiting $temp |
||||||
|
} elseif {[info exists result($toplevel)]} { |
||||||
|
set temp [set result($toplevel)] |
||||||
|
unset result($toplevel) |
||||||
|
set waiting $temp |
||||||
|
} elseif {[info exists default_result]} { |
||||||
|
set temp $default_result |
||||||
|
unset default_result |
||||||
|
set waiting $temp |
||||||
|
} else { |
||||||
|
set waiting "" |
||||||
|
} |
||||||
|
} else { |
||||||
|
::exit |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
proc close_window {toplevel} { |
||||||
|
wm withdraw $toplevel |
||||||
|
if {![llength [get_user_controllable_toplevels]]} { |
||||||
|
punkapp::exit $toplevel |
||||||
|
} |
||||||
|
destroy $toplevel |
||||||
|
} |
||||||
|
proc wait {args} { |
||||||
|
variable waiting |
||||||
|
variable default_result |
||||||
|
if {[dict exists $args -defaultresult]} { |
||||||
|
set default_result [dict get $args -defaultresult] |
||||||
|
} |
||||||
|
foreach t [punkapp::get_toplevels] { |
||||||
|
if {[wm protocol $t WM_DELETE_WINDOW] eq ""} { |
||||||
|
wm protocol $t WM_DELETE_WINDOW [list punkapp::close_window $t] |
||||||
|
} |
||||||
|
} |
||||||
|
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||||
|
puts stderr "repl eventloop seems to be running - punkapp::wait not required" |
||||||
|
} else { |
||||||
|
if {$waiting eq "no"} { |
||||||
|
set waiting "waiting" |
||||||
|
vwait ::punkapp::waiting |
||||||
|
return $::punkapp::waiting |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#A window can be 'visible' according to this - but underneath other windows etc |
||||||
|
#REVIEW - change name? |
||||||
|
proc get_visible_toplevels {{w .}} { |
||||||
|
if {![llength [info commands winfo]]} { |
||||||
|
return [list] |
||||||
|
} |
||||||
|
set list [get_toplevels $w] |
||||||
|
set mapped [lmap v $list {expr {[winfo ismapped $v] ? $v : {}}}] |
||||||
|
set mapped [concat {*}$mapped] ;#ignore {} |
||||||
|
set visible [list] |
||||||
|
foreach m $mapped { |
||||||
|
if {[wm overrideredirect $m] == 0 } { |
||||||
|
lappend visible $m |
||||||
|
} else { |
||||||
|
if {[winfo height $m] >1 && [winfo width $m] > 1} { |
||||||
|
#technically even a 1x1 is visible.. but in practice even a 10x10 is hardly likely to be noticeable when overrideredirect == 1 |
||||||
|
#as a convention - 1x1 with no controls is used to make a window invisible so we'll treat anything larger as visible |
||||||
|
lappend visible $m |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $visible |
||||||
|
} |
||||||
|
proc get_user_controllable_toplevels {{w .}} { |
||||||
|
set visible [get_visible_toplevels $w] |
||||||
|
set controllable [list] |
||||||
|
foreach v $visible { |
||||||
|
if {[wm overrideredirect $v] == 0} { |
||||||
|
lappend controllable $v |
||||||
|
} |
||||||
|
} |
||||||
|
#only return visible windows with overrideredirect == 0 because there exists some user control. |
||||||
|
#todo - review.. consider checking if position is outside screen areas? Technically controllable.. but not easily |
||||||
|
return $controllable |
||||||
|
} |
||||||
|
proc hide_console {args} { |
||||||
|
set opts [dict create -force 0] |
||||||
|
if {([llength $args] % 2) != 0} { |
||||||
|
error "hide_console expects pairs of arguments. e.g -force 1" |
||||||
|
} |
||||||
|
#set known_opts [dict keys $defaults] |
||||||
|
foreach {k v} $args { |
||||||
|
switch -- $k { |
||||||
|
-force { |
||||||
|
dict set opts $k $v |
||||||
|
} |
||||||
|
default { |
||||||
|
error "Unrecognised options '$k' known options: [dict keys $opts]" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
set force [dict get $opts -force] |
||||||
|
|
||||||
|
if {!$force} { |
||||||
|
if {![llength [get_user_controllable_toplevels]]} { |
||||||
|
puts stderr "Cannot hide console while no user-controllable windows available" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} |
||||||
|
if {$::tcl_platform(platform) eq "windows"} { |
||||||
|
#hide won't work for certain consoles cush as conemu,wezterm - and doesn't really make sense for tabbed windows anyway. |
||||||
|
#It would be nice if we could tell the console window to hide just the relevant tab - or the whole window if only one tab present - but this is unlikely to be possible in any standard way. |
||||||
|
#an ordinary cmd.exe or pwsh.exe or powershell.exe window can be hidden ok though. |
||||||
|
#(but with wezterm - process is cmd.exe - but it has style popup and can't be hidden with a twapi::hide_window call) |
||||||
|
package require twapi |
||||||
|
set h [twapi::get_console_window] |
||||||
|
set pid [twapi::get_window_process $h] |
||||||
|
set pinfo [twapi::get_process_info $pid -name] |
||||||
|
set pname [dict get $pinfo -name] |
||||||
|
set wstyle [twapi::get_window_style $h] |
||||||
|
#tclkitsh/tclsh? |
||||||
|
if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} { |
||||||
|
twapi::hide_window $h |
||||||
|
return 1 |
||||||
|
} else { |
||||||
|
puts stderr "punkapp::hide_console unable to hide this type of console window" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} else { |
||||||
|
#todo |
||||||
|
puts stderr "punkapp::hide_console unimplemented on this platform (todo)" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc show_console {} { |
||||||
|
if {$::tcl_platform(platform) eq "windows"} { |
||||||
|
package require twapi |
||||||
|
if {![catch {set h [twapi::get_console_window]} errM]} { |
||||||
|
twapi::show_window $h -activate -normal |
||||||
|
} else { |
||||||
|
#no console - assume launched from something like wish? |
||||||
|
catch {console show} |
||||||
|
} |
||||||
|
} else { |
||||||
|
#todo |
||||||
|
puts stderr "punkapp::show_console unimplemented on this platform" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
@ -0,0 +1,333 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punkcheck::cli 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
package require punk::mix::util |
||||||
|
|
||||||
|
namespace eval punkcheck::cli { |
||||||
|
namespace ensemble create |
||||||
|
#package require punk::overlay |
||||||
|
#punk::overlay::import_commandset debug. ::punk:mix::commandset::debug |
||||||
|
|
||||||
|
#init proc required - used for lazy loading of commandsets |
||||||
|
variable initialised 0 |
||||||
|
proc _init {args} { |
||||||
|
variable initialised |
||||||
|
if {$initialised} { |
||||||
|
return |
||||||
|
} |
||||||
|
puts stderr "punkcheck::cli::init $args" |
||||||
|
|
||||||
|
set initialised 1 |
||||||
|
} |
||||||
|
|
||||||
|
proc help {args} { |
||||||
|
set basehelp [punk::mix::base help {*}$args] |
||||||
|
return $basehelp |
||||||
|
} |
||||||
|
|
||||||
|
proc paths {{path {}}} { |
||||||
|
if {$path eq {}} { set path [pwd] } |
||||||
|
set search_from $path |
||||||
|
set bottom_to_top [list] |
||||||
|
while {[string length [set pcheck_file [punkcheck::cli::lib::find_nearest_file $search_from]]]} { |
||||||
|
set pcheck_folder [file dirname $pcheck_file] |
||||||
|
lappend bottom_to_top $pcheck_file |
||||||
|
set search_from [file dirname $pcheck_folder] |
||||||
|
} |
||||||
|
return $bottom_to_top |
||||||
|
} |
||||||
|
#todo! - group by fileset |
||||||
|
proc status {{path {}}} { |
||||||
|
if {$path eq {}} { set path [pwd] } |
||||||
|
set fullpath [file normalize $path] |
||||||
|
|
||||||
|
set ftype [file type $fullpath] |
||||||
|
|
||||||
|
|
||||||
|
set files [list] |
||||||
|
if {$ftype eq "file"} { |
||||||
|
set container [file dirname $fullpath] |
||||||
|
lappend files $fullpath |
||||||
|
} else { |
||||||
|
set container $fullpath |
||||||
|
#vfs can mask mounted files - so we can't just use 'file type' or glob with -type f |
||||||
|
##set files [glob -nocomplain -dir $fullpath -type f *] |
||||||
|
package require punk::nav::fs |
||||||
|
set folderinfo [punk::nav::fs::dirfiles_dict $fullpath] |
||||||
|
set files [concat [dict get $folderinfo files] [dict get $folderinfo underlayfiles]] |
||||||
|
} |
||||||
|
set punkcheck_files [paths $container] |
||||||
|
set repodict [punk::repo::find_repo $container] |
||||||
|
|
||||||
|
if {![llength $punkcheck_files]} { |
||||||
|
puts stderr "No .punkcheck files found at or above this folder" |
||||||
|
} |
||||||
|
|
||||||
|
set table "" |
||||||
|
set files_with_records [list] |
||||||
|
foreach p $punkcheck_files { |
||||||
|
set basedir [file dirname $p] |
||||||
|
set recordlist [punkcheck::load_records_from_file $p] |
||||||
|
set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist] |
||||||
|
|
||||||
|
foreach f $files { |
||||||
|
set relpath [punkcheck::lib::path_relative $basedir $f] |
||||||
|
|
||||||
|
if {[dict exists $tgt_dict $relpath]} { |
||||||
|
set filerec [dict get $tgt_dict $relpath] |
||||||
|
set records [punkcheck::dict_getwithdefault $filerec body [list]] |
||||||
|
if {$ftype eq "file"} { |
||||||
|
if {![llength $records]} { |
||||||
|
set pcheck "(has file record but no installation entries)" |
||||||
|
} else { |
||||||
|
set pcheck \n |
||||||
|
foreach irec $records { |
||||||
|
append pcheck [punk::tdl::prettyprint [list $irec] 1] \n |
||||||
|
#append pcheck " $irec" \n |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
if {![llength $records]} { |
||||||
|
set pcheck "(has file record but no installation entries)" |
||||||
|
} else { |
||||||
|
set display_records [list] |
||||||
|
set pcheck \n |
||||||
|
set latest_install_record [punkcheck::recordlist::file_record_latest_installrecord $filerec] |
||||||
|
if {[llength $latest_install_record]} { |
||||||
|
lappend display_records $latest_install_record |
||||||
|
} |
||||||
|
if {$latest_install_record ne [lindex $records end]} { |
||||||
|
lappend display_records [lindex $records end] |
||||||
|
} |
||||||
|
foreach irec $display_records { |
||||||
|
append pcheck "[format %-14s [dict get $irec tag]] [punkcheck::dict_getwithdefault $irec -tsiso "no-timestamp"]" |
||||||
|
set bodyrecords [punkcheck::dict_getwithdefault $irec body [list]] |
||||||
|
set source_files [list] |
||||||
|
set source_files_changed [list] |
||||||
|
set source_folders [list] |
||||||
|
set source_folders_changed [list] |
||||||
|
foreach r $bodyrecords { |
||||||
|
if {[dict get $r tag] eq "SOURCE"} { |
||||||
|
set path [dict get $r -path] |
||||||
|
set changed [dict get $r -changed] |
||||||
|
switch -- [dict get $r -type] { |
||||||
|
file { |
||||||
|
lappend source_files $path |
||||||
|
if {$changed} { |
||||||
|
lappend source_files_changed $path |
||||||
|
} |
||||||
|
} |
||||||
|
directory { |
||||||
|
lappend source_folders $path |
||||||
|
if {$changed} { |
||||||
|
lappend source_folders_changed $path |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
if {[llength $source_files]} { |
||||||
|
append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])" |
||||||
|
} |
||||||
|
if {[llength $source_folders]} { |
||||||
|
append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])" |
||||||
|
} |
||||||
|
append pcheck \n |
||||||
|
|
||||||
|
#append pcheck [punk::tdl::prettyprint [list $irec] 1] \n |
||||||
|
#append pcheck " $irec" \n |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
append table "$f $pcheck" \n |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $table |
||||||
|
} |
||||||
|
proc status_by_file {{path {}}} { |
||||||
|
if {$path eq {}} { set path [pwd] } |
||||||
|
set fullpath [file normalize $path] |
||||||
|
set ftype [file type $fullpath] |
||||||
|
set files [list] |
||||||
|
if {$ftype eq "file"} { |
||||||
|
set container [file dirname $fullpath] |
||||||
|
lappend files $fullpath |
||||||
|
} else { |
||||||
|
set container $fullpath |
||||||
|
set files [glob -nocomplain -dir $fullpath -type f *] |
||||||
|
} |
||||||
|
set punkcheck_files [paths $container] |
||||||
|
set repodict [punk::repo::find_repo $container] |
||||||
|
|
||||||
|
if {![llength $punkcheck_files]} { |
||||||
|
puts stderr "No .punkcheck files found at or above this folder" |
||||||
|
} |
||||||
|
|
||||||
|
set table "" |
||||||
|
set files_with_records [list] |
||||||
|
foreach p $punkcheck_files { |
||||||
|
set basedir [file dirname $p] |
||||||
|
set recordlist [punkcheck::load_records_from_file $p] |
||||||
|
set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist] |
||||||
|
foreach f $files { |
||||||
|
set relpath [punkcheck::lib::path_relative $basedir $f] |
||||||
|
|
||||||
|
if {[dict exists $tgt_dict $relpath]} { |
||||||
|
set filerec [dict get $tgt_dict $relpath] |
||||||
|
set records [punkcheck::dict_getwithdefault $filerec body [list]] |
||||||
|
if {$ftype eq "file"} { |
||||||
|
if {![llength $records]} { |
||||||
|
set pcheck "(has file record but no installation entries)" |
||||||
|
} else { |
||||||
|
set pcheck \n |
||||||
|
foreach irec $records { |
||||||
|
append pcheck [punk::tdl::prettyprint [list $irec] 1] \n |
||||||
|
#append pcheck " $irec" \n |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
if {![llength $records]} { |
||||||
|
set pcheck "(has file record but no installation entries)" |
||||||
|
} else { |
||||||
|
set display_records [list] |
||||||
|
set pcheck \n |
||||||
|
set latest_install_record [punkcheck::recordlist::file_record_latest_installrecord $filerec] |
||||||
|
lappend display_records $latest_install_record |
||||||
|
if {$latest_install_record ne [lindex $records end]} { |
||||||
|
lappend display_records [lindex $records end] |
||||||
|
} |
||||||
|
foreach irec $display_records { |
||||||
|
append pcheck "[format %-14s [dict get $irec tag]] [punkcheck::dict_getwithdefault $irec -tsiso "no-timestamp"]" |
||||||
|
set bodyrecords [punkcheck::dict_getwithdefault $irec body [list]] |
||||||
|
set source_files [list] |
||||||
|
set source_files_changed [list] |
||||||
|
set source_folders [list] |
||||||
|
set source_folders_changed [list] |
||||||
|
foreach r $bodyrecords { |
||||||
|
if {[dict get $r tag] eq "SOURCE"} { |
||||||
|
set path [dict get $r -path] |
||||||
|
set changed [dict get $r -changed] |
||||||
|
switch -- [dict get $r -type] { |
||||||
|
file { |
||||||
|
lappend source_files $path |
||||||
|
if {$changed} { |
||||||
|
lappend source_files_changed $path |
||||||
|
} |
||||||
|
} |
||||||
|
directory { |
||||||
|
lappend source_folders $path |
||||||
|
if {$changed} { |
||||||
|
lappend source_folders_changed $path |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
if {[llength $source_files]} { |
||||||
|
append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])" |
||||||
|
} |
||||||
|
if {[llength $source_folders]} { |
||||||
|
append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])" |
||||||
|
} |
||||||
|
append pcheck \n |
||||||
|
|
||||||
|
#append pcheck [punk::tdl::prettyprint [list $irec] 1] \n |
||||||
|
#append pcheck " $irec" \n |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
append table "$f $pcheck" \n |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $table |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punkcheck::cli::lib { |
||||||
|
namespace path ::punk::mix::util ;#askuser, do_in_path, foreach-file etc |
||||||
|
|
||||||
|
proc find_nearest_file {{path {}}} { |
||||||
|
if {$path eq {}} { set path [pwd] } |
||||||
|
set folder [lib::scanup $path lib::is_punkchecked_folder] |
||||||
|
if {$folder eq ""} { |
||||||
|
return "" |
||||||
|
} else { |
||||||
|
return [file join $folder .punkcheck] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc is_punkchecked_folder {{path {}}} { |
||||||
|
if {$path eq {}} { set path [pwd] } |
||||||
|
foreach control { |
||||||
|
.punkcheck |
||||||
|
} { |
||||||
|
set control [file join $path $control] |
||||||
|
if {[file isfile $control]} {return 1} |
||||||
|
} |
||||||
|
return 0 |
||||||
|
} |
||||||
|
|
||||||
|
proc scanup {path cmd} { |
||||||
|
if {$path eq {}} { set path [pwd] } |
||||||
|
#based on kettle::path::scanup |
||||||
|
if {[file pathtype $path] eq "relative"} { |
||||||
|
set path [file normalize $path] |
||||||
|
} |
||||||
|
while {1} { |
||||||
|
# Found the proper directory, per the predicate. |
||||||
|
if {[{*}$cmd $path]} { return $path } |
||||||
|
|
||||||
|
# Not found, walk to parent |
||||||
|
set new [file dirname $path] |
||||||
|
|
||||||
|
# Stop when reaching the root. |
||||||
|
if {$new eq $path} { return {} } |
||||||
|
if {$new eq {}} { return {} } |
||||||
|
|
||||||
|
# Ok, truly walk up. |
||||||
|
set path $new |
||||||
|
} |
||||||
|
return {} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punkcheck::cli { |
||||||
|
proc _cli {args} { |
||||||
|
#don't use tailcall - base uses info level to determine caller |
||||||
|
::punk::mix::base::_cli {*}$args |
||||||
|
} |
||||||
|
variable default_command status |
||||||
|
package require punk::mix::base |
||||||
|
package require punk::overlay |
||||||
|
punk::overlay::custom_from_base [namespace current] ::punk::mix::base |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punkcheck::cli [namespace eval punkcheck::cli { |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
|
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,259 @@ |
|||||||
|
|
||||||
|
# Tcl parser for optional arguments in function calls and |
||||||
|
# commandline arguments |
||||||
|
# |
||||||
|
# (c) 2001 Bastien Chevreux |
||||||
|
|
||||||
|
# Index of exported commands |
||||||
|
# - argp::registerArgs |
||||||
|
# - argp::setArgDefaults |
||||||
|
# - argp::setArgsNeeded |
||||||
|
# - argp::parseArgs |
||||||
|
|
||||||
|
# Internal commands |
||||||
|
# - argp::CheckValues |
||||||
|
|
||||||
|
# See end of file for an example on how to use |
||||||
|
|
||||||
|
package provide argp 0.2 |
||||||
|
|
||||||
|
namespace eval argp { |
||||||
|
variable Optstore |
||||||
|
variable Opttypes { |
||||||
|
boolean integer double string |
||||||
|
} |
||||||
|
|
||||||
|
namespace export {[a-z]*} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc argp::registerArgs { func arglist } { |
||||||
|
variable Opttypes |
||||||
|
variable Optstore |
||||||
|
|
||||||
|
set parentns [string range [uplevel 1 [list namespace current]] 2 end] |
||||||
|
if { $parentns != "" } { |
||||||
|
append caller $parentns :: $func |
||||||
|
} else { |
||||||
|
set caller $func |
||||||
|
} |
||||||
|
set cmangled [string map {:: _} $caller] |
||||||
|
|
||||||
|
#puts $parentns |
||||||
|
#puts $caller |
||||||
|
#puts $cmangled |
||||||
|
|
||||||
|
set Optstore(keys,$cmangled) {} |
||||||
|
set Optstore(deflist,$cmangled) {} |
||||||
|
set Optstore(argneeded,$cmangled) {} |
||||||
|
|
||||||
|
foreach arg $arglist { |
||||||
|
foreach {opt type default allowed} $arg { |
||||||
|
set optindex [lsearch -glob $Opttypes $type*] |
||||||
|
if { $optindex < 0} { |
||||||
|
return -code error "$caller, unknown type $type while registering arguments.\nAllowed types: [string trim $Opttypes]" |
||||||
|
} |
||||||
|
set type [lindex $Opttypes $optindex] |
||||||
|
|
||||||
|
lappend Optstore(keys,$cmangled) $opt |
||||||
|
set Optstore(type,$opt,$cmangled) $type |
||||||
|
set Optstore(default,$opt,$cmangled) $default |
||||||
|
set Optstore(allowed,$opt,$cmangled) $allowed |
||||||
|
lappend Optstore(deflist,$cmangled) $opt $default |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if { [catch {CheckValues $caller $cmangled $Optstore(deflist,$cmangled)} res]} { |
||||||
|
return -code error "Error in declaration of optional arguments.\n$res" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc argp::setArgDefaults { func arglist } { |
||||||
|
variable Optstore |
||||||
|
|
||||||
|
set parentns [string range [uplevel 1 [list namespace current]] 2 end] |
||||||
|
if { $parentns != "" } { |
||||||
|
append caller $parentns :: $func |
||||||
|
} else { |
||||||
|
set caller $func |
||||||
|
} |
||||||
|
set cmangled [string map {:: _} $caller] |
||||||
|
|
||||||
|
if {![info exists Optstore(deflist,$cmangled)]} { |
||||||
|
return -code error "Arguments for $caller not registered yet." |
||||||
|
} |
||||||
|
set Optstore(deflist,$cmangled) {} |
||||||
|
foreach {opt default} $arglist { |
||||||
|
if {![info exists Optstore(default,$opt,$cmangled)]} { |
||||||
|
return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)" |
||||||
|
} |
||||||
|
set Optstore(default,$opt,$cmangled) $default |
||||||
|
} |
||||||
|
|
||||||
|
# set the new defaultlist |
||||||
|
foreach opt $Optstore(keys,$cmangled) { |
||||||
|
lappend Optstore(deflist,$cmangled) $opt $Optstore(default,$opt,$cmangled) |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc argp::setArgsNeeded { func arglist } { |
||||||
|
variable Optstore |
||||||
|
|
||||||
|
set parentns [string range [uplevel 1 [list namespace current]] 2 end] |
||||||
|
if { $parentns != "" } { |
||||||
|
append caller $parentns :: $func |
||||||
|
} else { |
||||||
|
set caller $func |
||||||
|
} |
||||||
|
set cmangled [string map {:: _} $caller] |
||||||
|
|
||||||
|
#append caller $parentns :: $func |
||||||
|
#set cmangled ${parentns}_$func |
||||||
|
|
||||||
|
if {![info exists Optstore(deflist,$cmangled)]} { |
||||||
|
return -code error "Arguments for $caller not registered yet." |
||||||
|
} |
||||||
|
|
||||||
|
set Optstore(argneeded,$cmangled) {} |
||||||
|
foreach opt $arglist { |
||||||
|
if {![info exists Optstore(default,$opt,$cmangled)]} { |
||||||
|
return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)" |
||||||
|
} |
||||||
|
lappend Optstore(argneeded,$cmangled) $opt |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc argp::parseArgs { args } { |
||||||
|
variable Optstore |
||||||
|
|
||||||
|
if {[llength $args] == 0} { |
||||||
|
upvar args a opts o |
||||||
|
} else { |
||||||
|
upvar args a [lindex $args 0] o |
||||||
|
} |
||||||
|
|
||||||
|
if { [ catch { set caller [lindex [info level -1] 0]}]} { |
||||||
|
set caller "main program" |
||||||
|
set cmangled "" |
||||||
|
} else { |
||||||
|
set cmangled [string map {:: _} $caller] |
||||||
|
} |
||||||
|
|
||||||
|
if {![info exists Optstore(deflist,$cmangled)]} { |
||||||
|
return -code error "Arguments for $caller not registered yet." |
||||||
|
} |
||||||
|
|
||||||
|
# set the defaults |
||||||
|
array set o $Optstore(deflist,$cmangled) |
||||||
|
|
||||||
|
# but unset the needed arguments |
||||||
|
foreach key $Optstore(argneeded,$cmangled) { |
||||||
|
catch { unset o($key) } |
||||||
|
} |
||||||
|
|
||||||
|
foreach {key val} $a { |
||||||
|
if {![info exists Optstore(type,$key,$cmangled)]} { |
||||||
|
return -code error "$caller, unknown option $key, must be one of: $Optstore(keys,$cmangled)" |
||||||
|
} |
||||||
|
switch -exact -- $Optstore(type,$key,$cmangled) { |
||||||
|
boolean - |
||||||
|
integer { |
||||||
|
if { $val == "" } { |
||||||
|
return -code error "$caller, $key empty string is not $Optstore(type,$key,$cmangled) value." |
||||||
|
} |
||||||
|
if { ![string is $Optstore(type,$key,$cmangled) $val]} { |
||||||
|
return -code error "$caller, $key $val is not $Optstore(type,$key,$cmangled) value." |
||||||
|
} |
||||||
|
} |
||||||
|
double { |
||||||
|
if { $val == "" } { |
||||||
|
return -code error "$caller, $key empty string is not double value." |
||||||
|
} |
||||||
|
if { ![string is double $val]} { |
||||||
|
return -code error "$caller, $key $val is not double value." |
||||||
|
} |
||||||
|
if { [string is integer $val]} { |
||||||
|
set val [expr {$val + .0}] |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
} |
||||||
|
} |
||||||
|
set o($key) $val |
||||||
|
} |
||||||
|
|
||||||
|
foreach key $Optstore(argneeded,$cmangled) { |
||||||
|
if {![info exists o($key)]} { |
||||||
|
return -code error "$caller, needed argument $key was not given." |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if { [catch { CheckValues $caller $cmangled [array get o]} err]} { |
||||||
|
return -code error $err |
||||||
|
} |
||||||
|
|
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc argp::CheckValues { caller cmangled checklist } { |
||||||
|
variable Optstore |
||||||
|
|
||||||
|
#puts "Checking $checklist" |
||||||
|
|
||||||
|
foreach {key val} $checklist { |
||||||
|
if { [llength $Optstore(allowed,$key,$cmangled)] > 0 } { |
||||||
|
switch -exact -- $Optstore(type,$key,$cmangled) { |
||||||
|
string { |
||||||
|
if { [lsearch $Optstore(allowed,$key,$cmangled) $val] < 0} { |
||||||
|
return -code error "$caller, $key $val is not in allowed values: $Optstore(allowed,$key,$cmangled)" |
||||||
|
} |
||||||
|
} |
||||||
|
double - |
||||||
|
integer { |
||||||
|
set found 0 |
||||||
|
foreach range $Optstore(allowed,$key,$cmangled) { |
||||||
|
if {[llength $range] == 1} { |
||||||
|
if { $val == [lindex $range 0] } { |
||||||
|
set found 1 |
||||||
|
break |
||||||
|
} |
||||||
|
} elseif {[llength $range] == 2} { |
||||||
|
set low [lindex $range 0] |
||||||
|
set high [lindex $range 1] |
||||||
|
|
||||||
|
if { ![string is integer $low] \ |
||||||
|
&& [string compare "-" $low] != 0} { |
||||||
|
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a lower value range that is not integer and not \u00b4-\u00b4: $range" |
||||||
|
} |
||||||
|
if { ![string is integer $high] \ |
||||||
|
&& [string compare "+" $high] != 0} { |
||||||
|
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a upper value range that is not integer and not \u00b4+\u00b4: $range" |
||||||
|
} |
||||||
|
if {[string compare "-" $low] == 0} { |
||||||
|
if { [string compare "+" $high] == 0 \ |
||||||
|
|| $val <= $high } { |
||||||
|
set found 1 |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
if { $val >= $low } { |
||||||
|
if {[string compare "+" $high] == 0 \ |
||||||
|
|| $val <= $high } { |
||||||
|
set found 1 |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has an allowed value range containing more than 2 elements: $range" |
||||||
|
} |
||||||
|
} |
||||||
|
if { $found == 0 } { |
||||||
|
return -code error "$caller, $key $val is not covered by allowed ranges: $Optstore(allowed,$key,$cmangled)" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
@ -0,0 +1,306 @@ |
|||||||
|
# Debug - a debug narrative logger. |
||||||
|
# -- Colin McCormack / originally Wub server utilities |
||||||
|
# |
||||||
|
# Debugging areas of interest are represented by 'tokens' which have |
||||||
|
# independantly settable levels of interest (an integer, higher is more detailed) |
||||||
|
# |
||||||
|
# Debug narrative is provided as a tcl script whose value is [subst]ed in the |
||||||
|
# caller's scope if and only if the current level of interest matches or exceeds |
||||||
|
# the Debug call's level of detail. This is useful, as one can place arbitrarily |
||||||
|
# complex narrative in code without unnecessarily evaluating it. |
||||||
|
# |
||||||
|
# TODO: potentially different streams for different areas of interest. |
||||||
|
# (currently only stderr is used. there is some complexity in efficient |
||||||
|
# cross-threaded streams.) |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## Requisites |
||||||
|
|
||||||
|
package require Tcl 8.5- |
||||||
|
|
||||||
|
namespace eval ::debug { |
||||||
|
namespace export -clear \ |
||||||
|
define on off prefix suffix header trailer \ |
||||||
|
names 2array level setting parray pdict \ |
||||||
|
nl tab hexl |
||||||
|
namespace ensemble create -subcommands {} |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## API & Implementation |
||||||
|
|
||||||
|
proc ::debug::noop {args} {} |
||||||
|
|
||||||
|
proc ::debug::debug {tag message {level 1}} { |
||||||
|
variable detail |
||||||
|
if {$detail($tag) < $level} { |
||||||
|
#puts stderr "$tag @@@ $detail($tag) >= $level" |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
variable prefix |
||||||
|
variable suffix |
||||||
|
variable header |
||||||
|
variable trailer |
||||||
|
variable fds |
||||||
|
|
||||||
|
if {[info exists fds($tag)]} { |
||||||
|
set fd $fds($tag) |
||||||
|
} else { |
||||||
|
set fd stderr |
||||||
|
} |
||||||
|
|
||||||
|
# Assemble the shown text from the user message and the various |
||||||
|
# prefixes and suffices (global + per-tag). |
||||||
|
|
||||||
|
set themessage "" |
||||||
|
if {[info exists prefix(::)]} { append themessage $prefix(::) } |
||||||
|
if {[info exists prefix($tag)]} { append themessage $prefix($tag) } |
||||||
|
append themessage $message |
||||||
|
if {[info exists suffix($tag)]} { append themessage $suffix($tag) } |
||||||
|
if {[info exists suffix(::)]} { append themessage $suffix(::) } |
||||||
|
|
||||||
|
# Resolve variables references and command invokations embedded |
||||||
|
# into the message with plain text. |
||||||
|
set code [catch { |
||||||
|
set smessage [uplevel 1 [list ::subst -nobackslashes $themessage]] |
||||||
|
set sheader [uplevel 1 [list ::subst -nobackslashes $header]] |
||||||
|
set strailer [uplevel 1 [list ::subst -nobackslashes $trailer]] |
||||||
|
} __ eo] |
||||||
|
|
||||||
|
# And dump an internal error if that resolution failed. |
||||||
|
if {$code} { |
||||||
|
if {[catch { |
||||||
|
set caller [info level -1] |
||||||
|
}]} { set caller GLOBAL } |
||||||
|
if {[string length $caller] >= 1000} { |
||||||
|
set caller "[string range $caller 0 200]...[string range $caller end-200 end]" |
||||||
|
} |
||||||
|
foreach line [split $caller \n] { |
||||||
|
puts -nonewline $fd "@@(DebugError from $tag ($eo): $line)" |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# From here we have a good message to show. We only shorten it a |
||||||
|
# bit if its a bit excessive in size. |
||||||
|
|
||||||
|
if {[string length $smessage] > 4096} { |
||||||
|
set head [string range $smessage 0 2048] |
||||||
|
set tail [string range $smessage end-2048 end] |
||||||
|
set smessage "${head}...(truncated)...$tail" |
||||||
|
} |
||||||
|
|
||||||
|
foreach line [split $smessage \n] { |
||||||
|
puts $fd "$sheader$tag | $line$strailer" |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# names - return names of debug tags |
||||||
|
proc ::debug::names {} { |
||||||
|
variable detail |
||||||
|
return [lsort [array names detail]] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::2array {} { |
||||||
|
variable detail |
||||||
|
set result {} |
||||||
|
foreach n [lsort [array names detail]] { |
||||||
|
if {[interp alias {} debug.$n] ne "::debug::noop"} { |
||||||
|
lappend result $n $detail($n) |
||||||
|
} else { |
||||||
|
lappend result $n -$detail($n) |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
# level - set level and fd for tag |
||||||
|
proc ::debug::level {tag {level ""} {fd {}}} { |
||||||
|
variable detail |
||||||
|
# TODO: Force level >=0. |
||||||
|
if {$level ne ""} { |
||||||
|
set detail($tag) $level |
||||||
|
} |
||||||
|
|
||||||
|
if {![info exists detail($tag)]} { |
||||||
|
set detail($tag) 1 |
||||||
|
} |
||||||
|
|
||||||
|
variable fds |
||||||
|
if {$fd ne {}} { |
||||||
|
set fds($tag) $fd |
||||||
|
} |
||||||
|
|
||||||
|
return $detail($tag) |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::header {text} { variable header $text } |
||||||
|
proc ::debug::trailer {text} { variable trailer $text } |
||||||
|
|
||||||
|
proc ::debug::define {tag} { |
||||||
|
if {[interp alias {} debug.$tag] ne {}} return |
||||||
|
off $tag |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# Set a prefix/suffix to use for tag. |
||||||
|
# The global (tag-independent) prefix/suffix is adressed through tag '::'. |
||||||
|
# This works because colon (:) is an illegal character for user-specified tags. |
||||||
|
|
||||||
|
proc ::debug::prefix {tag {theprefix {}}} { |
||||||
|
variable prefix |
||||||
|
set prefix($tag) $theprefix |
||||||
|
|
||||||
|
if {[interp alias {} debug.$tag] ne {}} return |
||||||
|
off $tag |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::suffix {tag {theprefix {}}} { |
||||||
|
variable suffix |
||||||
|
set suffix($tag) $theprefix |
||||||
|
|
||||||
|
if {[interp alias {} debug.$tag] ne {}} return |
||||||
|
off $tag |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# turn on debugging for tag |
||||||
|
proc ::debug::on {tag {level ""} {fd {}}} { |
||||||
|
variable active |
||||||
|
set active($tag) 1 |
||||||
|
level $tag $level $fd |
||||||
|
interp alias {} debug.$tag {} ::debug::debug $tag |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# turn off debugging for tag |
||||||
|
proc ::debug::off {tag {level ""} {fd {}}} { |
||||||
|
variable active |
||||||
|
set active($tag) 1 |
||||||
|
level $tag $level $fd |
||||||
|
interp alias {} debug.$tag {} ::debug::noop |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::setting {args} { |
||||||
|
if {[llength $args] == 1} { |
||||||
|
set args [lindex $args 0] |
||||||
|
} |
||||||
|
set fd stderr |
||||||
|
if {[llength $args] % 2} { |
||||||
|
set fd [lindex $args end] |
||||||
|
set args [lrange $args 0 end-1] |
||||||
|
} |
||||||
|
foreach {tag level} $args { |
||||||
|
if {$level > 0} { |
||||||
|
level $tag $level $fd |
||||||
|
interp alias {} debug.$tag {} ::debug::debug $tag |
||||||
|
} else { |
||||||
|
level $tag [expr {-$level}] $fd |
||||||
|
interp alias {} debug.$tag {} ::debug::noop |
||||||
|
} |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## Convenience commands. |
||||||
|
# Format arrays and dicts as multi-line message. |
||||||
|
# Insert newlines and tabs. |
||||||
|
|
||||||
|
proc ::debug::nl {} { return \n } |
||||||
|
proc ::debug::tab {} { return \t } |
||||||
|
|
||||||
|
proc ::debug::parray {a {pattern *}} { |
||||||
|
upvar 1 $a array |
||||||
|
if {![array exists array]} { |
||||||
|
error "\"$a\" isn't an array" |
||||||
|
} |
||||||
|
pdict [array get array] $pattern |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::pdict {dict {pattern *}} { |
||||||
|
set maxl 0 |
||||||
|
set names [lsort -dict [dict keys $dict $pattern]] |
||||||
|
foreach name $names { |
||||||
|
if {[string length $name] > $maxl} { |
||||||
|
set maxl [string length $name] |
||||||
|
} |
||||||
|
} |
||||||
|
set maxl [expr {$maxl + 2}] |
||||||
|
set lines {} |
||||||
|
foreach name $names { |
||||||
|
set nameString [format (%s) $name] |
||||||
|
lappend lines [format "%-*s = %s" \ |
||||||
|
$maxl $nameString \ |
||||||
|
[dict get $dict $name]] |
||||||
|
} |
||||||
|
return [join $lines \n] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::hexl {data {prefix {}}} { |
||||||
|
set r {} |
||||||
|
|
||||||
|
# Convert the data to hex and to characters. |
||||||
|
binary scan $data H*@0a* hexa asciia |
||||||
|
|
||||||
|
# Replace non-printing characters in the data with dots. |
||||||
|
regsub -all -- {[^[:graph:] ]} $asciia {.} asciia |
||||||
|
|
||||||
|
# Pad with spaces to a full multiple of 32/16. |
||||||
|
set n [expr {[string length $hexa] % 32}] |
||||||
|
if {$n < 32} { append hexa [string repeat { } [expr {32-$n}]] } |
||||||
|
#puts "pad H [expr {32-$n}]" |
||||||
|
|
||||||
|
set n [expr {[string length $asciia] % 32}] |
||||||
|
if {$n < 16} { append asciia [string repeat { } [expr {16-$n}]] } |
||||||
|
#puts "pad A [expr {32-$n}]" |
||||||
|
|
||||||
|
# Reassemble formatted, in groups of 16 bytes/characters. |
||||||
|
# The hex part is handled in groups of 32 nibbles. |
||||||
|
set addr 0 |
||||||
|
while {[string length $hexa]} { |
||||||
|
# Get front group of 16 bytes each. |
||||||
|
set hex [string range $hexa 0 31] |
||||||
|
set ascii [string range $asciia 0 15] |
||||||
|
# Prep for next iteration |
||||||
|
set hexa [string range $hexa 32 end] |
||||||
|
set asciia [string range $asciia 16 end] |
||||||
|
|
||||||
|
# Convert the hex to pairs of hex digits |
||||||
|
regsub -all -- {..} $hex {& } hex |
||||||
|
|
||||||
|
# Add the hex and latin-1 data to the result buffer |
||||||
|
append r $prefix [format %04x $addr] { | } $hex { |} $ascii |\n |
||||||
|
incr addr 16 |
||||||
|
} |
||||||
|
|
||||||
|
# And done |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
|
||||||
|
namespace eval debug { |
||||||
|
variable detail ; # map: TAG -> level of interest |
||||||
|
variable prefix ; # map: TAG -> message prefix to use |
||||||
|
variable suffix ; # map: TAG -> message suffix to use |
||||||
|
variable fds ; # map: TAG -> handle of open channel to log to. |
||||||
|
variable header {} ; # per-line heading, subst'ed |
||||||
|
variable trailer {} ; # per-line ending, subst'ed |
||||||
|
|
||||||
|
# Notes: |
||||||
|
# - The tag '::' is reserved. "prefix" and "suffix" use it to store |
||||||
|
# the global message prefix / suffix. |
||||||
|
# - prefix and suffix are applied per message. |
||||||
|
# - header and trailer are per line. And should not generate multiple lines! |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## Ready |
||||||
|
|
||||||
|
package provide debug 1.0.6 |
||||||
|
return |
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,322 @@ |
|||||||
|
package provide funcl [namespace eval funcl { |
||||||
|
variable version |
||||||
|
set version 0.1 |
||||||
|
}] |
||||||
|
#funcl = function list (nested call structure) |
||||||
|
# |
||||||
|
#a basic functional composition o combinator |
||||||
|
#o(f,g)(x) == f(g(x)) |
||||||
|
|
||||||
|
namespace eval funcl { |
||||||
|
|
||||||
|
#from punk |
||||||
|
proc arg_is_script_shaped {arg} { |
||||||
|
if {[string first " " $arg] >= 0} { |
||||||
|
return 1 |
||||||
|
} elseif {[string first \n $arg] >= 0} { |
||||||
|
return 1 |
||||||
|
} elseif {[string first ";" $arg] >= 0} { |
||||||
|
return 1 |
||||||
|
} elseif {[string first \t $arg] >= 0} { |
||||||
|
return 1 |
||||||
|
} else { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc o args { |
||||||
|
set closing [string repeat {]} [expr [llength $args]-1]] |
||||||
|
set body "[join $args { [}] \$data $closing" |
||||||
|
return $body |
||||||
|
} |
||||||
|
|
||||||
|
proc o_ args { |
||||||
|
set body "" |
||||||
|
set tails [lrepeat [llength $args] ""] |
||||||
|
puts stdout "tails: $tails" |
||||||
|
|
||||||
|
set end [lindex $args end] |
||||||
|
if {[llength $end] == 1 && [arg_is_script_shaped $end]} { |
||||||
|
set endfunc [string map "<end> $end" {uplevel 1 [list if 1 <end> ]}] |
||||||
|
} else { |
||||||
|
set endfunc $end |
||||||
|
} |
||||||
|
if {[llength $args] == 1} { |
||||||
|
return $endfunc |
||||||
|
} |
||||||
|
|
||||||
|
set wrap { [} |
||||||
|
append wrap $endfunc |
||||||
|
append wrap { ]} |
||||||
|
|
||||||
|
set i 0 |
||||||
|
foreach cmdlist [lrange $args 0 end-1] { |
||||||
|
set is_script 0 |
||||||
|
if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} { |
||||||
|
set is_script 1 |
||||||
|
set script [lindex $cmdlist 0] |
||||||
|
} |
||||||
|
set t "" |
||||||
|
if {$i > 0} { |
||||||
|
append body { [} |
||||||
|
} |
||||||
|
set posn [lsearch $cmdlist _] |
||||||
|
if {$posn <= 0} { |
||||||
|
append body $cmdlist |
||||||
|
if {$i == [expr {[llength $args] -2}]} { |
||||||
|
#append body " \$data" |
||||||
|
append body " $wrap" |
||||||
|
} |
||||||
|
if {$i > 0} { |
||||||
|
set t {]} |
||||||
|
} |
||||||
|
} else { |
||||||
|
append body [lrange $cmdlist 0 $posn-1] |
||||||
|
if {$i == [expr {[llength $args] -2}]} { |
||||||
|
#append body " \$data" |
||||||
|
append body " $wrap" |
||||||
|
} |
||||||
|
set t [lrange $cmdlist $posn+1 end] |
||||||
|
if {$i > 0} { |
||||||
|
append t { ]} |
||||||
|
} |
||||||
|
} |
||||||
|
lset tails $i $t |
||||||
|
incr i |
||||||
|
} |
||||||
|
append body [join [lreverse $tails] " "] |
||||||
|
puts stdout "tails: $tails" |
||||||
|
|
||||||
|
return $body |
||||||
|
} |
||||||
|
|
||||||
|
#review - consider _call -- if count > 1 then they must all be callable cmdlists(?) |
||||||
|
# what does it mean to have additional _fn wrapper with no other elements? (no actual function) |
||||||
|
#e.g _fn 2 5 6 somefunc {_fn 1 3 {_call 1 3 xxx}} {_fn 1 4 command {_fn ...}} |
||||||
|
# what type indicates running subtrees in parallel vs sequentially? |
||||||
|
# any reason to have _call count other than 1? Presumably the parent node indicates the parallelism/sequentialism etc. |
||||||
|
# |
||||||
|
# |
||||||
|
# accept or return a funcl (or funcltree if multiple funcls in one commandlist) |
||||||
|
# also accept/return a call - return empty list if passed a call |
||||||
|
proc next_funcl {funcl_or_tree} { |
||||||
|
if {[lindex $funcl_or_tree 0] eq "_call"} { |
||||||
|
return [list] |
||||||
|
} |
||||||
|
if {[lindex $funcl_or_tree 0] in [list "_fn" "_call"]} { |
||||||
|
set funcl $funcl_or_tree |
||||||
|
} else { |
||||||
|
error "funcltree not implemented" |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
set count [lindex $funcl 1] |
||||||
|
if {$count == 0} { |
||||||
|
#null funcl.. what is it? metadata/placeholder? |
||||||
|
return $funcl |
||||||
|
} |
||||||
|
set indices [lrange $funcl 2 [expr {1 + $count}]] |
||||||
|
set i 0 |
||||||
|
foreach idx $indices { |
||||||
|
if {$i > 0} { |
||||||
|
#todo - return a funcltree |
||||||
|
error "multi funcl not implemented" |
||||||
|
} |
||||||
|
set next [lindex $funcl $idx] |
||||||
|
incr i |
||||||
|
} |
||||||
|
|
||||||
|
return $next |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
#convert a funcl to a tcl script |
||||||
|
proc funcl_script {funcl} { |
||||||
|
if {![llength $funcl]} { |
||||||
|
return "" |
||||||
|
} |
||||||
|
set body "" |
||||||
|
set tails [list] |
||||||
|
|
||||||
|
set type [lindex $funcl 0] |
||||||
|
if {$type ni [list "_fn" "_call"]} { |
||||||
|
#todo - handle funcltree |
||||||
|
error "type $type not implemented" |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#only count of 1 with index 3 supported(?) |
||||||
|
if {$type eq "_call"} { |
||||||
|
#leaf |
||||||
|
set cmdlist [lindex $funcl 3] |
||||||
|
return $cmdlist |
||||||
|
} |
||||||
|
|
||||||
|
#we will use next_funcl to walk the nodes.. todo support treefuncl response from next_funcl which could branch multiple times. |
||||||
|
#by continually passing back the resulting treefuncl/funcl to next_funcl we can process in correct order (?) |
||||||
|
# we would still need to maintain state to stitch it back together once returned from a subtree.. |
||||||
|
# ie multiple tail parts |
||||||
|
set count [lindex $funcl 1] |
||||||
|
|
||||||
|
if {$count == 1} { |
||||||
|
set idx [lindex $funcl 2] |
||||||
|
if {$idx == 3} { |
||||||
|
set cmdlist_pre [list] |
||||||
|
} else { |
||||||
|
set cmdlist_pre [lrange $funcl 3 $idx-1] |
||||||
|
} |
||||||
|
append body $cmdlist_pre |
||||||
|
set t [lrange $funcl $idx+1 end] |
||||||
|
lappend tails $t |
||||||
|
} else { |
||||||
|
#?? |
||||||
|
error "funcl_script branching not yet supported" |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
set get_next 1 |
||||||
|
set i 1 |
||||||
|
while {$get_next} { |
||||||
|
set funcl [next_funcl $funcl] |
||||||
|
if {![llength $funcl]} { |
||||||
|
set get_next 0 |
||||||
|
} |
||||||
|
lassign $funcl type count idx ;#todo support count > 1 |
||||||
|
if {$type eq "_call"} { |
||||||
|
set get_next 0 |
||||||
|
} |
||||||
|
set t "" |
||||||
|
if {$type eq "_call"} { |
||||||
|
append body { [} |
||||||
|
append body [lindex $funcl $idx] |
||||||
|
append body { ]} |
||||||
|
} else { |
||||||
|
append body { [} |
||||||
|
if {$idx == 3} { |
||||||
|
set cmdlist_pre [list] |
||||||
|
} else { |
||||||
|
set cmdlist_pre [lrange $funcl 3 $idx-1] |
||||||
|
} |
||||||
|
append body $cmdlist_pre |
||||||
|
set t [lrange $funcl $idx+1 end] |
||||||
|
lappend tails $t |
||||||
|
lappend tails { ]} |
||||||
|
} |
||||||
|
incr i |
||||||
|
} |
||||||
|
append body [join [lreverse $tails] " "] |
||||||
|
#puts stdout "tails: $tails" |
||||||
|
|
||||||
|
return $body |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
interp alias "" o_of "" funcl::o_of_n 1 |
||||||
|
|
||||||
|
#o_of_n |
||||||
|
#tcl list rep o combinator |
||||||
|
# |
||||||
|
# can take lists of ordinary commandlists, scripts and funcls |
||||||
|
# _fn 1 x where 1 indicates number of subfuncls and where x indicates next funcl position (_fn list or _arg) |
||||||
|
# _fn 0 indicates next item is an unwrapped commandlist (terminal command) |
||||||
|
# |
||||||
|
#o_of is equivalent to o_of_n 1 (1 argument o combinator) |
||||||
|
#last n args are passed to the prior function |
||||||
|
#e.g for n=1 f a b = f(a(b)) |
||||||
|
#e.g for n=2, e f a b = e(f(a b)) |
||||||
|
proc o_of_n {n args} { |
||||||
|
puts stdout "o_of_n '$args'" |
||||||
|
if {$n != 1} { |
||||||
|
error "o_of_n only implemented for 1 sub-funcl" |
||||||
|
} |
||||||
|
set comp [list] ;#composition list |
||||||
|
set end [lindex $args end] |
||||||
|
if {[lindex $end 0] in {_fn _call}]} { |
||||||
|
#is_funcl |
||||||
|
set endfunc [lindex $args end] |
||||||
|
} else { |
||||||
|
if {[llength $end] == 1 && [arg_is_script_shaped $end]} { |
||||||
|
#set endfunc [string map [list <end> $end] {uplevel 1 [list if 1 <end> ]}] |
||||||
|
set endfunc [list _call 1 3 [list uplevel 1 [list if 1 [lindex $end 0]]]] |
||||||
|
} else { |
||||||
|
set endfunc [list _call 1 3 [list {*}$end]] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {[llength $args] == 1} { |
||||||
|
return $endfunc |
||||||
|
} |
||||||
|
set comp $endfunc |
||||||
|
set revlist [lreverse [lrange $args 0 end-1]] |
||||||
|
foreach cmdlist $revlist { |
||||||
|
puts stderr "o_of_n >>-- $cmdlist" |
||||||
|
if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} { |
||||||
|
set is_script 1 |
||||||
|
set script [lindex $cmdlist 0] |
||||||
|
set arglist [list data] |
||||||
|
|
||||||
|
set comp [list _fn 1 6 call_script $script $arglist $comp] |
||||||
|
} else { |
||||||
|
set posn1 [expr {[llength $cmdlist] + 2 + $n}] |
||||||
|
set comp [list _fn $n $posn1 {*}$cmdlist $comp] |
||||||
|
} |
||||||
|
} |
||||||
|
return $comp |
||||||
|
} |
||||||
|
proc call_script {script argnames args} { |
||||||
|
uplevel 3 [list if 1 [list apply [list $argnames $script] {*}$args]] |
||||||
|
} |
||||||
|
proc funcl_script_test {scr} { |
||||||
|
do_funcl_script_test $scr |
||||||
|
} |
||||||
|
proc do_funcl_script_test {scr} { |
||||||
|
#set j "in do_funcl_script_test" |
||||||
|
#set data "xxx" |
||||||
|
#puts '$scr' |
||||||
|
if 1 $scr |
||||||
|
} |
||||||
|
|
||||||
|
#standard o_ with no script-handling |
||||||
|
proc o_plain args { |
||||||
|
set body "" |
||||||
|
set i 0 |
||||||
|
set tails [lrepeat [llength $args] ""] |
||||||
|
#puts stdout "tails: $tails" |
||||||
|
foreach cmdlist $args { |
||||||
|
set t "" |
||||||
|
if {$i > 0} { |
||||||
|
append body { [} |
||||||
|
} |
||||||
|
set posn [lsearch $cmdlist _] |
||||||
|
if {$posn <= 0} { |
||||||
|
append body $cmdlist |
||||||
|
if {$i == [expr {[llength $args] -1}]} { |
||||||
|
append body " \$data" |
||||||
|
} |
||||||
|
if {$i > 0} { |
||||||
|
set t {]} |
||||||
|
} |
||||||
|
} else { |
||||||
|
append body [lrange $cmdlist 0 $posn-1] |
||||||
|
if {$i == [expr {[llength $args] -1}]} { |
||||||
|
append body " \$data" |
||||||
|
} |
||||||
|
set t [lrange $cmdlist $posn+1 end] |
||||||
|
if {$i > 0} { |
||||||
|
append t { ]} |
||||||
|
} |
||||||
|
} |
||||||
|
lset tails $i $t |
||||||
|
incr i |
||||||
|
} |
||||||
|
append body [join [lreverse $tails] " "] |
||||||
|
#puts stdout "tails: $tails" |
||||||
|
|
||||||
|
return $body |
||||||
|
} |
||||||
|
#timings suggest no faster to split out the first item from the cmdlist loop |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,645 @@ |
|||||||
|
package provide patterncmd [namespace eval patterncmd { |
||||||
|
variable version |
||||||
|
|
||||||
|
set version 1.2.4 |
||||||
|
}] |
||||||
|
|
||||||
|
|
||||||
|
namespace eval pattern { |
||||||
|
variable idCounter 1 ;#used by pattern::uniqueKey |
||||||
|
|
||||||
|
namespace eval cmd { |
||||||
|
namespace eval util { |
||||||
|
package require overtype |
||||||
|
variable colwidths_lib [dict create] |
||||||
|
variable colwidths_lib_default 15 |
||||||
|
|
||||||
|
dict set colwidths_lib "library" [list ch " " num 21 head "|" tail ""] |
||||||
|
dict set colwidths_lib "version" [list ch " " num 7 head "|" tail ""] |
||||||
|
dict set colwidths_lib "type" [list ch " " num 9 head "|" tail ""] |
||||||
|
dict set colwidths_lib "note" [list ch " " num 31 head "|" tail "|"] |
||||||
|
|
||||||
|
proc colhead {type args} { |
||||||
|
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths |
||||||
|
set line "" |
||||||
|
foreach colname [dict keys $colwidths] { |
||||||
|
append line "[col $type $colname [string totitle $colname] {*}$args]" |
||||||
|
} |
||||||
|
return $line |
||||||
|
} |
||||||
|
proc colbreak {type} { |
||||||
|
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths |
||||||
|
set line "" |
||||||
|
foreach colname [dict keys $colwidths] { |
||||||
|
append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]" |
||||||
|
} |
||||||
|
return $line |
||||||
|
} |
||||||
|
proc col {type col val args} { |
||||||
|
# args -head bool -tail bool ? |
||||||
|
#---------------------------------------------------------------------------- |
||||||
|
set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify] |
||||||
|
dict set default -backchar "" |
||||||
|
dict set default -headchar "" |
||||||
|
dict set default -tailchar "" |
||||||
|
dict set default -headoverridechar "" |
||||||
|
dict set default -tailoverridechar "" |
||||||
|
dict set default -justify "left" |
||||||
|
if {([llength $args] % 2) != 0} { |
||||||
|
error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' " |
||||||
|
} |
||||||
|
foreach {k v} $args { |
||||||
|
if {$k ni $known_opts} { |
||||||
|
error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'" |
||||||
|
} |
||||||
|
} |
||||||
|
set opts [dict merge $default $args] |
||||||
|
set backchar [dict get $opts -backchar] |
||||||
|
set headchar [dict get $opts -headchar] |
||||||
|
set tailchar [dict get $opts -tailchar] |
||||||
|
set headoverridechar [dict get $opts -headoverridechar] |
||||||
|
set tailoverridechar [dict get $opts -tailoverridechar] |
||||||
|
set justify [dict get $opts -justify] |
||||||
|
#---------------------------------------------------------------------------- |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths |
||||||
|
#calculate headwidths |
||||||
|
set headwidth 0 |
||||||
|
set tailwidth 0 |
||||||
|
foreach {key def} $colwidths { |
||||||
|
set thisheadlen [string length [dict get $def head]] |
||||||
|
if {$thisheadlen > $headwidth} { |
||||||
|
set headwidth $thisheadlen |
||||||
|
} |
||||||
|
set thistaillen [string length [dict get $def tail]] |
||||||
|
if {$thistaillen > $tailwidth} { |
||||||
|
set tailwidth $thistaillen |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
set spec [dict get $colwidths $col] |
||||||
|
if {[string length $backchar]} { |
||||||
|
set ch $backchar |
||||||
|
} else { |
||||||
|
set ch [dict get $spec ch] |
||||||
|
} |
||||||
|
set num [dict get $spec num] |
||||||
|
set headchar [dict get $spec head] |
||||||
|
set tailchar [dict get $spec tail] |
||||||
|
|
||||||
|
if {[string length $headchar]} { |
||||||
|
set headchar $headchar |
||||||
|
} |
||||||
|
if {[string length $tailchar]} { |
||||||
|
set tailchar $tailchar |
||||||
|
} |
||||||
|
#overrides only apply if the head/tail has a length |
||||||
|
if {[string length $headchar]} { |
||||||
|
if {[string length $headoverridechar]} { |
||||||
|
set headchar $headoverridechar |
||||||
|
} |
||||||
|
} |
||||||
|
if {[string length $tailchar]} { |
||||||
|
if {[string length $tailoverridechar]} { |
||||||
|
set tailchar $tailoverridechar |
||||||
|
} |
||||||
|
} |
||||||
|
set head [string repeat $headchar $headwidth] |
||||||
|
set tail [string repeat $tailchar $tailwidth] |
||||||
|
|
||||||
|
set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]] |
||||||
|
if {$justify eq "left"} { |
||||||
|
set left_done [overtype::left $base "$head$val"] |
||||||
|
return [overtype::right $left_done "$tail"] |
||||||
|
} elseif {$justify in {centre center}} { |
||||||
|
set mid_done [overtype::centre $base $val] |
||||||
|
set left_mid_done [overtype::left $mid_done $head] |
||||||
|
return [overtype::right $left_mid_done $tail] |
||||||
|
} else { |
||||||
|
set right_done [overtype::right $base "$val$tail"] |
||||||
|
return [overtype::left $right_done $head] |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
#package require pattern |
||||||
|
|
||||||
|
proc ::pattern::libs {} { |
||||||
|
set libs [list \ |
||||||
|
pattern {-type core -note "alternative:pattern2"}\ |
||||||
|
pattern2 {-type core -note "alternative:pattern"}\ |
||||||
|
patterncmd {-type core}\ |
||||||
|
metaface {-type core}\ |
||||||
|
patternpredator2 {-type core}\ |
||||||
|
patterndispatcher {-type core}\ |
||||||
|
patternlib {-type core}\ |
||||||
|
patterncipher {-type optional -note optional}\ |
||||||
|
] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
package require overtype |
||||||
|
set result "" |
||||||
|
|
||||||
|
append result "[cmd::util::colbreak lib]\n" |
||||||
|
append result "[cmd::util::colhead lib -justify centre]\n" |
||||||
|
append result "[cmd::util::colbreak lib]\n" |
||||||
|
foreach libname [dict keys $libs] { |
||||||
|
set libinfo [dict get $libs $libname] |
||||||
|
|
||||||
|
append result [cmd::util::col lib library $libname] |
||||||
|
if {[catch [list package present $libname] ver]} { |
||||||
|
append result [cmd::util::col lib version "N/A"] |
||||||
|
} else { |
||||||
|
append result [cmd::util::col lib version $ver] |
||||||
|
} |
||||||
|
append result [cmd::util::col lib type [dict get $libinfo -type]] |
||||||
|
|
||||||
|
if {[dict exists $libinfo -note]} { |
||||||
|
set note [dict get $libinfo -note] |
||||||
|
} else { |
||||||
|
set note "" |
||||||
|
} |
||||||
|
append result [cmd::util::col lib note $note] |
||||||
|
append result "\n" |
||||||
|
} |
||||||
|
append result "[cmd::util::colbreak lib]\n" |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
proc ::pattern::record {recname fields} { |
||||||
|
if {[uplevel 1 [list namespace which $recname]] ne ""} { |
||||||
|
error "(pattern::record) Can't create command '$recname': A command of that name already exists" |
||||||
|
} |
||||||
|
|
||||||
|
set index -1 |
||||||
|
set accessor [list ::apply { |
||||||
|
{index rec args} |
||||||
|
{ |
||||||
|
if {[llength $args] == 0} { |
||||||
|
return [lindex $rec $index] |
||||||
|
} |
||||||
|
if {[llength $args] == 1} { |
||||||
|
return [lreplace $rec $index $index [lindex $args 0]] |
||||||
|
} |
||||||
|
error "Invalid number of arguments." |
||||||
|
} |
||||||
|
|
||||||
|
}] |
||||||
|
|
||||||
|
set map {} |
||||||
|
foreach field $fields { |
||||||
|
dict set map $field [linsert $accessor end [incr index]] |
||||||
|
} |
||||||
|
uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] |
||||||
|
} |
||||||
|
proc ::pattern::record2 {recname fields} { |
||||||
|
if {[uplevel 1 [list namespace which $recname]] ne ""} { |
||||||
|
error "(pattern::record) Can't create command '$recname': A command of that name already exists" |
||||||
|
} |
||||||
|
|
||||||
|
set index -1 |
||||||
|
set accessor [list ::apply] |
||||||
|
|
||||||
|
set template { |
||||||
|
{rec args} |
||||||
|
{ |
||||||
|
if {[llength $args] == 0} { |
||||||
|
return [lindex $rec %idx%] |
||||||
|
} |
||||||
|
if {[llength $args] == 1} { |
||||||
|
return [lreplace $rec %idx% %idx% [lindex $args 0]] |
||||||
|
} |
||||||
|
error "Invalid number of arguments." |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set map {} |
||||||
|
foreach field $fields { |
||||||
|
set body [string map [list %idx% [incr index]] $template] |
||||||
|
dict set map $field [list ::apply $body] |
||||||
|
} |
||||||
|
uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::argstest {args} { |
||||||
|
package require cmdline |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
proc ::pattern::objects {} { |
||||||
|
set result [::list] |
||||||
|
|
||||||
|
foreach ns [namespace children ::pp] { |
||||||
|
#lappend result [::list [namespace tail $ns] [set ${ns}::(self)]] |
||||||
|
set ch [namespace tail $ns] |
||||||
|
if {[string range $ch 0 2] eq "Obj"} { |
||||||
|
set OID [string range $ch 3 end] ;#OID need not be digits (!?) |
||||||
|
lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
proc ::pattern::name {num} { |
||||||
|
#!todo - fix |
||||||
|
#set ::p::${num}::(self) |
||||||
|
|
||||||
|
lassign [interp alias {} ::p::$num] _predator info |
||||||
|
if {![string length $_predator$info]} { |
||||||
|
error "No object found for num:$num (no interp alias for ::p::$num)" |
||||||
|
} |
||||||
|
set invocants [dict get $info i] |
||||||
|
set invocants_with_role_this [dict get $invocants this] |
||||||
|
set invocant_this [lindex $invocants_with_role_this 0] |
||||||
|
|
||||||
|
|
||||||
|
#lassign $invocant_this id info |
||||||
|
#set map [dict get $info map] |
||||||
|
#set fields [lindex $map 0] |
||||||
|
lassign $invocant_this _id _ns _defaultmethod name _etc |
||||||
|
return $name |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::pattern::with {cmd script} { |
||||||
|
foreach c [info commands ::p::-1::*] { |
||||||
|
interp alias {} [namespace tail $c] {} $c $cmd |
||||||
|
} |
||||||
|
interp alias {} . {} $cmd . |
||||||
|
interp alias {} .. {} $cmd .. |
||||||
|
|
||||||
|
return [uplevel 1 $script] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#system diagnostics etc |
||||||
|
|
||||||
|
proc ::pattern::varspace_list {IID} { |
||||||
|
namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables |
||||||
|
|
||||||
|
set varspaces [list] |
||||||
|
dict for {vname vdef} $o_variables { |
||||||
|
set vs [dict get $vdef varspace] |
||||||
|
if {$vs ni $varspaces} { |
||||||
|
lappend varspaces $vs |
||||||
|
} |
||||||
|
} |
||||||
|
if {$o_varspace ni $varspaces} { |
||||||
|
lappend varspaces $o_varspace |
||||||
|
} |
||||||
|
return $varspaces |
||||||
|
} |
||||||
|
|
||||||
|
proc ::pattern::check_interfaces {} { |
||||||
|
foreach ns [namespace children ::p] { |
||||||
|
set IID [namespace tail $ns] |
||||||
|
if {[string is digit $IID]} { |
||||||
|
foreach ref [array names ${ns}::_iface::o_usedby] { |
||||||
|
set OID [string range $ref 1 end] |
||||||
|
if {![namespace exists ::p::${OID}::_iface]} { |
||||||
|
puts -nonewline stdout "\r\nPROBLEM!!!!!!!!! nonexistant/invalid object $OID referenced by Interface $IID\r\n" |
||||||
|
} else { |
||||||
|
puts -nonewline stdout . |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#if {![info exists ::p::${OID}::(self)]} { |
||||||
|
# puts "PROBLEM!!!!!!!!! nonexistant object $OID referenced by Interface $IID" |
||||||
|
#} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
puts -nonewline stdout "\r\n" |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#from: http://wiki.tcl.tk/8766 (Introspection on aliases) |
||||||
|
#usedby: metaface-1.1.6+ |
||||||
|
#required because aliases can be renamed. |
||||||
|
#A renamed alias will still return it's target with 'interp alias {} oldname' |
||||||
|
# - so given newname - we require which_alias to return the same info. |
||||||
|
proc ::pattern::which_alias {cmd} { |
||||||
|
uplevel 1 [list ::trace add execution $cmd enterstep ::error] |
||||||
|
catch {uplevel 1 $cmd} res |
||||||
|
uplevel 1 [list ::trace remove execution $cmd enterstep ::error] |
||||||
|
#puts stdout "which_alias $cmd returning '$res'" |
||||||
|
return $res |
||||||
|
} |
||||||
|
# [info args] like proc following an alias recursivly until it reaches |
||||||
|
# the proc it originates from or cannot determine it. |
||||||
|
# accounts for default parameters set by interp alias |
||||||
|
# |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
proc ::pattern::aliasargs {cmd} { |
||||||
|
set orig $cmd |
||||||
|
|
||||||
|
set defaultargs [list] |
||||||
|
|
||||||
|
# loop until error or return occurs |
||||||
|
while {1} { |
||||||
|
# is it a proc already? |
||||||
|
if {[string equal [info procs $cmd] $cmd]} { |
||||||
|
set result [info args $cmd] |
||||||
|
# strip off the interp set default args |
||||||
|
return [lrange $result [llength $defaultargs] end] |
||||||
|
} |
||||||
|
# is it a built in or extension command we can get no args for? |
||||||
|
if {![string equal [info commands $cmd] $cmd]} { |
||||||
|
error "\"$orig\" isn't a procedure" |
||||||
|
} |
||||||
|
|
||||||
|
# catch bogus cmd names |
||||||
|
if {[lsearch [interp aliases {}] $cmd]==-1} { |
||||||
|
if {[catch {::pattern::which_alias $cmd} alias]} { |
||||||
|
error "\"$orig\" isn't a procedure or alias or command" |
||||||
|
} |
||||||
|
#set cmd [lindex $alias 0] |
||||||
|
if {[llength $alias]>1} { |
||||||
|
set cmd [lindex $alias 0] |
||||||
|
set defaultargs [concat [lrange $alias 1 end] $defaultargs] |
||||||
|
} else { |
||||||
|
set cmd $alias |
||||||
|
} |
||||||
|
} else { |
||||||
|
|
||||||
|
if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { |
||||||
|
# check if it is aliased in from another interpreter |
||||||
|
if {[catch {interp target {} $cmd} msg]} { |
||||||
|
error "Cannot resolve \"$orig\", alias leads to another interpreter." |
||||||
|
} |
||||||
|
if {$msg != {} } { |
||||||
|
error "Not recursing into slave interpreter \"$msg\".\ |
||||||
|
\"$orig\" could not be resolved." |
||||||
|
} |
||||||
|
# check if defaults are set for the alias |
||||||
|
if {[llength $cmdargs]>1} { |
||||||
|
set cmd [lindex $cmdargs 0] |
||||||
|
set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] |
||||||
|
} else { |
||||||
|
set cmd $cmdargs |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
proc ::pattern::aliasbody {cmd} { |
||||||
|
set orig $cmd |
||||||
|
|
||||||
|
set defaultargs [list] |
||||||
|
|
||||||
|
# loop until error or return occurs |
||||||
|
while {1} { |
||||||
|
# is it a proc already? |
||||||
|
if {[string equal [info procs $cmd] $cmd]} { |
||||||
|
set result [info body $cmd] |
||||||
|
# strip off the interp set default args |
||||||
|
return $result |
||||||
|
#return [lrange $result [llength $defaultargs] end] |
||||||
|
} |
||||||
|
# is it a built in or extension command we can get no args for? |
||||||
|
if {![string equal [info commands $cmd] $cmd]} { |
||||||
|
error "\"$orig\" isn't a procedure" |
||||||
|
} |
||||||
|
|
||||||
|
# catch bogus cmd names |
||||||
|
if {[lsearch [interp aliases {}] $cmd]==-1} { |
||||||
|
if {[catch {::pattern::which_alias $cmd} alias]} { |
||||||
|
error "\"$orig\" isn't a procedure or alias or command" |
||||||
|
} |
||||||
|
#set cmd [lindex $alias 0] |
||||||
|
if {[llength $alias]>1} { |
||||||
|
set cmd [lindex $alias 0] |
||||||
|
set defaultargs [concat [lrange $alias 1 end] $defaultargs] |
||||||
|
} else { |
||||||
|
set cmd $alias |
||||||
|
} |
||||||
|
} else { |
||||||
|
|
||||||
|
if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { |
||||||
|
# check if it is aliased in from another interpreter |
||||||
|
if {[catch {interp target {} $cmd} msg]} { |
||||||
|
error "Cannot resolve \"$orig\", alias leads to another interpreter." |
||||||
|
} |
||||||
|
if {$msg != {} } { |
||||||
|
error "Not recursing into slave interpreter \"$msg\".\ |
||||||
|
\"$orig\" could not be resolved." |
||||||
|
} |
||||||
|
# check if defaults are set for the alias |
||||||
|
if {[llength $cmdargs]>1} { |
||||||
|
set cmd [lindex $cmdargs 0] |
||||||
|
set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] |
||||||
|
} else { |
||||||
|
set cmd $cmdargs |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
proc ::pattern::uniqueKey2 {} { |
||||||
|
#!todo - something else?? |
||||||
|
return [clock seconds]-[incr ::pattern::idCounter] |
||||||
|
} |
||||||
|
|
||||||
|
#used by patternlib package |
||||||
|
proc ::pattern::uniqueKey {} { |
||||||
|
return [incr ::pattern::idCounter] |
||||||
|
#uuid with tcllibc is about 30us compared with 2us |
||||||
|
# for large datasets, e.g about 100K inserts this would be pretty noticable! |
||||||
|
#!todo - uuid pool with background thread to repopulate when idle? |
||||||
|
#return [uuid::uuid generate] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#------------------------------------------------------------------------------------------------------------------------- |
||||||
|
|
||||||
|
proc ::pattern::test1 {} { |
||||||
|
set msg "OK" |
||||||
|
|
||||||
|
puts stderr "next line should say:'--- saystuff:$msg" |
||||||
|
::>pattern .. Create ::>thing |
||||||
|
|
||||||
|
::>thing .. PatternMethod saystuff args { |
||||||
|
puts stderr "--- saystuff: $args" |
||||||
|
} |
||||||
|
::>thing .. Create ::>jjj |
||||||
|
|
||||||
|
::>jjj . saystuff $msg |
||||||
|
::>jjj .. Destroy |
||||||
|
::>thing .. Destroy |
||||||
|
} |
||||||
|
|
||||||
|
proc ::pattern::test2 {} { |
||||||
|
set msg "OK" |
||||||
|
|
||||||
|
puts stderr "next line should say:'--- property 'stuff' value:$msg" |
||||||
|
::>pattern .. Create ::>thing |
||||||
|
|
||||||
|
::>thing .. PatternProperty stuff $msg |
||||||
|
|
||||||
|
::>thing .. Create ::>jjj |
||||||
|
|
||||||
|
puts stderr "--- property 'stuff' value:[::>jjj . stuff]" |
||||||
|
::>jjj .. Destroy |
||||||
|
::>thing .. Destroy |
||||||
|
} |
||||||
|
|
||||||
|
proc ::pattern::test3 {} { |
||||||
|
set msg "OK" |
||||||
|
|
||||||
|
puts stderr "next line should say:'--- property 'stuff' value:$msg" |
||||||
|
::>pattern .. Create ::>thing |
||||||
|
|
||||||
|
::>thing .. Property stuff $msg |
||||||
|
|
||||||
|
puts stderr "--- property 'stuff' value:[::>thing . stuff]" |
||||||
|
::>thing .. Destroy |
||||||
|
} |
||||||
|
|
||||||
|
#--------------------------------- |
||||||
|
#unknown/obsolete |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args} |
||||||
|
if {0} { |
||||||
|
proc ::p::internals::new_interface {{usedbylist {}}} { |
||||||
|
set OID [incr ::p::ID] |
||||||
|
::p::internals::new_object ::p::ifaces::>$OID "" $OID |
||||||
|
puts "obsolete >> new_interface created object $OID" |
||||||
|
foreach usedby $usedbylist { |
||||||
|
set ::p::${OID}::_iface::o_usedby(i$usedby) 1 |
||||||
|
} |
||||||
|
set ::p::${OID}::_iface::o_varspace "" ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace) |
||||||
|
#NOTE - o_varspace is only the default varspace for when new methods/properties are added. |
||||||
|
# it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value. |
||||||
|
|
||||||
|
set ::p::${OID}::_iface::o_constructor [list] |
||||||
|
set ::p::${OID}::_iface::o_variables [list] |
||||||
|
set ::p::${OID}::_iface::o_properties [dict create] |
||||||
|
set ::p::${OID}::_iface::o_methods [dict create] |
||||||
|
array set ::p::${OID}::_iface::o_definition [list] |
||||||
|
set ::p::${OID}::_iface::o_open 1 ;#open for extending |
||||||
|
return $OID |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#temporary way to get OID - assumes single 'this' invocant |
||||||
|
#!todo - make generic. |
||||||
|
proc ::pattern::get_oid {_ID_} { |
||||||
|
#puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]" |
||||||
|
return [lindex [dict get $_ID_ i this] 0 0] |
||||||
|
|
||||||
|
#set invocants [dict get $_ID_ i] |
||||||
|
#set invocant_roles [dict keys $invocants] |
||||||
|
#set role_members [dict get $invocants this] |
||||||
|
##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list. |
||||||
|
#set this_invocant [lindex [dict get $_ID_ i this] 0] ; |
||||||
|
#lassign $this_invocant OID this_info |
||||||
|
# |
||||||
|
#return $OID |
||||||
|
} |
||||||
|
|
||||||
|
#compile the uncompiled level1 interface |
||||||
|
#assert: no more than one uncompiled interface present at level1 |
||||||
|
proc ::p::meta::PatternCompile {self} { |
||||||
|
???? |
||||||
|
|
||||||
|
upvar #0 $self SELFMAP |
||||||
|
set ID [lindex $SELFMAP 0 0] |
||||||
|
|
||||||
|
set patterns [lindex $SELFMAP 1 1] ;#list of level1 interfaces |
||||||
|
|
||||||
|
set iid -1 |
||||||
|
foreach i $patterns { |
||||||
|
if {[set ::p::${i}::_iface::o_open]} { |
||||||
|
set iid $i ;#found it |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {$iid > -1} { |
||||||
|
#!todo |
||||||
|
|
||||||
|
::p::compile_interface $iid |
||||||
|
set ::p::${iid}::_iface::o_open 0 |
||||||
|
} else { |
||||||
|
#no uncompiled interface present at level 1. Do nothing. |
||||||
|
return |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::p::meta::Def {self} { |
||||||
|
error ::p::meta::Def |
||||||
|
|
||||||
|
upvar #0 $self SELFMAP |
||||||
|
set self_ID [lindex $SELFMAP 0 0] |
||||||
|
set IFID [lindex $SELFMAP 1 0 end] |
||||||
|
|
||||||
|
set maxc1 0 |
||||||
|
set maxc2 0 |
||||||
|
|
||||||
|
set arrName ::p::${IFID}:: |
||||||
|
|
||||||
|
upvar #0 $arrName state |
||||||
|
|
||||||
|
array set methods {} |
||||||
|
|
||||||
|
foreach nm [array names state] { |
||||||
|
if {[regexp {^m-1,name,(.+)} $nm _match mname]} { |
||||||
|
set methods($mname) [set state($nm)] |
||||||
|
|
||||||
|
if {[string length $mname] > $maxc1} { |
||||||
|
set maxc1 [string length $mname] |
||||||
|
} |
||||||
|
if {[string length [set state($nm)]] > $maxc2} { |
||||||
|
set maxc2 [string length [set state($nm)]] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
set bg1 [string repeat " " [expr {$maxc1 + 2}]] |
||||||
|
set bg2 [string repeat " " [expr {$maxc2 + 2}]] |
||||||
|
|
||||||
|
|
||||||
|
set r {} |
||||||
|
foreach nm [lsort -dictionary [array names methods]] { |
||||||
|
set arglist $state(m-1,args,$nm) |
||||||
|
append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n" |
||||||
|
} |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,754 @@ |
|||||||
|
package provide patternpredator2 1.2.4 |
||||||
|
|
||||||
|
proc ::p::internals::jaws {OID _ID_ args} { |
||||||
|
#puts stderr ">>>(patternpredator2 lib)jaws called with _ID_:$_ID_ args: $args" |
||||||
|
#set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid |
||||||
|
|
||||||
|
yield |
||||||
|
set w 1 |
||||||
|
|
||||||
|
set stack [list] |
||||||
|
set wordcount [llength $args] |
||||||
|
set terminals [list . .. , # @ !] ;#tokens which require the current stack to be evaluated first |
||||||
|
set unsupported 0 |
||||||
|
set operator "" |
||||||
|
set operator_prev "" ;#used only by argprotect to revert to previous operator |
||||||
|
|
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
#!DO NOT use upvar here for MAP! (calling set on a MAP in another iteration/call will overwrite a map for another object!) |
||||||
|
#upvar #0 ::p::${OID}::_meta::map MAP |
||||||
|
set MAP [set ::p::${OID}::_meta::map] |
||||||
|
} else { |
||||||
|
# error "jaws - OID = 'null' ???" |
||||||
|
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] ;#MAP taken from _ID_ will be missing 'interfaces' key |
||||||
|
} |
||||||
|
set invocantdata [dict get $MAP invocantdata] |
||||||
|
lassign $invocantdata OID alias default_method object_command wrapped |
||||||
|
|
||||||
|
set finished_args 0 ;#whether we've completely processed all args in the while loop and therefor don't need to peform the final word processing code |
||||||
|
|
||||||
|
#don't use 'foreach word $args' - we sometimes need to backtrack a little by manipulating $w |
||||||
|
while {$w < $wordcount} { |
||||||
|
set word [lindex $args [expr {$w -1}]] |
||||||
|
#puts stdout "w:$w word:$word stack:$stack" |
||||||
|
|
||||||
|
if {$operator eq "argprotect"} { |
||||||
|
set operator $operator_prev |
||||||
|
lappend stack $word |
||||||
|
incr w |
||||||
|
} else { |
||||||
|
if {[llength $stack]} { |
||||||
|
if {$word in $terminals} { |
||||||
|
set reduction [list 0 $_ID_ {*}$stack ] |
||||||
|
#puts stderr ">>>jaws yielding value: $reduction triggered by word $word in position:$w" |
||||||
|
|
||||||
|
|
||||||
|
set _ID_ [yield $reduction] |
||||||
|
set stack [list] |
||||||
|
#set OID [::pattern::get_oid $_ID_] |
||||||
|
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid |
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
set MAP [set ::p::${OID}::_meta::map] ;#Do not use upvar here! |
||||||
|
} else { |
||||||
|
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces [list level0 {} level1 {}]] |
||||||
|
#puts stderr "WARNING REVIEW: jaws-branch - leave empty??????" |
||||||
|
} |
||||||
|
|
||||||
|
#review - 2018. switched to _ID_ instead of MAP |
||||||
|
lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command |
||||||
|
#lassign [dict get $MAP invocantdata] OID alias default_method object_command |
||||||
|
|
||||||
|
|
||||||
|
#puts stdout "---->>> yielded _ID_: $_ID_ OID:$OID alias:$alias default_method:$default_method object_command:$object_command" |
||||||
|
set operator $word |
||||||
|
#don't incr w |
||||||
|
#incr w |
||||||
|
} else { |
||||||
|
if {$operator eq "argprotect"} { |
||||||
|
set operator $operator_prev |
||||||
|
set operator_prev "" |
||||||
|
lappend stack $word |
||||||
|
} else { |
||||||
|
#only look for leading argprotect chacter (-) if we're not already in argprotect mode |
||||||
|
if {$word eq "--"} { |
||||||
|
set operator_prev $operator |
||||||
|
set operator "argprotect" |
||||||
|
#Don't add the plain argprotector to the stack |
||||||
|
} elseif {[string match "-*" $word]} { |
||||||
|
#argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) |
||||||
|
set operator_prev $operator |
||||||
|
set operator "argprotect" |
||||||
|
lappend stack $word |
||||||
|
} else { |
||||||
|
lappend stack $word |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
incr w |
||||||
|
} |
||||||
|
} else { |
||||||
|
#no stack |
||||||
|
switch -- $word {.} { |
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
#we know next word is a property or method of a pattern object |
||||||
|
incr w |
||||||
|
set nextword [lindex $args [expr {$w - 1}]] |
||||||
|
set command ::p::${OID}::$nextword |
||||||
|
set stack [list $command] ;#2018 j |
||||||
|
set operator . |
||||||
|
if {$w eq $wordcount} { |
||||||
|
set finished_args 1 |
||||||
|
} |
||||||
|
} else { |
||||||
|
# don't incr w |
||||||
|
#set nextword [lindex $args [expr {$w - 1}]] |
||||||
|
set command $object_command ;#taken from the MAP |
||||||
|
set stack [list "_exec_" $command] |
||||||
|
set operator . |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
} {..} { |
||||||
|
incr w |
||||||
|
set nextword [lindex $args [expr {$w -1}]] |
||||||
|
set command ::p::-1::$nextword |
||||||
|
#lappend stack $command ;#lappend a small number of items to an empty list is slower than just setting the list. |
||||||
|
set stack [list $command] ;#faster, and intent is clearer than lappend. |
||||||
|
set operator .. |
||||||
|
if {$w eq $wordcount} { |
||||||
|
set finished_args 1 |
||||||
|
} |
||||||
|
} {,} { |
||||||
|
#puts stdout "Stackless comma!" |
||||||
|
|
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
set command ::p::${OID}::$default_method |
||||||
|
} else { |
||||||
|
set command [list $default_method $object_command] |
||||||
|
#object_command in this instance presumably be a list and $default_method a list operation |
||||||
|
#e.g "lindex {A B C}" |
||||||
|
} |
||||||
|
#lappend stack $command |
||||||
|
set stack [list $command] |
||||||
|
set operator , |
||||||
|
} {--} { |
||||||
|
set operator_prev $operator |
||||||
|
set operator argprotect |
||||||
|
#no stack - |
||||||
|
} {!} { |
||||||
|
set command $object_command |
||||||
|
set stack [list "_exec_" $object_command] |
||||||
|
#puts stdout "!!!! !!!! $stack" |
||||||
|
set operator ! |
||||||
|
} default { |
||||||
|
if {$operator eq ""} { |
||||||
|
if {$OID ne "null"} { |
||||||
|
set command ::p::${OID}::$default_method |
||||||
|
} else { |
||||||
|
set command [list $default_method $object_command] |
||||||
|
} |
||||||
|
set stack [list $command] |
||||||
|
set operator , |
||||||
|
lappend stack $word |
||||||
|
} else { |
||||||
|
#no stack - so we don't expect to be in argprotect mode already. |
||||||
|
if {[string match "-*" $word]} { |
||||||
|
#argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) |
||||||
|
set operator_prev $operator |
||||||
|
set operator "argprotect" |
||||||
|
lappend stack $word |
||||||
|
} else { |
||||||
|
lappend stack $word |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
} |
||||||
|
incr w |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
} ;#end while |
||||||
|
|
||||||
|
#process final word outside of loop |
||||||
|
#assert $w == $wordcount |
||||||
|
#trailing operators or last argument |
||||||
|
if {!$finished_args} { |
||||||
|
set word [lindex $args [expr {$w -1}]] |
||||||
|
if {$operator eq "argprotect"} { |
||||||
|
set operator $operator_prev |
||||||
|
set operator_prev "" |
||||||
|
|
||||||
|
lappend stack $word |
||||||
|
incr w |
||||||
|
} else { |
||||||
|
|
||||||
|
|
||||||
|
switch -- $word {.} { |
||||||
|
if {![llength $stack]} { |
||||||
|
#set stack [list "_result_" [::p::internals::ref_to_object $_ID_]] |
||||||
|
yieldto return [::p::internals::ref_to_object $_ID_] |
||||||
|
error "assert: never gets here" |
||||||
|
|
||||||
|
} else { |
||||||
|
#puts stdout "==== $stack" |
||||||
|
#assert - whenever _ID_ changed in this proc - we have updated the $OID variable |
||||||
|
yieldto return [::p::internals::ref_to_stack $OID $_ID_ $stack] |
||||||
|
error "assert: never gets here" |
||||||
|
} |
||||||
|
set operator . |
||||||
|
|
||||||
|
} {..} { |
||||||
|
#trailing .. after chained call e.g >x . item 0 .. |
||||||
|
#puts stdout "$$$$$$$$$$$$ [list 0 $_ID_ {*}$stack] $$$$" |
||||||
|
#set reduction [list 0 $_ID_ {*}$stack] |
||||||
|
yieldto return [yield [list 0 $_ID_ {*}$stack]] |
||||||
|
} {#} { |
||||||
|
set unsupported 1 |
||||||
|
} {,} { |
||||||
|
set unsupported 1 |
||||||
|
} {&} { |
||||||
|
set unsupported 1 |
||||||
|
} {@} { |
||||||
|
set unsupported 1 |
||||||
|
} {--} { |
||||||
|
|
||||||
|
#set reduction [list 0 $_ID_ {*}$stack[set stack [list]]] |
||||||
|
#puts stdout " -> -> -> about to call yield $reduction <- <- <-" |
||||||
|
set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]] ] |
||||||
|
#set OID [::pattern::get_oid $_ID_] |
||||||
|
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid |
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! |
||||||
|
} else { |
||||||
|
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}} ] |
||||||
|
} |
||||||
|
yieldto return $MAP |
||||||
|
} {!} { |
||||||
|
#error "untested branch" |
||||||
|
set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]]] |
||||||
|
#set OID [::pattern::get_oid $_ID_] |
||||||
|
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid |
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! |
||||||
|
} else { |
||||||
|
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] |
||||||
|
} |
||||||
|
lassign [dict get $MAP invocantdata] OID alias default_command object_command |
||||||
|
set command $object_command |
||||||
|
set stack [list "_exec_" $command] |
||||||
|
set operator ! |
||||||
|
} default { |
||||||
|
if {$operator eq ""} { |
||||||
|
#error "untested branch" |
||||||
|
lassign [dict get $MAP invocantdata] OID alias default_command object_command |
||||||
|
#set command ::p::${OID}::item |
||||||
|
set command ::p::${OID}::$default_command |
||||||
|
lappend stack $command |
||||||
|
set operator , |
||||||
|
|
||||||
|
} |
||||||
|
#do not look for argprotect items here (e.g -option) as the final word can't be an argprotector anyway. |
||||||
|
lappend stack $word |
||||||
|
} |
||||||
|
if {$unsupported} { |
||||||
|
set unsupported 0 |
||||||
|
error "trailing '$word' not supported" |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
#if {$operator eq ","} { |
||||||
|
# incr wordcount 2 |
||||||
|
# set stack [linsert $stack end-1 . item] |
||||||
|
#} |
||||||
|
incr w |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#final = 1 |
||||||
|
#puts stderr ">>>jaws final return value: [list 1 $_ID_ {*}$stack]" |
||||||
|
|
||||||
|
return [list 1 $_ID_ {*}$stack] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#trailing. directly after object |
||||||
|
proc ::p::internals::ref_to_object {_ID_} { |
||||||
|
set OID [lindex [dict get $_ID_ i this] 0 0] |
||||||
|
upvar #0 ::p::${OID}::_meta::map MAP |
||||||
|
lassign [dict get $MAP invocantdata] OID alias default_method object_command |
||||||
|
set refname ::p::${OID}::_ref::__OBJECT |
||||||
|
|
||||||
|
array set $refname [list] ;#important to initialise the variable as an array here - or initial read attempts on elements will not fire traces |
||||||
|
|
||||||
|
set traceCmd [list ::p::predator::object_read_trace $OID $_ID_] |
||||||
|
if {[list {read} $traceCmd] ni [trace info variable $refname]} { |
||||||
|
#puts stdout "adding read trace on variable '$refname' - traceCmd:'$traceCmd'" |
||||||
|
trace add variable $refname {read} $traceCmd |
||||||
|
} |
||||||
|
set traceCmd [list ::p::predator::object_array_trace $OID $_ID_] |
||||||
|
if {[list {array} $traceCmd] ni [trace info variable $refname]} { |
||||||
|
trace add variable $refname {array} $traceCmd |
||||||
|
} |
||||||
|
|
||||||
|
set traceCmd [list ::p::predator::object_write_trace $OID $_ID_] |
||||||
|
if {[list {write} $traceCmd] ni [trace info variable $refname]} { |
||||||
|
trace add variable $refname {write} $traceCmd |
||||||
|
} |
||||||
|
|
||||||
|
set traceCmd [list ::p::predator::object_unset_trace $OID $_ID_] |
||||||
|
if {[list {unset} $traceCmd] ni [trace info variable $refname]} { |
||||||
|
trace add variable $refname {unset} $traceCmd |
||||||
|
} |
||||||
|
return $refname |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::p::internals::create_or_update_reference {OID _ID_ refname command} { |
||||||
|
#if {[lindex $fullstack 0] eq "_exec_"} { |
||||||
|
# #strip it. This instruction isn't relevant for a reference. |
||||||
|
# set commandstack [lrange $fullstack 1 end] |
||||||
|
#} else { |
||||||
|
# set commandstack $fullstack |
||||||
|
#} |
||||||
|
#set argstack [lassign $commandstack command] |
||||||
|
#set field [string map {> __OBJECT_} [namespace tail $command]] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
set reftail [namespace tail $refname] |
||||||
|
set argstack [lassign [split $reftail +] field] |
||||||
|
set field [string map {> __OBJECT_} [namespace tail $command]] |
||||||
|
|
||||||
|
#puts stderr "refname:'$refname' command: $command field:$field" |
||||||
|
|
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
upvar #0 ::p::${OID}::_meta::map MAP |
||||||
|
} else { |
||||||
|
#set map [dict get [lindex [dict get $_ID_ i this] 0 1] map] |
||||||
|
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}}] |
||||||
|
} |
||||||
|
lassign [dict get $MAP invocantdata] OID alias default_method object_command |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
if {$OID ne "null"} { |
||||||
|
interp alias {} $refname {} $command $_ID_ {*}$argstack |
||||||
|
} else { |
||||||
|
interp alias {} $refname {} $command {*}$argstack |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#set iflist [lindex $map 1 0] |
||||||
|
set iflist [dict get $MAP interfaces level0] |
||||||
|
#set iflist [dict get $MAP interfaces level0] |
||||||
|
set field_is_property_like 0 |
||||||
|
foreach IFID [lreverse $iflist] { |
||||||
|
#tcl (braced) expr has lazy evaluation for &&, || & ?: operators - so this should be reasonably efficient. |
||||||
|
if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} { |
||||||
|
set field_is_property_like 1 |
||||||
|
#There is a setter or getter (but not necessarily an entry in the o_properties dict) |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#whether field is a property or a method - remove any commandrefMisuse_TraceHandler |
||||||
|
foreach tinfo [trace info variable $refname] { |
||||||
|
#puts "-->removing traces on $refname: $tinfo" |
||||||
|
if {[lindex $tinfo 1 0] eq "::p::internals::commandrefMisuse_TraceHandler"} { |
||||||
|
trace remove variable $refname {*}$tinfo |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {$field_is_property_like} { |
||||||
|
#property reference |
||||||
|
|
||||||
|
|
||||||
|
set this_invocantdata [lindex [dict get $_ID_ i this] 0] |
||||||
|
lassign $this_invocantdata OID _alias _defaultmethod object_command |
||||||
|
#get fully qualified varspace |
||||||
|
|
||||||
|
# |
||||||
|
set propdict [$object_command .. GetPropertyInfo $field] |
||||||
|
if {[dict exist $propdict $field]} { |
||||||
|
set field_is_a_property 1 |
||||||
|
set propinfo [dict get $propdict $field] |
||||||
|
set varspace [dict get $propinfo varspace] |
||||||
|
if {$varspace eq ""} { |
||||||
|
set full_varspace ::p::${OID} |
||||||
|
} else { |
||||||
|
if {[::string match "::*" $varspace]} { |
||||||
|
set full_varspace $varspace |
||||||
|
} else { |
||||||
|
set full_varspace ::p::${OID}::$varspace |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
set field_is_a_property 0 |
||||||
|
#no propertyinfo - this field was probably established as a PropertyRead and/or PropertyWrite without a Property |
||||||
|
#this is ok - and we still set the trace infrastructure below (app may convert it to a normal Property later) |
||||||
|
set full_varspace ::p::${OID} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#We only trace on entire property.. not array elements (if references existed to both the array and an element both traces would be fired -(entire array trace first)) |
||||||
|
set Hndlr [::list ::p::predator::propvar_write_TraceHandler $OID $field] |
||||||
|
if { [::list {write} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { |
||||||
|
trace add variable ${full_varspace}::o_${field} {write} $Hndlr |
||||||
|
} |
||||||
|
set Hndlr [::list ::p::predator::propvar_unset_TraceHandler $OID $field] |
||||||
|
if { [::list {unset} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { |
||||||
|
trace add variable ${full_varspace}::o_${field} {unset} $Hndlr |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#supply all data in easy-access form so that propref_trace_read is not doing any extra work. |
||||||
|
set get_cmd ::p::${OID}::(GET)$field |
||||||
|
set traceCmd [list ::p::predator::propref_trace_read $get_cmd $_ID_ $refname $field $argstack] |
||||||
|
|
||||||
|
if {[list {read} $traceCmd] ni [trace info variable $refname]} { |
||||||
|
set fieldvarname ${full_varspace}::o_${field} |
||||||
|
|
||||||
|
|
||||||
|
#synch the refvar with the real var if it exists |
||||||
|
#catch {set $refname [$refname]} |
||||||
|
if {[array exists $fieldvarname]} { |
||||||
|
if {![llength $argstack]} { |
||||||
|
#unindexed reference |
||||||
|
array set $refname [array get $fieldvarname] |
||||||
|
#upvar $fieldvarname $refname |
||||||
|
} else { |
||||||
|
set s0 [lindex $argstack 0] |
||||||
|
#refs to nonexistant array members common? (catch vs 'info exists') |
||||||
|
if {[info exists ${fieldvarname}($s0)]} { |
||||||
|
set $refname [set ${fieldvarname}($s0)] |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
#refs to uninitialised props actually should be *very* common. |
||||||
|
#If we use 'catch', it means retrieving refs to non-initialised props is slower. Fired catches can be relatively expensive. |
||||||
|
#Because it's common to get a ref to uninitialised props (e.g for initial setting of their value) - we will use 'info exists' instead of catch. |
||||||
|
|
||||||
|
#set errorInfo_prev $::errorInfo ;#preserve errorInfo across catches! |
||||||
|
|
||||||
|
#puts stdout " ---->>!!! ref to uninitialised prop $field $argstack !!!<------" |
||||||
|
|
||||||
|
|
||||||
|
if {![llength $argstack]} { |
||||||
|
#catch {set $refname [set ::p::${OID}::o_$field]} |
||||||
|
if {[info exists $fieldvarname]} { |
||||||
|
set $refname [set $fieldvarname] |
||||||
|
#upvar $fieldvarname $refname |
||||||
|
} |
||||||
|
} else { |
||||||
|
if {[llength $argstack] == 1} { |
||||||
|
#catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $argstack 0]]} |
||||||
|
if {[info exists $fieldvarname]} { |
||||||
|
set $refname [lindex [set $fieldvarname] [lindex $argstack 0]] |
||||||
|
} |
||||||
|
|
||||||
|
} else { |
||||||
|
#catch {set $refname [lindex [set ::p::${OID}::o_$field] $argstack]} |
||||||
|
if {[info exists $fieldvarname]} { |
||||||
|
set $refname [lindex [set $fieldvarname] $argstack] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#! what if someone has put a trace on ::errorInfo?? |
||||||
|
#set ::errorInfo $errorInfo_prev |
||||||
|
} |
||||||
|
trace add variable $refname {read} $traceCmd |
||||||
|
|
||||||
|
set traceCmd [list ::p::predator::propref_trace_write $_ID_ $OID $full_varspace $refname] |
||||||
|
trace add variable $refname {write} $traceCmd |
||||||
|
|
||||||
|
set traceCmd [list ::p::predator::propref_trace_unset $_ID_ $OID $refname] |
||||||
|
trace add variable $refname {unset} $traceCmd |
||||||
|
|
||||||
|
|
||||||
|
set traceCmd [list ::p::predator::propref_trace_array $_ID_ $OID $refname] |
||||||
|
# puts "**************** installing array variable trace on ref:$refname - cmd:$traceCmd" |
||||||
|
trace add variable $refname {array} $traceCmd |
||||||
|
} |
||||||
|
|
||||||
|
} else { |
||||||
|
#puts "$refname ====> adding refMisuse_traceHandler $alias $field" |
||||||
|
#matching variable in order to detect attempted use as property and throw error |
||||||
|
|
||||||
|
#2018 |
||||||
|
#Note that we are adding a trace on a variable (the refname) which does not exist. |
||||||
|
#this is fine - except that the trace won't fire for attempt to write it as an array using syntax such as set $ref(someindex) |
||||||
|
#we could set the ref to an empty array - but then we have to also undo this if a property with matching name is added |
||||||
|
##array set $refname {} ;#empty array |
||||||
|
# - the empty array would mean a slightly better error message when misusing a command ref as an array |
||||||
|
#but this seems like a code complication for little benefit |
||||||
|
#review |
||||||
|
|
||||||
|
trace add variable $refname {read write unset array} [list ::p::internals::commandrefMisuse_TraceHandler $OID $field] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#trailing. after command/property |
||||||
|
proc ::p::internals::ref_to_stack {OID _ID_ fullstack} { |
||||||
|
if {[lindex $fullstack 0] eq "_exec_"} { |
||||||
|
#strip it. This instruction isn't relevant for a reference. |
||||||
|
set commandstack [lrange $fullstack 1 end] |
||||||
|
} else { |
||||||
|
set commandstack $fullstack |
||||||
|
} |
||||||
|
set argstack [lassign $commandstack command] |
||||||
|
set field [string map {> __OBJECT_} [namespace tail $command]] |
||||||
|
|
||||||
|
|
||||||
|
#!todo? |
||||||
|
# - make every object's OID unpredictable and sparse (UUID) and modify 'namespace child' etc to prevent iteration/inspection of ::p namespace. |
||||||
|
# - this would only make sense for an environment where any meta methods taking a code body (e.g .. Method .. PatternMethod etc) are restricted. |
||||||
|
|
||||||
|
|
||||||
|
#references created under ::p::${OID}::_ref are effectively inside a 'varspace' within the object itself. |
||||||
|
# - this would in theory allow a set of interface functions on the object which have direct access to the reference variables. |
||||||
|
|
||||||
|
|
||||||
|
set refname ::p::${OID}::_ref::[join [concat $field $argstack] +] |
||||||
|
|
||||||
|
if {[llength [info commands $refname]]} { |
||||||
|
#todo - review - what if the field changed to/from a property/method? |
||||||
|
#probably should fix that where such a change is made and leave this short circuit here to give reasonable performance for existing refs |
||||||
|
return $refname |
||||||
|
} |
||||||
|
::p::internals::create_or_update_reference $OID $_ID_ $refname $command |
||||||
|
return $refname |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
namespace eval pp { |
||||||
|
variable operators [list .. . -- - & @ # , !] |
||||||
|
variable operators_notin_args "" |
||||||
|
foreach op $operators { |
||||||
|
append operators_notin_args "({$op} ni \$args) && " |
||||||
|
} |
||||||
|
set operators_notin_args [string trimright $operators_notin_args " &"] ;#trim trailing spaces and ampersands |
||||||
|
#set operators_notin_args {({.} ni $args) && ({,} ni $args) && ({..} ni $args)} |
||||||
|
} |
||||||
|
interp alias {} strmap {} string map ;#stop code editor from mono-colouring our big string mapped code blocks! |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# 2017 ::p::predator2 is the development version - intended for eventual use as the main dispatch mechanism. |
||||||
|
#each map is a 2 element list of lists. |
||||||
|
# form: {$commandinfo $interfaceinfo} |
||||||
|
# commandinfo is of the form: {ID Namespace defaultmethod commandname _?} |
||||||
|
|
||||||
|
#2018 |
||||||
|
#each map is a dict. |
||||||
|
#form: {invocantdata {ID Namespace defaultmethod commandname _?} interfaces {level0 {} level1 {}}} |
||||||
|
|
||||||
|
|
||||||
|
#OID = Object ID (integer for now - could in future be a uuid) |
||||||
|
proc ::p::predator2 {_ID_ args} { |
||||||
|
#puts stderr "predator2: _ID_:'$_ID_' args:'$args'" |
||||||
|
#set invocants [dict get $_ID_ i] |
||||||
|
#set invocant_roles [dict keys $invocants] |
||||||
|
|
||||||
|
#For now - we are 'this'-centric (single dispatch). todo - adapt for multiple roles, multimethods etc. |
||||||
|
#set this_role_members [dict get $invocants this] |
||||||
|
#set this_invocant [lindex [dict get $_ID_ i this] 0] ;#for the role 'this' we assume only one invocant in the list. |
||||||
|
#lassign $this_invocant this_OID this_info_dict |
||||||
|
|
||||||
|
set this_OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid |
||||||
|
|
||||||
|
|
||||||
|
set cheat 1 ;# |
||||||
|
#------- |
||||||
|
#Optimise the next most common use case. A single . followed by args which contain no other operators (non-chained call) |
||||||
|
#(it should be functionally equivalent to remove this shortcut block) |
||||||
|
if {$cheat} { |
||||||
|
if { ([lindex $args 0] eq {.}) && ([llength $args] > 1) && ([llength [lsearch -all -inline $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args) && ({!} ni $args)} { |
||||||
|
|
||||||
|
set remaining_args [lassign $args dot method_or_prop] |
||||||
|
|
||||||
|
#how will we do multiple apis? (separate interface stacks) apply? apply [list [list _ID_ {*}$arglist] ::p::${stackid?}::$method_or_prop ::p::${this_OID}] ??? |
||||||
|
set command ::p::${this_OID}::$method_or_prop |
||||||
|
#REVIEW! |
||||||
|
#e.g what if the method is named "say hello" ?? (hint - it will break because we will look for 'say') |
||||||
|
#if {[llength $command] > 1} { |
||||||
|
# error "methods with spaces not included in test suites - todo fix!" |
||||||
|
#} |
||||||
|
#Dont use {*}$command - (so we can support methods with spaces) |
||||||
|
#if {![llength [info commands $command]]} {} |
||||||
|
if {[namespace which $command] eq ""} { |
||||||
|
if {[namespace which ::p::${this_OID}::(UNKNOWN)] ne ""} { |
||||||
|
#lset command 0 ::p::${this_OID}::(UNKNOWN) ;#seems wrong - command could have spaces |
||||||
|
set command ::p::${this_OID}::(UNKNOWN) |
||||||
|
#tailcall {*}$command $_ID_ $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||||
|
tailcall $command $_ID_ $method_or_prop {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||||
|
} else { |
||||||
|
return -code error -errorinfo "(::p::predator2) error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$method_or_prop' not found" |
||||||
|
} |
||||||
|
} else { |
||||||
|
#tailcall {*}$command $_ID_ {*}$remaining_args |
||||||
|
tailcall $command $_ID_ {*}$remaining_args |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
#------------ |
||||||
|
|
||||||
|
|
||||||
|
if {([llength $args] == 1) && ([lindex $args 0] eq "..")} { |
||||||
|
return $_ID_ |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#puts stderr "pattern::predator (test version) called with: _ID_:$_ID_ args:$args" |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#puts stderr "this_info_dict: $this_info_dict" |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
if {![llength $args]} { |
||||||
|
#should return some sort of public info.. i.e probably not the ID which is an implementation detail |
||||||
|
#return cmd |
||||||
|
return [lindex [dict get [set ::p::${this_OID}::_meta::map] invocantdata] 0] ;#Object ID |
||||||
|
|
||||||
|
#return a dict keyed on object command name - (suitable as use for a .. Create 'target') |
||||||
|
#lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method object_command wrapped |
||||||
|
#return [list $object_command [list -id $this_OID ]] |
||||||
|
} elseif {[llength $args] == 1} { |
||||||
|
#short-circuit the single index case for speed. |
||||||
|
if {[lindex $args 0] ni {.. . -- - & @ # , !}} { |
||||||
|
#lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method |
||||||
|
lassign [lindex [dict get $_ID_ i this] 0] this_OID alias default_method |
||||||
|
|
||||||
|
tailcall ::p::${this_OID}::$default_method $_ID_ [lindex $args 0] |
||||||
|
} elseif {[lindex $args 0] eq {--}} { |
||||||
|
|
||||||
|
#!todo - we could hide the invocant by only allowing this call from certain uplevel procs.. |
||||||
|
# - combined with using UUIDs for $OID, and a secured/removed metaface on the object |
||||||
|
# - (and also hiding of [interp aliases] command so they can't iterate and examine all aliases) |
||||||
|
# - this could effectively hide the object's namespaces,vars etc from the caller (?) |
||||||
|
return [set ::p::${this_OID}::_meta::map] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#upvar ::p::coroutine_instance c ;#coroutine names must be unique per call to predator (not just per object - or we could get a clash during some cyclic calls) |
||||||
|
#incr c |
||||||
|
#set reduce ::p::reducer${this_OID}_$c |
||||||
|
set reduce ::p::reducer${this_OID}_[incr ::p::coroutine_instance] |
||||||
|
#puts stderr "..................creating reducer $reduce with args $this_OID _ID_ $args" |
||||||
|
coroutine $reduce ::p::internals::jaws $this_OID $_ID_ {*}$args |
||||||
|
|
||||||
|
|
||||||
|
set current_ID_ $_ID_ |
||||||
|
|
||||||
|
set final 0 |
||||||
|
set result "" |
||||||
|
while {$final == 0} { |
||||||
|
#the argument given here to $reduce will be returned by 'yield' within the coroutine context (jaws) |
||||||
|
set reduction_args [lassign [$reduce $current_ID_[set current_ID_ [list]] ] final current_ID_ command] |
||||||
|
#puts stderr "..> final:$final current_ID_:'$current_ID_' command:'$command' reduction_args:'$reduction_args'" |
||||||
|
#if {[string match *Destroy $command]} { |
||||||
|
# puts stdout " calling Destroy reduction_args:'$reduction_args'" |
||||||
|
#} |
||||||
|
if {$final == 1} { |
||||||
|
|
||||||
|
if {[llength $command] == 1} { |
||||||
|
if {$command eq "_exec_"} { |
||||||
|
tailcall {*}$reduction_args |
||||||
|
} |
||||||
|
if {[llength [info commands $command]]} { |
||||||
|
tailcall {*}$command $current_ID_ {*}$reduction_args |
||||||
|
} |
||||||
|
set cmdname [namespace tail $command] |
||||||
|
set this_OID [lindex [dict get $current_ID_ i this] 0 0] |
||||||
|
if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { |
||||||
|
lset command 0 ::p::${this_OID}::(UNKNOWN) |
||||||
|
tailcall {*}$command $current_ID_ $cmdname {*}$reduction_args ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||||
|
} else { |
||||||
|
return -code error -errorinfo "1)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" |
||||||
|
} |
||||||
|
|
||||||
|
} else { |
||||||
|
#e.g lindex {a b c} |
||||||
|
tailcall {*}$command {*}$reduction_args |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
} else { |
||||||
|
if {[lindex $command 0] eq "_exec_"} { |
||||||
|
set result [uplevel 1 [list {*}[lrange $command 1 end] {*}$reduction_args]] |
||||||
|
|
||||||
|
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {} ] |
||||||
|
} else { |
||||||
|
if {[llength $command] == 1} { |
||||||
|
if {![llength [info commands $command]]} { |
||||||
|
set cmdname [namespace tail $command] |
||||||
|
set this_OID [lindex [dict get $current_ID_ i this] 0 0] |
||||||
|
if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { |
||||||
|
|
||||||
|
lset command 0 ::p::${this_OID}::(UNKNOWN) |
||||||
|
set result [uplevel 1 [list {*}$command $current_ID_ $cmdname {*}$reduction_args]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||||
|
} else { |
||||||
|
return -code error -errorinfo "2)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" |
||||||
|
} |
||||||
|
} else { |
||||||
|
#set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] |
||||||
|
set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] |
||||||
|
|
||||||
|
} |
||||||
|
} else { |
||||||
|
set result [uplevel 1 [list {*}$command {*}$reduction_args]] |
||||||
|
} |
||||||
|
|
||||||
|
if {[llength [info commands $result]]} { |
||||||
|
if {([llength $result] == 1) && ([string first ">" [namespace tail $result]] == 0)} { |
||||||
|
#looks like a pattern command |
||||||
|
set current_ID_ [$result .. INVOCANTDATA] |
||||||
|
|
||||||
|
|
||||||
|
#todo - determine if plain .. INVOCANTDATA is sufficient instead of .. UPDATEDINVOCANTDATA |
||||||
|
#if {![catch {$result .. INVOCANTDATA} result_invocantdata]} { |
||||||
|
# set current_ID_ $result_invocantdata |
||||||
|
#} else { |
||||||
|
# return -code error -errorinfo "3)error running command:'$command' argstack:'$reduction_args'\n - Failed to access result:'$result' as a pattern object." "Failed to access result:'$result' as a pattern object" |
||||||
|
#} |
||||||
|
} else { |
||||||
|
#non-pattern command |
||||||
|
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] |
||||||
|
} |
||||||
|
} else { |
||||||
|
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] |
||||||
|
#!todo - allow further operations on non-command values. e.g dicts, lists & strings (treat strings as lists) |
||||||
|
|
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
} |
||||||
|
error "Assert: Shouldn't get here (end of ::p::predator2)" |
||||||
|
#return $result |
||||||
|
} |
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,272 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::aliascore 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin shellspy_module_punk::aliascore 0 0.1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::aliascore] |
||||||
|
#[keywords module] |
||||||
|
#[description] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of punk::aliascore |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by punk::aliascore |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#tcl::namespace::eval punk::aliascore::class { |
||||||
|
# #*** !doctools |
||||||
|
# #[subsection {Namespace punk::aliascore::class}] |
||||||
|
# #[para] class definitions |
||||||
|
# if {[info commands [namespace current]::interface_sample1] eq ""} { |
||||||
|
# #*** !doctools |
||||||
|
# #[list_begin enumerated] |
||||||
|
# |
||||||
|
# # oo::class create interface_sample1 { |
||||||
|
# # #*** !doctools |
||||||
|
# # #[enum] CLASS [class interface_sample1] |
||||||
|
# # #[list_begin definitions] |
||||||
|
# |
||||||
|
# # method test {arg1} { |
||||||
|
# # #*** !doctools |
||||||
|
# # #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# # #[para] test method |
||||||
|
# # puts "test: $arg1" |
||||||
|
# # } |
||||||
|
# |
||||||
|
# # #*** !doctools |
||||||
|
# # #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# # } |
||||||
|
# |
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {--- end class enumeration ---}] |
||||||
|
# } |
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::aliascore { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
variable aliases |
||||||
|
#use absolute ns ie must be prefixed with :: |
||||||
|
#single element commands are imported if source command already exists, otherwise aliased. multi element commands are aliased |
||||||
|
|
||||||
|
#functions must be in export list of their source namespace |
||||||
|
set aliases [tcl::dict::create\ |
||||||
|
tstr ::punk::lib::tstr\ |
||||||
|
list_as_lines ::punk::lib::list_as_lines\ |
||||||
|
lines_as_list ::punk::lib::lines_as_list\ |
||||||
|
linelist ::punk::lib::linelist\ |
||||||
|
linesort ::punk::lib::linesort\ |
||||||
|
pdict ::punk::lib::pdict\ |
||||||
|
plist {::punk::lib::pdict -roottype list}\ |
||||||
|
showlist {::punk::lib::showdict -roottype list}\ |
||||||
|
showdict ::punk::lib::showdict\ |
||||||
|
ansistrip ::punk::ansi::ansistrip\ |
||||||
|
stripansi ::punk::ansi::ansistrip\ |
||||||
|
ansiwrap ::punk::ansi::ansiwrap\ |
||||||
|
colour ::punk::console::colour\ |
||||||
|
ansi ::punk::console::ansi\ |
||||||
|
color ::punk::console::colour\ |
||||||
|
a+ ::punk::console::code_a+\ |
||||||
|
A+ {::punk::console::code_a+ forcecolour}\ |
||||||
|
a ::punk::console::code_a\ |
||||||
|
A {::punk::console::code_a forcecolour}\ |
||||||
|
a? ::punk::console::code_a?\ |
||||||
|
A? {::punk::console::code_a? forcecolor}\ |
||||||
|
smcup ::punk::console::enable_alt_screen\ |
||||||
|
rmcup ::punk::console::disable_alt_screen\ |
||||||
|
] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::aliascore}] |
||||||
|
#[para] Core API functions for punk::aliascore |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#proc sample1 {p1 n args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||||
|
# #[para]Description of sample1 |
||||||
|
# #[para] Arguments: |
||||||
|
# # [list_begin arguments] |
||||||
|
# # [arg_def tring p1] A description of string argument p1. |
||||||
|
# # [arg_def integer n] A description of integer argument n. |
||||||
|
# # [list_end] |
||||||
|
# return "ok" |
||||||
|
#} |
||||||
|
|
||||||
|
#todo - options as to whether we should raise an error if collisions found, undo aliases etc? |
||||||
|
proc init {args} { |
||||||
|
set defaults {-force 0} |
||||||
|
set opts [dict merge $defaults $args] |
||||||
|
set opt_force [dict get $opts -force] |
||||||
|
|
||||||
|
variable aliases |
||||||
|
if {!$opt_force} { |
||||||
|
set existing [list] |
||||||
|
set conflicts [list] |
||||||
|
foreach {a cmd} $aliases { |
||||||
|
if {[tcl::info::commands ::$a] ne ""} { |
||||||
|
lappend existing $a |
||||||
|
if {[llength $cmd] > 1} { |
||||||
|
#use alias mechanism |
||||||
|
set existing_target [interp alias "" $a] |
||||||
|
} else { |
||||||
|
#using namespace import |
||||||
|
#check origin |
||||||
|
set existing_target [tcl::namespace::origin $cmd] |
||||||
|
} |
||||||
|
if {$existing_target ne $cmd} { |
||||||
|
#command exists in global ns but doesn't match our defined aliases/imports |
||||||
|
lappend conflicts $a |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
if {[llength $conflicts]} { |
||||||
|
error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts" |
||||||
|
} |
||||||
|
} |
||||||
|
set tempns ::temp_[info cmdcount] ;#temp ns for renames |
||||||
|
dict for {a cmd} $aliases { |
||||||
|
#puts "aliascore $a -> $cmd" |
||||||
|
if {[llength $cmd] > 1} { |
||||||
|
interp alias {} $a {} {*}$cmd |
||||||
|
} else { |
||||||
|
if {[tcl::info::commands $cmd] ne ""} { |
||||||
|
#todo - ensure exported? noclobber? |
||||||
|
if {[tcl::namespace::tail $a] eq [tcl::namespace::tail $cmd]} { |
||||||
|
#puts stderr "importing $cmd" |
||||||
|
tcl::namespace::eval :: [list namespace import $cmd] |
||||||
|
} else { |
||||||
|
#target command name differs from exported name |
||||||
|
#e.g stripansi -> punk::ansi::ansistrip |
||||||
|
#import and rename |
||||||
|
#puts stderr "importing $cmd (with rename to ::$a)" |
||||||
|
tcl::namespace::eval $tempns [list namespace import $cmd] |
||||||
|
catch {rename ${tempns}::[namespace tail $cmd] ::$a} |
||||||
|
} |
||||||
|
} else { |
||||||
|
interp alias {} $a {} {*}$cmd |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
#tcl::namespace::delete $tempns |
||||||
|
return [dict keys $aliases] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::aliascore ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#interp alias {} list_as_lines {} punk::lib::list_as_lines |
||||||
|
#interp alias {} lines_as_list {} punk::lib::lines_as_list |
||||||
|
#interp alias {} ansistrip {} punk::ansi::ansistrip ;#review |
||||||
|
#interp alias {} linelist {} punk::lib::linelist ;#critical for = assignment features |
||||||
|
#interp alias {} linesort {} punk::lib::linesort |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::aliascore::lib { |
||||||
|
namespace export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
namespace path [namespace parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::aliascore::lib}] |
||||||
|
#[para] Secondary functions that are part of the API |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
#proc utility1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of utility1 |
||||||
|
# return 1 |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::aliascore::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
namespace eval punk::aliascore::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::aliascore::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::aliascore [namespace eval punk::aliascore { |
||||||
|
variable pkg punk::aliascore |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
@ -0,0 +1,475 @@ |
|||||||
|
|
||||||
|
tcl::namespace::eval punk::config { |
||||||
|
variable loaded |
||||||
|
variable startup ;#include env overrides |
||||||
|
variable running |
||||||
|
variable punk_env_vars |
||||||
|
variable other_env_vars |
||||||
|
|
||||||
|
variable vars |
||||||
|
|
||||||
|
namespace export {[a-z]*} |
||||||
|
|
||||||
|
#todo - XDG_DATA_HOME etc |
||||||
|
#https://specifications.freedesktop.org/basedir-spec/latest/ |
||||||
|
# see also: http://hiphish.github.io/blog/2020/08/30/dotfiles-were-a-mistake/ |
||||||
|
|
||||||
|
proc init {} { |
||||||
|
variable defaults |
||||||
|
variable startup |
||||||
|
variable running |
||||||
|
variable punk_env_vars |
||||||
|
variable punk_env_vars_config |
||||||
|
variable other_env_vars |
||||||
|
variable other_env_vars_config |
||||||
|
|
||||||
|
set exename "" |
||||||
|
catch { |
||||||
|
#catch for safe interps |
||||||
|
#safe base will return empty string, ordinary safe interp will raise error |
||||||
|
set exename [tcl::info::nameofexecutable] |
||||||
|
} |
||||||
|
if {$exename ne ""} { |
||||||
|
set exefolder [file dirname $exename] |
||||||
|
#default file logs to logs folder at same level as exe if writable, or empty string |
||||||
|
set log_folder [file normalize $exefolder/../logs] |
||||||
|
#tcl::dict::set startup scriptlib $exefolder/scriptlib |
||||||
|
#tcl::dict::set startup apps $exefolder/../../punkapps |
||||||
|
|
||||||
|
#todo - use punk main.tcl location instead - exefolder doesn't work if system tclsh used etc |
||||||
|
set default_scriptlib $exefolder/scriptlib |
||||||
|
set default_apps $exefolder/../../punkapps |
||||||
|
if {[file isdirectory $log_folder] && [file writable $log_folder]} { |
||||||
|
#tcl::dict::set startup logfile_stdout $log_folder/repl-exec-stdout.txt |
||||||
|
#tcl::dict::set startup logfile_stderr $log_folder/repl-exec-stderr.txt |
||||||
|
set default_logfile_stdout $log_folder/repl-exec-stdout.txt |
||||||
|
set default_logfile_stderr $log_folder/repl-exec-stderr.txt |
||||||
|
} else { |
||||||
|
set default_logfile_stdout "" |
||||||
|
set default_logfile_stderr "" |
||||||
|
} |
||||||
|
} else { |
||||||
|
#probably a safe interp - which cannot access info nameofexecutable even if access given to the location via punk::island |
||||||
|
#review - todo? |
||||||
|
#tcl::dict::set startup scriptlib "" |
||||||
|
#tcl::dict::set startup apps "" |
||||||
|
set default_scriptlib "" |
||||||
|
set default_apps "" |
||||||
|
set default_logfile_stdout "" |
||||||
|
set default_logfile_stderr "" |
||||||
|
} |
||||||
|
|
||||||
|
# auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run |
||||||
|
|
||||||
|
#optional channel transforms on stdout/stderr. |
||||||
|
#can sometimes be useful to distinguish eventloop stdout/stderr writes compared to those triggered directly from repl commands |
||||||
|
#If no distinction necessary - should use default_color_<chan> |
||||||
|
#The counterpart: default_color_<chan>_repl is a transform that is added and removed with each repl evaluation. |
||||||
|
#startup color_stdout - parameters as suitable for punk::ansi::a+ (test with 'punk::ansi::a?') e.g "cyan bold" ;#not a good idea to default |
||||||
|
set default_color_stdout brightwhite ;#stdout colour including background calls (after etc) |
||||||
|
set default_color_stdout_repl "" ;#stdout colour applied during direct repl call only |
||||||
|
#This wraps the stderr stream as it comes in with Ansi - probably best to default to empty.. but it's useful. |
||||||
|
#set default_color_stderr "red bold" |
||||||
|
#set default_color_stderr "web-lightsalmon" |
||||||
|
set default_color_stderr yellow ;#limit to basic colours for wider terminal support. yellow = term-olive |
||||||
|
set default_color_stderr_repl "" ;#during repl call only |
||||||
|
|
||||||
|
set homedir "" |
||||||
|
if {[catch { |
||||||
|
#depending on which build of tcl - some safe interps prior to bugfix https://core.tcl-lang.org/tcl/info/3aa487993f will return a homedir value in an unmodified safe interp |
||||||
|
#other 'safe' interps may have explicitly made this available - we shouldn't override that decision here using interp issafe so we can't compensate for versions which shouldn't really be returning this in the safe interp |
||||||
|
set homedir [file home] |
||||||
|
} errM]} { |
||||||
|
#tcl 8.6 doesn't have file home.. try again |
||||||
|
if {[info exists ::env(HOME)]} { |
||||||
|
set homedir $::env(HOME) |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# per user xdg vars |
||||||
|
# --- |
||||||
|
set default_xdg_config_home "" ;#config data - portable |
||||||
|
set default_xdg_data_home "" ;#data the user likely to want to be portable |
||||||
|
set default_xdg_cache_home "" ;#local cache |
||||||
|
set default_xdg_state_home "" ;#persistent user data such as logs, but not as important or as portable as those in xdg_data_home |
||||||
|
# --- |
||||||
|
set default_xdg_data_dirs "" ;#non-user specific |
||||||
|
#xdg_config_dirs ? |
||||||
|
#xdg_runtime_dir ? |
||||||
|
|
||||||
|
|
||||||
|
#review. we are assuming if we can't get a home dir - then all the xdg vars including xdg_data_dirs aren't likely to be useful (as presumably filesystem access is absent) |
||||||
|
#(safe interp generally won't have access to ::env either) |
||||||
|
#This coupling doesn't necessarily hold - its possible the relevant env vars were copied to a safe interp - although that would be a policy that would make disabling 'info home' inconsistent. |
||||||
|
if {$homedir ne ""} { |
||||||
|
if {"windows" eq $::tcl_platform(platform)} { |
||||||
|
#as much as I'd prefer to use ~/.local/share and ~/.config to keep them more consistent with unixlike platforms - the vast majority of apps put them where microsoft wants them. |
||||||
|
#we have a choice of LOCALAPPDATA vs APPDATA (local to machine vs potentially roaming/redirected in a corporate environment) |
||||||
|
#using the roaming location should not impact users who aren't using a domain controller but is potentially much more convenient for those who do. |
||||||
|
if {[info exists ::env(APPDATA)]} { |
||||||
|
set default_xdg_config_home $::env(APPDATA) |
||||||
|
set default_xdg_data_home $::env(APPDATA) |
||||||
|
} |
||||||
|
|
||||||
|
#The xdg_cache_home should be kept local |
||||||
|
if {[info exists ::env(LOCALAPPDATA)]} { |
||||||
|
set default_xdg_cache_home $::env(LOCALAPPDATA) |
||||||
|
set default_xdg_state_home $::env(LOCALAPPDATA) |
||||||
|
} |
||||||
|
|
||||||
|
if {[info exists ::env(PROGRAMDATA)]} { |
||||||
|
#- equiv env(ALLUSERSPROFILE) ? |
||||||
|
set default_xdg_data_dirs $::env(PROGRAMDATA) |
||||||
|
} |
||||||
|
|
||||||
|
} else { |
||||||
|
#follow defaults as specified on freedesktop.org e.g https://specifications.freedesktop.org/basedir-spec/latest/ar01s03.html |
||||||
|
set default_xdg_config_home [file join $homedir .config] |
||||||
|
set default_xdg_data_home [file join $homedir .local share] |
||||||
|
set default_xdg_cache_home [file join $homedir .cache] |
||||||
|
set default_xdg_state_home [file join $homedir .local state] |
||||||
|
set default_xdg_data_dirs /usr/local/share |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set defaults [dict create\ |
||||||
|
apps $default_apps\ |
||||||
|
config ""\ |
||||||
|
configset ".punkshell"\ |
||||||
|
scriptlib $default_scriptlib\ |
||||||
|
color_stdout $default_color_stdout\ |
||||||
|
color_stdout_repl $default_color_stdout_repl\ |
||||||
|
color_stderr $default_color_stderr\ |
||||||
|
color_stderr_repl $default_color_stderr_repl\ |
||||||
|
logfile_stdout $default_logfile_stdout\ |
||||||
|
logfile_stderr $default_logfile_stderr\ |
||||||
|
logfile_active 0\ |
||||||
|
syslog_stdout "127.0.0.1:514"\ |
||||||
|
syslog_stderr "127.0.0.1:514"\ |
||||||
|
syslog_active 0\ |
||||||
|
auto_exec_mechanism exec\ |
||||||
|
auto_noexec 0\ |
||||||
|
xdg_config_home $default_xdg_config_home\ |
||||||
|
xdg_data_home $default_xdg_data_home\ |
||||||
|
xdg_cache_home $default_xdg_cache_home\ |
||||||
|
xdg_state_home $default_xdg_state_home\ |
||||||
|
xdg_data_dirs $default_xdg_data_dirs\ |
||||||
|
theme_posh_override ""\ |
||||||
|
posh_theme ""\ |
||||||
|
posh_themes_path ""\ |
||||||
|
] |
||||||
|
|
||||||
|
set startup $defaults |
||||||
|
#load values from saved config file - $xdg_config_home/punk/punk.config ? |
||||||
|
#typically we want env vars to override the stored config - as env vars conventionally used on some commandlines. |
||||||
|
#that's possibly ok for the PUNK_ vars |
||||||
|
#however.. others like the xdg vars and NOCOLOR may apply to other apps.. and we may want to override them from the saved config? |
||||||
|
#making some env vars override saved config values and some not would be potentially confusing. may need one/more specific settings or env vars to determine which takes precedence? |
||||||
|
#simpler is probably just to let env vars take precedence - and warn when saving or viewing config that the saved values are being overridden |
||||||
|
#- requiring user to manually unset any unwanted env vars when launching? |
||||||
|
|
||||||
|
#we are likely to want the saved configs for subshells/decks to override them however. |
||||||
|
|
||||||
|
#todo - load/save config file |
||||||
|
|
||||||
|
#todo - define which configvars are settable in env |
||||||
|
#list of varname varinfo where varinfo is a sub dictionary (type key is mandatory, with value from: string,pathlist,boolean) |
||||||
|
set punk_env_vars_config [dict create \ |
||||||
|
PUNK_APPS {type pathlist}\ |
||||||
|
PUNK_CONFIG {type string}\ |
||||||
|
PUNK_CONFIGSET {type string}\ |
||||||
|
PUNK_SCRIPTLIB {type string}\ |
||||||
|
PUNK_AUTO_EXEC_MECHANISM {type string}\ |
||||||
|
PUNK_AUTO_NOEXEC {type string default 0 help "set 1 to set Tcl's ::auto_noexec true.\nStops 'unknown' from running external programs"}\ |
||||||
|
PUNK_COLOR_STDERR {type string help "stderr colour transform. Use 'punk::ansi::a?' to see colour names"}\ |
||||||
|
PUNK_COLOR_STDERR_REPL {type string help "stderr colour transform only while command running (not active during 'after')"}\ |
||||||
|
PUNK_COLOR_STDOUT {type string help "stdout colour transform. Use 'punk::ansi::a?' to see colour names"}\ |
||||||
|
PUNK_COLOR_STDOUT_REPL {type string help "stdout colour transform only while command running (not active during 'after')"}\ |
||||||
|
PUNK_LOGFILE_STDOUT {type string}\ |
||||||
|
PUNK_LOGFILE_STDERR {type string}\ |
||||||
|
PUNK_LOGFILE_ACTIVE {type string}\ |
||||||
|
PUNK_SYSLOG_STDOUT {type string}\ |
||||||
|
PUNK_SYSLOG_STDERR {type string}\ |
||||||
|
PUNK_SYSLOG_ACTIVE {type string}\ |
||||||
|
PUNK_THEME_POSH_OVERRIDE {type string}\ |
||||||
|
] |
||||||
|
set punk_env_vars [dict keys $punk_env_vars_config] |
||||||
|
|
||||||
|
#override with env vars if set |
||||||
|
foreach {evar varinfo} $punk_env_vars_config { |
||||||
|
if {[info exists ::env($evar)]} { |
||||||
|
set vartype [dict get $varinfo type] |
||||||
|
set f [set ::env($evar)] |
||||||
|
if {$f ne "default"} { |
||||||
|
#e.g PUNK_SCRIPTLIB -> scriptlib |
||||||
|
set varname [tcl::string::tolower [tcl::string::range $evar 5 end]] |
||||||
|
if {$vartype eq "pathlist"} { |
||||||
|
#colon vs semicolon path sep is problematic for windows environments where unix-like systems such as cygwin/wsl are used and a variable may be set for either the native path separator or the unix-like system |
||||||
|
#Even without the colon vs semicolon issue, native vs unix-like paths on windows mixed environment systems can cause grief. |
||||||
|
#For now at least, we will simply respect the platform pathSeparator and hope the user manages the environment variables appropriately. |
||||||
|
#some programs do automatic translation - which is a nice idea in principle - but is also prone to error as we don't know if it's already occurred or not depending on how things are launched. |
||||||
|
#An example of where this sort of thing can go wrong is env(TCLLIBPATH) - which is defined as a space separated list not requiring further splitting |
||||||
|
# - but some programs have been known to split this value on colon anyway, which breaks things on windows. |
||||||
|
set paths [split $f $::tcl_platform(pathSeparator)] |
||||||
|
set final [list] |
||||||
|
#eliminate empty values (leading or trailing or extraneous separators) |
||||||
|
foreach p $paths { |
||||||
|
if {[tcl::string::trim $p] ne ""} { |
||||||
|
lappend final $p |
||||||
|
} |
||||||
|
} |
||||||
|
tcl::dict::set startup $varname $final |
||||||
|
} else { |
||||||
|
tcl::dict::set startup $varname $f |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# https://no-color.org |
||||||
|
#if {[info exists ::env(NO_COLOR)]} { |
||||||
|
# if {$::env(NO_COLOR) ne ""} { |
||||||
|
# set colour_disabled 1 |
||||||
|
# } |
||||||
|
#} |
||||||
|
set other_env_vars_config [dict create\ |
||||||
|
NO_COLOR {type string}\ |
||||||
|
XDG_CONFIG_HOME {type string}\ |
||||||
|
XDG_DATA_HOME {type string}\ |
||||||
|
XDG_CACHE_HOME {type string}\ |
||||||
|
XDG_STATE_HOME {type string}\ |
||||||
|
XDG_DATA_DIRS {type pathlist}\ |
||||||
|
POSH_THEME {type string}\ |
||||||
|
POSH_THEMES_PATH {type string}\ |
||||||
|
TCLLIBPATH {type string}\ |
||||||
|
] |
||||||
|
lassign [split [info tclversion] .] tclmajorv tclminorv |
||||||
|
#don't rely on lseq or punk::lib for now.. |
||||||
|
set relevant_minors [list] |
||||||
|
for {set i 0} {$i <= $tclminorv} {incr i} { |
||||||
|
lappend relevant_minors $i |
||||||
|
} |
||||||
|
foreach minor $relevant_minors { |
||||||
|
set vname TCL${tclmajorv}_${minor}_TM_PATH |
||||||
|
if {$minor eq $tclminorv || [info exists ::env($vname)]} { |
||||||
|
dict set other_env_vars_config $vname {type string} |
||||||
|
} |
||||||
|
} |
||||||
|
set other_env_vars [dict keys $other_env_vars_config] |
||||||
|
|
||||||
|
foreach {evar varinfo} $other_env_vars_config { |
||||||
|
if {[info exists ::env($evar)]} { |
||||||
|
set vartype [dict get $varinfo type] |
||||||
|
set f [set ::env($evar)] |
||||||
|
if {$f ne "default"} { |
||||||
|
set varname [tcl::string::tolower $evar] |
||||||
|
if {$vartype eq "pathlist"} { |
||||||
|
set paths [split $f $::tcl_platform(pathSeparator)] |
||||||
|
set final [list] |
||||||
|
#eliminate empty values (leading or trailing or extraneous separators) |
||||||
|
foreach p $paths { |
||||||
|
if {[tcl::string::trim $p] ne ""} { |
||||||
|
lappend final $p |
||||||
|
} |
||||||
|
} |
||||||
|
tcl::dict::set startup $varname $final |
||||||
|
} else { |
||||||
|
tcl::dict::set startup $varname $f |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#unset -nocomplain vars |
||||||
|
|
||||||
|
#todo |
||||||
|
set running [tcl::dict::create] |
||||||
|
set running [tcl::dict::merge $running $startup] |
||||||
|
} |
||||||
|
init |
||||||
|
|
||||||
|
#todo |
||||||
|
proc Apply {config} { |
||||||
|
puts stderr "punk::config::Apply partially implemented" |
||||||
|
set configname [string map {-config ""} $config] |
||||||
|
if {$configname in {startup running}} { |
||||||
|
upvar ::punk::config::$configname applyconfig |
||||||
|
|
||||||
|
if {[dict exists $applyconfig auto_noexec]} { |
||||||
|
set auto [dict get $applyconfig auto_noexec] |
||||||
|
if {![string is boolean -strict $auto]} { |
||||||
|
error "config::Apply error - invalid data for auto_noexec:'$auto' - expected boolean" |
||||||
|
} |
||||||
|
if {$auto} { |
||||||
|
set ::auto_noexec 1 |
||||||
|
} else { |
||||||
|
#puts "auto_noexec false" |
||||||
|
unset -nocomplain ::auto_noexec |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} else { |
||||||
|
error "no config named '$config' found" |
||||||
|
} |
||||||
|
return "apply done" |
||||||
|
} |
||||||
|
Apply startup |
||||||
|
|
||||||
|
#todo - consider how to divide up settings, categories, 'devices', decks etc |
||||||
|
proc get_running_global {varname} { |
||||||
|
variable running |
||||||
|
if {[dict exists $running $varname]} { |
||||||
|
return [dict get $running $varname] |
||||||
|
} |
||||||
|
error "No such global configuration item '$varname' found in running config" |
||||||
|
} |
||||||
|
proc get_startup_global {varname} { |
||||||
|
variable startup |
||||||
|
if {[dict exists $startup $varname]} { |
||||||
|
return [dict get $startup $varname] |
||||||
|
} |
||||||
|
error "No such global configuration item '$varname' found in startup config" |
||||||
|
} |
||||||
|
|
||||||
|
proc get {whichconfig {globfor *}} { |
||||||
|
variable startup |
||||||
|
variable running |
||||||
|
switch -- $whichconfig { |
||||||
|
config - startup - startup-config - startup-configuration { |
||||||
|
#show *startup* config - different behaviour may be confusing to those used to router startup and running configs |
||||||
|
set configdata $startup |
||||||
|
} |
||||||
|
running - running-config - running-configuration { |
||||||
|
set configdata $running |
||||||
|
} |
||||||
|
default { |
||||||
|
error "Unknown config name '$whichconfig' - try startup or running" |
||||||
|
} |
||||||
|
} |
||||||
|
if {$globfor eq "*"} { |
||||||
|
return $configdata |
||||||
|
} else { |
||||||
|
set keys [dict keys $configdata [string tolower $globfor]] |
||||||
|
set filtered [dict create] |
||||||
|
foreach k $keys { |
||||||
|
dict set filtered $k [dict get $configdata $k] |
||||||
|
} |
||||||
|
return $filtered |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc configure {args} { |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
|
||||||
|
whichconfig -type string -choices {startup running} |
||||||
|
} $args] |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
proc show {whichconfig {globfor *}} { |
||||||
|
#todo - tables for console |
||||||
|
set configdata [punk::config::get $whichconfig $globfor] |
||||||
|
return [punk::lib::showdict $configdata] |
||||||
|
} |
||||||
|
|
||||||
|
#e.g |
||||||
|
# copy running-config startup-config |
||||||
|
# copy startup-config test-config.cfg |
||||||
|
# copy backup-config.cfg running-config |
||||||
|
#review - consider the merge vs overwrite feature of some routers.. where copy to running-config does a merge rather than an overwrite |
||||||
|
#This is to allow partial configs to be loaded to running, whereas a save of running to any target is always a complete configuration |
||||||
|
proc copy {args} { |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
*proc -name punk::config::copy -help "Copy a partial or full configuration from one config to another |
||||||
|
If a target config has additional settings, then the source config can be considered to be partial with regards to the target. |
||||||
|
" |
||||||
|
-type -default "" -choices {replace merge} -help "Defaults to merge when target is running-config |
||||||
|
Defaults to replace when source is running-config" |
||||||
|
*values -min 2 -max 2 |
||||||
|
fromconfig -help "running or startup or file name (not fully implemented)" |
||||||
|
toconfig -help "running or startup or file name (not fully implemented)" |
||||||
|
} $args] |
||||||
|
set fromconfig [dict get $argd values fromconfig] |
||||||
|
set toconfig [dict get $argd values toconfig] |
||||||
|
set fromconfig [string map {-config ""} $fromconfig] |
||||||
|
set toconfig [string map {-config ""} $toconfig] |
||||||
|
|
||||||
|
set copytype [dict get $argd opts -type] |
||||||
|
|
||||||
|
|
||||||
|
#todo - warn & prompt if doing merge copy to startup |
||||||
|
switch -exact -- $fromconfig-$toconfig { |
||||||
|
running-startup { |
||||||
|
if {$copytype eq ""} { |
||||||
|
set copytype replace ;#full configuration |
||||||
|
} |
||||||
|
if {$copytype eq "replace"} { |
||||||
|
error "punk::config::copy error. full configuration copy from running to startup config not yet supported" |
||||||
|
} else { |
||||||
|
error "punk::config::copy error. merge configuration copy from running to startup config not yet supported" |
||||||
|
} |
||||||
|
} |
||||||
|
startup-running { |
||||||
|
#default type merge - even though it's not always what is desired |
||||||
|
if {$copytype eq ""} { |
||||||
|
set copytype merge ;#load in a partial configuration |
||||||
|
} |
||||||
|
|
||||||
|
#warn/prompt either way |
||||||
|
if {$copytype eq "replace"} { |
||||||
|
#some routers require use of a separate command for this branch. |
||||||
|
#presumably to ensure the user doesn't accidentally load partials onto a running system |
||||||
|
# |
||||||
|
error "punk::config::copy error. full configuration copy from startup to overwrite running config not supported" |
||||||
|
} else { |
||||||
|
error "punk::config::copy error. merge copy from possibly partial configuration: startup to running config not currently supported" |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
error "punk::config::copy error. copy must from running to startup or startup to running. File sources/targets not yet supported" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#todo - move to cli? |
||||||
|
::tcl::namespace::eval punk::config { |
||||||
|
#todo - something better - 'previous' rather than reverting to startup |
||||||
|
proc channelcolors {{onoff {}}} { |
||||||
|
variable running |
||||||
|
variable startup |
||||||
|
|
||||||
|
if {![string length $onoff]} { |
||||||
|
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] |
||||||
|
} else { |
||||||
|
if {![string is boolean $onoff]} { |
||||||
|
error "channelcolors: invalid value $onoff - expected boolean: true|false|on|off|1|0|yes|no" |
||||||
|
} |
||||||
|
if {$onoff} { |
||||||
|
dict set running color_stdout [dict get $startup color_stdout] |
||||||
|
dict set running color_stderr [dict get $startup color_stderr] |
||||||
|
} else { |
||||||
|
dict set running color_stdout "" |
||||||
|
dict set running color_stderr "" |
||||||
|
} |
||||||
|
} |
||||||
|
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
package provide punk::config [tcl::namespace::eval punk::config { |
||||||
|
variable version |
||||||
|
set version 0.1 |
||||||
|
|
||||||
|
}] |
@ -0,0 +1,164 @@ |
|||||||
|
#punkapps app manager |
||||||
|
# deck cli |
||||||
|
|
||||||
|
namespace eval punk::mod::cli { |
||||||
|
namespace export help list run |
||||||
|
namespace ensemble create |
||||||
|
|
||||||
|
# namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown |
||||||
|
if 0 { |
||||||
|
proc _unknown {ns args} { |
||||||
|
puts stderr "punk::mod::cli::_unknown '$ns' '$args'" |
||||||
|
puts stderr "punk::mod::cli::help $args" |
||||||
|
puts stderr "arglen:[llength $args]" |
||||||
|
punk::mod::cli::help {*}$args |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#cli must have _init method - usually used to load commandsets lazily |
||||||
|
# |
||||||
|
variable initialised 0 |
||||||
|
proc _init {args} { |
||||||
|
variable initialised |
||||||
|
if {$initialised} { |
||||||
|
return |
||||||
|
} |
||||||
|
#... |
||||||
|
set initialised 1 |
||||||
|
} |
||||||
|
|
||||||
|
proc help {args} { |
||||||
|
set basehelp [punk::mix::base help {*}$args] |
||||||
|
#namespace export |
||||||
|
return $basehelp |
||||||
|
} |
||||||
|
proc getraw {appname} { |
||||||
|
upvar ::punk::config::running running_config |
||||||
|
set app_folders [dict get $running_config apps] |
||||||
|
#todo search each app folder |
||||||
|
set bases [::list] |
||||||
|
set versions [::list] |
||||||
|
set mains [::list] |
||||||
|
set appinfo [::list bases {} mains {} versions {}] |
||||||
|
|
||||||
|
foreach containerfolder $app_folders { |
||||||
|
lappend bases $containerfolder |
||||||
|
if {[file exists $containerfolder]} { |
||||||
|
if {[file exists $containerfolder/$appname/main.tcl]} { |
||||||
|
#exact match - only return info for the exact one specified |
||||||
|
set namematches $appname |
||||||
|
set parts [split $appname -] |
||||||
|
} else { |
||||||
|
set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*] |
||||||
|
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? |
||||||
|
} |
||||||
|
foreach nm $namematches { |
||||||
|
set mainfile $containerfolder/$nm/main.tcl |
||||||
|
set parts [split $nm -] |
||||||
|
if {[llength $parts] == 1} { |
||||||
|
set ver "" |
||||||
|
} else { |
||||||
|
set ver [lindex $parts end] |
||||||
|
} |
||||||
|
if {$ver ni $versions} { |
||||||
|
lappend versions $ver |
||||||
|
lappend mains $ver $mainfile |
||||||
|
} else { |
||||||
|
puts stderr "punk::apps::app version '$ver' of app '$appname' already encountered at $mainfile. (will use earliest encountered in running-config apps and ignore others of same version)" |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config" |
||||||
|
} |
||||||
|
} |
||||||
|
dict set appinfo versions $versions |
||||||
|
#todo - natsort! |
||||||
|
set sorted_versions [lsort $versions] |
||||||
|
set latest [lindex $sorted_versions 0] |
||||||
|
if {$latest eq "" && [llength $sorted_versions] > 1} { |
||||||
|
set latest [lindex $sorted_versions 1 |
||||||
|
} |
||||||
|
dict set appinfo latest $latest |
||||||
|
|
||||||
|
dict set appinfo bases $bases |
||||||
|
dict set appinfo mains $mains |
||||||
|
return $appinfo |
||||||
|
} |
||||||
|
|
||||||
|
proc list {{glob *}} { |
||||||
|
upvar ::punk::config::running running_config |
||||||
|
set apps_folder [dict get $running_config apps] |
||||||
|
if {[file exists $apps_folder]} { |
||||||
|
if {[file exists $apps_folder/$glob]} { |
||||||
|
#tailcall source $apps_folder/$glob/main.tcl |
||||||
|
return $glob |
||||||
|
} |
||||||
|
set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob] |
||||||
|
if {[llength $apps] == 0} { |
||||||
|
if {[string first * $glob] <0 && [string first ? $glob] <0} { |
||||||
|
#no glob chars supplied - only launch if exact match for name part |
||||||
|
set namematches [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*] |
||||||
|
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? |
||||||
|
if {[llength $namematches] > 0} { |
||||||
|
set latest [lindex $namematches end] |
||||||
|
lassign $latest nm ver |
||||||
|
#tailcall source $apps_folder/$latest/main.tcl |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
return $apps |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#todo - way to launch as separate process |
||||||
|
# solo-opts only before appname - args following appname are passed to the app |
||||||
|
proc run {args} { |
||||||
|
set nameposn [lsearch -not $args -*] |
||||||
|
if {$nameposn < 0} { |
||||||
|
error "punkapp::run unable to determine application name" |
||||||
|
} |
||||||
|
set appname [lindex $args $nameposn] |
||||||
|
set controlargs [lrange $args 0 $nameposn-1] |
||||||
|
set appargs [lrange $args $nameposn+1 end] |
||||||
|
|
||||||
|
set appinfo [punk::mod::cli::getraw $appname] |
||||||
|
if {[llength [dict get $appinfo versions]]} { |
||||||
|
set ver [dict get $appinfo latest] |
||||||
|
puts stdout "info: $appinfo" |
||||||
|
set ::argc [llength $appargs] |
||||||
|
set ::argv $appargs |
||||||
|
source [dict get $appinfo mains $ver] |
||||||
|
if {"-hideconsole" in $controlargs} { |
||||||
|
puts stderr "attempting console hide" |
||||||
|
#todo - something better - a callback when window mapped? |
||||||
|
after 500 {::punkapp::hide_console} |
||||||
|
} |
||||||
|
return $appinfo |
||||||
|
} else { |
||||||
|
error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
namespace eval punk::mod::cli { |
||||||
|
proc _cli {args} { |
||||||
|
#don't use tailcall - base uses info level to determine caller |
||||||
|
::punk::mix::base::_cli {*}$args |
||||||
|
} |
||||||
|
variable default_command help |
||||||
|
package require punk::mix::base |
||||||
|
package require punk::overlay |
||||||
|
punk::overlay::custom_from_base [namespace current] ::punk::mix::base |
||||||
|
} |
||||||
|
|
||||||
|
package provide punk::mod [namespace eval punk::mod { |
||||||
|
variable version |
||||||
|
set version 0.1 |
||||||
|
|
||||||
|
}] |
||||||
|
|
||||||
|
|
||||||
|
|
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,259 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::repl::codethread 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin shellspy_module_punk::repl::codethread 0 0.1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::repl::codethread] |
||||||
|
#[keywords module] |
||||||
|
#[description] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of punk::repl::codethread |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by punk::repl::codethread |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
package require punk::config |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#tcl::namespace::eval punk::repl::codethread::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::repl::codethread::class}] |
||||||
|
#[para] class definitions |
||||||
|
#if {[info commands [tcl::namespace::current]::interface_sample1] eq ""} { |
||||||
|
#*** !doctools |
||||||
|
#[list_begin enumerated] |
||||||
|
|
||||||
|
# oo::class create interface_sample1 { |
||||||
|
# #*** !doctools |
||||||
|
# #[enum] CLASS [class interface_sample1] |
||||||
|
# #[list_begin definitions] |
||||||
|
|
||||||
|
# method test {arg1} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# #[para] test method |
||||||
|
# puts "test: $arg1" |
||||||
|
# } |
||||||
|
|
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# } |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end class enumeration ---}] |
||||||
|
#} |
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::repl::codethread { |
||||||
|
tcl::namespace::export * |
||||||
|
variable replthread |
||||||
|
variable replthread_cond |
||||||
|
variable running 0 |
||||||
|
|
||||||
|
variable output_stdout "" |
||||||
|
variable output_stderr "" |
||||||
|
|
||||||
|
#variable xyz |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::repl::codethread}] |
||||||
|
#[para] Core API functions for punk::repl::codethread |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#proc sample1 {p1 n args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||||
|
# #[para]Description of sample1 |
||||||
|
# #[para] Arguments: |
||||||
|
# # [list_begin arguments] |
||||||
|
# # [arg_def tring p1] A description of string argument p1. |
||||||
|
# # [arg_def integer n] A description of integer argument n. |
||||||
|
# # [list_end] |
||||||
|
# return "ok" |
||||||
|
#} |
||||||
|
|
||||||
|
proc is_running {} { |
||||||
|
variable running |
||||||
|
return $running |
||||||
|
} |
||||||
|
proc runscript {script} { |
||||||
|
#puts stderr "->runscript" |
||||||
|
variable replthread_cond |
||||||
|
variable output_stdout "" |
||||||
|
variable output_stderr "" |
||||||
|
#expecting to be called from a thread::send in parent repl - ie in the toplevel interp so that the sub-interp "code" is available |
||||||
|
#if a thread::send is done from the commandline in a codethread - Tcl will |
||||||
|
if {"code" ni [interp children] || ![info exists replthread_cond]} { |
||||||
|
#in case someone tries calling from codethread directly - don't do anything or change any state |
||||||
|
#(direct caller could create an interp named code at the level "" -> "code" -"code" and add a replthread_cond value to avoid this check - but it probably won't do anything useful) |
||||||
|
#if called directly - the context will be within the first 'code' interp. |
||||||
|
#inappropriate caller could add superfluous entries to shellfilter stack if function errors out |
||||||
|
#inappropriate caller could affect tsv vars (if their interp allows that anyway) |
||||||
|
puts stderr "runscript is meant to be called from the parent repl thread via a thread::send to the codethread" |
||||||
|
return |
||||||
|
} |
||||||
|
set outstack [list] |
||||||
|
set errstack [list] |
||||||
|
upvar ::punk::config::running running_config |
||||||
|
if {[string length [dict get $running_config color_stdout_repl]] && [interp eval code punk::console::colour]} { |
||||||
|
lappend outstack [interp eval code [list shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout_repl]]]] |
||||||
|
} |
||||||
|
lappend outstack [interp eval code [list shellfilter::stack::add stdout tee_to_var -settings {-varname ::punk::repl::codethread::output_stdout}]] |
||||||
|
|
||||||
|
if {[string length [dict get $running_config color_stderr_repl]] && [interp eval code punk::console::colour]} { |
||||||
|
lappend errstack [interp eval code [list shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr_repl]]]] |
||||||
|
# #lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour cyan]] |
||||||
|
} |
||||||
|
lappend errstack [interp eval code [list shellfilter::stack::add stderr tee_to_var -settings {-varname ::punk::repl::codethread::output_stderr}]] |
||||||
|
|
||||||
|
#an experiment |
||||||
|
#set errhandle [shellfilter::stack::item_tophandle stderr] |
||||||
|
#interp transfer "" $errhandle code |
||||||
|
|
||||||
|
set scope [interp eval code [list set ::punk::ns::ns_current]] |
||||||
|
set status [catch { |
||||||
|
interp eval code [list tcl::namespace::inscope $scope $script] |
||||||
|
} result] |
||||||
|
|
||||||
|
|
||||||
|
flush stdout |
||||||
|
flush stderr |
||||||
|
|
||||||
|
#interp transfer code $errhandle "" |
||||||
|
#flush $errhandle |
||||||
|
set lastoutchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stdout]] end] |
||||||
|
set lasterrchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stderr]] end] |
||||||
|
#puts stderr "-->[ansistring VIEW -lf 1 $lastoutchar$lasterrchar]" |
||||||
|
|
||||||
|
set tid [thread::id] |
||||||
|
tsv::set codethread_$tid info [list lastoutchar $lastoutchar lasterrchar $lasterrchar] |
||||||
|
tsv::set codethread_$tid status $status |
||||||
|
tsv::set codethread_$tid result $result |
||||||
|
tsv::set codethread_$tid errorcode $::errorCode |
||||||
|
|
||||||
|
|
||||||
|
#only remove from shellfilter::stack the items we added to stack in this function |
||||||
|
foreach s [lreverse $outstack] { |
||||||
|
interp eval code [list shellfilter::stack::remove stdout $s] |
||||||
|
} |
||||||
|
foreach s [lreverse $errstack] { |
||||||
|
interp eval code [list shellfilter::stack::remove stderr $s] |
||||||
|
} |
||||||
|
thread::cond notify $replthread_cond |
||||||
|
} |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::repl::codethread ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::repl::codethread::lib { |
||||||
|
tcl::namespace::export * |
||||||
|
tcl::namespace::path [tcl::namespace::parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::repl::codethread::lib}] |
||||||
|
#[para] Secondary functions that are part of the API |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
#proc utility1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of utility1 |
||||||
|
# return 1 |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::repl::codethread::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
tcl::namespace::eval punk::repl::codethread::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::repl::codethread::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::repl::codethread [tcl::namespace::eval punk::repl::codethread { |
||||||
|
variable pkg punk::repl::codethread |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
@ -0,0 +1,237 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::unixywindows 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
#for illegalname_test |
||||||
|
package require punk::winpath |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::unixywindows { |
||||||
|
#'cached' name to make obvious it could be out of date - and to distinguish from unixyroot arg |
||||||
|
variable cachedunixyroot "" |
||||||
|
|
||||||
|
|
||||||
|
#----------------- |
||||||
|
#e.g something like c:/Users/geek/scoop/apps/msys2/current c:/msys2 |
||||||
|
proc get_unixyroot {} { |
||||||
|
variable cachedunixyroot |
||||||
|
if {![string length $cachedunixyroot]} { |
||||||
|
if {![catch { |
||||||
|
set result [exec cygpath -m /] ;# -m gives result with forward-slashes - which is ok for windows paths in a Tcl context. |
||||||
|
set cachedunixyroot [punk::objclone $result] |
||||||
|
file pathtype $cachedunixyroot; #this call causes the int-rep to be path |
||||||
|
#set ::punk::last_run_display [list] ;#hack - review shouldn't really be necessary.. but because we call winpath from ./ - the repl looks for last_run_display |
||||||
|
} errM]} { |
||||||
|
|
||||||
|
} else { |
||||||
|
puts stderr "Warning: Failed to determine base for unix-like paths - using default of c:/msys2" |
||||||
|
file pathtype [set cachedunixyroot [punk::objclone "c:/msys2"]] |
||||||
|
} |
||||||
|
} |
||||||
|
#will have been shimmered from string to 'path' internal rep by 'file pathtype' call |
||||||
|
|
||||||
|
#let's return a different copy as it's so easy to lose path-rep |
||||||
|
set copy [punk::objclone $cachedunixyroot] |
||||||
|
return $copy |
||||||
|
} |
||||||
|
proc refresh_unixyroot {} { |
||||||
|
variable cachedunixyroot |
||||||
|
set result [exec cygpath -m /] ;# -m gives result with forward-slashes - which is ok for windows paths in a Tcl context. |
||||||
|
set cachedunixyroot [punk::objclone $result] |
||||||
|
file pathtype $cachedunixyroot; #this call causes the int-rep to be path |
||||||
|
|
||||||
|
set copy [punk::objclone $cachedunixyroot] |
||||||
|
return $copy |
||||||
|
} |
||||||
|
proc set_unixyroot {windows_path} { |
||||||
|
variable cachedunixyroot |
||||||
|
file pathtype $windows_path |
||||||
|
set cachedunixyroot [punk::objclone $windows_path] |
||||||
|
#return the original - but probably int-rep will have shimmered to path even if started out as string |
||||||
|
#- that's probably what we want. Caller can use as string or path without affecting cachedunixyroot |
||||||
|
return $windows_path |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc windir {path} { |
||||||
|
if {$path eq "~"} { |
||||||
|
#as the tilde hasn't been normalized.. we can't assume we're running on the actual platform |
||||||
|
return ~/.. |
||||||
|
} |
||||||
|
return [file dirname [towinpath $path]] |
||||||
|
} |
||||||
|
|
||||||
|
#REVIEW high-coupling |
||||||
|
proc cdwin {path} { |
||||||
|
set path [towinpath $path] |
||||||
|
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||||
|
if {[llength [info commands ::punk::console::titleset]]} { |
||||||
|
::punk::console::titleset $path |
||||||
|
} |
||||||
|
} |
||||||
|
cd $path |
||||||
|
} |
||||||
|
proc cdwindir {path} { |
||||||
|
set path [towinpath $path] |
||||||
|
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||||
|
if {[llength [info commands ::punk::console::titleset]]} { |
||||||
|
::punk::console::titleset $path |
||||||
|
} |
||||||
|
} |
||||||
|
cd [file dirname $path] |
||||||
|
} |
||||||
|
|
||||||
|
#NOTE - this is an expensive operation - avoid where possible. |
||||||
|
#review - is this intended to be useful/callable on non-windows platforms? |
||||||
|
#it should in theory be useable from another platform that wants to create a path for use on windows. |
||||||
|
#In this case - we shouldn't examine what volumes exist (assume A: .. Z: are valid) |
||||||
|
#review zipfs:// other uri schemes? |
||||||
|
proc towinpath {unixypath {unixyroot ""}} { |
||||||
|
#NOTE: tcl file exists gives different answers on windows for paths like /c depending on cwd (presumably based on file pathtype of volumerelative) |
||||||
|
#(Tcl is also somewhat broken as at 2023 as far as volume relative paths - process can get out of sync with tcl if cd to a vol relative path is used) |
||||||
|
#This is add odds with attempting to navigate on a windows system which has cygwin, wsl etc... It also makes it difficult for functions intended to operate independent of CWD. |
||||||
|
#e.g there is potential confusion when there is a c folder on c: drive (c:/c) |
||||||
|
#I will attempt to provide a coherent operation for winpath ./ ../ etc , but it may disallow for example; change to /something or /x where these don't match a driveletter or /mnt |
||||||
|
#whereas tcl may allow cd to /something if a something folder happens to exist on the current volume based on cwd. |
||||||
|
#I think it's preferable to require an explicit driveletter /x or /mnt when using unix-like paths on windows - but practical considerations may prove me wrong.. |
||||||
|
#It's possible that this function should also ignore the current set of driveletters - and operate completely independent of whether a path actually exists |
||||||
|
#This makes it hard to use things like 'file normalize' - which also looks at things like current volume. |
||||||
|
# |
||||||
|
#Note for example the results of 'which' grep on windows can produce a path like /c/Users/somewhere/bin/grep |
||||||
|
#which tcl's file normalize may change to C:/c/Users or X:/c/Users - based on current volumen. Given that C:/c might exist - this can be problematic in a couple of ways. |
||||||
|
#The mixing of unix-like and windows commands on the same machine is a large part of the problem.. but this mix is now common |
||||||
|
# |
||||||
|
#convert /c/etc to C:/etc |
||||||
|
set re_slash_x_slash {^/([[:alpha:]]){1}/.*} |
||||||
|
set re_slash_else {^/([[:alpha:]]*)(.*)} |
||||||
|
set volumes [file volumes] |
||||||
|
#exclude things like //zipfs:/ ?? |
||||||
|
set driveletters [list] |
||||||
|
foreach v $volumes { |
||||||
|
if {[regexp {^([[:alpha:]]){1}:/$} $v _ letter]} { |
||||||
|
lappend driveletters $letter |
||||||
|
} |
||||||
|
} |
||||||
|
#puts stderr "->$driveletters" |
||||||
|
|
||||||
|
set path [punk::objclone $unixypath] ;#take another copy that we can deliberatley shimmer to path and know is separate to the supplied argument |
||||||
|
set supplied_pathtype [file pathtype $path] ;#we don't care about the pathtype so much as the act of making this call shimmers to a path internal-rep |
||||||
|
|
||||||
|
#copy of var that we can treat as a string without affecting path rep |
||||||
|
#Note that some but not all read operations will lose path rep e.g 'string length $x' will lose any path-rep $x had, (but 'string equal $x something' won't) |
||||||
|
#Todo - make int-rep tests to check stability of these behaviours across Tcl versions! |
||||||
|
set strcopy_path [punk::objclone $path] |
||||||
|
|
||||||
|
set str_newpath "" |
||||||
|
|
||||||
|
set have_pathobj 0 |
||||||
|
|
||||||
|
if {[regexp $re_slash_x_slash $strcopy_path _ letter]} { |
||||||
|
#upper case appears to be windows canonical form |
||||||
|
set str_newpath [string toupper $letter]:/[string range $strcopy_path 3 end] |
||||||
|
} elseif {[regexp {^/mnt/([[:alpha:]]){1}/.*} [string tolower $strcopy_path] _ letter]} { |
||||||
|
set str_newpath [string toupper $letter]:/[string range $strcopy_path 7 end] |
||||||
|
} elseif {[regexp {^/mnt/([[:alpha:]]){1}$} [string tolower $strcopy_path] _ letter]} { |
||||||
|
set str_newpath [string toupper $letter]:/ |
||||||
|
} elseif {[regexp $re_slash_else $strcopy_path _ firstpart remainder]} { |
||||||
|
#could be for example /c or /something/users |
||||||
|
if {[string length $firstpart] == 1} { |
||||||
|
set letter $firstpart |
||||||
|
set str_newpath [string toupper $letter]:/ |
||||||
|
} else { |
||||||
|
#according to regex we have a single leading slash |
||||||
|
set str_tail [string range $strcopy_path 1 end] |
||||||
|
if {$unixyroot eq ""} { |
||||||
|
set unixyroot [get_unixyroot] |
||||||
|
} else { |
||||||
|
file pathtype $unixyroot; #side-effect generates int-rep of type path ) |
||||||
|
} |
||||||
|
set pathobj [file join $unixyroot $str_tail] |
||||||
|
file pathtype $pathobj |
||||||
|
set have_pathobj 1 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {!$have_pathobj} { |
||||||
|
if {$str_newpath eq ""} { |
||||||
|
#dunno - pass through |
||||||
|
set pathobj $path |
||||||
|
} else { |
||||||
|
set pathobj [punk::objclone $str_newpath] |
||||||
|
file pathtype $pathobj |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#puts stderr "=> $path" |
||||||
|
#things like 'which' seem to return a path minus the .exe - so we'll just test the containing folder |
||||||
|
# |
||||||
|
#By now file normalize shouldn't do too many shannanigans related to cwd.. |
||||||
|
#We want it to look at cwd for relative paths.. |
||||||
|
#but we don't consider things like /c/Users to be relative even on windows where it would normally mean a volume-relative path e.g c:/c/Users if cwd happens to be somewhere on C: at the time. |
||||||
|
#if {![file exists [file dirname $path]]} { |
||||||
|
# set path [file normalize $path] |
||||||
|
# #may still not exist.. that's ok. |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#file normalize may change backslashes to forward slashes.. including things like the special \\?\ prefix which is intended to stop windows api from parsing a name |
||||||
|
#2023 - this is ok as //?/ also seems to work.. but it is unclear if that is because Tcl is re-converting to backslashes |
||||||
|
if {[punk::winpath::illegalname_test $pathobj]} { |
||||||
|
set pathobj [punk::winpath::illegalname_fix $pathobj] |
||||||
|
} |
||||||
|
|
||||||
|
return $pathobj |
||||||
|
} |
||||||
|
|
||||||
|
#---------------------------------------------- |
||||||
|
#leave the unixywindows related aliases available on all platforms |
||||||
|
#interp alias {} cdwin {} punk::unixywindows::cdwin |
||||||
|
#interp alias {} cdwindir {} punk::unixywindoes::cdwindir |
||||||
|
#interp alias {} towinpath {} punk::unixywindows::towinpath |
||||||
|
#interp alias {} windir {} punk::unixywindows::windir |
||||||
|
#---------------------------------------------- |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::unixywindows [namespace eval punk::unixywindows { |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
@ -0,0 +1,239 @@ |
|||||||
|
#utilities for punk apps to call |
||||||
|
|
||||||
|
package provide punkapp [namespace eval punkapp { |
||||||
|
variable version |
||||||
|
set version 0.1 |
||||||
|
}] |
||||||
|
|
||||||
|
namespace eval punkapp { |
||||||
|
variable result |
||||||
|
variable waiting "no" |
||||||
|
proc hide_dot_window {} { |
||||||
|
#alternative to wm withdraw . |
||||||
|
#see https://wiki.tcl-lang.org/page/wm+withdraw |
||||||
|
wm geometry . 1x1+0+0 |
||||||
|
wm overrideredirect . 1 |
||||||
|
wm transient . |
||||||
|
} |
||||||
|
proc is_toplevel {w} { |
||||||
|
if {![llength [info commands winfo]]} { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
expr {[winfo toplevel $w] eq $w && ![catch {$w cget -menu}]} |
||||||
|
} |
||||||
|
proc get_toplevels {{w .}} { |
||||||
|
if {![llength [info commands winfo]]} { |
||||||
|
return [list] |
||||||
|
} |
||||||
|
set list {} |
||||||
|
if {[is_toplevel $w]} { |
||||||
|
lappend list $w |
||||||
|
} |
||||||
|
foreach w [winfo children $w] { |
||||||
|
lappend list {*}[get_toplevels $w] |
||||||
|
} |
||||||
|
return $list |
||||||
|
} |
||||||
|
|
||||||
|
proc make_toplevel_next {prefix} { |
||||||
|
set top [get_toplevel_next $prefix] |
||||||
|
return [toplevel $top] |
||||||
|
} |
||||||
|
#possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime |
||||||
|
#todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase? |
||||||
|
#can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix |
||||||
|
proc get_toplevel_next {prefix} { |
||||||
|
set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> "" |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
proc exit {{toplevel ""}} { |
||||||
|
variable waiting |
||||||
|
variable result |
||||||
|
variable default_result |
||||||
|
set toplevels [get_toplevels] |
||||||
|
if {[string length $toplevel]} { |
||||||
|
set wposn [lsearch $toplevels $toplevel] |
||||||
|
if {$wposn > 0} { |
||||||
|
destroy $toplevel |
||||||
|
} |
||||||
|
} else { |
||||||
|
#review |
||||||
|
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||||
|
puts stderr "punkapp::exit called without toplevel - showing console" |
||||||
|
show_console |
||||||
|
return 0 |
||||||
|
} else { |
||||||
|
puts stderr "punkapp::exit called without toplevel - exiting" |
||||||
|
if {$waiting ne "no"} { |
||||||
|
if {[info exists result(shell)]} { |
||||||
|
set temp [set result(shell)] |
||||||
|
unset result(shell) |
||||||
|
set waiting $temp |
||||||
|
} else { |
||||||
|
set waiting "" |
||||||
|
} |
||||||
|
} else { |
||||||
|
::exit |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set controllable [get_user_controllable_toplevels] |
||||||
|
if {![llength $controllable]} { |
||||||
|
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||||
|
show_console |
||||||
|
} else { |
||||||
|
if {$waiting ne "no"} { |
||||||
|
if {[info exists result(shell)]} { |
||||||
|
set temp [set result(shell)] |
||||||
|
unset result(shell) |
||||||
|
set waiting $temp |
||||||
|
} elseif {[info exists result($toplevel)]} { |
||||||
|
set temp [set result($toplevel)] |
||||||
|
unset result($toplevel) |
||||||
|
set waiting $temp |
||||||
|
} elseif {[info exists default_result]} { |
||||||
|
set temp $default_result |
||||||
|
unset default_result |
||||||
|
set waiting $temp |
||||||
|
} else { |
||||||
|
set waiting "" |
||||||
|
} |
||||||
|
} else { |
||||||
|
::exit |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
proc close_window {toplevel} { |
||||||
|
wm withdraw $toplevel |
||||||
|
if {![llength [get_user_controllable_toplevels]]} { |
||||||
|
punkapp::exit $toplevel |
||||||
|
} |
||||||
|
destroy $toplevel |
||||||
|
} |
||||||
|
proc wait {args} { |
||||||
|
variable waiting |
||||||
|
variable default_result |
||||||
|
if {[dict exists $args -defaultresult]} { |
||||||
|
set default_result [dict get $args -defaultresult] |
||||||
|
} |
||||||
|
foreach t [punkapp::get_toplevels] { |
||||||
|
if {[wm protocol $t WM_DELETE_WINDOW] eq ""} { |
||||||
|
wm protocol $t WM_DELETE_WINDOW [list punkapp::close_window $t] |
||||||
|
} |
||||||
|
} |
||||||
|
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||||
|
puts stderr "repl eventloop seems to be running - punkapp::wait not required" |
||||||
|
} else { |
||||||
|
if {$waiting eq "no"} { |
||||||
|
set waiting "waiting" |
||||||
|
vwait ::punkapp::waiting |
||||||
|
return $::punkapp::waiting |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#A window can be 'visible' according to this - but underneath other windows etc |
||||||
|
#REVIEW - change name? |
||||||
|
proc get_visible_toplevels {{w .}} { |
||||||
|
if {![llength [info commands winfo]]} { |
||||||
|
return [list] |
||||||
|
} |
||||||
|
set list [get_toplevels $w] |
||||||
|
set mapped [lmap v $list {expr {[winfo ismapped $v] ? $v : {}}}] |
||||||
|
set mapped [concat {*}$mapped] ;#ignore {} |
||||||
|
set visible [list] |
||||||
|
foreach m $mapped { |
||||||
|
if {[wm overrideredirect $m] == 0 } { |
||||||
|
lappend visible $m |
||||||
|
} else { |
||||||
|
if {[winfo height $m] >1 && [winfo width $m] > 1} { |
||||||
|
#technically even a 1x1 is visible.. but in practice even a 10x10 is hardly likely to be noticeable when overrideredirect == 1 |
||||||
|
#as a convention - 1x1 with no controls is used to make a window invisible so we'll treat anything larger as visible |
||||||
|
lappend visible $m |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $visible |
||||||
|
} |
||||||
|
proc get_user_controllable_toplevels {{w .}} { |
||||||
|
set visible [get_visible_toplevels $w] |
||||||
|
set controllable [list] |
||||||
|
foreach v $visible { |
||||||
|
if {[wm overrideredirect $v] == 0} { |
||||||
|
lappend controllable $v |
||||||
|
} |
||||||
|
} |
||||||
|
#only return visible windows with overrideredirect == 0 because there exists some user control. |
||||||
|
#todo - review.. consider checking if position is outside screen areas? Technically controllable.. but not easily |
||||||
|
return $controllable |
||||||
|
} |
||||||
|
proc hide_console {args} { |
||||||
|
set opts [dict create -force 0] |
||||||
|
if {([llength $args] % 2) != 0} { |
||||||
|
error "hide_console expects pairs of arguments. e.g -force 1" |
||||||
|
} |
||||||
|
#set known_opts [dict keys $defaults] |
||||||
|
foreach {k v} $args { |
||||||
|
switch -- $k { |
||||||
|
-force { |
||||||
|
dict set opts $k $v |
||||||
|
} |
||||||
|
default { |
||||||
|
error "Unrecognised options '$k' known options: [dict keys $opts]" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
set force [dict get $opts -force] |
||||||
|
|
||||||
|
if {!$force} { |
||||||
|
if {![llength [get_user_controllable_toplevels]]} { |
||||||
|
puts stderr "Cannot hide console while no user-controllable windows available" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} |
||||||
|
if {$::tcl_platform(platform) eq "windows"} { |
||||||
|
#hide won't work for certain consoles cush as conemu,wezterm - and doesn't really make sense for tabbed windows anyway. |
||||||
|
#It would be nice if we could tell the console window to hide just the relevant tab - or the whole window if only one tab present - but this is unlikely to be possible in any standard way. |
||||||
|
#an ordinary cmd.exe or pwsh.exe or powershell.exe window can be hidden ok though. |
||||||
|
#(but with wezterm - process is cmd.exe - but it has style popup and can't be hidden with a twapi::hide_window call) |
||||||
|
package require twapi |
||||||
|
set h [twapi::get_console_window] |
||||||
|
set pid [twapi::get_window_process $h] |
||||||
|
set pinfo [twapi::get_process_info $pid -name] |
||||||
|
set pname [dict get $pinfo -name] |
||||||
|
set wstyle [twapi::get_window_style $h] |
||||||
|
#tclkitsh/tclsh? |
||||||
|
if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} { |
||||||
|
twapi::hide_window $h |
||||||
|
return 1 |
||||||
|
} else { |
||||||
|
puts stderr "punkapp::hide_console unable to hide this type of console window" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} else { |
||||||
|
#todo |
||||||
|
puts stderr "punkapp::hide_console unimplemented on this platform (todo)" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc show_console {} { |
||||||
|
if {$::tcl_platform(platform) eq "windows"} { |
||||||
|
package require twapi |
||||||
|
if {![catch {set h [twapi::get_console_window]} errM]} { |
||||||
|
twapi::show_window $h -activate -normal |
||||||
|
} else { |
||||||
|
#no console - assume launched from something like wish? |
||||||
|
catch {console show} |
||||||
|
} |
||||||
|
} else { |
||||||
|
#todo |
||||||
|
puts stderr "punkapp::show_console unimplemented on this platform" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
@ -0,0 +1,333 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punkcheck::cli 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
package require punk::mix::util |
||||||
|
|
||||||
|
namespace eval punkcheck::cli { |
||||||
|
namespace ensemble create |
||||||
|
#package require punk::overlay |
||||||
|
#punk::overlay::import_commandset debug. ::punk:mix::commandset::debug |
||||||
|
|
||||||
|
#init proc required - used for lazy loading of commandsets |
||||||
|
variable initialised 0 |
||||||
|
proc _init {args} { |
||||||
|
variable initialised |
||||||
|
if {$initialised} { |
||||||
|
return |
||||||
|
} |
||||||
|
puts stderr "punkcheck::cli::init $args" |
||||||
|
|
||||||
|
set initialised 1 |
||||||
|
} |
||||||
|
|
||||||
|
proc help {args} { |
||||||
|
set basehelp [punk::mix::base help {*}$args] |
||||||
|
return $basehelp |
||||||
|
} |
||||||
|
|
||||||
|
proc paths {{path {}}} { |
||||||
|
if {$path eq {}} { set path [pwd] } |
||||||
|
set search_from $path |
||||||
|
set bottom_to_top [list] |
||||||
|
while {[string length [set pcheck_file [punkcheck::cli::lib::find_nearest_file $search_from]]]} { |
||||||
|
set pcheck_folder [file dirname $pcheck_file] |
||||||
|
lappend bottom_to_top $pcheck_file |
||||||
|
set search_from [file dirname $pcheck_folder] |
||||||
|
} |
||||||
|
return $bottom_to_top |
||||||
|
} |
||||||
|
#todo! - group by fileset |
||||||
|
proc status {{path {}}} { |
||||||
|
if {$path eq {}} { set path [pwd] } |
||||||
|
set fullpath [file normalize $path] |
||||||
|
|
||||||
|
set ftype [file type $fullpath] |
||||||
|
|
||||||
|
|
||||||
|
set files [list] |
||||||
|
if {$ftype eq "file"} { |
||||||
|
set container [file dirname $fullpath] |
||||||
|
lappend files $fullpath |
||||||
|
} else { |
||||||
|
set container $fullpath |
||||||
|
#vfs can mask mounted files - so we can't just use 'file type' or glob with -type f |
||||||
|
##set files [glob -nocomplain -dir $fullpath -type f *] |
||||||
|
package require punk::nav::fs |
||||||
|
set folderinfo [punk::nav::fs::dirfiles_dict $fullpath] |
||||||
|
set files [concat [dict get $folderinfo files] [dict get $folderinfo underlayfiles]] |
||||||
|
} |
||||||
|
set punkcheck_files [paths $container] |
||||||
|
set repodict [punk::repo::find_repo $container] |
||||||
|
|
||||||
|
if {![llength $punkcheck_files]} { |
||||||
|
puts stderr "No .punkcheck files found at or above this folder" |
||||||
|
} |
||||||
|
|
||||||
|
set table "" |
||||||
|
set files_with_records [list] |
||||||
|
foreach p $punkcheck_files { |
||||||
|
set basedir [file dirname $p] |
||||||
|
set recordlist [punkcheck::load_records_from_file $p] |
||||||
|
set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist] |
||||||
|
|
||||||
|
foreach f $files { |
||||||
|
set relpath [punkcheck::lib::path_relative $basedir $f] |
||||||
|
|
||||||
|
if {[dict exists $tgt_dict $relpath]} { |
||||||
|
set filerec [dict get $tgt_dict $relpath] |
||||||
|
set records [punkcheck::dict_getwithdefault $filerec body [list]] |
||||||
|
if {$ftype eq "file"} { |
||||||
|
if {![llength $records]} { |
||||||
|
set pcheck "(has file record but no installation entries)" |
||||||
|
} else { |
||||||
|
set pcheck \n |
||||||
|
foreach irec $records { |
||||||
|
append pcheck [punk::tdl::prettyprint [list $irec] 1] \n |
||||||
|
#append pcheck " $irec" \n |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
if {![llength $records]} { |
||||||
|
set pcheck "(has file record but no installation entries)" |
||||||
|
} else { |
||||||
|
set display_records [list] |
||||||
|
set pcheck \n |
||||||
|
set latest_install_record [punkcheck::recordlist::file_record_latest_installrecord $filerec] |
||||||
|
if {[llength $latest_install_record]} { |
||||||
|
lappend display_records $latest_install_record |
||||||
|
} |
||||||
|
if {$latest_install_record ne [lindex $records end]} { |
||||||
|
lappend display_records [lindex $records end] |
||||||
|
} |
||||||
|
foreach irec $display_records { |
||||||
|
append pcheck "[format %-14s [dict get $irec tag]] [punkcheck::dict_getwithdefault $irec -tsiso "no-timestamp"]" |
||||||
|
set bodyrecords [punkcheck::dict_getwithdefault $irec body [list]] |
||||||
|
set source_files [list] |
||||||
|
set source_files_changed [list] |
||||||
|
set source_folders [list] |
||||||
|
set source_folders_changed [list] |
||||||
|
foreach r $bodyrecords { |
||||||
|
if {[dict get $r tag] eq "SOURCE"} { |
||||||
|
set path [dict get $r -path] |
||||||
|
set changed [dict get $r -changed] |
||||||
|
switch -- [dict get $r -type] { |
||||||
|
file { |
||||||
|
lappend source_files $path |
||||||
|
if {$changed} { |
||||||
|
lappend source_files_changed $path |
||||||
|
} |
||||||
|
} |
||||||
|
directory { |
||||||
|
lappend source_folders $path |
||||||
|
if {$changed} { |
||||||
|
lappend source_folders_changed $path |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
if {[llength $source_files]} { |
||||||
|
append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])" |
||||||
|
} |
||||||
|
if {[llength $source_folders]} { |
||||||
|
append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])" |
||||||
|
} |
||||||
|
append pcheck \n |
||||||
|
|
||||||
|
#append pcheck [punk::tdl::prettyprint [list $irec] 1] \n |
||||||
|
#append pcheck " $irec" \n |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
append table "$f $pcheck" \n |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $table |
||||||
|
} |
||||||
|
proc status_by_file {{path {}}} { |
||||||
|
if {$path eq {}} { set path [pwd] } |
||||||
|
set fullpath [file normalize $path] |
||||||
|
set ftype [file type $fullpath] |
||||||
|
set files [list] |
||||||
|
if {$ftype eq "file"} { |
||||||
|
set container [file dirname $fullpath] |
||||||
|
lappend files $fullpath |
||||||
|
} else { |
||||||
|
set container $fullpath |
||||||
|
set files [glob -nocomplain -dir $fullpath -type f *] |
||||||
|
} |
||||||
|
set punkcheck_files [paths $container] |
||||||
|
set repodict [punk::repo::find_repo $container] |
||||||
|
|
||||||
|
if {![llength $punkcheck_files]} { |
||||||
|
puts stderr "No .punkcheck files found at or above this folder" |
||||||
|
} |
||||||
|
|
||||||
|
set table "" |
||||||
|
set files_with_records [list] |
||||||
|
foreach p $punkcheck_files { |
||||||
|
set basedir [file dirname $p] |
||||||
|
set recordlist [punkcheck::load_records_from_file $p] |
||||||
|
set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist] |
||||||
|
foreach f $files { |
||||||
|
set relpath [punkcheck::lib::path_relative $basedir $f] |
||||||
|
|
||||||
|
if {[dict exists $tgt_dict $relpath]} { |
||||||
|
set filerec [dict get $tgt_dict $relpath] |
||||||
|
set records [punkcheck::dict_getwithdefault $filerec body [list]] |
||||||
|
if {$ftype eq "file"} { |
||||||
|
if {![llength $records]} { |
||||||
|
set pcheck "(has file record but no installation entries)" |
||||||
|
} else { |
||||||
|
set pcheck \n |
||||||
|
foreach irec $records { |
||||||
|
append pcheck [punk::tdl::prettyprint [list $irec] 1] \n |
||||||
|
#append pcheck " $irec" \n |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
if {![llength $records]} { |
||||||
|
set pcheck "(has file record but no installation entries)" |
||||||
|
} else { |
||||||
|
set display_records [list] |
||||||
|
set pcheck \n |
||||||
|
set latest_install_record [punkcheck::recordlist::file_record_latest_installrecord $filerec] |
||||||
|
lappend display_records $latest_install_record |
||||||
|
if {$latest_install_record ne [lindex $records end]} { |
||||||
|
lappend display_records [lindex $records end] |
||||||
|
} |
||||||
|
foreach irec $display_records { |
||||||
|
append pcheck "[format %-14s [dict get $irec tag]] [punkcheck::dict_getwithdefault $irec -tsiso "no-timestamp"]" |
||||||
|
set bodyrecords [punkcheck::dict_getwithdefault $irec body [list]] |
||||||
|
set source_files [list] |
||||||
|
set source_files_changed [list] |
||||||
|
set source_folders [list] |
||||||
|
set source_folders_changed [list] |
||||||
|
foreach r $bodyrecords { |
||||||
|
if {[dict get $r tag] eq "SOURCE"} { |
||||||
|
set path [dict get $r -path] |
||||||
|
set changed [dict get $r -changed] |
||||||
|
switch -- [dict get $r -type] { |
||||||
|
file { |
||||||
|
lappend source_files $path |
||||||
|
if {$changed} { |
||||||
|
lappend source_files_changed $path |
||||||
|
} |
||||||
|
} |
||||||
|
directory { |
||||||
|
lappend source_folders $path |
||||||
|
if {$changed} { |
||||||
|
lappend source_folders_changed $path |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
if {[llength $source_files]} { |
||||||
|
append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])" |
||||||
|
} |
||||||
|
if {[llength $source_folders]} { |
||||||
|
append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])" |
||||||
|
} |
||||||
|
append pcheck \n |
||||||
|
|
||||||
|
#append pcheck [punk::tdl::prettyprint [list $irec] 1] \n |
||||||
|
#append pcheck " $irec" \n |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
append table "$f $pcheck" \n |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $table |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punkcheck::cli::lib { |
||||||
|
namespace path ::punk::mix::util ;#askuser, do_in_path, foreach-file etc |
||||||
|
|
||||||
|
proc find_nearest_file {{path {}}} { |
||||||
|
if {$path eq {}} { set path [pwd] } |
||||||
|
set folder [lib::scanup $path lib::is_punkchecked_folder] |
||||||
|
if {$folder eq ""} { |
||||||
|
return "" |
||||||
|
} else { |
||||||
|
return [file join $folder .punkcheck] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc is_punkchecked_folder {{path {}}} { |
||||||
|
if {$path eq {}} { set path [pwd] } |
||||||
|
foreach control { |
||||||
|
.punkcheck |
||||||
|
} { |
||||||
|
set control [file join $path $control] |
||||||
|
if {[file isfile $control]} {return 1} |
||||||
|
} |
||||||
|
return 0 |
||||||
|
} |
||||||
|
|
||||||
|
proc scanup {path cmd} { |
||||||
|
if {$path eq {}} { set path [pwd] } |
||||||
|
#based on kettle::path::scanup |
||||||
|
if {[file pathtype $path] eq "relative"} { |
||||||
|
set path [file normalize $path] |
||||||
|
} |
||||||
|
while {1} { |
||||||
|
# Found the proper directory, per the predicate. |
||||||
|
if {[{*}$cmd $path]} { return $path } |
||||||
|
|
||||||
|
# Not found, walk to parent |
||||||
|
set new [file dirname $path] |
||||||
|
|
||||||
|
# Stop when reaching the root. |
||||||
|
if {$new eq $path} { return {} } |
||||||
|
if {$new eq {}} { return {} } |
||||||
|
|
||||||
|
# Ok, truly walk up. |
||||||
|
set path $new |
||||||
|
} |
||||||
|
return {} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punkcheck::cli { |
||||||
|
proc _cli {args} { |
||||||
|
#don't use tailcall - base uses info level to determine caller |
||||||
|
::punk::mix::base::_cli {*}$args |
||||||
|
} |
||||||
|
variable default_command status |
||||||
|
package require punk::mix::base |
||||||
|
package require punk::overlay |
||||||
|
punk::overlay::custom_from_base [namespace current] ::punk::mix::base |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punkcheck::cli [namespace eval punkcheck::cli { |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
|
Loading…
Reference in new issue