Browse Source
Resolves the build-maintenance TODO: built module trees no longer accumulate superseded intermediate versions, and .punkcheck state stays consistent because every deletion is recorded through punkcheck's event mechanism. punkcheck (0.3.0): - installsource_add_virtual + installevent method targetset_addsource_virtual: 'virtual' named-value SOURCE records (-type virtual -path virtual:<id> -value <v>) compared by stored value, participating in targetset_source_changes. Needed because successive module versions are built from the same physical source files - the recorded virtual module_name/module_version identify which product of the source fileset a target is, at install and delete time. punk::mix::cli (0.5.0): - lib::prune_superseded_target_modules: deletes lower-version .tm siblings only when records prove the same module line (virtual module_name match, or legacy fallback: recorded sources share the keep-version's source folder(s) and name prefix). Unrecorded files are never deleted - reported to stderr instead. - lib::prune_sourcevanished_targets: mirror-prune of recorded targets whose recorded source files no longer exist (layout bootsupport copies, vendormodule copies) - intentional multi-version vendoring is preserved. - build_modules_from_source_to_base prunes after each module install/skip and records virtual module identity sources on installs. make.tcl: - bootsupport: non-glob include_modules.config entries track only the latest version - superseded recorded snapshot versions pruned; project-layout copies mirror-pruned; virtual identity recorded on snapshot installs. Calls guarded (info commands) so a stale bootsupport snapshot degrades to a warning and the two-pass modules+bootsupport bootstrap self-heals. - vendormodule copies in root modules*/ mirror-pruned after install. docs/config: - include_modules.config headers now document the entry format (non-glob = latest-only + prune; glob chars = keep all matches; unrecorded never pruned) - src/AGENTS.md TODO replaced with the durable prune contract; src/bootsupport/AGENTS.md + src/tests/modules/AGENTS.md updated tests: src/tests/modules/punk/mix/testsuites/cli/prune.test (19 tests) covering virtual source recording/comparison and prune identity/safety rules. Suites: punkcheck 64/64, full suite under Tcl 9.0.3 green except pre-existing exec-14.3. payload sync: bootsupport snapshots, project layouts and _vfscommon.vfs pruned of superseded intermediates (~570k lines of stale .tm copies removed). Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.commaster
234 changed files with 2272 additions and 574044 deletions
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,201 +0,0 @@
|
||||
#JMN - api should be kept in sync with package patternlib where possible |
||||
# |
||||
package provide oolib [namespace eval oolib { |
||||
variable version |
||||
set version 0.1.2 |
||||
}] |
||||
|
||||
namespace eval oolib { |
||||
oo::class create collection { |
||||
variable o_data ;#dict |
||||
#variable o_alias |
||||
constructor {} { |
||||
set o_data [dict create] |
||||
} |
||||
method info {} { |
||||
return [dict info $o_data] |
||||
} |
||||
method count {} { |
||||
return [dict size $o_data] |
||||
} |
||||
method isEmpty {} { |
||||
expr {[dict size $o_data] == 0} |
||||
} |
||||
method names {{globOrIdx {}}} { |
||||
if {[llength $globOrIdx]} { |
||||
if {[string is integer -strict $globOrIdx]} { |
||||
set idx $globOrIdx |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $idx} result]} { |
||||
error "[self object] no such index : '$idx'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} else { |
||||
#glob |
||||
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] |
||||
} |
||||
} else { |
||||
return [dict keys $o_data] |
||||
} |
||||
} |
||||
#like names but without globbing |
||||
method keys {} { |
||||
dict keys $o_data |
||||
} |
||||
method key {{posn 0}} { |
||||
if {$posn < 0} { |
||||
set posn "end-[expr {abs($posn + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $posn} result]} { |
||||
error "[self object] no such index : '$posn'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} |
||||
method hasKey {key} { |
||||
dict exists $o_data $key |
||||
} |
||||
method get {} { |
||||
return $o_data |
||||
} |
||||
method items {} { |
||||
return [dict values $o_data] |
||||
} |
||||
method item {key} { |
||||
if {[string is integer -strict $key]} { |
||||
if {$key >= 0} { |
||||
set valposn [expr {(2*$key) +1}] |
||||
return [lindex $o_data $valposn] |
||||
} else { |
||||
set key "end-[expr {abs($key + 1)}]" |
||||
return [lindex $o_data $key] |
||||
#return [lindex [dict keys $o_data] $key] |
||||
} |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
return [dict get $o_data $key] |
||||
} |
||||
} |
||||
#inverse lookup |
||||
method itemKeys {value} { |
||||
set value_indices [lsearch -all [dict values $o_data] $value] |
||||
set keylist [list] |
||||
foreach i $value_indices { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
method search {value args} { |
||||
set matches [lsearch {*}$args [dict values $o_data] $value] |
||||
if {"-inline" in $args} { |
||||
return $matches |
||||
} else { |
||||
set keylist [list] |
||||
foreach i $matches { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
} |
||||
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? |
||||
#review - what is the point of alias anyway? - why slow down other operations when a variable can hold a keyname perfectly well? |
||||
#method alias {newAlias existingKeyOrAlias} { |
||||
# if {[string is integer -strict $newAlias]} { |
||||
# error "[self object] collection key alias cannot be integer" |
||||
# } |
||||
# if {[string length $existingKeyOrAlias]} { |
||||
# set o_alias($newAlias) $existingKeyOrAlias |
||||
# } else { |
||||
# unset o_alias($newAlias) |
||||
# } |
||||
#} |
||||
#method aliases {{key ""}} { |
||||
# if {[string length $key]} { |
||||
# set result [list] |
||||
# foreach {n v} [array get o_alias] { |
||||
# if {$v eq $key} { |
||||
# lappend result $n $v |
||||
# } |
||||
# } |
||||
# return $result |
||||
# } else { |
||||
# return [array get o_alias] |
||||
# } |
||||
#} |
||||
##if the supplied index is an alias, return the underlying key; else return the index supplied. |
||||
#method realKey {idx} { |
||||
# if {[catch {set o_alias($idx)} key]} { |
||||
# return $idx |
||||
# } else { |
||||
# return $key |
||||
# } |
||||
#} |
||||
method add {value key} { |
||||
if {[string is integer -strict $key]} { |
||||
error "[self object] collection key must not be an integer. Use another structure if integer keys required" |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
error "[self object] col_processors object error: key '$key' already exists in collection" |
||||
} |
||||
dict set o_data $key $value |
||||
return [expr {[dict size $o_data] - 1}] ;#return index of item |
||||
} |
||||
method remove {idx {endRange ""}} { |
||||
if {[string length $endRange]} { |
||||
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" |
||||
} |
||||
if {[string is integer -strict $idx]} { |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx+1)}]" |
||||
} |
||||
set key [lindex [dict keys $o_data] $idx] |
||||
set posn $idx |
||||
} else { |
||||
set key $idx |
||||
set posn [lsearch -exact [dict keys $o_data] $key] |
||||
if {$posn < 0} { |
||||
error "[self object] no such index: '$idx' in this collection" |
||||
} |
||||
} |
||||
dict unset o_data $key |
||||
return |
||||
} |
||||
method clear {} { |
||||
set o_data [dict create] |
||||
return |
||||
} |
||||
method reverse_the_collection {} { |
||||
#named slightly obtusely because reversing the data when there may be references held is a potential source of bugs |
||||
#the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy. |
||||
#todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations. |
||||
set dictnew [dict create] |
||||
foreach k [lreverse [dict keys $o_data]] { |
||||
dict set dictnew $k [dict get $o_data $k] |
||||
} |
||||
set o_data $dictnew |
||||
return |
||||
} |
||||
#review - cmd as list vs cmd as script? |
||||
method map {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list {*}$cmd $v]] |
||||
} |
||||
return $seed |
||||
} |
||||
method objectmap {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list $v {*}$cmd]] |
||||
} |
||||
return $seed |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
@ -1,361 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.4.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) 2026 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application opunk::console 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
package require Tcl 8.6- |
||||
|
||||
package require voo |
||||
package require punk::args |
||||
|
||||
#opunk::Console - a voo (value-based) representation of a console: an in/out channel pair claimed to |
||||
#belong to one responding endpoint, together with settled capability facts about that endpoint. |
||||
# |
||||
#Motivation (see punk::console get_size / get_ansi_response_payload history): |
||||
#ANSI query mechanisms assume the input channel receives what the output channel's device emits in |
||||
#response. When stdio is redirected that pairing silently breaks - queries go to a terminal whose |
||||
#replies land in some other process's input. A console object makes the pairing an explicit, |
||||
#construction-time property instead of a per-query-site guess. |
||||
# |
||||
#Design notes: |
||||
# - Objects are voo values (plain lists). Consoles are entities, not values - so canonical instances |
||||
# are anchored at well-known namespace variables (::opunk::console::instances::<name>) and the value |
||||
# semantics serve as cheap snapshots. Mutation (settling capabilities) goes through the anchor via |
||||
# the lowercase ::opunk::console wrapper procs. |
||||
# - The class is -virtual: slot 0 of each value carries the concrete class namespace, so channel |
||||
# environments that respond like terminals but aren't platform consoles can subclass |
||||
# (-extends ::opunk::Console) and override the capability/size methods, with existing holders of |
||||
# console values dispatching correctly. |
||||
# - This first cut is standalone and passive: capability detection is heuristic (channel options, |
||||
# probed eof, terminal env hints) and size uses chan -winsize else the default size. Active ANSI |
||||
# query probing arrives with punk::console integration (which will delegate here rather than the |
||||
# class depending on punk::console). |
||||
|
||||
tcl::namespace::eval ::opunk::console { |
||||
variable PUNKARGS |
||||
|
||||
#well-known cooperative store for bytes consumed by probe reads on pipe-like channels |
||||
#dict keyed by channel name -> list of chunks. Readers taking over a channel should consume |
||||
#and clear any entry for that channel first. (analogous to punk::console::input_chunks_waiting) |
||||
variable waiting_chunks |
||||
if {![info exists waiting_chunks]} { |
||||
set waiting_chunks [dict create] |
||||
} |
||||
} |
||||
|
||||
voo::class ::opunk::Console -virtual { |
||||
private { |
||||
#o_ prefix per opunk voo convention (distinguishes fields from locals in -update methods, |
||||
#and matches tclOO-style implementations elsewhere for easier code movement). |
||||
#Note the class is -virtual: slot 0 of the object value is the concrete class namespace tag. |
||||
string_t o_in stdin |
||||
string_t o_out stdout |
||||
string_t o_terminal_class "" ;#e.g windows-console, tty, pipe - "" until classified |
||||
list_t o_size_mechanism [list] ;#preferred size mechanism try-order - empty until timed/settled |
||||
dict_t o_default_size [dict create columns 80 rows 24] |
||||
} |
||||
public { |
||||
#settled response capability: -1 unknown, 0 cannot respond, 1 can respond. |
||||
#public accessors (get.o_can_respond / set.o_can_respond) so the anchored-mutation wrappers in |
||||
#::opunk::console can settle it without reaching into private my.* accessors. |
||||
int_t o_can_respond -1 |
||||
|
||||
method in {} { |
||||
my.get.o_in $this |
||||
} |
||||
method out {} { |
||||
my.get.o_out $this |
||||
} |
||||
method channels {} { |
||||
list [my.get.o_in $this] [my.get.o_out $this] |
||||
} |
||||
method terminal_class {} { |
||||
my.get.o_terminal_class $this |
||||
} |
||||
method default_size {} { |
||||
my.get.o_default_size $this |
||||
} |
||||
|
||||
#Certainty test: is the input channel closed or at eof (and so can never deliver a response)? |
||||
#A consumed/half-closed pipe may not flag eof until a read is attempted, so pipe-like channels |
||||
#get a non-blocking 1-byte probe. A probed byte is preserved in ::opunk::console::waiting_chunks |
||||
#for cooperating readers. Console/tty channels are never probed (must not consume a keystroke). |
||||
method at_eof {} -virtual { |
||||
if {[llength $this] < 7} { |
||||
error "invalid object $this" |
||||
} |
||||
set in [my.get.o_in $this] |
||||
if {[catch {chan eof $in} is_eof]} { |
||||
return 1 ;#closed/invalid channel - unusable |
||||
} |
||||
if {$is_eof} { |
||||
return 1 |
||||
} |
||||
if {[catch {chan configure $in} conf]} { |
||||
return 1 |
||||
} |
||||
if {[dict exists $conf -inputmode] || [dict exists $conf -mode]} { |
||||
return 0 |
||||
} |
||||
if {[catch { |
||||
set prior_blocking [dict get $conf -blocking] |
||||
chan configure $in -blocking 0 |
||||
set probe [read $in 1] |
||||
chan configure $in -blocking $prior_blocking |
||||
}]} { |
||||
return 1 |
||||
} |
||||
if {$probe ne ""} { |
||||
dict lappend ::opunk::console::waiting_chunks $in $probe |
||||
} |
||||
return [chan eof $in] |
||||
} |
||||
|
||||
#Heuristic: could the input channel be connected to a terminal able to answer queries? |
||||
#Returns 0 only when reasonably confident it cannot. mintty without winpty presents a |
||||
#terminal's stdin as a plain pipe, so env hints (MSYSTEM, TERM_PROGRAM) prevent false |
||||
#negatives there at the cost of false positives for genuinely piped-but-open input. |
||||
method is_console_or_tty {} -virtual { |
||||
if {[llength $this] < 7} { |
||||
error "invalid object $this" |
||||
} |
||||
set in [my.get.o_in $this] |
||||
if {[catch {chan configure $in} conf]} { |
||||
return 0 |
||||
} |
||||
if {[dict exists $conf -inputmode]} { |
||||
return 1 |
||||
} |
||||
if {[dict exists $conf -mode]} { |
||||
return 1 |
||||
} |
||||
if {[at_eof $this]} { |
||||
return 0 |
||||
} |
||||
if {[info exists ::env(TERM_PROGRAM)] || [info exists ::env(MSYSTEM)]} { |
||||
return 1 |
||||
} |
||||
return 0 |
||||
} |
||||
|
||||
#Response capability: settled value if known, else computed heuristically (without settling - |
||||
#this method is pure; use ::opunk::console::can_respond <name> to settle an anchored instance). |
||||
#TODO: active probe query (device attributes with timeout) when punk::console query machinery |
||||
#is integrated - heuristics can then be replaced by one settling probe at first use. |
||||
method can_respond {} -virtual { |
||||
if {[llength $this] < 7} { |
||||
error "invalid object $this" |
||||
} |
||||
set settled [get.o_can_respond $this] |
||||
if {$settled != -1} { |
||||
return $settled |
||||
} |
||||
return [is_console_or_tty $this] |
||||
} |
||||
|
||||
#Size of the console: chan -winsize on the output channel when available (fast, no query), |
||||
#else the configured default size. ANSI cursor-report mechanisms are deliberately absent from |
||||
#this standalone class - they arrive via punk::console integration and subclasses. |
||||
method size {} -virtual { |
||||
if {[llength $this] < 7} { |
||||
error "invalid object $this" |
||||
} |
||||
set out [my.get.o_out $this] |
||||
if {![catch {chan configure $out} oconf]} { |
||||
if {[dict exists $oconf -winsize]} { |
||||
lassign [dict get $oconf -winsize] cols lines |
||||
if {[string is integer -strict $cols] && [string is integer -strict $lines]} { |
||||
return [dict create columns $cols rows $lines] |
||||
} |
||||
} |
||||
} |
||||
return [my.get.o_default_size $this] |
||||
} |
||||
} |
||||
|
||||
constructor {in out} { |
||||
#new() supplies the class defaults including the virtual class tag at slot 0 |
||||
set obj [new()] |
||||
my.set.o_in obj $in |
||||
my.set.o_out obj $out |
||||
return $obj |
||||
} |
||||
} |
||||
|
||||
#make introspection (with i and punk::ns::cmdinfo) easier by making the class namespace an ensemble - we can still access it as ::opunk::Console |
||||
namespace eval ::opunk::Console { |
||||
namespace ensemble create |
||||
} |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Anchored instances - the 'consoles are entities' layer |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval ::opunk::console { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
|
||||
namespace eval instances { |
||||
#one variable per anchored console instance - the canonical location of each console object. |
||||
#Access via the sibling procs; methods needing to mutate an instance go through these anchors. |
||||
} |
||||
|
||||
proc create {name in out} { |
||||
if {![string is wordchar -strict $name]} { |
||||
error "opunk::console::create name must be alphanumeric/underscore, got '$name'" |
||||
} |
||||
set [namespace current]::instances::$name [::opunk::Console::new $in $out] |
||||
return [namespace current]::instances::$name |
||||
} |
||||
proc instancevar {name} { |
||||
set v [namespace current]::instances::$name |
||||
if {![info exists $v]} { |
||||
error "opunk::console: no anchored console instance named '$name' (known: [names])" |
||||
} |
||||
return $v |
||||
} |
||||
proc instance {name} { |
||||
set [instancevar $name] |
||||
} |
||||
proc names {} { |
||||
set result [list] |
||||
foreach v [info vars [namespace current]::instances::*] { |
||||
lappend result [namespace tail $v] |
||||
} |
||||
return $result |
||||
} |
||||
proc forget {name} { |
||||
unset [instancevar $name] |
||||
return |
||||
} |
||||
|
||||
#settle-and-cache response capability on the anchored instance. |
||||
#The class method is pure (value-in) - this wrapper owns the mutation via the anchor. |
||||
proc can_respond {name} { |
||||
upvar #0 [instancevar $name] obj |
||||
set settled [::opunk::Console::get.o_can_respond $obj] |
||||
if {$settled != -1} { |
||||
return $settled |
||||
} |
||||
set r [::opunk::Console::can_respond $obj] |
||||
::opunk::Console::set.o_can_respond obj $r |
||||
return $r |
||||
} |
||||
proc size {name} { |
||||
::opunk::Console::size [instance $name] |
||||
} |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# == === === === === === === === === === === === === === === |
||||
# Sample 'about' function with punk::args documentation |
||||
# == === === === === === === === === === === === === === === |
||||
tcl::namespace::eval ::opunk::console { |
||||
variable PUNKARGS |
||||
variable PUNKARGS_aliases |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)opunk::console" |
||||
@package -name "opunk::console" -help\ |
||||
"voo class ::opunk::Console representing a console as an in/out channel pair with settled |
||||
response-capability facts, plus anchored canonical instances under ::opunk::console::instances." |
||||
}] |
||||
|
||||
namespace eval argdoc { |
||||
proc package_name {} { |
||||
return opunk::console |
||||
} |
||||
proc about_topics {} { |
||||
set topic_funs [info commands [namespace current]::get_topic_*] |
||||
set about_topics [list] |
||||
foreach f $topic_funs { |
||||
set tail [namespace tail $f] |
||||
lappend about_topics [string range $tail [string length get_topic_] end] |
||||
} |
||||
return [lsort $about_topics] |
||||
} |
||||
proc default_topics {} {return [list Description *]} |
||||
|
||||
proc get_topic_Description {} { |
||||
punk::args::lib::tstr [string trim { |
||||
package opunk::console |
||||
voo class for consoles as channel-pair objects with anchored canonical instances. |
||||
} \n] |
||||
} |
||||
proc get_topic_License {} { |
||||
return "BSD" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return "$::opunk::console::version" |
||||
} |
||||
proc get_topic_Contributors {} { |
||||
set authors {{"Julian Noble" "julian@precisium.com.au"}} |
||||
set contributors "" |
||||
foreach a $authors { |
||||
append contributors $a \n |
||||
} |
||||
if {[string index $contributors end] eq "\n"} { |
||||
set contributors [string range $contributors 0 end-1] |
||||
} |
||||
return $contributors |
||||
} |
||||
proc get_topic_classes {} { |
||||
punk::args::lib::tstr -return string { |
||||
opunk::Console "virtual class for consoles as in/out channel pairs" |
||||
} |
||||
} |
||||
} |
||||
|
||||
set overrides [dict create] |
||||
dict set overrides @id -id "::opunk::console::about" |
||||
dict set overrides @cmd -name "opunk::console::about" |
||||
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||
About opunk::console |
||||
}] \n] |
||||
dict set overrides topic -choices [list {*}[opunk::console::argdoc::about_topics] *] |
||||
dict set overrides topic -choicerestricted 1 |
||||
dict set overrides topic -default [opunk::console::argdoc::default_topics] |
||||
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||
lappend PUNKARGS [list $newdef] |
||||
proc about {args} { |
||||
package require punk::args |
||||
set argd [punk::args::parse $args withid ::opunk::console::about] |
||||
lassign [dict values $argd] _leaders opts values _received |
||||
punk::args::package::standard_about -package_about_namespace ::opunk::console::argdoc {*}$opts {*}[dict get $values topic] |
||||
} |
||||
} |
||||
# end of sample 'about' function |
||||
# == === === === === === === === === === === === === === === |
||||
|
||||
|
||||
# ----------------------------------------------------------------------------- |
||||
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
||||
# ----------------------------------------------------------------------------- |
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::opunk::console ::opunk::Console |
||||
} |
||||
# ----------------------------------------------------------------------------- |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide opunk::console [tcl::namespace::eval ::opunk::console { |
||||
variable pkg opunk::console |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -1,361 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.4.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) 2026 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application opunk::console 0.1.1 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
package require Tcl 8.6- |
||||
|
||||
package require voo |
||||
package require punk::args |
||||
|
||||
#opunk::Console - a voo (value-based) representation of a console: an in/out channel pair claimed to |
||||
#belong to one responding endpoint, together with settled capability facts about that endpoint. |
||||
# |
||||
#Motivation (see punk::console get_size / get_ansi_response_payload history): |
||||
#ANSI query mechanisms assume the input channel receives what the output channel's device emits in |
||||
#response. When stdio is redirected that pairing silently breaks - queries go to a terminal whose |
||||
#replies land in some other process's input. A console object makes the pairing an explicit, |
||||
#construction-time property instead of a per-query-site guess. |
||||
# |
||||
#Design notes: |
||||
# - Objects are voo values (plain lists). Consoles are entities, not values - so canonical instances |
||||
# are anchored at well-known namespace variables (::opunk::console::instances::<name>) and the value |
||||
# semantics serve as cheap snapshots. Mutation (settling capabilities) goes through the anchor via |
||||
# the lowercase ::opunk::console wrapper procs. |
||||
# - The class is -virtual: slot 0 of each value carries the concrete class namespace, so channel |
||||
# environments that respond like terminals but aren't platform consoles can subclass |
||||
# (-extends ::opunk::Console) and override the capability/size methods, with existing holders of |
||||
# console values dispatching correctly. |
||||
# - This first cut is standalone and passive: capability detection is heuristic (channel options, |
||||
# probed eof, terminal env hints) and size uses chan -winsize else the default size. Active ANSI |
||||
# query probing arrives with punk::console integration (which will delegate here rather than the |
||||
# class depending on punk::console). |
||||
|
||||
tcl::namespace::eval ::opunk::console { |
||||
variable PUNKARGS |
||||
|
||||
#well-known cooperative store for bytes consumed by probe reads on pipe-like channels |
||||
#dict keyed by channel name -> list of chunks. Readers taking over a channel should consume |
||||
#and clear any entry for that channel first. (analogous to punk::console::input_chunks_waiting) |
||||
variable waiting_chunks |
||||
if {![info exists waiting_chunks]} { |
||||
set waiting_chunks [dict create] |
||||
} |
||||
} |
||||
|
||||
voo::class ::opunk::Console -virtual { |
||||
private { |
||||
#o_ prefix per opunk voo convention (distinguishes fields from locals in -update methods, |
||||
#and matches tclOO-style implementations elsewhere for easier code movement). |
||||
#Note the class is -virtual: slot 0 of the object value is the concrete class namespace tag. |
||||
string_t o_in stdin |
||||
string_t o_out stdout |
||||
string_t o_terminal_class "" ;#e.g windows-console, tty, pipe - "" until classified |
||||
list_t o_size_mechanism [list] ;#preferred size mechanism try-order - empty until timed/settled |
||||
dict_t o_default_size [dict create columns 80 rows 24] |
||||
} |
||||
public { |
||||
#settled response capability: -1 unknown, 0 cannot respond, 1 can respond. |
||||
#public accessors (get.o_can_respond / set.o_can_respond) so the anchored-mutation wrappers in |
||||
#::opunk::console can settle it without reaching into private my.* accessors. |
||||
int_t o_can_respond -1 |
||||
|
||||
method in {} { |
||||
my.get.o_in $this |
||||
} |
||||
method out {} { |
||||
my.get.o_out $this |
||||
} |
||||
method channels {} { |
||||
list [my.get.o_in $this] [my.get.o_out $this] |
||||
} |
||||
method terminal_class {} { |
||||
my.get.o_terminal_class $this |
||||
} |
||||
method default_size {} { |
||||
my.get.o_default_size $this |
||||
} |
||||
|
||||
#Certainty test: is the input channel closed or at eof (and so can never deliver a response)? |
||||
#A consumed/half-closed pipe may not flag eof until a read is attempted, so pipe-like channels |
||||
#get a non-blocking 1-byte probe. A probed byte is preserved in ::opunk::console::waiting_chunks |
||||
#for cooperating readers. Console/tty channels are never probed (must not consume a keystroke). |
||||
method at_eof {} -virtual { |
||||
if {[llength $this] < 7} { |
||||
error "invalid object $this" |
||||
} |
||||
set in [my.get.o_in $this] |
||||
if {[catch {chan eof $in} is_eof]} { |
||||
return 1 ;#closed/invalid channel - unusable |
||||
} |
||||
if {$is_eof} { |
||||
return 1 |
||||
} |
||||
if {[catch {chan configure $in} conf]} { |
||||
return 1 |
||||
} |
||||
if {[dict exists $conf -inputmode] || [dict exists $conf -mode]} { |
||||
return 0 |
||||
} |
||||
if {[catch { |
||||
set prior_blocking [dict get $conf -blocking] |
||||
chan configure $in -blocking 0 |
||||
set probe [read $in 1] |
||||
chan configure $in -blocking $prior_blocking |
||||
}]} { |
||||
return 1 |
||||
} |
||||
if {$probe ne ""} { |
||||
dict lappend ::opunk::console::waiting_chunks $in $probe |
||||
} |
||||
return [chan eof $in] |
||||
} |
||||
|
||||
#Heuristic: could the input channel be connected to a terminal able to answer queries? |
||||
#Returns 0 only when reasonably confident it cannot. mintty without winpty presents a |
||||
#terminal's stdin as a plain pipe, so env hints (MSYSTEM, TERM_PROGRAM) prevent false |
||||
#negatives there at the cost of false positives for genuinely piped-but-open input. |
||||
method is_console_or_tty {} -virtual { |
||||
if {[llength $this] < 7} { |
||||
error "invalid object $this" |
||||
} |
||||
set in [my.get.o_in $this] |
||||
if {[catch {chan configure $in} conf]} { |
||||
return 0 |
||||
} |
||||
if {[dict exists $conf -inputmode]} { |
||||
return 1 |
||||
} |
||||
if {[dict exists $conf -mode]} { |
||||
return 1 |
||||
} |
||||
if {[at_eof $this]} { |
||||
return 0 |
||||
} |
||||
if {[info exists ::env(TERM_PROGRAM)] || [info exists ::env(MSYSTEM)]} { |
||||
return 1 |
||||
} |
||||
return 0 |
||||
} |
||||
|
||||
#Response capability: settled value if known, else computed heuristically (without settling - |
||||
#this method is pure; use ::opunk::console::can_respond <name> to settle an anchored instance |
||||
#heuristically, or punk::console::settle_can_respond <spec> for active-probe settling - the |
||||
#probe machinery lives in punk::console so this class stays free of that dependency). |
||||
method can_respond {} -virtual { |
||||
if {[llength $this] < 7} { |
||||
error "invalid object $this" |
||||
} |
||||
set settled [get.o_can_respond $this] |
||||
if {$settled != -1} { |
||||
return $settled |
||||
} |
||||
return [is_console_or_tty $this] |
||||
} |
||||
|
||||
#Size of the console: chan -winsize on the output channel when available (fast, no query), |
||||
#else the configured default size. ANSI cursor-report mechanisms are deliberately absent from |
||||
#this standalone class - they arrive via punk::console integration and subclasses. |
||||
method size {} -virtual { |
||||
if {[llength $this] < 7} { |
||||
error "invalid object $this" |
||||
} |
||||
set out [my.get.o_out $this] |
||||
if {![catch {chan configure $out} oconf]} { |
||||
if {[dict exists $oconf -winsize]} { |
||||
lassign [dict get $oconf -winsize] cols lines |
||||
if {[string is integer -strict $cols] && [string is integer -strict $lines]} { |
||||
return [dict create columns $cols rows $lines] |
||||
} |
||||
} |
||||
} |
||||
return [my.get.o_default_size $this] |
||||
} |
||||
} |
||||
|
||||
constructor {in out} { |
||||
#new() supplies the class defaults including the virtual class tag at slot 0 |
||||
set obj [new()] |
||||
my.set.o_in obj $in |
||||
my.set.o_out obj $out |
||||
return $obj |
||||
} |
||||
} |
||||
|
||||
#make introspection (with i and punk::ns::cmdinfo) easier by making the class namespace an ensemble - we can still access it as ::opunk::Console |
||||
namespace eval ::opunk::Console { |
||||
namespace ensemble create |
||||
} |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Anchored instances - the 'consoles are entities' layer |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval ::opunk::console { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
|
||||
namespace eval instances { |
||||
#one variable per anchored console instance - the canonical location of each console object. |
||||
#Access via the sibling procs; methods needing to mutate an instance go through these anchors. |
||||
} |
||||
|
||||
proc create {name in out} { |
||||
if {![string is wordchar -strict $name]} { |
||||
error "opunk::console::create name must be alphanumeric/underscore, got '$name'" |
||||
} |
||||
set [namespace current]::instances::$name [::opunk::Console::new $in $out] |
||||
return [namespace current]::instances::$name |
||||
} |
||||
proc instancevar {name} { |
||||
set v [namespace current]::instances::$name |
||||
if {![info exists $v]} { |
||||
error "opunk::console: no anchored console instance named '$name' (known: [names])" |
||||
} |
||||
return $v |
||||
} |
||||
proc instance {name} { |
||||
set [instancevar $name] |
||||
} |
||||
proc names {} { |
||||
set result [list] |
||||
foreach v [info vars [namespace current]::instances::*] { |
||||
lappend result [namespace tail $v] |
||||
} |
||||
return $result |
||||
} |
||||
proc forget {name} { |
||||
unset [instancevar $name] |
||||
return |
||||
} |
||||
|
||||
#settle-and-cache response capability on the anchored instance. |
||||
#The class method is pure (value-in) - this wrapper owns the mutation via the anchor. |
||||
proc can_respond {name} { |
||||
upvar #0 [instancevar $name] obj |
||||
set settled [::opunk::Console::get.o_can_respond $obj] |
||||
if {$settled != -1} { |
||||
return $settled |
||||
} |
||||
set r [::opunk::Console::can_respond $obj] |
||||
::opunk::Console::set.o_can_respond obj $r |
||||
return $r |
||||
} |
||||
proc size {name} { |
||||
::opunk::Console::size [instance $name] |
||||
} |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# == === === === === === === === === === === === === === === |
||||
# Sample 'about' function with punk::args documentation |
||||
# == === === === === === === === === === === === === === === |
||||
tcl::namespace::eval ::opunk::console { |
||||
variable PUNKARGS |
||||
variable PUNKARGS_aliases |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)opunk::console" |
||||
@package -name "opunk::console" -help\ |
||||
"voo class ::opunk::Console representing a console as an in/out channel pair with settled |
||||
response-capability facts, plus anchored canonical instances under ::opunk::console::instances." |
||||
}] |
||||
|
||||
namespace eval argdoc { |
||||
proc package_name {} { |
||||
return opunk::console |
||||
} |
||||
proc about_topics {} { |
||||
set topic_funs [info commands [namespace current]::get_topic_*] |
||||
set about_topics [list] |
||||
foreach f $topic_funs { |
||||
set tail [namespace tail $f] |
||||
lappend about_topics [string range $tail [string length get_topic_] end] |
||||
} |
||||
return [lsort $about_topics] |
||||
} |
||||
proc default_topics {} {return [list Description *]} |
||||
|
||||
proc get_topic_Description {} { |
||||
punk::args::lib::tstr [string trim { |
||||
package opunk::console |
||||
voo class for consoles as channel-pair objects with anchored canonical instances. |
||||
} \n] |
||||
} |
||||
proc get_topic_License {} { |
||||
return "BSD" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return "$::opunk::console::version" |
||||
} |
||||
proc get_topic_Contributors {} { |
||||
set authors {{"Julian Noble" "julian@precisium.com.au"}} |
||||
set contributors "" |
||||
foreach a $authors { |
||||
append contributors $a \n |
||||
} |
||||
if {[string index $contributors end] eq "\n"} { |
||||
set contributors [string range $contributors 0 end-1] |
||||
} |
||||
return $contributors |
||||
} |
||||
proc get_topic_classes {} { |
||||
punk::args::lib::tstr -return string { |
||||
opunk::Console "virtual class for consoles as in/out channel pairs" |
||||
} |
||||
} |
||||
} |
||||
|
||||
set overrides [dict create] |
||||
dict set overrides @id -id "::opunk::console::about" |
||||
dict set overrides @cmd -name "opunk::console::about" |
||||
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||
About opunk::console |
||||
}] \n] |
||||
dict set overrides topic -choices [list {*}[opunk::console::argdoc::about_topics] *] |
||||
dict set overrides topic -choicerestricted 1 |
||||
dict set overrides topic -default [opunk::console::argdoc::default_topics] |
||||
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||
lappend PUNKARGS [list $newdef] |
||||
proc about {args} { |
||||
package require punk::args |
||||
set argd [punk::args::parse $args withid ::opunk::console::about] |
||||
lassign [dict values $argd] _leaders opts values _received |
||||
punk::args::package::standard_about -package_about_namespace ::opunk::console::argdoc {*}$opts {*}[dict get $values topic] |
||||
} |
||||
} |
||||
# end of sample 'about' function |
||||
# == === === === === === === === === === === === === === === |
||||
|
||||
|
||||
# ----------------------------------------------------------------------------- |
||||
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
||||
# ----------------------------------------------------------------------------- |
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::opunk::console ::opunk::Console |
||||
} |
||||
# ----------------------------------------------------------------------------- |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide opunk::console [tcl::namespace::eval ::opunk::console { |
||||
variable pkg opunk::console |
||||
variable version |
||||
set version 0.1.1 |
||||
}] |
||||
return |
||||
@ -1,372 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.4.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) 2026 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application opunk::console 0.2.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
package require Tcl 8.6- |
||||
|
||||
package require voo |
||||
package require punk::args |
||||
|
||||
#opunk::Console - a voo (value-based) representation of a console: an in/out channel pair claimed to |
||||
#belong to one responding endpoint, together with settled capability facts about that endpoint. |
||||
# |
||||
#Motivation (see punk::console get_size / get_ansi_response_payload history): |
||||
#ANSI query mechanisms assume the input channel receives what the output channel's device emits in |
||||
#response. When stdio is redirected that pairing silently breaks - queries go to a terminal whose |
||||
#replies land in some other process's input. A console object makes the pairing an explicit, |
||||
#construction-time property instead of a per-query-site guess. |
||||
# |
||||
#Design notes: |
||||
# - Objects are voo values (plain lists). Consoles are entities, not values - so canonical instances |
||||
# are anchored at well-known namespace variables (::opunk::console::instances::<name>) and the value |
||||
# semantics serve as cheap snapshots. Mutation (settling capabilities) goes through the anchor via |
||||
# the lowercase ::opunk::console wrapper procs. |
||||
# - The class is -virtual: slot 0 of each value carries the concrete class namespace, so channel |
||||
# environments that respond like terminals but aren't platform consoles can subclass |
||||
# (-extends ::opunk::Console) and override the capability/size methods, with existing holders of |
||||
# console values dispatching correctly. |
||||
# - This first cut is standalone and passive: capability detection is heuristic (channel options, |
||||
# probed eof, terminal env hints) and size uses chan -winsize else the default size. Active ANSI |
||||
# query probing arrives with punk::console integration (which will delegate here rather than the |
||||
# class depending on punk::console). |
||||
|
||||
tcl::namespace::eval ::opunk::console { |
||||
variable PUNKARGS |
||||
|
||||
#well-known cooperative store for bytes consumed by probe reads on pipe-like channels: |
||||
#an array keyed by channel name -> list of chunks. Readers taking over a channel should consume |
||||
#and clear any entry for that channel first. |
||||
#The store is PLUGGABLE via waiting_chunks_arrayvar: environments with an established cooperative |
||||
#store (e.g punk::console::input_chunks_waiting, which the punk repl reader consults) redirect it |
||||
#so probe-consumed bytes are never invisible to the active reader. The class itself stays free of |
||||
#any punk::console dependency - redirection is performed by the integrating layer. |
||||
variable waiting_chunks |
||||
if {![array exists waiting_chunks]} { |
||||
array set waiting_chunks {} |
||||
} |
||||
variable waiting_chunks_arrayvar |
||||
if {![info exists waiting_chunks_arrayvar]} { |
||||
set waiting_chunks_arrayvar ::opunk::console::waiting_chunks |
||||
} |
||||
} |
||||
|
||||
voo::class ::opunk::Console -virtual { |
||||
private { |
||||
#o_ prefix per opunk voo convention (distinguishes fields from locals in -update methods, |
||||
#and matches tclOO-style implementations elsewhere for easier code movement). |
||||
#Note the class is -virtual: slot 0 of the object value is the concrete class namespace tag. |
||||
string_t o_in stdin |
||||
string_t o_out stdout |
||||
string_t o_terminal_class "" ;#e.g windows-console, tty, pipe - "" until classified |
||||
list_t o_size_mechanism [list] ;#preferred size mechanism try-order - empty until timed/settled |
||||
dict_t o_default_size [dict create columns 80 rows 24] |
||||
} |
||||
public { |
||||
#settled response capability: -1 unknown, 0 cannot respond, 1 can respond. |
||||
#public accessors (get.o_can_respond / set.o_can_respond) so the anchored-mutation wrappers in |
||||
#::opunk::console can settle it without reaching into private my.* accessors. |
||||
int_t o_can_respond -1 |
||||
|
||||
method in {} { |
||||
my.get.o_in $this |
||||
} |
||||
method out {} { |
||||
my.get.o_out $this |
||||
} |
||||
method channels {} { |
||||
list [my.get.o_in $this] [my.get.o_out $this] |
||||
} |
||||
method terminal_class {} { |
||||
my.get.o_terminal_class $this |
||||
} |
||||
method default_size {} { |
||||
my.get.o_default_size $this |
||||
} |
||||
|
||||
#Certainty test: is the input channel closed or at eof (and so can never deliver a response)? |
||||
#A consumed/half-closed pipe may not flag eof until a read is attempted, so pipe-like channels |
||||
#get a non-blocking 1-byte probe. A probed byte is preserved in the cooperative waiting store |
||||
#(array named by ::opunk::console::waiting_chunks_arrayvar - redirectable by the integrating |
||||
#layer to e.g punk::console::input_chunks_waiting so active readers can find it). |
||||
#Console/tty channels are never probed (must not consume a keystroke). |
||||
method at_eof {} -virtual { |
||||
if {[llength $this] < 7} { |
||||
error "invalid object $this" |
||||
} |
||||
set in [my.get.o_in $this] |
||||
if {[catch {chan eof $in} is_eof]} { |
||||
return 1 ;#closed/invalid channel - unusable |
||||
} |
||||
if {$is_eof} { |
||||
return 1 |
||||
} |
||||
if {[catch {chan configure $in} conf]} { |
||||
return 1 |
||||
} |
||||
if {[dict exists $conf -inputmode] || [dict exists $conf -mode]} { |
||||
return 0 |
||||
} |
||||
if {[catch { |
||||
set prior_blocking [dict get $conf -blocking] |
||||
chan configure $in -blocking 0 |
||||
set probe [read $in 1] |
||||
chan configure $in -blocking $prior_blocking |
||||
}]} { |
||||
return 1 |
||||
} |
||||
if {$probe ne ""} { |
||||
upvar #0 $::opunk::console::waiting_chunks_arrayvar wchunks |
||||
lappend wchunks($in) $probe |
||||
} |
||||
return [chan eof $in] |
||||
} |
||||
|
||||
#Heuristic: could the input channel be connected to a terminal able to answer queries? |
||||
#Returns 0 only when reasonably confident it cannot. mintty without winpty presents a |
||||
#terminal's stdin as a plain pipe, so env hints (MSYSTEM, TERM_PROGRAM) prevent false |
||||
#negatives there at the cost of false positives for genuinely piped-but-open input. |
||||
method is_console_or_tty {} -virtual { |
||||
if {[llength $this] < 7} { |
||||
error "invalid object $this" |
||||
} |
||||
set in [my.get.o_in $this] |
||||
if {[catch {chan configure $in} conf]} { |
||||
return 0 |
||||
} |
||||
if {[dict exists $conf -inputmode]} { |
||||
return 1 |
||||
} |
||||
if {[dict exists $conf -mode]} { |
||||
return 1 |
||||
} |
||||
if {[at_eof $this]} { |
||||
return 0 |
||||
} |
||||
if {[info exists ::env(TERM_PROGRAM)] || [info exists ::env(MSYSTEM)]} { |
||||
return 1 |
||||
} |
||||
return 0 |
||||
} |
||||
|
||||
#Response capability: settled value if known, else computed heuristically (without settling - |
||||
#this method is pure; use ::opunk::console::can_respond <name> to settle an anchored instance |
||||
#heuristically, or punk::console::settle_can_respond <spec> for active-probe settling - the |
||||
#probe machinery lives in punk::console so this class stays free of that dependency). |
||||
method can_respond {} -virtual { |
||||
if {[llength $this] < 7} { |
||||
error "invalid object $this" |
||||
} |
||||
set settled [get.o_can_respond $this] |
||||
if {$settled != -1} { |
||||
return $settled |
||||
} |
||||
return [is_console_or_tty $this] |
||||
} |
||||
|
||||
#Size of the console: chan -winsize on the output channel when available (fast, no query), |
||||
#else the configured default size. ANSI cursor-report mechanisms are deliberately absent from |
||||
#this standalone class - they arrive via punk::console integration and subclasses. |
||||
method size {} -virtual { |
||||
if {[llength $this] < 7} { |
||||
error "invalid object $this" |
||||
} |
||||
set out [my.get.o_out $this] |
||||
if {![catch {chan configure $out} oconf]} { |
||||
if {[dict exists $oconf -winsize]} { |
||||
lassign [dict get $oconf -winsize] cols lines |
||||
if {[string is integer -strict $cols] && [string is integer -strict $lines]} { |
||||
return [dict create columns $cols rows $lines] |
||||
} |
||||
} |
||||
} |
||||
return [my.get.o_default_size $this] |
||||
} |
||||
} |
||||
|
||||
constructor {in out} { |
||||
#new() supplies the class defaults including the virtual class tag at slot 0 |
||||
set obj [new()] |
||||
my.set.o_in obj $in |
||||
my.set.o_out obj $out |
||||
return $obj |
||||
} |
||||
} |
||||
|
||||
#make introspection (with i and punk::ns::cmdinfo) easier by making the class namespace an ensemble - we can still access it as ::opunk::Console |
||||
namespace eval ::opunk::Console { |
||||
namespace ensemble create |
||||
} |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Anchored instances - the 'consoles are entities' layer |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval ::opunk::console { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
|
||||
namespace eval instances { |
||||
#one variable per anchored console instance - the canonical location of each console object. |
||||
#Access via the sibling procs; methods needing to mutate an instance go through these anchors. |
||||
} |
||||
|
||||
proc create {name in out} { |
||||
if {![string is wordchar -strict $name]} { |
||||
error "opunk::console::create name must be alphanumeric/underscore, got '$name'" |
||||
} |
||||
set [namespace current]::instances::$name [::opunk::Console::new $in $out] |
||||
return [namespace current]::instances::$name |
||||
} |
||||
proc instancevar {name} { |
||||
set v [namespace current]::instances::$name |
||||
if {![info exists $v]} { |
||||
error "opunk::console: no anchored console instance named '$name' (known: [names])" |
||||
} |
||||
return $v |
||||
} |
||||
proc instance {name} { |
||||
set [instancevar $name] |
||||
} |
||||
proc names {} { |
||||
set result [list] |
||||
foreach v [info vars [namespace current]::instances::*] { |
||||
lappend result [namespace tail $v] |
||||
} |
||||
return $result |
||||
} |
||||
proc forget {name} { |
||||
unset [instancevar $name] |
||||
return |
||||
} |
||||
|
||||
#settle-and-cache response capability on the anchored instance. |
||||
#The class method is pure (value-in) - this wrapper owns the mutation via the anchor. |
||||
proc can_respond {name} { |
||||
upvar #0 [instancevar $name] obj |
||||
set settled [::opunk::Console::get.o_can_respond $obj] |
||||
if {$settled != -1} { |
||||
return $settled |
||||
} |
||||
set r [::opunk::Console::can_respond $obj] |
||||
::opunk::Console::set.o_can_respond obj $r |
||||
return $r |
||||
} |
||||
proc size {name} { |
||||
::opunk::Console::size [instance $name] |
||||
} |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# == === === === === === === === === === === === === === === |
||||
# Sample 'about' function with punk::args documentation |
||||
# == === === === === === === === === === === === === === === |
||||
tcl::namespace::eval ::opunk::console { |
||||
variable PUNKARGS |
||||
variable PUNKARGS_aliases |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)opunk::console" |
||||
@package -name "opunk::console" -help\ |
||||
"voo class ::opunk::Console representing a console as an in/out channel pair with settled |
||||
response-capability facts, plus anchored canonical instances under ::opunk::console::instances." |
||||
}] |
||||
|
||||
namespace eval argdoc { |
||||
proc package_name {} { |
||||
return opunk::console |
||||
} |
||||
proc about_topics {} { |
||||
set topic_funs [info commands [namespace current]::get_topic_*] |
||||
set about_topics [list] |
||||
foreach f $topic_funs { |
||||
set tail [namespace tail $f] |
||||
lappend about_topics [string range $tail [string length get_topic_] end] |
||||
} |
||||
return [lsort $about_topics] |
||||
} |
||||
proc default_topics {} {return [list Description *]} |
||||
|
||||
proc get_topic_Description {} { |
||||
punk::args::lib::tstr [string trim { |
||||
package opunk::console |
||||
voo class for consoles as channel-pair objects with anchored canonical instances. |
||||
} \n] |
||||
} |
||||
proc get_topic_License {} { |
||||
return "BSD" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return "$::opunk::console::version" |
||||
} |
||||
proc get_topic_Contributors {} { |
||||
set authors {{"Julian Noble" "julian@precisium.com.au"}} |
||||
set contributors "" |
||||
foreach a $authors { |
||||
append contributors $a \n |
||||
} |
||||
if {[string index $contributors end] eq "\n"} { |
||||
set contributors [string range $contributors 0 end-1] |
||||
} |
||||
return $contributors |
||||
} |
||||
proc get_topic_classes {} { |
||||
punk::args::lib::tstr -return string { |
||||
opunk::Console "virtual class for consoles as in/out channel pairs" |
||||
} |
||||
} |
||||
} |
||||
|
||||
set overrides [dict create] |
||||
dict set overrides @id -id "::opunk::console::about" |
||||
dict set overrides @cmd -name "opunk::console::about" |
||||
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||
About opunk::console |
||||
}] \n] |
||||
dict set overrides topic -choices [list {*}[opunk::console::argdoc::about_topics] *] |
||||
dict set overrides topic -choicerestricted 1 |
||||
dict set overrides topic -default [opunk::console::argdoc::default_topics] |
||||
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||
lappend PUNKARGS [list $newdef] |
||||
proc about {args} { |
||||
package require punk::args |
||||
set argd [punk::args::parse $args withid ::opunk::console::about] |
||||
lassign [dict values $argd] _leaders opts values _received |
||||
punk::args::package::standard_about -package_about_namespace ::opunk::console::argdoc {*}$opts {*}[dict get $values topic] |
||||
} |
||||
} |
||||
# end of sample 'about' function |
||||
# == === === === === === === === === === === === === === === |
||||
|
||||
|
||||
# ----------------------------------------------------------------------------- |
||||
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
||||
# ----------------------------------------------------------------------------- |
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::opunk::console ::opunk::Console |
||||
} |
||||
# ----------------------------------------------------------------------------- |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide opunk::console [tcl::namespace::eval ::opunk::console { |
||||
variable pkg opunk::console |
||||
variable version |
||||
set version 0.2.0 |
||||
}] |
||||
return |
||||
Binary file not shown.
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,324 +0,0 @@
|
||||
# -*- 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::mix::commandset::doc 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
package require punk::path ;# for treefilenames, relative |
||||
package require punk::repo |
||||
package require punk::docgen ;#inline doctools - generate doctools .man files at src/docgen prior to using kettle to producing .html .md etc |
||||
package require punk::mix::cli ;#punk::mix::cli::lib used for kettle_call |
||||
#package require punkcheck ;#for path_relative |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::doc { |
||||
namespace export * |
||||
|
||||
proc _default {} { |
||||
puts "documentation subsystem" |
||||
puts "commands: doc.build" |
||||
puts " build documentation from src/doc to src/embedded using the kettle build tool" |
||||
puts "commands: doc.status" |
||||
} |
||||
|
||||
proc build {} { |
||||
puts "build docs" |
||||
set projectdir [punk::repo::find_project] |
||||
if {$projectdir eq ""} { |
||||
puts stderr "No current project dir - unable to build docs" |
||||
return |
||||
} |
||||
#user may delete the comment containing "--- punk::docgen::overwrites" and then manually edit, and we won't overwrite |
||||
#we still generate output in src/docgen so user can diff and manually update if thats what they prefer |
||||
set oldfiles [punk::path::treefilenames -dir $projectdir/src/doc _module_*.man] |
||||
foreach maybedoomed $oldfiles { |
||||
set fd [open $maybedoomed r] |
||||
chan conf $fd -translation binary |
||||
set data [read $fd] |
||||
close $fd |
||||
if {[string match "*--- punk::docgen overwrites *" $data]} { |
||||
file delete -force $maybedoomed |
||||
} |
||||
} |
||||
set generated [lib::do_docgen modules] |
||||
if {[dict get $generated count] > 0} { |
||||
#review |
||||
set doclist [dict get $generated docs] |
||||
set source_base [dict get $generated base] |
||||
set target_base $projectdir/src/doc |
||||
foreach dinfo $doclist { |
||||
lassign $dinfo module fpath |
||||
set relpath [punk::path::relative $source_base $fpath] |
||||
set relfolder [file dirname $relpath] |
||||
if {$relfolder eq "."} { |
||||
set relfolder "" |
||||
} |
||||
file mkdir [file join $target_base $relfolder] |
||||
set target [file join $target_base $relfolder _module_[file tail $fpath]] |
||||
puts stderr "target --> $target" |
||||
if {![file exists $target]} { |
||||
file copy $fpath $target |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {[file exists $projectdir/src/doc]} { |
||||
set original_wd [pwd] |
||||
cd $projectdir/src |
||||
#---------- |
||||
set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] |
||||
$installer set_source_target $projectdir/src/doc $projectdir/src/embedded |
||||
set event [$installer start_event {-install_step kettledoc}] |
||||
#use same virtual id "kettle_build_doc" as project.new - review best way to keep identifiers like this in sync. |
||||
$event targetset_init VIRTUAL kettle_build_doc ;#VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated |
||||
$event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source |
||||
#---------- |
||||
if {\ |
||||
[llength [dict get [$event targetset_source_changes] changed]]\ |
||||
} { |
||||
$event targetset_started |
||||
# -- --- --- --- --- --- |
||||
puts stdout "BUILDING DOCS at $projectdir/src/embedded from src/doc" |
||||
if {[catch { |
||||
if {"::meta" eq [info commands ::meta]} { |
||||
puts stderr "There appears to be a leftover ::meta command which is presumed to be from doctools. Destroying object" |
||||
::meta destroy |
||||
} |
||||
punk::mix::cli::lib::kettle_call lib doc |
||||
#Kettle doc |
||||
|
||||
} errM]} { |
||||
$event targetset_end FAILED -note "kettle_build_doc failed: $errM" |
||||
} else { |
||||
$event targetset_end OK |
||||
} |
||||
# -- --- --- --- --- --- |
||||
} else { |
||||
puts stderr "No change detected in src/doc" |
||||
$event targetset_end SKIPPED |
||||
} |
||||
$event end |
||||
$event destroy |
||||
$installer destroy |
||||
cd $original_wd |
||||
} else { |
||||
puts stderr "No doc folder found at $projectdir/src/doc" |
||||
} |
||||
} |
||||
proc status {} { |
||||
set projectdir [punk::repo::find_project] |
||||
if {$projectdir eq ""} { |
||||
puts stderr "No current project dir - unable to check doc status" |
||||
return |
||||
} |
||||
if {![file exists $projectdir/src/doc]} { |
||||
set result "No documentation source found. Expected .man files in doctools format at $projectdir/src/doc" |
||||
return $result |
||||
} |
||||
set original_wd [pwd] |
||||
cd $projectdir/src |
||||
puts stdout "Testing status of doctools source location $projectdir/src/doc ..." |
||||
flush stdout |
||||
#---------- |
||||
set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] |
||||
$installer set_source_target $projectdir/src/doc $projectdir/src/embedded |
||||
set event [$installer start_event {-install_step kettledoc}] |
||||
#use same virtual id "kettle_build_doc" as project.new - review best way to keep identifiers like this in sync. |
||||
$event targetset_init QUERY kettle_build_doc ;#usually VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated - but here we use QUERY to ensure no writes to .punkcheck |
||||
set last_completion [$event targetset_last_complete] |
||||
|
||||
if {[llength $last_completion]} { |
||||
#adding a source causes it to be checksummed |
||||
$event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source |
||||
#---------- |
||||
set changeinfo [$event targetset_source_changes] |
||||
if {\ |
||||
[llength [dict get $changeinfo changed]]\ |
||||
} { |
||||
puts stdout "changed" |
||||
puts stdout $changeinfo |
||||
} else { |
||||
puts stdout "No changes detected in $projectdir/src/doc tree" |
||||
} |
||||
} else { |
||||
#no previous completion-record for this target - must assume changed - no need to trigger checksumming |
||||
puts stdout "No existing record of doc build in .punkcheck. Assume it needs to be rebuilt." |
||||
} |
||||
|
||||
|
||||
$event destroy |
||||
$installer destroy |
||||
|
||||
cd $original_wd |
||||
} |
||||
proc validate {args} { |
||||
set argd [punk::args::parse $args withdef { |
||||
@id -id ::punk::mix::commandset::doc::validate |
||||
-- -type none -optional 1 -help "end of options marker --" |
||||
-individual -type boolean -default 1 |
||||
@values -min 0 -max -1 |
||||
patterns -default {*.man} -type any -multiple 1 |
||||
}] |
||||
set opt_individual [tcl::dict::get $argd opts -individual] |
||||
set patterns [tcl::dict::get $argd values patterns] |
||||
|
||||
|
||||
#todo - run and validate punk::docgen output |
||||
set projectdir [punk::repo::find_project] |
||||
if {$projectdir eq ""} { |
||||
puts stderr "No current project dir - unable to check doc status" |
||||
return |
||||
} |
||||
if {![file exists $projectdir/src/doc]} { |
||||
set result "No documentation source found. Expected .man files in doctools format at $projectdir/src/doc" |
||||
return $result |
||||
} |
||||
set original_wd [pwd] |
||||
set docroot $projectdir/src/doc |
||||
cd $docroot |
||||
|
||||
if {!$opt_individual && "*.man" in $patterns} { |
||||
if {[catch { |
||||
dtplite validate $docroot |
||||
} errM]} { |
||||
puts stderr "commandset::doc::validate failed for projectdir '$projectdir'" |
||||
puts stderr "docroot '$docroot'" |
||||
puts stderr "dtplite error was: $errM" |
||||
} |
||||
} else { |
||||
foreach p $patterns { |
||||
set treefiles [punk::path::treefilenames $p] |
||||
foreach path $treefiles { |
||||
puts stdout "dtplite validate $path" |
||||
dtplite validate $path |
||||
} |
||||
} |
||||
} |
||||
|
||||
#punk::mix::cli::lib::kettle_call lib validate-doc |
||||
|
||||
cd $original_wd |
||||
} |
||||
|
||||
namespace eval collection { |
||||
variable pkg |
||||
set pkg punk::mix::commandset::doc |
||||
|
||||
namespace export * |
||||
namespace path [namespace parent] |
||||
|
||||
} |
||||
|
||||
namespace eval lib { |
||||
variable pkg |
||||
set pkg punk::mix::commandset::doc |
||||
proc do_docgen {{project_subpath modules}} { |
||||
#Extract doctools comments from source code |
||||
set projectdir [punk::repo::find_project] |
||||
set output_base [file join $projectdir src docgen] |
||||
set codesource_path [file join $projectdir $project_subpath] |
||||
if {![file isdirectory $codesource_path]} { |
||||
puts stderr "WARNING punk::mix::commandset::doc unable to find codesource_path $codesource_path during do_docgen - skipping inline doctools generation" |
||||
return |
||||
} |
||||
if {[file isdirectory $output_base]} { |
||||
if {[catch { |
||||
file delete -force $output_base |
||||
}]} { |
||||
error "do_docgen failed to delete existing output base folder: $output_base" |
||||
} |
||||
} |
||||
file mkdir $output_base |
||||
|
||||
set matched_paths [punk::path::treefilenames -dir $codesource_path -antiglob_paths {**/mix/templates/** **/project_layouts/** **/decktemplates/** **/_aside **/_aside/**} *.tm] |
||||
set count 0 |
||||
set newdocs [list] |
||||
set docgen_header_comments "" |
||||
append docgen_header_comments {[comment {--- punk::docgen generated from inline doctools comments ---}]} \n |
||||
append docgen_header_comments {[comment {--- punk::docgen DO NOT EDIT DOCS HERE UNLESS YOU REMOVE THESE COMMENT LINES ---}]} \n |
||||
append docgen_header_comments {[comment {--- punk::docgen overwrites this file ---}]} \n |
||||
foreach fullpath $matched_paths { |
||||
puts stdout "do_docgen processing: $fullpath" |
||||
set doctools [punk::docgen::get_doctools_comments $fullpath] |
||||
if {$doctools ne ""} { |
||||
set fname [file tail $fullpath] |
||||
set mod_tail [file rootname $fname] |
||||
set relpath [punk::path::relative $codesource_path [file dirname $fullpath]] |
||||
if {$relpath eq "."} { |
||||
set relpath "" |
||||
} |
||||
set tailsegs [file split $relpath] |
||||
set module_fullname [join $tailsegs ::]::$mod_tail |
||||
set target_docname $fname.man |
||||
set this_outdir [file join $output_base $relpath] |
||||
|
||||
if {[string length $fname] > 99} { |
||||
#output needs to be tarballed to do checksum change tests in a reasonably straightforward and not-too-terribly slow way. |
||||
#hack - review. Determine exact limit - test if tcllib tar fixed or if it's a limit of the particular tar format |
||||
#work around tcllib tar filename length limit ( somewhere around 100?) This seems to be a limit on the length of a particular segment in the path.. not whole path length? |
||||
#this case only came up because docgen used to path munge to long filenames - but left because we know there is a limit and renaming fixes it - even if it's ugly - but still allows doc generation. |
||||
#review - if we're checking fname - should also test length of whole path and determine limits for tar |
||||
package require md5 |
||||
if {[package vsatisfies [package present md5] 2- ] } { |
||||
set md5opt "-hex" |
||||
} else { |
||||
set md5opt "" |
||||
} |
||||
set target_docname [md5::md5 {*}$md5opt [encoding convertto utf-8 $fullpath]]_overlongfilename.man |
||||
puts stderr "WARNING - overlong file name - renaming $fullpath" |
||||
puts stderr " to [file dirname $fullpath]/$target_docname" |
||||
} |
||||
|
||||
file mkdir $this_outdir |
||||
puts stdout "saving [string length $doctools] bytes of doctools output from file $relpath/$fname" |
||||
set outfile [file join $this_outdir $target_docname] |
||||
set fd [open $outfile w] |
||||
fconfigure $fd -translation binary |
||||
puts -nonewline $fd $docgen_header_comments$doctools |
||||
close $fd |
||||
incr count |
||||
lappend newdocs [list $module_fullname $outfile] |
||||
} |
||||
} |
||||
return [list count $count docs $newdocs base $output_base] |
||||
} |
||||
|
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::doc [namespace eval punk::mix::commandset::doc { |
||||
variable pkg punk::mix::commandset::doc |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,94 +0,0 @@
|
||||
# -*- 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::mix::templates 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
package require punk::cap |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::templates { |
||||
variable pkg punk::mix::templates |
||||
variable cap_provider |
||||
|
||||
namespace eval capsystem { |
||||
if {[info commands capprovider.registration] eq ""} { |
||||
punk::cap::class::interface_capprovider.registration create capprovider.registration |
||||
oo::objdefine capprovider.registration { |
||||
method get_declarations {} { |
||||
set decls [list] |
||||
lappend decls [list punk.templates {path templates pathtype adhoc vendor _project}] ;#todo - split out to a different provider package? |
||||
|
||||
lappend decls [list punk.templates {path templates pathtype module vendor punk}] |
||||
#only punk::templates is allowed to register a _multivendor path - review |
||||
#other punk.template providers should use module, absolute, currentproject and shellproject pathtypes only |
||||
lappend decls [list punk.templates {path src/decktemplates pathtype currentproject_multivendor vendor punk}] |
||||
lappend decls [list punk.templates {path decktemplates pathtype shellproject_multivendor vendor punk}] |
||||
|
||||
|
||||
#we need a way to ensure we don't pull updates from a remote repo into a local project that is actually the same project ? review! |
||||
#need flags as to whether/how provider allows template updates that are out of sync with the provider pkg version |
||||
#perhaps a separate .txt file (alongside buildversion and description txt files) that has some package require statements (we can't put them in the template itself as the filled template may have nothing to do with the punk.templates provider) |
||||
lappend decls [list punk.templates {path src/decktemplates/vendor/punk pathtype currentproject vendor punk allowupdates 0 repo "https://www.gitea1.intx.com.au/jn/punkshell" reposubdir "src/decktemplates/vendor/punk"}] |
||||
lappend decls [list punk.isbogus {provider punk::mix::templates something blah}] ;#some capability for which there is no handler to validate - therefore no warning will result. |
||||
#review - we should report unhandled caps somewhere, or provide a mechanism to detect/report. |
||||
#we don't want to warn at the time this provider is loaded - as handler may legitimately be loaded later. |
||||
return $decls |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {[info commands provider] eq ""} { |
||||
punk::cap::class::interface_capprovider.provider create provider punk::mix::templates |
||||
oo::objdefine provider { |
||||
method register {{capabilityname_glob *}} { |
||||
#puts registering punk::mix::templates $capabilityname |
||||
next $capabilityname_glob |
||||
} |
||||
method capabilities {} { |
||||
next |
||||
} |
||||
} |
||||
} |
||||
|
||||
# -- --- |
||||
#provider api |
||||
# -- --- |
||||
#none - declarations only |
||||
#todo - template folder install/update/status methods? |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::templates [namespace eval punk::mix::templates { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
Binary file not shown.
Binary file not shown.
@ -1,161 +0,0 @@
|
||||
#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} { |
||||
set app_folders [punk::config::configure running 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 *}} { |
||||
set apps_folder [punk::config::configure running 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 |
||||
}] |
||||
|
||||
|
||||
|
||||
@ -1,193 +0,0 @@
|
||||
|
||||
|
||||
package require punk::mix::util |
||||
package require punk::args |
||||
|
||||
tcl::namespace::eval ::punk::overlay { |
||||
#based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend |
||||
# extend an ensemble-like routine with the routines in some namespace |
||||
# |
||||
# e.g custom_from_base ::punk::mix::cli ::punk::mix::base |
||||
# |
||||
proc custom_from_base {routine base} { |
||||
if {![tcl::string::match ::* $routine]} { |
||||
set resolved [uplevel 1 [list ::tcl::namespace::which $routine]] |
||||
if {$resolved eq {}} { |
||||
error [list {no such routine} $routine] |
||||
} |
||||
set routine $resolved |
||||
} |
||||
set routinens [tcl::namespace::qualifiers $routine] |
||||
if {$routinens eq {::}} { |
||||
set routinens {} |
||||
} |
||||
set routinetail [tcl::namespace::tail $routine] |
||||
|
||||
if {![tcl::string::match ::* $base]} { |
||||
set base [uplevel 1 [ |
||||
list [tcl::namespace::which namespace] current]]::$base |
||||
} |
||||
|
||||
if {![tcl::namespace::exists $base]} { |
||||
error [list {no such namespace} $base] |
||||
} |
||||
|
||||
set base [tcl::namespace::eval $base [ |
||||
list [tcl::namespace::which namespace] current]] |
||||
|
||||
|
||||
#while 1 { |
||||
# set renamed ${routinens}::${routinetail}_[info cmdcount] |
||||
# if {[namespace which $renamed] eq {}} break |
||||
#} |
||||
|
||||
tcl::namespace::eval $routine [ |
||||
::list tcl::namespace::ensemble configure $routine -unknown [ |
||||
::list ::apply {{base ensemble subcommand args} { |
||||
::list ${base}::_redirected $ensemble $subcommand |
||||
}} $base |
||||
] |
||||
] |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${routine}::util |
||||
#namespace eval ${routine}::util { |
||||
#::namespace import ::punk::mix::util::* |
||||
#} |
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ${base}::lib::* ${routine}::lib |
||||
#namespace eval ${routine}::lib [string map [list <base> $base] { |
||||
# ::namespace import <base>::lib::* |
||||
#}] |
||||
|
||||
tcl::namespace::eval ${routine}::lib [tcl::string::map [list <base> $base <routine> $routine] { |
||||
if {[tcl::namespace::exists <base>::lib]} { |
||||
::set current_paths [tcl::namespace::path] |
||||
if {"<routine>" ni $current_paths} { |
||||
::lappend current_paths <routine> |
||||
} |
||||
tcl::namespace::path $current_paths |
||||
} |
||||
}] |
||||
|
||||
tcl::namespace::eval $routine { |
||||
::set exportlist [::list] |
||||
::foreach cmd [tcl::info::commands [tcl::namespace::current]::*] { |
||||
::set c [tcl::namespace::tail $cmd] |
||||
if {![tcl::string::match _* $c]} { |
||||
::lappend exportlist $c |
||||
} |
||||
} |
||||
tcl::namespace::export {*}$exportlist |
||||
} |
||||
|
||||
return $routine |
||||
} |
||||
punk::args::define { |
||||
@id -id ::punk::overlay::import_commandset |
||||
@cmd -name punk::overlay::import_commandset\ |
||||
-summary\ |
||||
"Import commands into caller's namespace with optional prefix and separator."\ |
||||
-help\ |
||||
"Import commands that have been exported by another namespace into the caller's |
||||
namespace. Usually a prefix and optionally a separator should be used. |
||||
This is part of the punk::mix CLI commandset infrastructure - design in flux. |
||||
Todo - .toml configuration files for defining CLI configurations." |
||||
@values |
||||
prefix -type string |
||||
separator -type string -help\ |
||||
"A string, usually punctuation, to separate the prefix and the command name |
||||
of the final imported command. The value \"::\" is disallowed in this context." |
||||
cmdnamespace -type string -help\ |
||||
"Namespace from which to import commands. Commands are those that have been exported." |
||||
} |
||||
#load *exported* commands from cmdnamespace into caller's namespace - prefixing each command with $prefix |
||||
#Note: commandset may be imported by different CLIs with different bases *at the same time* |
||||
#so we don't make commands from the cli or its base available automatically (will generally require fully-qualified commands to use code from cli/base) |
||||
#we do load punk::mix::util::* into the util subnamespace even though the commandset might not be loaded in a cli using punk::mix::base i.e punk::mix::util is a common dependency for CLIs. |
||||
#commandsets designed to be used with a specific cli/base may choose to do their own import e.g with util::namespace_import_pattern_to_namespace_noclobber and/or set namespace path if they |
||||
#want the convenience of using lib:xxx with commands coming from those packages. |
||||
#This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. |
||||
#The basic principle is that the commandset is loaded into the caller(s) with a prefix |
||||
#- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) |
||||
proc import_commandset {prefix separator cmdnamespace} { |
||||
set bad_seps [list "::"] |
||||
if {$separator in $bad_seps} { |
||||
error "import_commandset invalid separator '$separator'" |
||||
} |
||||
if {$prefix in $bad_seps} { |
||||
error "import_commandset invalid prefix '$prefix'" |
||||
} |
||||
if {"$prefix$separator" in $bad_seps} { |
||||
error "import_commandset invalid prefix/separator combination '$prefix$separator'" |
||||
} |
||||
if {"[string index $prefix end][string index $separator 0]" in $bad_seps} { |
||||
error "import_commandset invalid prefix/separator combination '$prefix$separator'" |
||||
} |
||||
#review - do we allow prefixes/separators such as a::b? |
||||
|
||||
#namespace may or may not be a package |
||||
# allow with or without leading :: |
||||
if {[tcl::string::range $cmdnamespace 0 1] eq "::"} { |
||||
set cmdpackage [tcl::string::range $cmdnamespace 2 end] |
||||
} else { |
||||
set cmdpackage $cmdnamespace |
||||
set cmdnamespace ::$cmdnamespace |
||||
} |
||||
|
||||
if {![tcl::namespace::exists $cmdnamespace]} { |
||||
#only do package require if the namespace not already present |
||||
catch {package require $cmdpackage} pkg_load_info |
||||
#recheck |
||||
if {![tcl::namespace::exists $cmdnamespace]} { |
||||
set prov [package provide $cmdpackage] |
||||
if {[tcl::string::length $prov]} { |
||||
set provinfo "(package $cmdpackage is present with version $prov)" |
||||
} else { |
||||
set provinfo "(package $cmdpackage not present)" |
||||
} |
||||
error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Pkg_load_result: $pkg_load_info Usage: import_commandset prefix separator namespace" |
||||
} |
||||
} |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util |
||||
|
||||
#let child namespace 'lib' resolve parent namespace and thus util::xxx |
||||
tcl::namespace::eval ${cmdnamespace}::lib [tcl::string::map [list <cmdns> $cmdnamespace] { |
||||
::set nspaths [tcl::namespace::path] |
||||
if {"<cmdns>" ni $nspaths} { |
||||
::lappend nspaths <cmdns> |
||||
} |
||||
tcl::namespace::path $nspaths |
||||
}] |
||||
|
||||
set imported_commands [list] |
||||
set imported_tails [list] |
||||
set nscaller [uplevel 1 [list tcl::namespace::current]] |
||||
if {[catch { |
||||
#review - noclobber? |
||||
tcl::namespace::eval ${nscaller}::temp_import [list tcl::namespace::import ${cmdnamespace}::*] |
||||
foreach cmd [tcl::info::commands ${nscaller}::temp_import::*] { |
||||
set cmdtail [tcl::namespace::tail $cmd] |
||||
if {$cmdtail eq "_default"} { |
||||
set import_as ${nscaller}::${prefix} |
||||
} else { |
||||
set import_as ${nscaller}::${prefix}${separator}${cmdtail} |
||||
} |
||||
rename $cmd $import_as |
||||
lappend imported_commands $import_as |
||||
lappend imported_tails [namespace tail $import_as] |
||||
} |
||||
#make imported commands exported so they are available to the ensemble |
||||
tcl::namespace::eval ${nscaller} [list namespace export {*}$imported_tails] |
||||
} errM]} { |
||||
puts stderr "Error loading commandset $prefix $separator $cmdnamespace" |
||||
puts stderr "err: $errM" |
||||
} |
||||
return $imported_commands |
||||
} |
||||
} |
||||
|
||||
|
||||
package provide punk::overlay [tcl::namespace::eval punk::overlay { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,239 +0,0 @@
|
||||
#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" |
||||
} |
||||
} |
||||
|
||||
} |
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,897 +0,0 @@
|
||||
# vim: set ft=tcl |
||||
# |
||||
#purpose: handle the run commands that call shellfilter::run |
||||
#e.g run,runout,runerr,runx |
||||
|
||||
package require shellfilter |
||||
package require punk::ansi |
||||
|
||||
#NOTE: the run,runout,runerr,runx commands only produce an error if the command didn't run. |
||||
# - If it did run, but there was a non-zero exitcode it is up to the application to check that. |
||||
#This is deliberate, but means 'catch' doesn't catch errors within the command itself - the exitcode has to be checked. |
||||
#The user can always use exec for different process error semantics (they don't get exitcode with exec) |
||||
|
||||
namespace eval shellrun { |
||||
variable PUNKARGS |
||||
variable runout |
||||
variable runerr |
||||
|
||||
#do we need these? |
||||
#variable punkout |
||||
#variable punkerr |
||||
|
||||
#some ugly coupling with punk/punk::config for now |
||||
#todo - something better |
||||
if {[info exists ::punk::config::configdata]} { |
||||
set conf_running [punk::config::configure running] |
||||
set syslog_stdout [dict get $conf_running syslog_stdout] |
||||
set syslog_stderr [dict get $conf_running syslog_stderr] |
||||
set logfile_stdout [dict get $conf_running logfile_stdout] |
||||
set logfile_stderr [dict get $conf_running logfile_stderr] |
||||
} else { |
||||
lassign [list "" "" "" ""] syslog_stdout syslog_stderr logfile_stdout logfile_stderr |
||||
} |
||||
if {"punkshout" ni [shellfilter::stack::items]} { |
||||
set outdevice [shellfilter::stack::new punkshout -settings [list -tag "punkshout" -buffering none -raw 1 -syslog $syslog_stdout -file $logfile_stdout]] |
||||
set out [dict get $outdevice localchan] |
||||
} else { |
||||
set out [dict get [shellfilter::stack::item punkshout] device localchan] |
||||
} |
||||
if {"punksherr" ni [shellfilter::stack::items]} { |
||||
set errdevice [shellfilter::stack::new punksherr -settings [list -tag "punksherr" -buffering none -raw 1 -syslog $syslog_stderr -file $logfile_stderr]] |
||||
set err [dict get $errdevice localchan] |
||||
} else { |
||||
set err [dict get [shellfilter::stack::item punksherr] device localchan] |
||||
} |
||||
|
||||
namespace import ::punk::ansi::a+ |
||||
namespace import ::punk::ansi::a |
||||
|
||||
|
||||
|
||||
|
||||
#repltelemetry - additional/alternative display info used in a repl context i.e info directed towards the screen |
||||
#todo - package up in repltelemetry module and rewrite proc based on whether the module was found/loaded. |
||||
#somewhat strong coupling to punk - but let's try to behave decently if it's not loaded |
||||
#The last_run_display is actually intended for the repl - but is resident in the punk namespace with a view to the possibility of a different repl being in use. |
||||
proc set_last_run_display {chunklist} { |
||||
#chunklist as understood by the |
||||
if {![info exists ::punk::repltelemetry_emmitters]} { |
||||
namespace eval ::punk { |
||||
variable repltelemetry_emmitters |
||||
set repltelemetry_emmitters "shellrun" |
||||
} |
||||
} else { |
||||
if {"shellrun" ni $::punk::repltelemetry_emmitters} { |
||||
lappend punk::repltelemetry_emmitters "shellrun" |
||||
} |
||||
} |
||||
|
||||
#most basic of validity tests here.. just that it is a list (can be empty). We don't want to duplicate or over-constrain the way repls/shells/terminals interpet the info |
||||
if {[catch {llength $chunklist} errMsg]} { |
||||
error "set_last_run_display expects a list. Value supplied doesn't appear to be a well formed tcl list. '$errMsg'" |
||||
} |
||||
#todo - |
||||
tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist |
||||
} |
||||
|
||||
|
||||
|
||||
#maintenance: similar used in punk::ns & punk::winrun |
||||
#todo - take runopts + aliases as args |
||||
#longopts must be passed as a single item ie --timeout=100 not --timeout 100 |
||||
proc get_run_opts {arglist} { |
||||
if {[catch { |
||||
set callerinfo [info level -1] |
||||
} errM]} { |
||||
set caller "" |
||||
} else { |
||||
set caller [lindex $callerinfo 0] |
||||
} |
||||
|
||||
#we provide -nonewline even for 'run' even though run doesn't deliver stderr or stdout to the tcl return value |
||||
#This is for compatibility with other runX commands, and the difference is also visible when calling from repl. |
||||
set known_runopts [list "-echo" "-e" "-nonewline" "-n" "-tcl" "-debug"] |
||||
set known_longopts [list "--timeout"] |
||||
set known_longopts_msg "" |
||||
foreach lng $known_longopts { |
||||
append known_longopts_msg "${lng}=val " |
||||
} |
||||
set aliases [list "-e" "-echo" "-echo" "-echo" "-n" "-nonewline" "-nonewline" "-nonewline" "-tcl" "-tcl" "-debug" "-debug"] ;#include map to self |
||||
set runopts [list] |
||||
set runoptslong [list] |
||||
set cmdargs [list] |
||||
|
||||
set idx_first_cmdarg [lsearch -not $arglist "-*"] |
||||
|
||||
set allopts [lrange $arglist 0 $idx_first_cmdarg-1] |
||||
set cmdargs [lrange $arglist $idx_first_cmdarg end] |
||||
foreach o $allopts { |
||||
if {[string match --* $o]} { |
||||
lassign [split $o =] flagpart valpart |
||||
if {$valpart eq ""} { |
||||
error "$caller: longopt $o seems to be missing a value - must be of form --option=value" |
||||
} |
||||
if {$flagpart ni $known_longopts} { |
||||
error "$caller: Unknown runoption $o - known options $known_runopts $known_longopts_msg" |
||||
} |
||||
lappend runoptslong $flagpart $valpart |
||||
} else { |
||||
if {$o ni $known_runopts} { |
||||
error "$caller: Unknown runoption $o - known options $known_runopts $known_longopts_msg" |
||||
} |
||||
lappend runopts [dict get $aliases $o] |
||||
} |
||||
} |
||||
return [list runopts $runopts runoptslong $runoptslong cmdargs $cmdargs] |
||||
} |
||||
|
||||
|
||||
#todo - investigate cause of punk86 run hanging sometimes. An 'after 500' before exit in the called script fixes the issue. punk87 doesn't seem to be affected. |
||||
lappend PUNKARGS [list { |
||||
@id -id ::shellrun::run |
||||
@leaders -min 0 -max 0 |
||||
@opts |
||||
-nonewline -type none |
||||
-tcl -type none -default 0 |
||||
-debug -type none -default 0 |
||||
--timeout= -type integer |
||||
@values -min 1 -max -1 |
||||
cmdname -type string |
||||
cmdarg -type any -multiple 1 -optional 1 |
||||
}] |
||||
proc run {args} { |
||||
#set_last_run_display [list] |
||||
|
||||
#set splitargs [get_run_opts $args] |
||||
#set runopts [dict get $splitargs runopts] |
||||
#set runoptslong [dict get $splitargs runoptslong] |
||||
#set cmdargs [dict get $splitargs cmdargs] |
||||
set argd [punk::args::parse $args withid ::shellrun::run] |
||||
lassign [dict values $argd] leaders opts values received |
||||
|
||||
if {[dict exists $received "-nonewline"]} { |
||||
set nonewline 1 |
||||
} else { |
||||
set nonewline 0 |
||||
} |
||||
#review nonewline does nothing here.. |
||||
|
||||
set idlist_stderr [list] |
||||
#we leave stdout without imposed ansi colouring - because the source may be colourised and because ansi-wrapping a stream at whatever boundaries it comes in at isn't a really nice thing to do. |
||||
#stderr might have source colouring - but it usually doesn't seem to, and the visual distiction of red stderr can be very handy for the run command. |
||||
#A further enhancement could be to detect well-known options such as --color and/or use a configuration for specific commands that have useful colourised stderr, |
||||
#but having an option to configure stderr to red is a compromise. |
||||
#Note that the other run commands, runout,runerr, runx don't emit in real-time - so for those commands there may be options to detect and/or post-process stdout and stderr. |
||||
#TODO - fix. This has no effect if/when the repl adds an ansiwrap transform |
||||
# what we probably want to do is 'aside' that transform for runxxx commands only. |
||||
#lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] |
||||
|
||||
set callopts [dict create] |
||||
if {[dict exists $received "-tcl"]} { |
||||
dict set callopts -tclscript 1 |
||||
} |
||||
if {[dict exists $received "-debug"]} { |
||||
dict set callopts -debug 1 |
||||
} |
||||
if {[dict exists $received --timeout]} { |
||||
dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash |
||||
} |
||||
set cmdname [dict get $values cmdname] |
||||
if {[dict exists $received cmdarg]} { |
||||
set cmdarglist [dict get $values cmdarg] |
||||
} else { |
||||
set cmdarglist {} |
||||
} |
||||
set cmdargs [concat $cmdname $cmdarglist] |
||||
#--------------------------------------------------------------------------------------------- |
||||
set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none ] |
||||
#--------------------------------------------------------------------------------------------- |
||||
foreach id $idlist_stderr { |
||||
shellfilter::stack::remove stderr $id |
||||
} |
||||
#puts stderr "shellrun::run exitinfo: $exitinfo" |
||||
|
||||
flush stderr |
||||
flush stdout |
||||
|
||||
if {[dict exists $exitinfo error]} { |
||||
error "[dict get $exitinfo error]\n$exitinfo" |
||||
} |
||||
|
||||
return $exitinfo |
||||
} |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id ::shellrun::runconsole |
||||
@leaders -min 0 -max 0 |
||||
@opts |
||||
@values -min 1 -max -1 |
||||
cmdname -type string |
||||
cmdarg -type any -multiple 1 -optional 1 |
||||
}] |
||||
#run in the way tcl unknown does - but without regard to auto_noexec |
||||
proc runconsole {args} { |
||||
set argd [punk::args::parse $args withid ::shellrun::runconsole] |
||||
lassign [dict values $argd] leaders opts values received |
||||
set cmdname [dict get $values cmdname] |
||||
if {[dict exists $received cmdarg]} { |
||||
set arglist [dict get $values cmdarg] |
||||
} else { |
||||
set arglist {} |
||||
} |
||||
|
||||
set resolved_cmdname [auto_execok $cmdname] |
||||
if {$resolved_cmdname eq ""} { |
||||
error "Cannot find path for executable '$cmdname'" |
||||
} |
||||
set repl_runid [punk::get_repl_runid] |
||||
#set ::punk::last_run_display [list] |
||||
|
||||
set redir ">&@stdout <@stdin" |
||||
uplevel 1 [list ::catch [concat exec $redir $resolved_cmdname $arglist] ::tcl::UnknownResult ::tcl::UnknownOptions] |
||||
#we can't detect stdout/stderr output from the exec |
||||
#for now emit an extra \n on stderr |
||||
#todo - there is probably no way around this but to somehow exec in the context of a completely separate console |
||||
#This is probably a tricky problem - especially to do cross-platform |
||||
# |
||||
# - use [dict get $::tcl::UnknownOptions -code] (0|1) exit |
||||
if {[dict get $::tcl::UnknownOptions -code] == 0} { |
||||
set c green |
||||
set m "ok" |
||||
} else { |
||||
set c yellow |
||||
set m "errorCode $::errorCode" |
||||
} |
||||
set chunklist [list] |
||||
lappend chunklist [list "info" "[a $c]$m[a] " ] |
||||
if {$repl_runid != 0} { |
||||
tsv::lappend repl runchunks-$repl_runid {*}$chunklist |
||||
} |
||||
|
||||
dict incr ::tcl::UnknownOptions -level |
||||
return -options $::tcl::UnknownOptions $::tcl::UnknownResult |
||||
} |
||||
lappend PUNKARGS [list { |
||||
@id -id ::shellrun::runout |
||||
@leaders -min 0 -max 0 |
||||
@opts |
||||
-echo -type none |
||||
-nonewline -type none |
||||
-tcl -type none -default 0 |
||||
-debug -type none -default 0 |
||||
--timeout= -type integer |
||||
@values -min 1 -max -1 |
||||
cmdname -type string |
||||
cmdarg -type any -multiple 1 -optional 1 |
||||
}] |
||||
proc runout {args} { |
||||
set argd [punk::args::parse $args withid ::shellrun::runout] |
||||
lassign [dict values $argd] leaders opts values received |
||||
|
||||
if {[dict exists $received "-nonewline"]} { |
||||
set nonewline 1 |
||||
} else { |
||||
set nonewline 0 |
||||
} |
||||
|
||||
#set_last_run_display [list] |
||||
variable runout |
||||
variable runerr |
||||
set runout "" |
||||
set runerr "" |
||||
set RST [a] |
||||
|
||||
#set splitargs [get_run_opts $args] |
||||
#set runopts [dict get $splitargs runopts] |
||||
#set cmdargs [dict get $splitargs cmdargs] |
||||
|
||||
|
||||
#puts stdout "RUNOUT cmdargs: $cmdargs" |
||||
|
||||
#todo add -data boolean and -data lastwrite to -settings with default being -data all |
||||
# because sometimes we're only interested in last char (e.g to detect something was output) |
||||
|
||||
#set outvar_stackid [shellfilter::stack::add commandout tee_to_var -action float -settings {-varname ::runout}] |
||||
# |
||||
#when not echoing - use float-locked so that the repl's stack is bypassed |
||||
if {[dict exists $received "-echo"]} { |
||||
set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}] |
||||
set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}] |
||||
#set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action sink-locked -settings {-varname ::shellrun::runerr}] |
||||
} else { |
||||
set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -settings {-varname ::shellrun::runout}] |
||||
set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -settings {-varname ::shellrun::runerr}] |
||||
} |
||||
|
||||
set callopts [dict create] |
||||
if {[dict exists $received "-tcl"]} { |
||||
dict set callopts -tclscript 1 |
||||
} |
||||
if {[dict exists $received "-debug"]} { |
||||
dict set callopts -debug 1 |
||||
} |
||||
if {[dict exists $received --timeout]} { |
||||
dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash |
||||
} |
||||
set cmdname [dict get $values cmdname] |
||||
if {[dict exists $received cmdarg]} { |
||||
set cmdarglist [dict get $values cmdarg] |
||||
} else { |
||||
set cmdarglist {} |
||||
} |
||||
set cmdargs [concat $cmdname $cmdarglist] |
||||
|
||||
#shellfilter::run [lrange $args 1 end] -teehandle punksh -outchan stdout -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler |
||||
set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none ] |
||||
|
||||
flush stderr |
||||
flush stdout |
||||
|
||||
shellfilter::stack::remove stdout $stdout_stackid |
||||
shellfilter::stack::remove stderr $stderr_stackid |
||||
|
||||
#shellfilter::stack::remove commandout $outvar_stackid |
||||
|
||||
if {[dict exists $exitinfo error]} { |
||||
if {[dict exists $received "-tcl"]} { |
||||
|
||||
} else { |
||||
#we must raise an error. |
||||
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||
# |
||||
set msg "" |
||||
append msg [dict get $exitinfo error] |
||||
append msg "\n(add -tcl option to run as a tcl command/script instead of an external command)" |
||||
error $msg |
||||
} |
||||
} |
||||
|
||||
set chunklist [list] |
||||
|
||||
#exitcode not part of return value for runout - colourcode appropriately |
||||
set n $RST |
||||
set c "" |
||||
|
||||
if {[dict exists $exitinfo exitcode]} { |
||||
set code [dict get $exitinfo exitcode] |
||||
if {$code == 0} { |
||||
set c [a+ green] |
||||
} else { |
||||
set c [a+ white bold] |
||||
} |
||||
lappend chunklist [list "info" "$c$exitinfo$n"] |
||||
} elseif {[dict exists $exitinfo error]} { |
||||
# -tcl (with error) |
||||
set c [a+ yellow bold] |
||||
lappend chunklist [list "info" "${c}error [dict get $exitinfo error]$n"] |
||||
lappend chunklist [list "info" "errorCode [dict get $exitinfo errorCode]"] |
||||
#lappend chunklist [list "info" "errorInfo [list [dict get $exitinfo errorInfo]]"] |
||||
lappend chunklist [list "info" errorInfo] |
||||
lappend chunklist [list "stderr" [dict get $exitinfo errorInfo]] |
||||
} else { |
||||
# -tcl (without error) |
||||
set c [a+ Green white bold] |
||||
#lappend chunklist [list "info" "$c$exitinfo$n"] |
||||
lappend chunklist [list "info" [punk::ansi::ansiwrap_raw $c \x1b\[m "" $exitinfo]] |
||||
} |
||||
|
||||
|
||||
set chunk "[a+ red bold]stderr$RST" |
||||
lappend chunklist [list "info" $chunk] |
||||
|
||||
set chunk "" |
||||
if {[string length $::shellrun::runerr]} { |
||||
if {$nonewline} { |
||||
set e [string trimright $::shellrun::runerr \r\n] |
||||
} else { |
||||
set e $::shellrun::runerr |
||||
} |
||||
#append chunk "[a+ red normal]$e$RST\n" |
||||
append chunk "[a+ red normal]$e$RST" |
||||
} |
||||
lappend chunklist [list stderr $chunk] |
||||
|
||||
|
||||
|
||||
|
||||
lappend chunklist [list "info" "[a+ white bold]stdout$RST"] |
||||
set chunk "" |
||||
if {[string length $::shellrun::runout]} { |
||||
if {$nonewline} { |
||||
set o [string trimright $::shellrun::runout \r\n] |
||||
} else { |
||||
set o $::shellrun::runout |
||||
} |
||||
append chunk "$o" |
||||
} |
||||
lappend chunklist [list result $chunk] |
||||
|
||||
|
||||
#set_last_run_display $chunklist |
||||
tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist |
||||
|
||||
if {$nonewline} { |
||||
return [string trimright $::shellrun::runout \r\n] |
||||
} else { |
||||
return $::shellrun::runout |
||||
} |
||||
} |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id ::shellrun::runerr |
||||
@leaders -min 0 -max 0 |
||||
@opts |
||||
-echo -type none |
||||
-nonewline -type none |
||||
-tcl -type none -default 0 |
||||
-debug -type none -default 0 |
||||
--timeout= -type integer |
||||
@values -min 1 -max -1 |
||||
cmdname -type string |
||||
cmdarg -type any -multiple 1 -optional 1 |
||||
}] |
||||
proc runerr {args} { |
||||
set argd [punk::args::parse $args withid ::shellrun::runerr] |
||||
lassign [dict values $argd] leaders opts values received |
||||
|
||||
if {[dict exists $received "-nonewline"]} { |
||||
set nonewline 1 |
||||
} else { |
||||
set nonewline 0 |
||||
} |
||||
|
||||
#set_last_run_display [list] |
||||
variable runout |
||||
variable runerr |
||||
set runout "" |
||||
set runerr "" |
||||
|
||||
#set splitargs [get_run_opts $args] |
||||
#set runopts [dict get $splitargs runopts] |
||||
#set cmdargs [dict get $splitargs cmdargs] |
||||
|
||||
set callopts [dict create] |
||||
if {[dict exists $received "-tcl"]} { |
||||
dict set callopts -tclscript 1 |
||||
} |
||||
if {[dict exists $received "-debug"]} { |
||||
dict set callopts -debug 1 |
||||
} |
||||
if {[dict exists $received --timeout]} { |
||||
dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash |
||||
} |
||||
set cmdname [dict get $values cmdname] |
||||
if {[dict exists $received cmdarg]} { |
||||
set cmdarglist [dict get $values cmdarg] |
||||
} else { |
||||
set cmdarglist {} |
||||
} |
||||
set cmdargs [concat $cmdname $cmdarglist] |
||||
|
||||
if {[dict exists $received "-tcl"]} { |
||||
append callopts " -tclscript 1" |
||||
} |
||||
if {[dict exists $received "-echo"]} { |
||||
set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}] |
||||
set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}] |
||||
} else { |
||||
set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -settings {-varname ::shellrun::runerr}] |
||||
set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -settings {-varname ::shellrun::runout}] |
||||
} |
||||
|
||||
|
||||
set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] |
||||
shellfilter::stack::remove stderr $stderr_stackid |
||||
shellfilter::stack::remove stdout $stdout_stackid |
||||
|
||||
|
||||
flush stderr |
||||
flush stdout |
||||
|
||||
#we raise an error because an error during calling is different to collecting stderr from a command, and the caller should be able to wrap in a catch |
||||
# to determine something other than just a nonzero exit code or output on stderr. |
||||
if {[dict exists $exitinfo error]} { |
||||
if {[dict exists $received "-tcl"]} { |
||||
|
||||
} else { |
||||
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||
error [dict get $exitinfo error] |
||||
} |
||||
} |
||||
|
||||
set chunklist [list] |
||||
|
||||
set n [a] |
||||
set c "" |
||||
if {[dict exists $exitinfo exitcode]} { |
||||
set code [dict get $exitinfo exitcode] |
||||
if {$code == 0} { |
||||
set c [a+ green] |
||||
} else { |
||||
set c [a+ white bold] |
||||
} |
||||
lappend chunklist [list "info" "$c$exitinfo$n"] |
||||
} elseif {[dict exists $exitinfo error]} { |
||||
# -tcl (with error) |
||||
set c [a+ yellow bold] |
||||
lappend chunklist [list "info" "error [dict get $exitinfo error]"] |
||||
lappend chunklist [list "info" "errorCode [dict get $exitinfo errorCode]"] |
||||
lappend chunklist [list "info" "errorInfo [list [dict get $exitinfo errorInfo]]"] |
||||
} else { |
||||
# -tcl (without error) |
||||
set c [a+ Green white bold] |
||||
#lappend chunklist [list "info" "$c$exitinfo$n"] |
||||
lappend chunklist [list "info" [punk::ansi::ansiwrap_raw $c "\x1b\[m" "" $exitinfo]] |
||||
} |
||||
|
||||
|
||||
lappend chunklist [list "info" "[a+ white bold]stdout[a]"] |
||||
set chunk "" |
||||
if {[string length $::shellrun::runout]} { |
||||
if {$nonewline} { |
||||
set o [string trimright $::shellrun::runout \r\n] |
||||
} else { |
||||
set o $::shellrun::runout |
||||
} |
||||
append chunk "[a+ white normal]$o[a]\n" ;#this newline is the display output separator - always there whether data has trailing newline or not. |
||||
} |
||||
lappend chunklist [list stdout $chunk] |
||||
|
||||
|
||||
#set c_stderr [punk::config] |
||||
set chunk "[a+ red bold]stderr[a]" |
||||
lappend chunklist [list "info" $chunk] |
||||
|
||||
set chunk "" |
||||
if {[string length $::shellrun::runerr]} { |
||||
if {$nonewline} { |
||||
set e [string trimright $::shellrun::runerr \r\n] |
||||
} else { |
||||
set e $::shellrun::runerr |
||||
} |
||||
append chunk "$e" |
||||
} |
||||
lappend chunklist [list resulterr $chunk] |
||||
|
||||
|
||||
#set_last_run_display $chunklist |
||||
tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist |
||||
|
||||
if {$nonewline} { |
||||
return [string trimright $::shellrun::runerr \r\n] |
||||
} |
||||
return $::shellrun::runerr |
||||
} |
||||
|
||||
|
||||
proc runx {args} { |
||||
#set_last_run_display [list] |
||||
variable runout |
||||
variable runerr |
||||
set runout "" |
||||
set runerr "" |
||||
|
||||
set splitargs [get_run_opts $args] |
||||
set runopts [dict get $splitargs runopts] |
||||
set cmdargs [dict get $splitargs cmdargs] |
||||
|
||||
if {"-nonewline" in $runopts} { |
||||
set nonewline 1 |
||||
} else { |
||||
set nonewline 0 |
||||
} |
||||
|
||||
#shellfilter::stack::remove stdout $::repl::id_outstack |
||||
|
||||
if {"-echo" in $runopts} { |
||||
#float to ensure repl transform doesn't interfere with the output data |
||||
set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float -settings {-varname ::shellrun::runerr}] |
||||
set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}] |
||||
} else { |
||||
#set stderr_stackid [shellfilter::stack::add stderr var -action sink-locked -settings {-varname ::shellrun::runerr}] |
||||
#set stdout_stackid [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::shellrun::runout}] |
||||
|
||||
#float above the repl's tee_to_var to deliberately block it. |
||||
#a var transform is naturally a junction point because there is no flow-through.. |
||||
# - but mark it with -junction 1 just to be explicit |
||||
set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -junction 1 -settings {-varname ::shellrun::runerr}] |
||||
set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -junction 1 -settings {-varname ::shellrun::runout}] |
||||
} |
||||
|
||||
set callopts "" |
||||
if {"-tcl" in $runopts} { |
||||
append callopts " -tclscript 1" |
||||
} |
||||
#set exitinfo [shellfilter::run $cmdargs -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] |
||||
set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none] |
||||
|
||||
shellfilter::stack::remove stdout $stdout_stackid |
||||
shellfilter::stack::remove stderr $stderr_stackid |
||||
|
||||
|
||||
flush stderr |
||||
flush stdout |
||||
|
||||
if {[dict exists $exitinfo error]} { |
||||
if {"-tcl" in $runopts} { |
||||
|
||||
} else { |
||||
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||
error [dict get $exitinfo error] |
||||
} |
||||
} |
||||
|
||||
#set x [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::repl::runxoutput}] |
||||
|
||||
set chunk "" |
||||
if {[string length $::shellrun::runout]} { |
||||
if {$nonewline} { |
||||
set o [string trimright $::shellrun::runout \r\n] |
||||
} else { |
||||
set o $::shellrun::runout |
||||
} |
||||
set chunk $o |
||||
} |
||||
set chunklist [list] |
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" stdout] ;#key 'stdout' forms part of the resulting dictionary output |
||||
lappend chunklist [list "info" "[a+ white bold]stdout[a]"] |
||||
lappend chunklist [list result $chunk] ;#value corresponding to 'stdout' key in resulting dict |
||||
|
||||
|
||||
lappend chunklist [list "info" " "] |
||||
set chunk "[a+ red bold]stderr[a]" |
||||
lappend chunklist [list "result" $chunk] |
||||
lappend chunklist [list "info" stderr] |
||||
|
||||
set chunk "" |
||||
if {[string length $::shellrun::runerr]} { |
||||
if {$nonewline} { |
||||
set e [string trimright $::shellrun::runerr \r\n] |
||||
} else { |
||||
set e $::shellrun::runerr |
||||
} |
||||
set chunk $e |
||||
} |
||||
#stderr is part of the result |
||||
lappend chunklist [list "resulterr" $chunk] |
||||
|
||||
|
||||
|
||||
set n [a] |
||||
set c "" |
||||
if {[dict exists $exitinfo exitcode]} { |
||||
set code [dict get $exitinfo exitcode] |
||||
if {$code == 0} { |
||||
set c [a+ green] |
||||
} else { |
||||
set c [a+ yellow bold] |
||||
} |
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" exitcode] |
||||
lappend chunklist [list "info" "exitcode $code"] |
||||
lappend chunklist [list "result" "$c$code$n"] |
||||
set exitdict [list exitcode $code] |
||||
} elseif {[dict exists $exitinfo result]} { |
||||
# presumably from a -tcl call |
||||
set val [dict get $exitinfo result] |
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" result] |
||||
lappend chunklist [list "info" result] |
||||
lappend chunklist [list "result" $val] |
||||
set exitdict [list result $val] |
||||
} elseif {[dict exists $exitinfo error]} { |
||||
# -tcl call with error |
||||
#set exitdict [dict create] |
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" error] |
||||
lappend chunklist [list "info" error] |
||||
lappend chunklist [list "result" [dict get $exitinfo error]] |
||||
|
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" errorCode] |
||||
lappend chunklist [list "info" errorCode] |
||||
lappend chunklist [list "result" [dict get $exitinfo errorCode]] |
||||
|
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" errorInfo] |
||||
lappend chunklist [list "info" errorInfo] |
||||
lappend chunklist [list "result" [dict get $exitinfo errorInfo]] |
||||
|
||||
set exitdict $exitinfo |
||||
} else { |
||||
#review - if no exitcode or result. then what is it? |
||||
lappend chunklist [list "info" exitinfo] |
||||
set c [a+ yellow bold] |
||||
lappend chunklist [list result "$c$exitinfo$n"] |
||||
set exitdict [list exitinfo $exitinfo] |
||||
} |
||||
|
||||
#set_last_run_display $chunklist |
||||
tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist |
||||
|
||||
#set ::repl::result_print 0 |
||||
#return [lindex [list [list stdout $::runout stderr $::runerr {*}$exitinfo] [shellfilter::stack::remove stdout $x][puts -nonewline stdout $pretty][set ::repl::output ""]] 0] |
||||
|
||||
|
||||
if {$nonewline} { |
||||
return [list {*}$exitdict stdout [string trimright $::shellrun::runout \r\n] stderr [string trimright $::shellrun::runerr \r\n]] |
||||
} |
||||
#always return exitinfo $code at beginning of dict (so that punk unknown can interpret the exit code as a unix-style bool if double evaluated) |
||||
return [list {*}$exitdict stdout $::shellrun::runout stderr $::shellrun::runerr] |
||||
} |
||||
|
||||
#an experiment |
||||
# |
||||
#run as raw string instead of tcl-list - no variable subst etc |
||||
# |
||||
#dummy repl_runraw that repl will intercept |
||||
proc repl_runraw {args} { |
||||
error "runraw: only available in repl as direct call - not from script" |
||||
} |
||||
#we can only call runraw with a single (presumably braced) string if we want to use it from both repl and tcl scripts (why? todo with unbalanced quotes/braces?) |
||||
proc runraw {commandline} { |
||||
#runraw fails as intended - because we can't bypass exec/open interference quoting :/ |
||||
#set_last_run_display [list] |
||||
variable runout |
||||
variable runerr |
||||
set runout "" |
||||
set runerr "" |
||||
|
||||
#return [shellfilter::run [lrange $args 1 end] -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] |
||||
puts stdout ">>runraw got: $commandline" |
||||
|
||||
#run always echoes anyway.. as we aren't diverting stdout/stderr off for capturing |
||||
#for consistency with other runxxx commands - we'll just consume it. (review) |
||||
|
||||
set reallyraw 1 |
||||
if {$reallyraw} { |
||||
set wordparts [regexp -inline -all {\S+} $commandline] |
||||
set runwords $wordparts |
||||
} else { |
||||
#shell style args parsing not suitable for windows where we can't assume matched quotes etc. |
||||
package require string::token::shell |
||||
set parts [string token shell -indices -- $commandline] |
||||
puts stdout ">>shellparts: $parts" |
||||
set runwords [list] |
||||
foreach p $parts { |
||||
set ptype [lindex $p 0] |
||||
set pval [lindex $p 3] |
||||
if {$ptype eq "PLAIN"} { |
||||
lappend runwords [lindex $p 3] |
||||
} elseif {$ptype eq "D:QUOTED"} { |
||||
set v {"} |
||||
append v $pval |
||||
append v {"} |
||||
lappend runwords $v |
||||
} elseif {$ptype eq "S:QUOTED"} { |
||||
set v {'} |
||||
append v $pval |
||||
append v {'} |
||||
lappend runwords $v |
||||
} |
||||
} |
||||
} |
||||
|
||||
puts stdout ">>runraw runwords: $runwords" |
||||
set runwords [lrange $runwords 1 end] |
||||
|
||||
puts stdout ">>runraw runwords: $runwords" |
||||
#set args [lrange $args 1 end] |
||||
#set runwords [lrange $wordparts 1 end] |
||||
|
||||
set known_runopts [list "-echo" "-e" "-terminal" "-t"] |
||||
set aliases [list "-e" "-echo" "-echo" "-echo" "-t" "-terminal" "-terminal" "-terminal"] ;#include map to self |
||||
set runopts [list] |
||||
set cmdwords [list] |
||||
set idx_first_cmdarg [lsearch -not $runwords "-*"] |
||||
set runopts [lrange $runwords 0 $idx_first_cmdarg-1] |
||||
set cmdwords [lrange $runwords $idx_first_cmdarg end] |
||||
|
||||
foreach o $runopts { |
||||
if {$o ni $known_runopts} { |
||||
error "runraw: Unknown runoption $o" |
||||
} |
||||
} |
||||
set runopts [lmap o $runopts {dict get $aliases $o}] |
||||
|
||||
set cmd_as_string [join $cmdwords " "] |
||||
puts stdout ">>cmd_as_string: $cmd_as_string" |
||||
|
||||
if {"-terminal" in $runopts} { |
||||
#fake terminal using 'script' command. |
||||
#not ideal: smushes stdout & stderr together amongst other problems |
||||
set tcmd [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not $cmdwords] |
||||
puts stdout ">>tcmd: $tcmd" |
||||
set exitinfo [shellfilter::run $tcmd -teehandle punksh -inbuffering line -outbuffering none ] |
||||
set exitinfo "exitcode not-implemented" |
||||
} else { |
||||
set exitinfo [shellfilter::run $cmdwords -teehandle punksh -inbuffering line -outbuffering none ] |
||||
} |
||||
|
||||
if {[dict exists $exitinfo error]} { |
||||
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||
error [dict get $exitinfo error] |
||||
} |
||||
set code [dict get $exitinfo exitcode] |
||||
if {$code == 0} { |
||||
set c [a+ green] |
||||
} else { |
||||
set c [a+ white bold] |
||||
} |
||||
puts stderr $c |
||||
return $exitinfo |
||||
} |
||||
|
||||
proc sh_run {args} { |
||||
set splitargs [get_run_opts $args] |
||||
set runopts [dict get $splitargs runopts] |
||||
set cmdargs [dict get $splitargs cmdargs] |
||||
#e.g sh -c "ls -l *" |
||||
#we pass cmdargs to sh -c as a list, not individually |
||||
tailcall shellrun::run {*}$runopts sh -c $cmdargs |
||||
} |
||||
proc sh_runout {args} { |
||||
set splitargs [get_run_opts $args] |
||||
set runopts [dict get $splitargs runopts] |
||||
set cmdargs [dict get $splitargs cmdargs] |
||||
tailcall shellrun::runout {*}$runopts sh -c $cmdargs |
||||
} |
||||
proc sh_runerr {args} { |
||||
set splitargs [get_run_opts $args] |
||||
set runopts [dict get $splitargs runopts] |
||||
set cmdargs [dict get $splitargs cmdargs] |
||||
tailcall shellrun::runerr {*}$runopts sh -c $cmdargs |
||||
} |
||||
proc sh_runx {args} { |
||||
set splitargs [get_run_opts $args] |
||||
set runopts [dict get $splitargs runopts] |
||||
set cmdargs [dict get $splitargs cmdargs] |
||||
tailcall shellrun::runx {*}$runopts sh -c $cmdargs |
||||
} |
||||
} |
||||
|
||||
namespace eval shellrun { |
||||
interp alias {} run {} shellrun::run |
||||
interp alias {} sh_run {} shellrun::sh_run |
||||
interp alias {} runout {} shellrun::runout |
||||
interp alias {} sh_runout {} shellrun::sh_runout |
||||
interp alias {} runerr {} shellrun::runerr |
||||
interp alias {} sh_runerr {} shellrun::sh_runerr |
||||
interp alias {} runx {} shellrun::runx |
||||
interp alias {} sh_runx {} shellrun::sh_runx |
||||
|
||||
interp alias {} runc {} shellrun::runconsole |
||||
interp alias {} runraw {} shellrun::runraw |
||||
|
||||
|
||||
#the shortened versions deliberately don't get pretty output from the repl |
||||
interp alias {} r {} shellrun::run |
||||
interp alias {} ro {} shellrun::runout |
||||
interp alias {} re {} shellrun::runerr |
||||
interp alias {} rx {} shellrun::runx |
||||
|
||||
|
||||
} |
||||
|
||||
namespace eval shellrun { |
||||
proc test_cffi {} { |
||||
package require test_cffi |
||||
cffi::Wrapper create ::shellrun::kernel32 [file join $env(windir) system32 Kernel32.dll] |
||||
::shellrun::kernel32 stdcall CreateProcessA |
||||
#todo - stuff. |
||||
return ::shellrun::kernel32 |
||||
} |
||||
|
||||
} |
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::shellrun |
||||
} |
||||
|
||||
|
||||
package provide shellrun [namespace eval shellrun { |
||||
variable version |
||||
set version 0.1.1 |
||||
}] |
||||
Binary file not shown.
@ -1,4 +1,5 @@
|
||||
0.4.0 |
||||
0.5.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
#0.5.0 - added lib::prune_superseded_target_modules and lib::prune_sourcevanished_targets; build_modules_from_source_to_base now prunes punkcheck-recorded superseded module versions from target dirs (recorded as punkcheck DELETE events) and records virtual module_name/module_version sources on installs (punkcheck 0.3.0 targetset_addsource_virtual); requires punk::mix::util explicitly |
||||
#0.4.0 - updated -max_depth to -max-depth at punkcheck::install call sites — call-site flag change warrants minor bump |
||||
|
||||
@ -1,5 +1,6 @@
|
||||
0.2.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
#0.2.0 - merged -exclude-dirsegments + -antiglob_paths into unified -exclude-paths (backward-compat aliases retained) |
||||
#0.2.0 - renamed all underscore flags to hyphenated forms (-max-depth, -source-checksum, -punkcheck-folder, etc.) with backward-compat alias pre-processing |
||||
0.3.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
#0.3.0 - added installsource_add_virtual proc + installevent targetset_addsource_virtual method: 'virtual' named-value SOURCE records (-type virtual -path virtual:<id> -value <v>) compared by value, for e.g recording resolved module build versions on install/delete records |
||||
#0.2.0 - merged -exclude-dirsegments + -antiglob_paths into unified -exclude-paths (backward-compat aliases retained) |
||||
#0.2.0 - renamed all underscore flags to hyphenated forms (-max-depth, -source-checksum, -punkcheck-folder, etc.) with backward-compat alias pre-processing |
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,709 +0,0 @@
|
||||
# -*- 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) 2024 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application modpod 0.1.3 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin modpod_module_modpod 0 0.1.3] |
||||
#[copyright "2024"] |
||||
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||
#[require modpod] |
||||
#[keywords module] |
||||
#[description] |
||||
#[para] - |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of modpod |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by modpod |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
package require struct::set ;#review |
||||
package require punk::lib |
||||
package require punk::args |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6-}] |
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# oo::class namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval modpod::class { |
||||
#*** !doctools |
||||
#[subsection {Namespace modpod::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 |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval modpod { |
||||
namespace export {[a-z]*}; # Convention: export all lowercase |
||||
|
||||
variable connected |
||||
if {![info exists connected(to)]} { |
||||
set connected(to) list |
||||
} |
||||
variable modpodscript |
||||
set modpodscript [info script] |
||||
if {[string tolower [file extension $modpodscript]] eq ".tcl"} { |
||||
set connected(self) [file dirname $modpodscript] |
||||
} else { |
||||
#expecting a .tm |
||||
set connected(self) $modpodscript |
||||
} |
||||
variable loadables [info sharedlibextension] |
||||
variable sourceables {.tcl .tk} ;# .tm ? |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace modpod}] |
||||
#[para] Core API functions for modpod |
||||
#[list_begin definitions] |
||||
|
||||
|
||||
|
||||
#proc sample1 {p1 args} { |
||||
# #*** !doctools |
||||
# #[call [fun sample1] [arg p1] [opt {?option value...?}]] |
||||
# #[para]Description of sample1 |
||||
# return "ok" |
||||
#} |
||||
|
||||
#old tar connect mechanism - review - not needed? |
||||
proc connect {args} { |
||||
puts stderr "modpod::connect--->>$args" |
||||
set argd [punk::args::parse $args withdef { |
||||
@id -id ::modpod::connect |
||||
-type -default "" |
||||
@values -min 1 -max 1 |
||||
path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)" |
||||
}] |
||||
catch { |
||||
punk::lib::showdict $argd ;#heavy dependencies |
||||
} |
||||
set opt_path [dict get $argd values path] |
||||
variable connected |
||||
set original_connectpath $opt_path |
||||
set modpodpath [modpod::system::normalize $opt_path] ;# |
||||
|
||||
if {$modpodpath in $connected(to)} { |
||||
return [dict create ok ALREADY_CONNECTED] |
||||
} |
||||
lappend connected(to) $modpodpath |
||||
|
||||
set connected(connectpath,$opt_path) $original_connectpath |
||||
set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info script]]}] |
||||
|
||||
set connected(location,$modpodpath) [file dirname $modpodpath] |
||||
set connected(startdata,$modpodpath) -1 |
||||
set connected(type,$modpodpath) [dict get $argd opts -type] |
||||
set connected(fh,$modpodpath) "" |
||||
|
||||
if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { |
||||
set connected(type,$modpodpath) "unwrapped" |
||||
lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
||||
set this_pkg_tm_folder [file dirname [file dirname $modpodpath]] |
||||
|
||||
} else { |
||||
#connect to .tm but may still be unwrapped version available |
||||
lassign [::split [file rootname [file tail $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
||||
set this_pkg_tm_folder [file dirname $modpodpath] |
||||
if {$connected(type,$modpodpath) ne "unwrapped"} { |
||||
#Not directly connected to unwrapped version - but may still be redirected there |
||||
set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)] |
||||
if {[file exists $unwrappedFolder]} { |
||||
#folder with exact version-match must exist for redirect to 'unwrapped' |
||||
set con(type,$modpodpath) "modpod-redirecting" |
||||
} |
||||
} |
||||
|
||||
} |
||||
set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm" |
||||
set connected(tmfile,$modpodpath) |
||||
set tail_segments [list] |
||||
set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]] |
||||
set lcase_modulepaths [string tolower [tcl::tm::list]] |
||||
foreach lc_mpath $lcase_modulepaths { |
||||
set mpath_segments [file split $lc_mpath] |
||||
if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
||||
set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end] |
||||
break |
||||
} |
||||
} |
||||
if {[llength $tail_segments]} { |
||||
set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require |
||||
} else { |
||||
set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)] |
||||
} |
||||
|
||||
switch -exact -- $connected(type,$modpodpath) { |
||||
"modpod-redirecting" { |
||||
#redirect to the unwrapped version |
||||
set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl] |
||||
|
||||
} |
||||
"unwrapped" { |
||||
if {[info commands ::thread::id] ne ""} { |
||||
set from [pid],[thread::id] |
||||
} else { |
||||
set from [pid] |
||||
} |
||||
#::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath" |
||||
return [list ok ""] |
||||
} |
||||
default { |
||||
#autodetect .tm - zip/tar ? |
||||
#todo - use vfs ? |
||||
|
||||
#connect to tarball - start at 1st header |
||||
set connected(startdata,$modpodpath) 0 |
||||
set fh [open $modpodpath r] |
||||
set connected(fh,$modpodpath) $fh |
||||
fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {} |
||||
|
||||
if {$connected(startdata,$modpodpath) >= 0} { |
||||
#verify we have a valid tar header |
||||
if {![catch {::modpod::system::tar::readHeader [read $fh 512]}]} { |
||||
seek $fh $connected(startdata,$modpodpath) start |
||||
return [list ok $fh] |
||||
} else { |
||||
#error "cannot verify tar header" |
||||
#try zipfs |
||||
if {[info commands tcl::zipfs::mount] ne ""} { |
||||
|
||||
} |
||||
} |
||||
} |
||||
lpop connected(to) end |
||||
set connected(startdata,$modpodpath) -1 |
||||
unset connected(fh,$modpodpath) |
||||
catch {close $fh} |
||||
return [dict create err {Does not appear to be a valid modpod}] |
||||
} |
||||
} |
||||
} |
||||
proc disconnect {{modpod ""}} { |
||||
variable connected |
||||
if {![llength $connected(to)]} { |
||||
return 0 |
||||
} |
||||
if {$modpod eq ""} { |
||||
puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]" |
||||
set modpod [lindex $connected(to) end] |
||||
} |
||||
|
||||
if {[set posn [lsearch $connected(to) $modpod]] == -1} { |
||||
puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod" |
||||
return 0 |
||||
} |
||||
if {[string length $connected(fh,$modpod)]} { |
||||
close $connected(fh,$modpod) |
||||
} |
||||
array unset connected *,$modpod |
||||
set connected(to) [lreplace $connected(to) $posn $posn] |
||||
return 1 |
||||
} |
||||
proc get {args} { |
||||
set argd [punk::args::parse $args withdef { |
||||
@id -id ::modpod::get |
||||
-from -default "" -help "path to pod" |
||||
@values -min 1 -max 1 |
||||
filename |
||||
}] |
||||
set frompod [dict get $argd opts -from] |
||||
set filename [dict get $argd values filename] |
||||
|
||||
variable connected |
||||
#//review |
||||
set modpod [::modpod::system::connect_if_not $frompod] |
||||
set fh $connected(fh,$modpod) |
||||
if {$connected(type,$modpod) eq "unwrapped"} { |
||||
#for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder |
||||
if {[string range $filename 0 0 eq "/"]} { |
||||
#absolute path (?) |
||||
set path [file join $connected(location,$modpod) .. [string trim $filename /]] |
||||
} else { |
||||
#relative path - use #modpod-xxx as base |
||||
set path [file join $connected(location,$modpod) $filename] |
||||
} |
||||
set fd [open $path r] |
||||
#utf-8? |
||||
#fconfigure $fd -encoding iso8859-1 -translation binary |
||||
return [list ok [lindex [list [read $fd] [close $fd]] 0]] |
||||
} else { |
||||
#read from vfs |
||||
puts stderr "get $filename from wrapped pod '$frompod' not implemented" |
||||
} |
||||
} |
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace modpod ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval modpod::lib { |
||||
namespace export {[a-z]*}; # Convention: export all lowercase |
||||
namespace path [namespace parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace modpod::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 |
||||
#} |
||||
|
||||
proc is_valid_tm_version {versionpart} { |
||||
#Needs to be suitable for use with Tcl's 'package vcompare' |
||||
if {![catch [list package vcompare $versionparts $versionparts]]} { |
||||
return 1 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
|
||||
#zipfile is a pure zip at this point - ie no script/exe header |
||||
proc make_zip_modpod {args} { |
||||
set argd [punk::args::parse $args withdef { |
||||
@id -id ::modpod::lib::make_zip_modpod |
||||
-offsettype -default "archive" -choices {archive file} -help\ |
||||
"Whether zip offsets are relative to start of file or start of zip-data within the file. |
||||
'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip, |
||||
but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip) |
||||
info-zip's 'zip -A' can sometimes convert archive-relative to file-relative. |
||||
-offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'" |
||||
@values -min 2 -max 2 |
||||
zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" |
||||
outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" |
||||
}] |
||||
set zipfile [dict get $argd values zipfile] |
||||
set outfile [dict get $argd values outfile] |
||||
set opt_offsettype [dict get $argd opts -offsettype] |
||||
|
||||
|
||||
set mount_stub [string map [list %offsettype% $opt_offsettype] { |
||||
#zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. |
||||
#Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. |
||||
#generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% <zipfile> <tmfile> |
||||
if {[catch {file normalize [info script]} modfile]} { |
||||
error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" |
||||
} |
||||
if {$modfile eq "" || ![file exists $modfile]} { |
||||
error "modpod zip stub error. Unable to determine module path" |
||||
} |
||||
set moddir [file dirname $modfile] |
||||
set mod_and_ver [file rootname [file tail $modfile]] |
||||
lassign [split $mod_and_ver -] moduletail version |
||||
if {[file exists $moddir/#modpod-$mod_and_ver]} { |
||||
source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm |
||||
} else { |
||||
#determine module namespace so we can mount appropriately |
||||
proc intersect {A B} { |
||||
if {[llength $A] == 0} {return {}} |
||||
if {[llength $B] == 0} {return {}} |
||||
if {[llength $B] > [llength $A]} { |
||||
set res $A |
||||
set A $B |
||||
set B $res |
||||
} |
||||
set res {} |
||||
foreach x $A {set ($x) {}} |
||||
foreach x $B { |
||||
if {[info exists ($x)]} { |
||||
lappend res $x |
||||
} |
||||
} |
||||
return $res |
||||
} |
||||
set lcase_tmfile_segments [string tolower [file split $moddir]] |
||||
set lcase_modulepaths [string tolower [tcl::tm::list]] |
||||
foreach lc_mpath $lcase_modulepaths { |
||||
set mpath_segments [file split $lc_mpath] |
||||
if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
||||
set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use properly cased tail |
||||
break |
||||
} |
||||
} |
||||
if {[llength $tail_segments]} { |
||||
set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require |
||||
set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver |
||||
} else { |
||||
set fullpackage $moduletail |
||||
set mount_at #modpod/#mounted-modpod-$mod_and_ver |
||||
} |
||||
|
||||
if {[info commands tcl::zipfs::mount] ne ""} { |
||||
#argument order changed to be consistent with vfs::zip::Mount etc |
||||
#early versions: zipfs::Mount mountpoint zipname |
||||
#since 2023-09: zipfs::Mount zipname mountpoint |
||||
#don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance) |
||||
#This is presumably related to // being interpreted as a network path |
||||
set mountpoints [dict keys [tcl::zipfs::mount]] |
||||
if {"//zipfs:/$mount_at" ni $mountpoints} { |
||||
#despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it |
||||
if {[catch { |
||||
#tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) |
||||
#puts "tcl::zipfs::mount $modfile $mount_at" |
||||
tcl::zipfs::mount $modfile $mount_at |
||||
} errM]} { |
||||
#try old api |
||||
if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { |
||||
puts stderr "modpod stub>>> tcl::zipfs::mount <file> <mountpoint> failed.\nbut old api: tcl::zipfs::mount <mountpoint> <file> succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" |
||||
puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" |
||||
} |
||||
} |
||||
if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
||||
puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]" |
||||
#tcl::zipfs::unmount //zipfs:/$mount_at |
||||
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" |
||||
} |
||||
} |
||||
# #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form |
||||
source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm |
||||
} else { |
||||
#fallback to slower vfs::zip |
||||
#NB. We don't create the intermediate dirs - but the mount still works |
||||
if {![file exists $moddir/$mount_at]} { |
||||
if {[catch {package require vfs::zip} errM]} { |
||||
set msg "Unable to load vfs::zip package to mount module $mod_and_ver (and zipfs not available either)" |
||||
append msg \n "If neither zipfs or vfs::zip are available - the module can still be loaded by manually unzipping the file $modfile in place." |
||||
append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" |
||||
error $msg |
||||
} else { |
||||
set fd [vfs::zip::Mount $modfile $moddir/$mount_at] |
||||
if {![file exists $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
||||
vfs::zip::Unmount $fd $moddir/$mount_at |
||||
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" |
||||
} |
||||
} |
||||
} |
||||
source $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm |
||||
} |
||||
} |
||||
#zipped data follows |
||||
}] |
||||
#todo - test if supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? |
||||
append mount_stub \x1A |
||||
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub $opt_offsettype |
||||
|
||||
} |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace modpod::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
namespace eval modpod::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace modpod::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
#deflate,store only supported |
||||
|
||||
#zipfile here is plain zip - no script/exe prefix part. |
||||
proc make_mountable_zip {zipfile outfile mount_stub {offsettype "archive"}} { |
||||
set inzip [open $zipfile r] |
||||
fconfigure $inzip -encoding iso8859-1 -translation binary |
||||
set out [open $outfile w+] |
||||
fconfigure $out -encoding iso8859-1 -translation binary |
||||
puts -nonewline $out $mount_stub |
||||
set stuboffset [tell $out] |
||||
lappend report "stub size: $stuboffset" |
||||
fcopy $inzip $out |
||||
close $inzip |
||||
|
||||
set size [tell $out] |
||||
lappend report "modpod::system::make_mountable_zip" |
||||
lappend report "tmfile : [file tail $outfile]" |
||||
lappend report "output size : $size" |
||||
lappend report "offsettype : $offsettype" |
||||
|
||||
if {$offsettype eq "file"} { |
||||
#make zip offsets relative to start of whole file including prepended script. |
||||
#same offset structure as Tcl's older 'zipfs mkimg' as at 2024-10 |
||||
#2025 - zipfs mkimg fixed to use 'archive' offset. |
||||
#not editable by 7z,nanazip,peazip |
||||
|
||||
#we aren't adding any new files/folders so we can edit the offsets in place |
||||
|
||||
#Now seek in $out to find the end of directory signature: |
||||
#The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text |
||||
if {$size < 65559} { |
||||
set tailsearch_start 0 |
||||
} else { |
||||
set tailsearch_start [expr {$size - 65559}] |
||||
} |
||||
seek $out $tailsearch_start |
||||
set data [read $out] |
||||
#EOCD - End of Central Directory record |
||||
#PK\5\6 |
||||
set start_of_end [string last "\x50\x4b\x05\x06" $data] |
||||
#set start_of_end [expr {$start_of_end + $seek}] |
||||
#incr start_of_end $seek |
||||
set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] |
||||
|
||||
lappend report "kitfile-relative START-OF-EOCD: $filerelative_eocd_posn" |
||||
|
||||
seek $out $filerelative_eocd_posn |
||||
set end_of_ctrl_dir [read $out] |
||||
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||
|
||||
lappend report "End of central directory: [array get eocd]" |
||||
seek $out [expr {$filerelative_eocd_posn+16}] |
||||
|
||||
#adjust offset of start of central directory by the length of our sfx stub |
||||
puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $stuboffset}]] |
||||
flush $out |
||||
|
||||
seek $out $filerelative_eocd_posn |
||||
set end_of_ctrl_dir [read $out] |
||||
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||
|
||||
# 0x06054b50 - end of central dir signature |
||||
puts stderr "$end_of_ctrl_dir" |
||||
puts stderr "comment_len: $eocd(comment_len)" |
||||
puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" |
||||
lappend report "New dir offset: $eocd(diroffset)" |
||||
lappend report "Adjusting $eocd(totalnum) zip file items." |
||||
catch { |
||||
punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies |
||||
} |
||||
|
||||
seek $out $eocd(diroffset) |
||||
for {set i 0} {$i <$eocd(totalnum)} {incr i} { |
||||
set current_file [tell $out] |
||||
set fileheader [read $out 46] |
||||
puts -------------- |
||||
puts [ansistring VIEW -lf 1 $fileheader] |
||||
puts -------------- |
||||
#binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||
# x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||
|
||||
binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||
set ::last_header $fileheader |
||||
|
||||
puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" |
||||
puts "ver: $x(version)" |
||||
puts "method: $x(method)" |
||||
|
||||
#PK\1\2 |
||||
#33639248 dec = 0x02014b50 - central directory file header signature |
||||
if { $x(sig) != 33639248 } { |
||||
error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" |
||||
} |
||||
|
||||
foreach size $x(lengths) var {filename extrafield comment} { |
||||
if { $size > 0 } { |
||||
set x($var) [read $out $size] |
||||
} else { |
||||
set x($var) "" |
||||
} |
||||
} |
||||
set next_file [tell $out] |
||||
lappend report "file $i: $x(offset) $x(sizes) $x(filename)" |
||||
|
||||
seek $out [expr {$current_file+42}] |
||||
puts -nonewline $out [binary format i [expr {$x(offset)+$stuboffset}]] |
||||
|
||||
#verify: |
||||
flush $out |
||||
seek $out $current_file |
||||
set fileheader [read $out 46] |
||||
lappend report "old $x(offset) + $stuboffset" |
||||
binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||
lappend report "new $x(offset)" |
||||
|
||||
seek $out $next_file |
||||
} |
||||
} |
||||
|
||||
close $out |
||||
#pdict/showdict reuire punk & textlib - ie lots of dependencies |
||||
#don't fall over just because of that |
||||
catch { |
||||
punk::lib::showdict -roottype list -chan stderr $report |
||||
} |
||||
#puts [join $report \n] |
||||
return |
||||
} |
||||
|
||||
proc connect_if_not {{podpath ""}} { |
||||
upvar ::modpod::connected connected |
||||
set podpath [::modpod::system::normalize $podpath] |
||||
set docon 0 |
||||
if {![llength $connected(to)]} { |
||||
if {![string length $podpath]} { |
||||
error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified" |
||||
} else { |
||||
set docon 1 |
||||
} |
||||
} else { |
||||
if {![string length $podpath]} { |
||||
set podpath [lindex $connected(to) end] |
||||
puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]" |
||||
} else { |
||||
if {$podpath ni $connected(to)} { |
||||
set docon 1 |
||||
} |
||||
} |
||||
} |
||||
if {$docon} { |
||||
if {[lindex [modpod::connect $podpath]] 0] ne "ok"} { |
||||
error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod" |
||||
} else { |
||||
return $podpath |
||||
} |
||||
} |
||||
#we were already connected |
||||
return $podpath |
||||
} |
||||
|
||||
proc myversion {} { |
||||
upvar ::modpod::connected connected |
||||
set script [info script] |
||||
if {![string length $script]} { |
||||
error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod" |
||||
} |
||||
set fname [file tail [file rootname [file normalize $script]]] |
||||
set scriptdir [file dirname $script] |
||||
|
||||
if {![string match "#modpod-*" $fname]} { |
||||
lassign [lrange [split $fname -] end-1 end] _pkgname version |
||||
} else { |
||||
lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version |
||||
if {![string length $version]} { |
||||
#try again on the name of the containing folder |
||||
lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version |
||||
#todo - proper walk up the directory tree |
||||
if {![string length $version]} { |
||||
#try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod) |
||||
lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version |
||||
} |
||||
} |
||||
} |
||||
|
||||
#tarjar::Log debug "'myversion' determined version for [info script]: $version" |
||||
return $version |
||||
} |
||||
|
||||
proc myname {} { |
||||
upvar ::modpod::connected connected |
||||
set script [info script] |
||||
if {![string length $script]} { |
||||
error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod" |
||||
} |
||||
return $connected(fullpackage,$script) |
||||
} |
||||
proc myfullname {} { |
||||
upvar ::modpod::connected connected |
||||
set script [info script] |
||||
#set script [::tarjar::normalize $script] |
||||
set script [file normalize $script] |
||||
if {![string length $script]} { |
||||
error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar" |
||||
} |
||||
return $::tarjar::connected(fullpackage,$script) |
||||
} |
||||
proc normalize {path} { |
||||
#newer versions of Tcl don't do tilde sub |
||||
|
||||
#Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths) |
||||
# we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function. |
||||
set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes.. |
||||
set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after |
||||
set path [file normalize $path] |
||||
#set path [string tolower $path] ;#must do this after file normalize |
||||
return [string map [list $matilda ~] $path] ;#get our tildes back. |
||||
} |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide modpod [namespace eval modpod { |
||||
variable pkg modpod |
||||
variable version |
||||
set version 0.1.3 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
@ -1,673 +0,0 @@
|
||||
# -*- 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) 2024 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application modpod 0.1.4 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin modpod_module_modpod 0 0.1.4] |
||||
#[copyright "2024"] |
||||
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||
#[require modpod] |
||||
#[keywords module] |
||||
#[description] |
||||
#[para] - |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of modpod |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by modpod |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
package require struct::set ;#review |
||||
package require punk::lib |
||||
package require punk::args |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6-}] |
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
|
||||
#changes |
||||
#0.1.4 - when mounting with vfs::zip (because zipfs not available) - mount relative to executable folder instead of module dir |
||||
# (given just a module name it's easier to find exepath than look at package ifneeded script to get module path) |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Base namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval modpod { |
||||
namespace export {[a-z]*}; # Convention: export all lowercase |
||||
|
||||
variable connected |
||||
if {![info exists connected(to)]} { |
||||
set connected(to) list |
||||
} |
||||
variable modpodscript |
||||
set modpodscript [info script] |
||||
if {[string tolower [file extension $modpodscript]] eq ".tcl"} { |
||||
set connected(self) [file dirname $modpodscript] |
||||
} else { |
||||
#expecting a .tm |
||||
set connected(self) $modpodscript |
||||
} |
||||
variable loadables [info sharedlibextension] |
||||
variable sourceables {.tcl .tk} ;# .tm ? |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace modpod}] |
||||
#[para] Core API functions for modpod |
||||
#[list_begin definitions] |
||||
|
||||
|
||||
|
||||
#old tar connect mechanism - review - not needed? |
||||
proc connect {args} { |
||||
puts stderr "modpod::connect--->>$args" |
||||
set argd [punk::args::parse $args withdef { |
||||
@id -id ::modpod::connect |
||||
-type -default "" |
||||
@values -min 1 -max 1 |
||||
path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)" |
||||
}] |
||||
catch { |
||||
punk::lib::showdict $argd ;#heavy dependencies |
||||
} |
||||
set opt_path [dict get $argd values path] |
||||
variable connected |
||||
set original_connectpath $opt_path |
||||
set modpodpath [modpod::system::normalize $opt_path] ;# |
||||
|
||||
if {$modpodpath in $connected(to)} { |
||||
return [dict create ok ALREADY_CONNECTED] |
||||
} |
||||
lappend connected(to) $modpodpath |
||||
|
||||
set connected(connectpath,$opt_path) $original_connectpath |
||||
set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info script]]}] |
||||
|
||||
set connected(location,$modpodpath) [file dirname $modpodpath] |
||||
set connected(startdata,$modpodpath) -1 |
||||
set connected(type,$modpodpath) [dict get $argd opts -type] |
||||
set connected(fh,$modpodpath) "" |
||||
|
||||
if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { |
||||
set connected(type,$modpodpath) "unwrapped" |
||||
lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
||||
set this_pkg_tm_folder [file dirname [file dirname $modpodpath]] |
||||
|
||||
} else { |
||||
#connect to .tm but may still be unwrapped version available |
||||
lassign [::split [file rootname [file tail $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
||||
set this_pkg_tm_folder [file dirname $modpodpath] |
||||
if {$connected(type,$modpodpath) ne "unwrapped"} { |
||||
#Not directly connected to unwrapped version - but may still be redirected there |
||||
set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)] |
||||
if {[file exists $unwrappedFolder]} { |
||||
#folder with exact version-match must exist for redirect to 'unwrapped' |
||||
set con(type,$modpodpath) "modpod-redirecting" |
||||
} |
||||
} |
||||
|
||||
} |
||||
set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm" |
||||
set connected(tmfile,$modpodpath) |
||||
set tail_segments [list] |
||||
set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]] |
||||
set lcase_modulepaths [string tolower [tcl::tm::list]] |
||||
foreach lc_mpath $lcase_modulepaths { |
||||
set mpath_segments [file split $lc_mpath] |
||||
if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
||||
set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end] |
||||
break |
||||
} |
||||
} |
||||
if {[llength $tail_segments]} { |
||||
set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require |
||||
} else { |
||||
set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)] |
||||
} |
||||
|
||||
switch -exact -- $connected(type,$modpodpath) { |
||||
"modpod-redirecting" { |
||||
#redirect to the unwrapped version |
||||
set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl] |
||||
|
||||
} |
||||
"unwrapped" { |
||||
if {[info commands ::thread::id] ne ""} { |
||||
set from [pid],[thread::id] |
||||
} else { |
||||
set from [pid] |
||||
} |
||||
#::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath" |
||||
return [list ok ""] |
||||
} |
||||
default { |
||||
#autodetect .tm - zip/tar ? |
||||
#todo - use vfs ? |
||||
|
||||
#connect to tarball - start at 1st header |
||||
set connected(startdata,$modpodpath) 0 |
||||
set fh [open $modpodpath r] |
||||
set connected(fh,$modpodpath) $fh |
||||
fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {} |
||||
|
||||
if {$connected(startdata,$modpodpath) >= 0} { |
||||
#verify we have a valid tar header |
||||
if {![catch {::modpod::system::tar::readHeader [read $fh 512]}]} { |
||||
seek $fh $connected(startdata,$modpodpath) start |
||||
return [list ok $fh] |
||||
} else { |
||||
#error "cannot verify tar header" |
||||
#try zipfs |
||||
if {[info commands tcl::zipfs::mount] ne ""} { |
||||
|
||||
} |
||||
} |
||||
} |
||||
lpop connected(to) end |
||||
set connected(startdata,$modpodpath) -1 |
||||
unset connected(fh,$modpodpath) |
||||
catch {close $fh} |
||||
return [dict create err {Does not appear to be a valid modpod}] |
||||
} |
||||
} |
||||
} |
||||
proc disconnect {{modpod ""}} { |
||||
variable connected |
||||
if {![llength $connected(to)]} { |
||||
return 0 |
||||
} |
||||
if {$modpod eq ""} { |
||||
puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]" |
||||
set modpod [lindex $connected(to) end] |
||||
} |
||||
|
||||
if {[set posn [lsearch $connected(to) $modpod]] == -1} { |
||||
puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod" |
||||
return 0 |
||||
} |
||||
if {[string length $connected(fh,$modpod)]} { |
||||
close $connected(fh,$modpod) |
||||
} |
||||
array unset connected *,$modpod |
||||
set connected(to) [lreplace $connected(to) $posn $posn] |
||||
return 1 |
||||
} |
||||
proc get {args} { |
||||
set argd [punk::args::parse $args withdef { |
||||
@id -id ::modpod::get |
||||
-from -default "" -help "path to pod" |
||||
@values -min 1 -max 1 |
||||
filename |
||||
}] |
||||
set frompod [dict get $argd opts -from] |
||||
set filename [dict get $argd values filename] |
||||
|
||||
variable connected |
||||
#//review |
||||
set modpod [::modpod::system::connect_if_not $frompod] |
||||
set fh $connected(fh,$modpod) |
||||
if {$connected(type,$modpod) eq "unwrapped"} { |
||||
#for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder |
||||
if {[string range $filename 0 0 eq "/"]} { |
||||
#absolute path (?) |
||||
set path [file join $connected(location,$modpod) .. [string trim $filename /]] |
||||
} else { |
||||
#relative path - use #modpod-xxx as base |
||||
set path [file join $connected(location,$modpod) $filename] |
||||
} |
||||
set fd [open $path r] |
||||
#utf-8? |
||||
#fconfigure $fd -encoding iso8859-1 -translation binary |
||||
return [list ok [lindex [list [read $fd] [close $fd]] 0]] |
||||
} else { |
||||
#read from vfs |
||||
puts stderr "get $filename from wrapped pod '$frompod' not implemented" |
||||
} |
||||
} |
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace modpod ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval modpod::lib { |
||||
namespace export {[a-z]*}; # Convention: export all lowercase |
||||
namespace path [namespace parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace modpod::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 |
||||
#} |
||||
|
||||
proc is_valid_tm_version {versionpart} { |
||||
#Needs to be suitable for use with Tcl's 'package vcompare' |
||||
if {![catch [list package vcompare $versionparts $versionparts]]} { |
||||
return 1 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
|
||||
#zipfile is a pure zip at this point - ie no script/exe header |
||||
proc make_zip_modpod {args} { |
||||
set argd [punk::args::parse $args withdef { |
||||
@id -id ::modpod::lib::make_zip_modpod |
||||
-offsettype -default "archive" -choices {archive file} -help\ |
||||
"Whether zip offsets are relative to start of file or start of zip-data within the file. |
||||
'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip, |
||||
but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip) |
||||
info-zip's 'zip -A' can sometimes convert archive-relative to file-relative. |
||||
-offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'" |
||||
@values -min 2 -max 2 |
||||
zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" |
||||
outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" |
||||
}] |
||||
set zipfile [dict get $argd values zipfile] |
||||
set outfile [dict get $argd values outfile] |
||||
set opt_offsettype [dict get $argd opts -offsettype] |
||||
|
||||
|
||||
set mount_stub [string map [list %offsettype% $opt_offsettype] { |
||||
#zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. |
||||
#Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. |
||||
#generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% <zipfile> <tmfile> |
||||
if {[catch {file normalize [info script]} modfile]} { |
||||
error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" |
||||
} |
||||
if {$modfile eq "" || ![file exists $modfile]} { |
||||
error "modpod zip stub error. Unable to determine module path" |
||||
} |
||||
set moddir [file dirname $modfile] |
||||
set exedir [file dirname [file normalize [info nameofexecutable]]] |
||||
set mod_and_ver [file rootname [file tail $modfile]] |
||||
lassign [split $mod_and_ver -] moduletail version |
||||
|
||||
#determine module namespace so we can mount appropriately |
||||
proc intersect {A B} { |
||||
if {[llength $A] == 0} {return {}} |
||||
if {[llength $B] == 0} {return {}} |
||||
if {[llength $B] > [llength $A]} { |
||||
set res $A |
||||
set A $B |
||||
set B $res |
||||
} |
||||
set res {} |
||||
foreach x $A {set ($x) {}} |
||||
foreach x $B { |
||||
if {[info exists ($x)]} { |
||||
lappend res $x |
||||
} |
||||
} |
||||
return $res |
||||
} |
||||
set lcase_tmfile_segments [string tolower [file split $moddir]] |
||||
set lcase_modulepaths [string tolower [tcl::tm::list]] |
||||
foreach lc_mpath $lcase_modulepaths { |
||||
set mpath_segments [file split $lc_mpath] |
||||
if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
||||
set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use properly cased tail |
||||
break |
||||
} |
||||
} |
||||
if {[llength $tail_segments]} { |
||||
set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require |
||||
set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver |
||||
} else { |
||||
set fullpackage $moduletail |
||||
set mount_at #modpod/#mounted-modpod-$mod_and_ver |
||||
} |
||||
|
||||
if {[info commands tcl::zipfs::mount] ne ""} { |
||||
#argument order changed to be consistent with vfs::zip::Mount etc |
||||
#early versions: zipfs::Mount mountpoint zipname |
||||
#since 2023-09: zipfs::Mount zipname mountpoint |
||||
#don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance) |
||||
#This is presumably related to // being interpreted as a network path |
||||
set mountpoints [dict keys [tcl::zipfs::mount]] |
||||
if {"//zipfs:/$mount_at" ni $mountpoints} { |
||||
#despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it |
||||
if {[catch { |
||||
#tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) |
||||
#puts "tcl::zipfs::mount $modfile $mount_at" |
||||
tcl::zipfs::mount $modfile $mount_at |
||||
} errM]} { |
||||
#try old api |
||||
if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { |
||||
puts stderr "modpod stub>>> tcl::zipfs::mount <file> <mountpoint> failed.\nbut old api: tcl::zipfs::mount <mountpoint> <file> succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" |
||||
puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" |
||||
} |
||||
} |
||||
if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
||||
puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]" |
||||
#tcl::zipfs::unmount //zipfs:/$mount_at |
||||
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" |
||||
} |
||||
} |
||||
# #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form |
||||
source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm |
||||
} else { |
||||
#fallback to slower vfs::zip |
||||
#NB. We don't create the intermediate dirs - but the mount still works |
||||
|
||||
if {![file exists $exedir/$mount_at]} { |
||||
if {[catch {package require vfs::zip} errM]} { |
||||
set msg "Unable to load vfs::zip package to mount module $mod_and_ver (and zipfs not available either)" |
||||
append msg \n "If neither zipfs or vfs::zip are available - the module can still be loaded by manually unzipping the file $modfile in place." |
||||
append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" |
||||
error $msg |
||||
} else { |
||||
set fd [vfs::zip::Mount $modfile $exedir/$mount_at] |
||||
if {![file exists $exedir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
||||
vfs::zip::Unmount $fd $exedir/$mount_at |
||||
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" |
||||
} |
||||
} |
||||
} |
||||
source $exedir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm |
||||
} |
||||
#zipped data follows |
||||
}] |
||||
#todo - test if supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? |
||||
append mount_stub \x1A |
||||
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub $opt_offsettype |
||||
|
||||
} |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace modpod::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
namespace eval modpod::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace modpod::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
#deflate,store only supported |
||||
|
||||
#zipfile here is plain zip - no script/exe prefix part. |
||||
proc make_mountable_zip {zipfile outfile mount_stub {offsettype "archive"}} { |
||||
set inzip [open $zipfile r] |
||||
fconfigure $inzip -encoding iso8859-1 -translation binary |
||||
set out [open $outfile w+] |
||||
fconfigure $out -encoding iso8859-1 -translation binary |
||||
puts -nonewline $out $mount_stub |
||||
set stuboffset [tell $out] |
||||
lappend report "stub size: $stuboffset" |
||||
fcopy $inzip $out |
||||
close $inzip |
||||
|
||||
set size [tell $out] |
||||
lappend report "modpod::system::make_mountable_zip" |
||||
lappend report "tmfile : [file tail $outfile]" |
||||
lappend report "output size : $size" |
||||
lappend report "offsettype : $offsettype" |
||||
|
||||
if {$offsettype eq "file"} { |
||||
#make zip offsets relative to start of whole file including prepended script. |
||||
#same offset structure as Tcl's older 'zipfs mkimg' as at 2024-10 |
||||
#2025 - zipfs mkimg fixed to use 'archive' offset. |
||||
#not editable by 7z,nanazip,peazip |
||||
|
||||
#we aren't adding any new files/folders so we can edit the offsets in place |
||||
|
||||
#Now seek in $out to find the end of directory signature: |
||||
#The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text |
||||
if {$size < 65559} { |
||||
set tailsearch_start 0 |
||||
} else { |
||||
set tailsearch_start [expr {$size - 65559}] |
||||
} |
||||
seek $out $tailsearch_start |
||||
set data [read $out] |
||||
#EOCD - End of Central Directory record |
||||
#PK\5\6 |
||||
set start_of_end [string last "\x50\x4b\x05\x06" $data] |
||||
#set start_of_end [expr {$start_of_end + $seek}] |
||||
#incr start_of_end $seek |
||||
set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] |
||||
|
||||
lappend report "kitfile-relative START-OF-EOCD: $filerelative_eocd_posn" |
||||
|
||||
seek $out $filerelative_eocd_posn |
||||
set end_of_ctrl_dir [read $out] |
||||
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||
|
||||
lappend report "End of central directory: [array get eocd]" |
||||
seek $out [expr {$filerelative_eocd_posn+16}] |
||||
|
||||
#adjust offset of start of central directory by the length of our sfx stub |
||||
puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $stuboffset}]] |
||||
flush $out |
||||
|
||||
seek $out $filerelative_eocd_posn |
||||
set end_of_ctrl_dir [read $out] |
||||
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||
|
||||
# 0x06054b50 - end of central dir signature |
||||
puts stderr "$end_of_ctrl_dir" |
||||
puts stderr "comment_len: $eocd(comment_len)" |
||||
puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" |
||||
lappend report "New dir offset: $eocd(diroffset)" |
||||
lappend report "Adjusting $eocd(totalnum) zip file items." |
||||
catch { |
||||
punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies |
||||
} |
||||
|
||||
seek $out $eocd(diroffset) |
||||
for {set i 0} {$i <$eocd(totalnum)} {incr i} { |
||||
set current_file [tell $out] |
||||
set fileheader [read $out 46] |
||||
puts -------------- |
||||
puts [ansistring VIEW -lf 1 $fileheader] |
||||
puts -------------- |
||||
#binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||
# x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||
|
||||
binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||
set ::last_header $fileheader |
||||
|
||||
puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" |
||||
puts "ver: $x(version)" |
||||
puts "method: $x(method)" |
||||
|
||||
#PK\1\2 |
||||
#33639248 dec = 0x02014b50 - central directory file header signature |
||||
if { $x(sig) != 33639248 } { |
||||
error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" |
||||
} |
||||
|
||||
foreach size $x(lengths) var {filename extrafield comment} { |
||||
if { $size > 0 } { |
||||
set x($var) [read $out $size] |
||||
} else { |
||||
set x($var) "" |
||||
} |
||||
} |
||||
set next_file [tell $out] |
||||
lappend report "file $i: $x(offset) $x(sizes) $x(filename)" |
||||
|
||||
seek $out [expr {$current_file+42}] |
||||
puts -nonewline $out [binary format i [expr {$x(offset)+$stuboffset}]] |
||||
|
||||
#verify: |
||||
flush $out |
||||
seek $out $current_file |
||||
set fileheader [read $out 46] |
||||
lappend report "old $x(offset) + $stuboffset" |
||||
binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||
lappend report "new $x(offset)" |
||||
|
||||
seek $out $next_file |
||||
} |
||||
} |
||||
|
||||
close $out |
||||
#pdict/showdict reuire punk & textlib - ie lots of dependencies |
||||
#don't fall over just because of that |
||||
catch { |
||||
punk::lib::showdict -roottype list -chan stderr $report |
||||
} |
||||
#puts [join $report \n] |
||||
return |
||||
} |
||||
|
||||
proc connect_if_not {{podpath ""}} { |
||||
upvar ::modpod::connected connected |
||||
set podpath [::modpod::system::normalize $podpath] |
||||
set docon 0 |
||||
if {![llength $connected(to)]} { |
||||
if {![string length $podpath]} { |
||||
error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified" |
||||
} else { |
||||
set docon 1 |
||||
} |
||||
} else { |
||||
if {![string length $podpath]} { |
||||
set podpath [lindex $connected(to) end] |
||||
puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]" |
||||
} else { |
||||
if {$podpath ni $connected(to)} { |
||||
set docon 1 |
||||
} |
||||
} |
||||
} |
||||
if {$docon} { |
||||
if {[lindex [modpod::connect $podpath]] 0] ne "ok"} { |
||||
error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod" |
||||
} else { |
||||
return $podpath |
||||
} |
||||
} |
||||
#we were already connected |
||||
return $podpath |
||||
} |
||||
|
||||
proc myversion {} { |
||||
upvar ::modpod::connected connected |
||||
set script [info script] |
||||
if {![string length $script]} { |
||||
error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod" |
||||
} |
||||
set fname [file tail [file rootname [file normalize $script]]] |
||||
set scriptdir [file dirname $script] |
||||
|
||||
if {![string match "#modpod-*" $fname]} { |
||||
lassign [lrange [split $fname -] end-1 end] _pkgname version |
||||
} else { |
||||
lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version |
||||
if {![string length $version]} { |
||||
#try again on the name of the containing folder |
||||
lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version |
||||
#todo - proper walk up the directory tree |
||||
if {![string length $version]} { |
||||
#try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod) |
||||
lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version |
||||
} |
||||
} |
||||
} |
||||
|
||||
#tarjar::Log debug "'myversion' determined version for [info script]: $version" |
||||
return $version |
||||
} |
||||
|
||||
proc myname {} { |
||||
upvar ::modpod::connected connected |
||||
set script [info script] |
||||
if {![string length $script]} { |
||||
error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod" |
||||
} |
||||
return $connected(fullpackage,$script) |
||||
} |
||||
proc myfullname {} { |
||||
upvar ::modpod::connected connected |
||||
set script [info script] |
||||
#set script [::tarjar::normalize $script] |
||||
set script [file normalize $script] |
||||
if {![string length $script]} { |
||||
error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar" |
||||
} |
||||
return $::tarjar::connected(fullpackage,$script) |
||||
} |
||||
proc normalize {path} { |
||||
#newer versions of Tcl don't do tilde sub |
||||
|
||||
#Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths) |
||||
# we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function. |
||||
set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes.. |
||||
set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after |
||||
set path [file normalize $path] |
||||
#set path [string tolower $path] ;#must do this after file normalize |
||||
return [string map [list $matilda ~] $path] ;#get our tildes back. |
||||
} |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide modpod [namespace eval modpod { |
||||
variable pkg modpod |
||||
variable version |
||||
set version 0.1.4 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -1,201 +0,0 @@
|
||||
#JMN - api should be kept in sync with package patternlib where possible |
||||
# |
||||
package provide oolib [namespace eval oolib { |
||||
variable version |
||||
set version 0.1.2 |
||||
}] |
||||
|
||||
namespace eval oolib { |
||||
oo::class create collection { |
||||
variable o_data ;#dict |
||||
#variable o_alias |
||||
constructor {} { |
||||
set o_data [dict create] |
||||
} |
||||
method info {} { |
||||
return [dict info $o_data] |
||||
} |
||||
method count {} { |
||||
return [dict size $o_data] |
||||
} |
||||
method isEmpty {} { |
||||
expr {[dict size $o_data] == 0} |
||||
} |
||||
method names {{globOrIdx {}}} { |
||||
if {[llength $globOrIdx]} { |
||||
if {[string is integer -strict $globOrIdx]} { |
||||
set idx $globOrIdx |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $idx} result]} { |
||||
error "[self object] no such index : '$idx'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} else { |
||||
#glob |
||||
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] |
||||
} |
||||
} else { |
||||
return [dict keys $o_data] |
||||
} |
||||
} |
||||
#like names but without globbing |
||||
method keys {} { |
||||
dict keys $o_data |
||||
} |
||||
method key {{posn 0}} { |
||||
if {$posn < 0} { |
||||
set posn "end-[expr {abs($posn + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $posn} result]} { |
||||
error "[self object] no such index : '$posn'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} |
||||
method hasKey {key} { |
||||
dict exists $o_data $key |
||||
} |
||||
method get {} { |
||||
return $o_data |
||||
} |
||||
method items {} { |
||||
return [dict values $o_data] |
||||
} |
||||
method item {key} { |
||||
if {[string is integer -strict $key]} { |
||||
if {$key >= 0} { |
||||
set valposn [expr {(2*$key) +1}] |
||||
return [lindex $o_data $valposn] |
||||
} else { |
||||
set key "end-[expr {abs($key + 1)}]" |
||||
return [lindex $o_data $key] |
||||
#return [lindex [dict keys $o_data] $key] |
||||
} |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
return [dict get $o_data $key] |
||||
} |
||||
} |
||||
#inverse lookup |
||||
method itemKeys {value} { |
||||
set value_indices [lsearch -all [dict values $o_data] $value] |
||||
set keylist [list] |
||||
foreach i $value_indices { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
method search {value args} { |
||||
set matches [lsearch {*}$args [dict values $o_data] $value] |
||||
if {"-inline" in $args} { |
||||
return $matches |
||||
} else { |
||||
set keylist [list] |
||||
foreach i $matches { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
} |
||||
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? |
||||
#review - what is the point of alias anyway? - why slow down other operations when a variable can hold a keyname perfectly well? |
||||
#method alias {newAlias existingKeyOrAlias} { |
||||
# if {[string is integer -strict $newAlias]} { |
||||
# error "[self object] collection key alias cannot be integer" |
||||
# } |
||||
# if {[string length $existingKeyOrAlias]} { |
||||
# set o_alias($newAlias) $existingKeyOrAlias |
||||
# } else { |
||||
# unset o_alias($newAlias) |
||||
# } |
||||
#} |
||||
#method aliases {{key ""}} { |
||||
# if {[string length $key]} { |
||||
# set result [list] |
||||
# foreach {n v} [array get o_alias] { |
||||
# if {$v eq $key} { |
||||
# lappend result $n $v |
||||
# } |
||||
# } |
||||
# return $result |
||||
# } else { |
||||
# return [array get o_alias] |
||||
# } |
||||
#} |
||||
##if the supplied index is an alias, return the underlying key; else return the index supplied. |
||||
#method realKey {idx} { |
||||
# if {[catch {set o_alias($idx)} key]} { |
||||
# return $idx |
||||
# } else { |
||||
# return $key |
||||
# } |
||||
#} |
||||
method add {value key} { |
||||
if {[string is integer -strict $key]} { |
||||
error "[self object] collection key must not be an integer. Use another structure if integer keys required" |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
error "[self object] col_processors object error: key '$key' already exists in collection" |
||||
} |
||||
dict set o_data $key $value |
||||
return [expr {[dict size $o_data] - 1}] ;#return index of item |
||||
} |
||||
method remove {idx {endRange ""}} { |
||||
if {[string length $endRange]} { |
||||
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" |
||||
} |
||||
if {[string is integer -strict $idx]} { |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx+1)}]" |
||||
} |
||||
set key [lindex [dict keys $o_data] $idx] |
||||
set posn $idx |
||||
} else { |
||||
set key $idx |
||||
set posn [lsearch -exact [dict keys $o_data] $key] |
||||
if {$posn < 0} { |
||||
error "[self object] no such index: '$idx' in this collection" |
||||
} |
||||
} |
||||
dict unset o_data $key |
||||
return |
||||
} |
||||
method clear {} { |
||||
set o_data [dict create] |
||||
return |
||||
} |
||||
method reverse_the_collection {} { |
||||
#named slightly obtusely because reversing the data when there may be references held is a potential source of bugs |
||||
#the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy. |
||||
#todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations. |
||||
set dictnew [dict create] |
||||
foreach k [lreverse [dict keys $o_data]] { |
||||
dict set dictnew $k [dict get $o_data $k] |
||||
} |
||||
set o_data $dictnew |
||||
return |
||||
} |
||||
#review - cmd as list vs cmd as script? |
||||
method map {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list {*}$cmd $v]] |
||||
} |
||||
return $seed |
||||
} |
||||
method objectmap {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list $v {*}$cmd]] |
||||
} |
||||
return $seed |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
@ -1,361 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.4.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) 2026 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application opunk::console 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
package require Tcl 8.6- |
||||
|
||||
package require voo |
||||
package require punk::args |
||||
|
||||
#opunk::Console - a voo (value-based) representation of a console: an in/out channel pair claimed to |
||||
#belong to one responding endpoint, together with settled capability facts about that endpoint. |
||||
# |
||||
#Motivation (see punk::console get_size / get_ansi_response_payload history): |
||||
#ANSI query mechanisms assume the input channel receives what the output channel's device emits in |
||||
#response. When stdio is redirected that pairing silently breaks - queries go to a terminal whose |
||||
#replies land in some other process's input. A console object makes the pairing an explicit, |
||||
#construction-time property instead of a per-query-site guess. |
||||
# |
||||
#Design notes: |
||||
# - Objects are voo values (plain lists). Consoles are entities, not values - so canonical instances |
||||
# are anchored at well-known namespace variables (::opunk::console::instances::<name>) and the value |
||||
# semantics serve as cheap snapshots. Mutation (settling capabilities) goes through the anchor via |
||||
# the lowercase ::opunk::console wrapper procs. |
||||
# - The class is -virtual: slot 0 of each value carries the concrete class namespace, so channel |
||||
# environments that respond like terminals but aren't platform consoles can subclass |
||||
# (-extends ::opunk::Console) and override the capability/size methods, with existing holders of |
||||
# console values dispatching correctly. |
||||
# - This first cut is standalone and passive: capability detection is heuristic (channel options, |
||||
# probed eof, terminal env hints) and size uses chan -winsize else the default size. Active ANSI |
||||
# query probing arrives with punk::console integration (which will delegate here rather than the |
||||
# class depending on punk::console). |
||||
|
||||
tcl::namespace::eval ::opunk::console { |
||||
variable PUNKARGS |
||||
|
||||
#well-known cooperative store for bytes consumed by probe reads on pipe-like channels |
||||
#dict keyed by channel name -> list of chunks. Readers taking over a channel should consume |
||||
#and clear any entry for that channel first. (analogous to punk::console::input_chunks_waiting) |
||||
variable waiting_chunks |
||||
if {![info exists waiting_chunks]} { |
||||
set waiting_chunks [dict create] |
||||
} |
||||
} |
||||
|
||||
voo::class ::opunk::Console -virtual { |
||||
private { |
||||
#o_ prefix per opunk voo convention (distinguishes fields from locals in -update methods, |
||||
#and matches tclOO-style implementations elsewhere for easier code movement). |
||||
#Note the class is -virtual: slot 0 of the object value is the concrete class namespace tag. |
||||
string_t o_in stdin |
||||
string_t o_out stdout |
||||
string_t o_terminal_class "" ;#e.g windows-console, tty, pipe - "" until classified |
||||
list_t o_size_mechanism [list] ;#preferred size mechanism try-order - empty until timed/settled |
||||
dict_t o_default_size [dict create columns 80 rows 24] |
||||
} |
||||
public { |
||||
#settled response capability: -1 unknown, 0 cannot respond, 1 can respond. |
||||
#public accessors (get.o_can_respond / set.o_can_respond) so the anchored-mutation wrappers in |
||||
#::opunk::console can settle it without reaching into private my.* accessors. |
||||
int_t o_can_respond -1 |
||||
|
||||
method in {} { |
||||
my.get.o_in $this |
||||
} |
||||
method out {} { |
||||
my.get.o_out $this |
||||
} |
||||
method channels {} { |
||||
list [my.get.o_in $this] [my.get.o_out $this] |
||||
} |
||||
method terminal_class {} { |
||||
my.get.o_terminal_class $this |
||||
} |
||||
method default_size {} { |
||||
my.get.o_default_size $this |
||||
} |
||||
|
||||
#Certainty test: is the input channel closed or at eof (and so can never deliver a response)? |
||||
#A consumed/half-closed pipe may not flag eof until a read is attempted, so pipe-like channels |
||||
#get a non-blocking 1-byte probe. A probed byte is preserved in ::opunk::console::waiting_chunks |
||||
#for cooperating readers. Console/tty channels are never probed (must not consume a keystroke). |
||||
method at_eof {} -virtual { |
||||
if {[llength $this] < 7} { |
||||
error "invalid object $this" |
||||
} |
||||
set in [my.get.o_in $this] |
||||
if {[catch {chan eof $in} is_eof]} { |
||||
return 1 ;#closed/invalid channel - unusable |
||||
} |
||||
if {$is_eof} { |
||||
return 1 |
||||
} |
||||
if {[catch {chan configure $in} conf]} { |
||||
return 1 |
||||
} |
||||
if {[dict exists $conf -inputmode] || [dict exists $conf -mode]} { |
||||
return 0 |
||||
} |
||||
if {[catch { |
||||
set prior_blocking [dict get $conf -blocking] |
||||
chan configure $in -blocking 0 |
||||
set probe [read $in 1] |
||||
chan configure $in -blocking $prior_blocking |
||||
}]} { |
||||
return 1 |
||||
} |
||||
if {$probe ne ""} { |
||||
dict lappend ::opunk::console::waiting_chunks $in $probe |
||||
} |
||||
return [chan eof $in] |
||||
} |
||||
|
||||
#Heuristic: could the input channel be connected to a terminal able to answer queries? |
||||
#Returns 0 only when reasonably confident it cannot. mintty without winpty presents a |
||||
#terminal's stdin as a plain pipe, so env hints (MSYSTEM, TERM_PROGRAM) prevent false |
||||
#negatives there at the cost of false positives for genuinely piped-but-open input. |
||||
method is_console_or_tty {} -virtual { |
||||
if {[llength $this] < 7} { |
||||
error "invalid object $this" |
||||
} |
||||
set in [my.get.o_in $this] |
||||
if {[catch {chan configure $in} conf]} { |
||||
return 0 |
||||
} |
||||
if {[dict exists $conf -inputmode]} { |
||||
return 1 |
||||
} |
||||
if {[dict exists $conf -mode]} { |
||||
return 1 |
||||
} |
||||
if {[at_eof $this]} { |
||||
return 0 |
||||
} |
||||
if {[info exists ::env(TERM_PROGRAM)] || [info exists ::env(MSYSTEM)]} { |
||||
return 1 |
||||
} |
||||
return 0 |
||||
} |
||||
|
||||
#Response capability: settled value if known, else computed heuristically (without settling - |
||||
#this method is pure; use ::opunk::console::can_respond <name> to settle an anchored instance). |
||||
#TODO: active probe query (device attributes with timeout) when punk::console query machinery |
||||
#is integrated - heuristics can then be replaced by one settling probe at first use. |
||||
method can_respond {} -virtual { |
||||
if {[llength $this] < 7} { |
||||
error "invalid object $this" |
||||
} |
||||
set settled [get.o_can_respond $this] |
||||
if {$settled != -1} { |
||||
return $settled |
||||
} |
||||
return [is_console_or_tty $this] |
||||
} |
||||
|
||||
#Size of the console: chan -winsize on the output channel when available (fast, no query), |
||||
#else the configured default size. ANSI cursor-report mechanisms are deliberately absent from |
||||
#this standalone class - they arrive via punk::console integration and subclasses. |
||||
method size {} -virtual { |
||||
if {[llength $this] < 7} { |
||||
error "invalid object $this" |
||||
} |
||||
set out [my.get.o_out $this] |
||||
if {![catch {chan configure $out} oconf]} { |
||||
if {[dict exists $oconf -winsize]} { |
||||
lassign [dict get $oconf -winsize] cols lines |
||||
if {[string is integer -strict $cols] && [string is integer -strict $lines]} { |
||||
return [dict create columns $cols rows $lines] |
||||
} |
||||
} |
||||
} |
||||
return [my.get.o_default_size $this] |
||||
} |
||||
} |
||||
|
||||
constructor {in out} { |
||||
#new() supplies the class defaults including the virtual class tag at slot 0 |
||||
set obj [new()] |
||||
my.set.o_in obj $in |
||||
my.set.o_out obj $out |
||||
return $obj |
||||
} |
||||
} |
||||
|
||||
#make introspection (with i and punk::ns::cmdinfo) easier by making the class namespace an ensemble - we can still access it as ::opunk::Console |
||||
namespace eval ::opunk::Console { |
||||
namespace ensemble create |
||||
} |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Anchored instances - the 'consoles are entities' layer |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval ::opunk::console { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
|
||||
namespace eval instances { |
||||
#one variable per anchored console instance - the canonical location of each console object. |
||||
#Access via the sibling procs; methods needing to mutate an instance go through these anchors. |
||||
} |
||||
|
||||
proc create {name in out} { |
||||
if {![string is wordchar -strict $name]} { |
||||
error "opunk::console::create name must be alphanumeric/underscore, got '$name'" |
||||
} |
||||
set [namespace current]::instances::$name [::opunk::Console::new $in $out] |
||||
return [namespace current]::instances::$name |
||||
} |
||||
proc instancevar {name} { |
||||
set v [namespace current]::instances::$name |
||||
if {![info exists $v]} { |
||||
error "opunk::console: no anchored console instance named '$name' (known: [names])" |
||||
} |
||||
return $v |
||||
} |
||||
proc instance {name} { |
||||
set [instancevar $name] |
||||
} |
||||
proc names {} { |
||||
set result [list] |
||||
foreach v [info vars [namespace current]::instances::*] { |
||||
lappend result [namespace tail $v] |
||||
} |
||||
return $result |
||||
} |
||||
proc forget {name} { |
||||
unset [instancevar $name] |
||||
return |
||||
} |
||||
|
||||
#settle-and-cache response capability on the anchored instance. |
||||
#The class method is pure (value-in) - this wrapper owns the mutation via the anchor. |
||||
proc can_respond {name} { |
||||
upvar #0 [instancevar $name] obj |
||||
set settled [::opunk::Console::get.o_can_respond $obj] |
||||
if {$settled != -1} { |
||||
return $settled |
||||
} |
||||
set r [::opunk::Console::can_respond $obj] |
||||
::opunk::Console::set.o_can_respond obj $r |
||||
return $r |
||||
} |
||||
proc size {name} { |
||||
::opunk::Console::size [instance $name] |
||||
} |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# == === === === === === === === === === === === === === === |
||||
# Sample 'about' function with punk::args documentation |
||||
# == === === === === === === === === === === === === === === |
||||
tcl::namespace::eval ::opunk::console { |
||||
variable PUNKARGS |
||||
variable PUNKARGS_aliases |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)opunk::console" |
||||
@package -name "opunk::console" -help\ |
||||
"voo class ::opunk::Console representing a console as an in/out channel pair with settled |
||||
response-capability facts, plus anchored canonical instances under ::opunk::console::instances." |
||||
}] |
||||
|
||||
namespace eval argdoc { |
||||
proc package_name {} { |
||||
return opunk::console |
||||
} |
||||
proc about_topics {} { |
||||
set topic_funs [info commands [namespace current]::get_topic_*] |
||||
set about_topics [list] |
||||
foreach f $topic_funs { |
||||
set tail [namespace tail $f] |
||||
lappend about_topics [string range $tail [string length get_topic_] end] |
||||
} |
||||
return [lsort $about_topics] |
||||
} |
||||
proc default_topics {} {return [list Description *]} |
||||
|
||||
proc get_topic_Description {} { |
||||
punk::args::lib::tstr [string trim { |
||||
package opunk::console |
||||
voo class for consoles as channel-pair objects with anchored canonical instances. |
||||
} \n] |
||||
} |
||||
proc get_topic_License {} { |
||||
return "BSD" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return "$::opunk::console::version" |
||||
} |
||||
proc get_topic_Contributors {} { |
||||
set authors {{"Julian Noble" "julian@precisium.com.au"}} |
||||
set contributors "" |
||||
foreach a $authors { |
||||
append contributors $a \n |
||||
} |
||||
if {[string index $contributors end] eq "\n"} { |
||||
set contributors [string range $contributors 0 end-1] |
||||
} |
||||
return $contributors |
||||
} |
||||
proc get_topic_classes {} { |
||||
punk::args::lib::tstr -return string { |
||||
opunk::Console "virtual class for consoles as in/out channel pairs" |
||||
} |
||||
} |
||||
} |
||||
|
||||
set overrides [dict create] |
||||
dict set overrides @id -id "::opunk::console::about" |
||||
dict set overrides @cmd -name "opunk::console::about" |
||||
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||
About opunk::console |
||||
}] \n] |
||||
dict set overrides topic -choices [list {*}[opunk::console::argdoc::about_topics] *] |
||||
dict set overrides topic -choicerestricted 1 |
||||
dict set overrides topic -default [opunk::console::argdoc::default_topics] |
||||
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||
lappend PUNKARGS [list $newdef] |
||||
proc about {args} { |
||||
package require punk::args |
||||
set argd [punk::args::parse $args withid ::opunk::console::about] |
||||
lassign [dict values $argd] _leaders opts values _received |
||||
punk::args::package::standard_about -package_about_namespace ::opunk::console::argdoc {*}$opts {*}[dict get $values topic] |
||||
} |
||||
} |
||||
# end of sample 'about' function |
||||
# == === === === === === === === === === === === === === === |
||||
|
||||
|
||||
# ----------------------------------------------------------------------------- |
||||
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
||||
# ----------------------------------------------------------------------------- |
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::opunk::console ::opunk::Console |
||||
} |
||||
# ----------------------------------------------------------------------------- |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide opunk::console [tcl::namespace::eval ::opunk::console { |
||||
variable pkg opunk::console |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -1,361 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.4.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) 2026 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application opunk::console 0.1.1 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
package require Tcl 8.6- |
||||
|
||||
package require voo |
||||
package require punk::args |
||||
|
||||
#opunk::Console - a voo (value-based) representation of a console: an in/out channel pair claimed to |
||||
#belong to one responding endpoint, together with settled capability facts about that endpoint. |
||||
# |
||||
#Motivation (see punk::console get_size / get_ansi_response_payload history): |
||||
#ANSI query mechanisms assume the input channel receives what the output channel's device emits in |
||||
#response. When stdio is redirected that pairing silently breaks - queries go to a terminal whose |
||||
#replies land in some other process's input. A console object makes the pairing an explicit, |
||||
#construction-time property instead of a per-query-site guess. |
||||
# |
||||
#Design notes: |
||||
# - Objects are voo values (plain lists). Consoles are entities, not values - so canonical instances |
||||
# are anchored at well-known namespace variables (::opunk::console::instances::<name>) and the value |
||||
# semantics serve as cheap snapshots. Mutation (settling capabilities) goes through the anchor via |
||||
# the lowercase ::opunk::console wrapper procs. |
||||
# - The class is -virtual: slot 0 of each value carries the concrete class namespace, so channel |
||||
# environments that respond like terminals but aren't platform consoles can subclass |
||||
# (-extends ::opunk::Console) and override the capability/size methods, with existing holders of |
||||
# console values dispatching correctly. |
||||
# - This first cut is standalone and passive: capability detection is heuristic (channel options, |
||||
# probed eof, terminal env hints) and size uses chan -winsize else the default size. Active ANSI |
||||
# query probing arrives with punk::console integration (which will delegate here rather than the |
||||
# class depending on punk::console). |
||||
|
||||
tcl::namespace::eval ::opunk::console { |
||||
variable PUNKARGS |
||||
|
||||
#well-known cooperative store for bytes consumed by probe reads on pipe-like channels |
||||
#dict keyed by channel name -> list of chunks. Readers taking over a channel should consume |
||||
#and clear any entry for that channel first. (analogous to punk::console::input_chunks_waiting) |
||||
variable waiting_chunks |
||||
if {![info exists waiting_chunks]} { |
||||
set waiting_chunks [dict create] |
||||
} |
||||
} |
||||
|
||||
voo::class ::opunk::Console -virtual { |
||||
private { |
||||
#o_ prefix per opunk voo convention (distinguishes fields from locals in -update methods, |
||||
#and matches tclOO-style implementations elsewhere for easier code movement). |
||||
#Note the class is -virtual: slot 0 of the object value is the concrete class namespace tag. |
||||
string_t o_in stdin |
||||
string_t o_out stdout |
||||
string_t o_terminal_class "" ;#e.g windows-console, tty, pipe - "" until classified |
||||
list_t o_size_mechanism [list] ;#preferred size mechanism try-order - empty until timed/settled |
||||
dict_t o_default_size [dict create columns 80 rows 24] |
||||
} |
||||
public { |
||||
#settled response capability: -1 unknown, 0 cannot respond, 1 can respond. |
||||
#public accessors (get.o_can_respond / set.o_can_respond) so the anchored-mutation wrappers in |
||||
#::opunk::console can settle it without reaching into private my.* accessors. |
||||
int_t o_can_respond -1 |
||||
|
||||
method in {} { |
||||
my.get.o_in $this |
||||
} |
||||
method out {} { |
||||
my.get.o_out $this |
||||
} |
||||
method channels {} { |
||||
list [my.get.o_in $this] [my.get.o_out $this] |
||||
} |
||||
method terminal_class {} { |
||||
my.get.o_terminal_class $this |
||||
} |
||||
method default_size {} { |
||||
my.get.o_default_size $this |
||||
} |
||||
|
||||
#Certainty test: is the input channel closed or at eof (and so can never deliver a response)? |
||||
#A consumed/half-closed pipe may not flag eof until a read is attempted, so pipe-like channels |
||||
#get a non-blocking 1-byte probe. A probed byte is preserved in ::opunk::console::waiting_chunks |
||||
#for cooperating readers. Console/tty channels are never probed (must not consume a keystroke). |
||||
method at_eof {} -virtual { |
||||
if {[llength $this] < 7} { |
||||
error "invalid object $this" |
||||
} |
||||
set in [my.get.o_in $this] |
||||
if {[catch {chan eof $in} is_eof]} { |
||||
return 1 ;#closed/invalid channel - unusable |
||||
} |
||||
if {$is_eof} { |
||||
return 1 |
||||
} |
||||
if {[catch {chan configure $in} conf]} { |
||||
return 1 |
||||
} |
||||
if {[dict exists $conf -inputmode] || [dict exists $conf -mode]} { |
||||
return 0 |
||||
} |
||||
if {[catch { |
||||
set prior_blocking [dict get $conf -blocking] |
||||
chan configure $in -blocking 0 |
||||
set probe [read $in 1] |
||||
chan configure $in -blocking $prior_blocking |
||||
}]} { |
||||
return 1 |
||||
} |
||||
if {$probe ne ""} { |
||||
dict lappend ::opunk::console::waiting_chunks $in $probe |
||||
} |
||||
return [chan eof $in] |
||||
} |
||||
|
||||
#Heuristic: could the input channel be connected to a terminal able to answer queries? |
||||
#Returns 0 only when reasonably confident it cannot. mintty without winpty presents a |
||||
#terminal's stdin as a plain pipe, so env hints (MSYSTEM, TERM_PROGRAM) prevent false |
||||
#negatives there at the cost of false positives for genuinely piped-but-open input. |
||||
method is_console_or_tty {} -virtual { |
||||
if {[llength $this] < 7} { |
||||
error "invalid object $this" |
||||
} |
||||
set in [my.get.o_in $this] |
||||
if {[catch {chan configure $in} conf]} { |
||||
return 0 |
||||
} |
||||
if {[dict exists $conf -inputmode]} { |
||||
return 1 |
||||
} |
||||
if {[dict exists $conf -mode]} { |
||||
return 1 |
||||
} |
||||
if {[at_eof $this]} { |
||||
return 0 |
||||
} |
||||
if {[info exists ::env(TERM_PROGRAM)] || [info exists ::env(MSYSTEM)]} { |
||||
return 1 |
||||
} |
||||
return 0 |
||||
} |
||||
|
||||
#Response capability: settled value if known, else computed heuristically (without settling - |
||||
#this method is pure; use ::opunk::console::can_respond <name> to settle an anchored instance |
||||
#heuristically, or punk::console::settle_can_respond <spec> for active-probe settling - the |
||||
#probe machinery lives in punk::console so this class stays free of that dependency). |
||||
method can_respond {} -virtual { |
||||
if {[llength $this] < 7} { |
||||
error "invalid object $this" |
||||
} |
||||
set settled [get.o_can_respond $this] |
||||
if {$settled != -1} { |
||||
return $settled |
||||
} |
||||
return [is_console_or_tty $this] |
||||
} |
||||
|
||||
#Size of the console: chan -winsize on the output channel when available (fast, no query), |
||||
#else the configured default size. ANSI cursor-report mechanisms are deliberately absent from |
||||
#this standalone class - they arrive via punk::console integration and subclasses. |
||||
method size {} -virtual { |
||||
if {[llength $this] < 7} { |
||||
error "invalid object $this" |
||||
} |
||||
set out [my.get.o_out $this] |
||||
if {![catch {chan configure $out} oconf]} { |
||||
if {[dict exists $oconf -winsize]} { |
||||
lassign [dict get $oconf -winsize] cols lines |
||||
if {[string is integer -strict $cols] && [string is integer -strict $lines]} { |
||||
return [dict create columns $cols rows $lines] |
||||
} |
||||
} |
||||
} |
||||
return [my.get.o_default_size $this] |
||||
} |
||||
} |
||||
|
||||
constructor {in out} { |
||||
#new() supplies the class defaults including the virtual class tag at slot 0 |
||||
set obj [new()] |
||||
my.set.o_in obj $in |
||||
my.set.o_out obj $out |
||||
return $obj |
||||
} |
||||
} |
||||
|
||||
#make introspection (with i and punk::ns::cmdinfo) easier by making the class namespace an ensemble - we can still access it as ::opunk::Console |
||||
namespace eval ::opunk::Console { |
||||
namespace ensemble create |
||||
} |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Anchored instances - the 'consoles are entities' layer |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval ::opunk::console { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
|
||||
namespace eval instances { |
||||
#one variable per anchored console instance - the canonical location of each console object. |
||||
#Access via the sibling procs; methods needing to mutate an instance go through these anchors. |
||||
} |
||||
|
||||
proc create {name in out} { |
||||
if {![string is wordchar -strict $name]} { |
||||
error "opunk::console::create name must be alphanumeric/underscore, got '$name'" |
||||
} |
||||
set [namespace current]::instances::$name [::opunk::Console::new $in $out] |
||||
return [namespace current]::instances::$name |
||||
} |
||||
proc instancevar {name} { |
||||
set v [namespace current]::instances::$name |
||||
if {![info exists $v]} { |
||||
error "opunk::console: no anchored console instance named '$name' (known: [names])" |
||||
} |
||||
return $v |
||||
} |
||||
proc instance {name} { |
||||
set [instancevar $name] |
||||
} |
||||
proc names {} { |
||||
set result [list] |
||||
foreach v [info vars [namespace current]::instances::*] { |
||||
lappend result [namespace tail $v] |
||||
} |
||||
return $result |
||||
} |
||||
proc forget {name} { |
||||
unset [instancevar $name] |
||||
return |
||||
} |
||||
|
||||
#settle-and-cache response capability on the anchored instance. |
||||
#The class method is pure (value-in) - this wrapper owns the mutation via the anchor. |
||||
proc can_respond {name} { |
||||
upvar #0 [instancevar $name] obj |
||||
set settled [::opunk::Console::get.o_can_respond $obj] |
||||
if {$settled != -1} { |
||||
return $settled |
||||
} |
||||
set r [::opunk::Console::can_respond $obj] |
||||
::opunk::Console::set.o_can_respond obj $r |
||||
return $r |
||||
} |
||||
proc size {name} { |
||||
::opunk::Console::size [instance $name] |
||||
} |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# == === === === === === === === === === === === === === === |
||||
# Sample 'about' function with punk::args documentation |
||||
# == === === === === === === === === === === === === === === |
||||
tcl::namespace::eval ::opunk::console { |
||||
variable PUNKARGS |
||||
variable PUNKARGS_aliases |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)opunk::console" |
||||
@package -name "opunk::console" -help\ |
||||
"voo class ::opunk::Console representing a console as an in/out channel pair with settled |
||||
response-capability facts, plus anchored canonical instances under ::opunk::console::instances." |
||||
}] |
||||
|
||||
namespace eval argdoc { |
||||
proc package_name {} { |
||||
return opunk::console |
||||
} |
||||
proc about_topics {} { |
||||
set topic_funs [info commands [namespace current]::get_topic_*] |
||||
set about_topics [list] |
||||
foreach f $topic_funs { |
||||
set tail [namespace tail $f] |
||||
lappend about_topics [string range $tail [string length get_topic_] end] |
||||
} |
||||
return [lsort $about_topics] |
||||
} |
||||
proc default_topics {} {return [list Description *]} |
||||
|
||||
proc get_topic_Description {} { |
||||
punk::args::lib::tstr [string trim { |
||||
package opunk::console |
||||
voo class for consoles as channel-pair objects with anchored canonical instances. |
||||
} \n] |
||||
} |
||||
proc get_topic_License {} { |
||||
return "BSD" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return "$::opunk::console::version" |
||||
} |
||||
proc get_topic_Contributors {} { |
||||
set authors {{"Julian Noble" "julian@precisium.com.au"}} |
||||
set contributors "" |
||||
foreach a $authors { |
||||
append contributors $a \n |
||||
} |
||||
if {[string index $contributors end] eq "\n"} { |
||||
set contributors [string range $contributors 0 end-1] |
||||
} |
||||
return $contributors |
||||
} |
||||
proc get_topic_classes {} { |
||||
punk::args::lib::tstr -return string { |
||||
opunk::Console "virtual class for consoles as in/out channel pairs" |
||||
} |
||||
} |
||||
} |
||||
|
||||
set overrides [dict create] |
||||
dict set overrides @id -id "::opunk::console::about" |
||||
dict set overrides @cmd -name "opunk::console::about" |
||||
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||
About opunk::console |
||||
}] \n] |
||||
dict set overrides topic -choices [list {*}[opunk::console::argdoc::about_topics] *] |
||||
dict set overrides topic -choicerestricted 1 |
||||
dict set overrides topic -default [opunk::console::argdoc::default_topics] |
||||
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||
lappend PUNKARGS [list $newdef] |
||||
proc about {args} { |
||||
package require punk::args |
||||
set argd [punk::args::parse $args withid ::opunk::console::about] |
||||
lassign [dict values $argd] _leaders opts values _received |
||||
punk::args::package::standard_about -package_about_namespace ::opunk::console::argdoc {*}$opts {*}[dict get $values topic] |
||||
} |
||||
} |
||||
# end of sample 'about' function |
||||
# == === === === === === === === === === === === === === === |
||||
|
||||
|
||||
# ----------------------------------------------------------------------------- |
||||
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
||||
# ----------------------------------------------------------------------------- |
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::opunk::console ::opunk::Console |
||||
} |
||||
# ----------------------------------------------------------------------------- |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide opunk::console [tcl::namespace::eval ::opunk::console { |
||||
variable pkg opunk::console |
||||
variable version |
||||
set version 0.1.1 |
||||
}] |
||||
return |
||||
@ -1,372 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.4.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) 2026 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application opunk::console 0.2.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
package require Tcl 8.6- |
||||
|
||||
package require voo |
||||
package require punk::args |
||||
|
||||
#opunk::Console - a voo (value-based) representation of a console: an in/out channel pair claimed to |
||||
#belong to one responding endpoint, together with settled capability facts about that endpoint. |
||||
# |
||||
#Motivation (see punk::console get_size / get_ansi_response_payload history): |
||||
#ANSI query mechanisms assume the input channel receives what the output channel's device emits in |
||||
#response. When stdio is redirected that pairing silently breaks - queries go to a terminal whose |
||||
#replies land in some other process's input. A console object makes the pairing an explicit, |
||||
#construction-time property instead of a per-query-site guess. |
||||
# |
||||
#Design notes: |
||||
# - Objects are voo values (plain lists). Consoles are entities, not values - so canonical instances |
||||
# are anchored at well-known namespace variables (::opunk::console::instances::<name>) and the value |
||||
# semantics serve as cheap snapshots. Mutation (settling capabilities) goes through the anchor via |
||||
# the lowercase ::opunk::console wrapper procs. |
||||
# - The class is -virtual: slot 0 of each value carries the concrete class namespace, so channel |
||||
# environments that respond like terminals but aren't platform consoles can subclass |
||||
# (-extends ::opunk::Console) and override the capability/size methods, with existing holders of |
||||
# console values dispatching correctly. |
||||
# - This first cut is standalone and passive: capability detection is heuristic (channel options, |
||||
# probed eof, terminal env hints) and size uses chan -winsize else the default size. Active ANSI |
||||
# query probing arrives with punk::console integration (which will delegate here rather than the |
||||
# class depending on punk::console). |
||||
|
||||
tcl::namespace::eval ::opunk::console { |
||||
variable PUNKARGS |
||||
|
||||
#well-known cooperative store for bytes consumed by probe reads on pipe-like channels: |
||||
#an array keyed by channel name -> list of chunks. Readers taking over a channel should consume |
||||
#and clear any entry for that channel first. |
||||
#The store is PLUGGABLE via waiting_chunks_arrayvar: environments with an established cooperative |
||||
#store (e.g punk::console::input_chunks_waiting, which the punk repl reader consults) redirect it |
||||
#so probe-consumed bytes are never invisible to the active reader. The class itself stays free of |
||||
#any punk::console dependency - redirection is performed by the integrating layer. |
||||
variable waiting_chunks |
||||
if {![array exists waiting_chunks]} { |
||||
array set waiting_chunks {} |
||||
} |
||||
variable waiting_chunks_arrayvar |
||||
if {![info exists waiting_chunks_arrayvar]} { |
||||
set waiting_chunks_arrayvar ::opunk::console::waiting_chunks |
||||
} |
||||
} |
||||
|
||||
voo::class ::opunk::Console -virtual { |
||||
private { |
||||
#o_ prefix per opunk voo convention (distinguishes fields from locals in -update methods, |
||||
#and matches tclOO-style implementations elsewhere for easier code movement). |
||||
#Note the class is -virtual: slot 0 of the object value is the concrete class namespace tag. |
||||
string_t o_in stdin |
||||
string_t o_out stdout |
||||
string_t o_terminal_class "" ;#e.g windows-console, tty, pipe - "" until classified |
||||
list_t o_size_mechanism [list] ;#preferred size mechanism try-order - empty until timed/settled |
||||
dict_t o_default_size [dict create columns 80 rows 24] |
||||
} |
||||
public { |
||||
#settled response capability: -1 unknown, 0 cannot respond, 1 can respond. |
||||
#public accessors (get.o_can_respond / set.o_can_respond) so the anchored-mutation wrappers in |
||||
#::opunk::console can settle it without reaching into private my.* accessors. |
||||
int_t o_can_respond -1 |
||||
|
||||
method in {} { |
||||
my.get.o_in $this |
||||
} |
||||
method out {} { |
||||
my.get.o_out $this |
||||
} |
||||
method channels {} { |
||||
list [my.get.o_in $this] [my.get.o_out $this] |
||||
} |
||||
method terminal_class {} { |
||||
my.get.o_terminal_class $this |
||||
} |
||||
method default_size {} { |
||||
my.get.o_default_size $this |
||||
} |
||||
|
||||
#Certainty test: is the input channel closed or at eof (and so can never deliver a response)? |
||||
#A consumed/half-closed pipe may not flag eof until a read is attempted, so pipe-like channels |
||||
#get a non-blocking 1-byte probe. A probed byte is preserved in the cooperative waiting store |
||||
#(array named by ::opunk::console::waiting_chunks_arrayvar - redirectable by the integrating |
||||
#layer to e.g punk::console::input_chunks_waiting so active readers can find it). |
||||
#Console/tty channels are never probed (must not consume a keystroke). |
||||
method at_eof {} -virtual { |
||||
if {[llength $this] < 7} { |
||||
error "invalid object $this" |
||||
} |
||||
set in [my.get.o_in $this] |
||||
if {[catch {chan eof $in} is_eof]} { |
||||
return 1 ;#closed/invalid channel - unusable |
||||
} |
||||
if {$is_eof} { |
||||
return 1 |
||||
} |
||||
if {[catch {chan configure $in} conf]} { |
||||
return 1 |
||||
} |
||||
if {[dict exists $conf -inputmode] || [dict exists $conf -mode]} { |
||||
return 0 |
||||
} |
||||
if {[catch { |
||||
set prior_blocking [dict get $conf -blocking] |
||||
chan configure $in -blocking 0 |
||||
set probe [read $in 1] |
||||
chan configure $in -blocking $prior_blocking |
||||
}]} { |
||||
return 1 |
||||
} |
||||
if {$probe ne ""} { |
||||
upvar #0 $::opunk::console::waiting_chunks_arrayvar wchunks |
||||
lappend wchunks($in) $probe |
||||
} |
||||
return [chan eof $in] |
||||
} |
||||
|
||||
#Heuristic: could the input channel be connected to a terminal able to answer queries? |
||||
#Returns 0 only when reasonably confident it cannot. mintty without winpty presents a |
||||
#terminal's stdin as a plain pipe, so env hints (MSYSTEM, TERM_PROGRAM) prevent false |
||||
#negatives there at the cost of false positives for genuinely piped-but-open input. |
||||
method is_console_or_tty {} -virtual { |
||||
if {[llength $this] < 7} { |
||||
error "invalid object $this" |
||||
} |
||||
set in [my.get.o_in $this] |
||||
if {[catch {chan configure $in} conf]} { |
||||
return 0 |
||||
} |
||||
if {[dict exists $conf -inputmode]} { |
||||
return 1 |
||||
} |
||||
if {[dict exists $conf -mode]} { |
||||
return 1 |
||||
} |
||||
if {[at_eof $this]} { |
||||
return 0 |
||||
} |
||||
if {[info exists ::env(TERM_PROGRAM)] || [info exists ::env(MSYSTEM)]} { |
||||
return 1 |
||||
} |
||||
return 0 |
||||
} |
||||
|
||||
#Response capability: settled value if known, else computed heuristically (without settling - |
||||
#this method is pure; use ::opunk::console::can_respond <name> to settle an anchored instance |
||||
#heuristically, or punk::console::settle_can_respond <spec> for active-probe settling - the |
||||
#probe machinery lives in punk::console so this class stays free of that dependency). |
||||
method can_respond {} -virtual { |
||||
if {[llength $this] < 7} { |
||||
error "invalid object $this" |
||||
} |
||||
set settled [get.o_can_respond $this] |
||||
if {$settled != -1} { |
||||
return $settled |
||||
} |
||||
return [is_console_or_tty $this] |
||||
} |
||||
|
||||
#Size of the console: chan -winsize on the output channel when available (fast, no query), |
||||
#else the configured default size. ANSI cursor-report mechanisms are deliberately absent from |
||||
#this standalone class - they arrive via punk::console integration and subclasses. |
||||
method size {} -virtual { |
||||
if {[llength $this] < 7} { |
||||
error "invalid object $this" |
||||
} |
||||
set out [my.get.o_out $this] |
||||
if {![catch {chan configure $out} oconf]} { |
||||
if {[dict exists $oconf -winsize]} { |
||||
lassign [dict get $oconf -winsize] cols lines |
||||
if {[string is integer -strict $cols] && [string is integer -strict $lines]} { |
||||
return [dict create columns $cols rows $lines] |
||||
} |
||||
} |
||||
} |
||||
return [my.get.o_default_size $this] |
||||
} |
||||
} |
||||
|
||||
constructor {in out} { |
||||
#new() supplies the class defaults including the virtual class tag at slot 0 |
||||
set obj [new()] |
||||
my.set.o_in obj $in |
||||
my.set.o_out obj $out |
||||
return $obj |
||||
} |
||||
} |
||||
|
||||
#make introspection (with i and punk::ns::cmdinfo) easier by making the class namespace an ensemble - we can still access it as ::opunk::Console |
||||
namespace eval ::opunk::Console { |
||||
namespace ensemble create |
||||
} |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Anchored instances - the 'consoles are entities' layer |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval ::opunk::console { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
|
||||
namespace eval instances { |
||||
#one variable per anchored console instance - the canonical location of each console object. |
||||
#Access via the sibling procs; methods needing to mutate an instance go through these anchors. |
||||
} |
||||
|
||||
proc create {name in out} { |
||||
if {![string is wordchar -strict $name]} { |
||||
error "opunk::console::create name must be alphanumeric/underscore, got '$name'" |
||||
} |
||||
set [namespace current]::instances::$name [::opunk::Console::new $in $out] |
||||
return [namespace current]::instances::$name |
||||
} |
||||
proc instancevar {name} { |
||||
set v [namespace current]::instances::$name |
||||
if {![info exists $v]} { |
||||
error "opunk::console: no anchored console instance named '$name' (known: [names])" |
||||
} |
||||
return $v |
||||
} |
||||
proc instance {name} { |
||||
set [instancevar $name] |
||||
} |
||||
proc names {} { |
||||
set result [list] |
||||
foreach v [info vars [namespace current]::instances::*] { |
||||
lappend result [namespace tail $v] |
||||
} |
||||
return $result |
||||
} |
||||
proc forget {name} { |
||||
unset [instancevar $name] |
||||
return |
||||
} |
||||
|
||||
#settle-and-cache response capability on the anchored instance. |
||||
#The class method is pure (value-in) - this wrapper owns the mutation via the anchor. |
||||
proc can_respond {name} { |
||||
upvar #0 [instancevar $name] obj |
||||
set settled [::opunk::Console::get.o_can_respond $obj] |
||||
if {$settled != -1} { |
||||
return $settled |
||||
} |
||||
set r [::opunk::Console::can_respond $obj] |
||||
::opunk::Console::set.o_can_respond obj $r |
||||
return $r |
||||
} |
||||
proc size {name} { |
||||
::opunk::Console::size [instance $name] |
||||
} |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# == === === === === === === === === === === === === === === |
||||
# Sample 'about' function with punk::args documentation |
||||
# == === === === === === === === === === === === === === === |
||||
tcl::namespace::eval ::opunk::console { |
||||
variable PUNKARGS |
||||
variable PUNKARGS_aliases |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)opunk::console" |
||||
@package -name "opunk::console" -help\ |
||||
"voo class ::opunk::Console representing a console as an in/out channel pair with settled |
||||
response-capability facts, plus anchored canonical instances under ::opunk::console::instances." |
||||
}] |
||||
|
||||
namespace eval argdoc { |
||||
proc package_name {} { |
||||
return opunk::console |
||||
} |
||||
proc about_topics {} { |
||||
set topic_funs [info commands [namespace current]::get_topic_*] |
||||
set about_topics [list] |
||||
foreach f $topic_funs { |
||||
set tail [namespace tail $f] |
||||
lappend about_topics [string range $tail [string length get_topic_] end] |
||||
} |
||||
return [lsort $about_topics] |
||||
} |
||||
proc default_topics {} {return [list Description *]} |
||||
|
||||
proc get_topic_Description {} { |
||||
punk::args::lib::tstr [string trim { |
||||
package opunk::console |
||||
voo class for consoles as channel-pair objects with anchored canonical instances. |
||||
} \n] |
||||
} |
||||
proc get_topic_License {} { |
||||
return "BSD" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return "$::opunk::console::version" |
||||
} |
||||
proc get_topic_Contributors {} { |
||||
set authors {{"Julian Noble" "julian@precisium.com.au"}} |
||||
set contributors "" |
||||
foreach a $authors { |
||||
append contributors $a \n |
||||
} |
||||
if {[string index $contributors end] eq "\n"} { |
||||
set contributors [string range $contributors 0 end-1] |
||||
} |
||||
return $contributors |
||||
} |
||||
proc get_topic_classes {} { |
||||
punk::args::lib::tstr -return string { |
||||
opunk::Console "virtual class for consoles as in/out channel pairs" |
||||
} |
||||
} |
||||
} |
||||
|
||||
set overrides [dict create] |
||||
dict set overrides @id -id "::opunk::console::about" |
||||
dict set overrides @cmd -name "opunk::console::about" |
||||
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||
About opunk::console |
||||
}] \n] |
||||
dict set overrides topic -choices [list {*}[opunk::console::argdoc::about_topics] *] |
||||
dict set overrides topic -choicerestricted 1 |
||||
dict set overrides topic -default [opunk::console::argdoc::default_topics] |
||||
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||
lappend PUNKARGS [list $newdef] |
||||
proc about {args} { |
||||
package require punk::args |
||||
set argd [punk::args::parse $args withid ::opunk::console::about] |
||||
lassign [dict values $argd] _leaders opts values _received |
||||
punk::args::package::standard_about -package_about_namespace ::opunk::console::argdoc {*}$opts {*}[dict get $values topic] |
||||
} |
||||
} |
||||
# end of sample 'about' function |
||||
# == === === === === === === === === === === === === === === |
||||
|
||||
|
||||
# ----------------------------------------------------------------------------- |
||||
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
||||
# ----------------------------------------------------------------------------- |
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::opunk::console ::opunk::Console |
||||
} |
||||
# ----------------------------------------------------------------------------- |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide opunk::console [tcl::namespace::eval ::opunk::console { |
||||
variable pkg opunk::console |
||||
variable version |
||||
set version 0.2.0 |
||||
}] |
||||
return |
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
Binary file not shown.
File diff suppressed because it is too large
Load Diff
@ -1,645 +0,0 @@
|
||||
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
@ -1,754 +0,0 @@
|
||||
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
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,37 +0,0 @@
|
||||
|
||||
package require punk::cap |
||||
|
||||
|
||||
tcl::namespace::eval punk::mix { |
||||
proc init {} { |
||||
package require punk::cap::handlers::templates ;#handler for templates cap |
||||
punk::cap::register_capabilityname punk.templates ::punk::cap::handlers::templates ;#time taken should generally be sub 200us |
||||
|
||||
#todo: use tcllib pluginmgr to load all modules that provide 'punk.templates' |
||||
#review - tcllib pluginmgr 0.5 @2025 has some bugs - esp regarding .tm modules vs packages |
||||
#We may also need to better control the order of module and library paths in the safe interps pluginmgr uses. |
||||
#todo - develop punk::pluginmgr to fix these issues (bug reports already submitted re tcllib, but the path issues may need customisation) |
||||
|
||||
package require punk::mix::templates ;#registers as provider pkg for 'punk.templates' capability with punk::cap |
||||
set t [time { |
||||
if {[catch {punk::mix::templates::provider register *} errM]} { |
||||
puts stderr "punk::mix failure during punk::mix::templates::provider register *" |
||||
puts stderr $errM |
||||
puts stderr "-----" |
||||
puts stderr $::errorInfo |
||||
} |
||||
}] |
||||
puts stderr "->punk::mix::templates::provider register * t=$t" |
||||
} |
||||
init |
||||
|
||||
} |
||||
|
||||
package require punk::mix::base |
||||
package require punk::mix::cli |
||||
|
||||
package provide punk::mix [tcl::namespace::eval punk::mix { |
||||
variable version |
||||
set version 0.2 |
||||
|
||||
}] |
||||
@ -1,324 +0,0 @@
|
||||
# -*- 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::mix::commandset::doc 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
package require punk::path ;# for treefilenames, relative |
||||
package require punk::repo |
||||
package require punk::docgen ;#inline doctools - generate doctools .man files at src/docgen prior to using kettle to producing .html .md etc |
||||
package require punk::mix::cli ;#punk::mix::cli::lib used for kettle_call |
||||
#package require punkcheck ;#for path_relative |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::doc { |
||||
namespace export * |
||||
|
||||
proc _default {} { |
||||
puts "documentation subsystem" |
||||
puts "commands: doc.build" |
||||
puts " build documentation from src/doc to src/embedded using the kettle build tool" |
||||
puts "commands: doc.status" |
||||
} |
||||
|
||||
proc build {} { |
||||
puts "build docs" |
||||
set projectdir [punk::repo::find_project] |
||||
if {$projectdir eq ""} { |
||||
puts stderr "No current project dir - unable to build docs" |
||||
return |
||||
} |
||||
#user may delete the comment containing "--- punk::docgen::overwrites" and then manually edit, and we won't overwrite |
||||
#we still generate output in src/docgen so user can diff and manually update if thats what they prefer |
||||
set oldfiles [punk::path::treefilenames -dir $projectdir/src/doc _module_*.man] |
||||
foreach maybedoomed $oldfiles { |
||||
set fd [open $maybedoomed r] |
||||
chan conf $fd -translation binary |
||||
set data [read $fd] |
||||
close $fd |
||||
if {[string match "*--- punk::docgen overwrites *" $data]} { |
||||
file delete -force $maybedoomed |
||||
} |
||||
} |
||||
set generated [lib::do_docgen modules] |
||||
if {[dict get $generated count] > 0} { |
||||
#review |
||||
set doclist [dict get $generated docs] |
||||
set source_base [dict get $generated base] |
||||
set target_base $projectdir/src/doc |
||||
foreach dinfo $doclist { |
||||
lassign $dinfo module fpath |
||||
set relpath [punk::path::relative $source_base $fpath] |
||||
set relfolder [file dirname $relpath] |
||||
if {$relfolder eq "."} { |
||||
set relfolder "" |
||||
} |
||||
file mkdir [file join $target_base $relfolder] |
||||
set target [file join $target_base $relfolder _module_[file tail $fpath]] |
||||
puts stderr "target --> $target" |
||||
if {![file exists $target]} { |
||||
file copy $fpath $target |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {[file exists $projectdir/src/doc]} { |
||||
set original_wd [pwd] |
||||
cd $projectdir/src |
||||
#---------- |
||||
set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] |
||||
$installer set_source_target $projectdir/src/doc $projectdir/src/embedded |
||||
set event [$installer start_event {-install_step kettledoc}] |
||||
#use same virtual id "kettle_build_doc" as project.new - review best way to keep identifiers like this in sync. |
||||
$event targetset_init VIRTUAL kettle_build_doc ;#VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated |
||||
$event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source |
||||
#---------- |
||||
if {\ |
||||
[llength [dict get [$event targetset_source_changes] changed]]\ |
||||
} { |
||||
$event targetset_started |
||||
# -- --- --- --- --- --- |
||||
puts stdout "BUILDING DOCS at $projectdir/src/embedded from src/doc" |
||||
if {[catch { |
||||
if {"::meta" eq [info commands ::meta]} { |
||||
puts stderr "There appears to be a leftover ::meta command which is presumed to be from doctools. Destroying object" |
||||
::meta destroy |
||||
} |
||||
punk::mix::cli::lib::kettle_call lib doc |
||||
#Kettle doc |
||||
|
||||
} errM]} { |
||||
$event targetset_end FAILED -note "kettle_build_doc failed: $errM" |
||||
} else { |
||||
$event targetset_end OK |
||||
} |
||||
# -- --- --- --- --- --- |
||||
} else { |
||||
puts stderr "No change detected in src/doc" |
||||
$event targetset_end SKIPPED |
||||
} |
||||
$event end |
||||
$event destroy |
||||
$installer destroy |
||||
cd $original_wd |
||||
} else { |
||||
puts stderr "No doc folder found at $projectdir/src/doc" |
||||
} |
||||
} |
||||
proc status {} { |
||||
set projectdir [punk::repo::find_project] |
||||
if {$projectdir eq ""} { |
||||
puts stderr "No current project dir - unable to check doc status" |
||||
return |
||||
} |
||||
if {![file exists $projectdir/src/doc]} { |
||||
set result "No documentation source found. Expected .man files in doctools format at $projectdir/src/doc" |
||||
return $result |
||||
} |
||||
set original_wd [pwd] |
||||
cd $projectdir/src |
||||
puts stdout "Testing status of doctools source location $projectdir/src/doc ..." |
||||
flush stdout |
||||
#---------- |
||||
set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] |
||||
$installer set_source_target $projectdir/src/doc $projectdir/src/embedded |
||||
set event [$installer start_event {-install_step kettledoc}] |
||||
#use same virtual id "kettle_build_doc" as project.new - review best way to keep identifiers like this in sync. |
||||
$event targetset_init QUERY kettle_build_doc ;#usually VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated - but here we use QUERY to ensure no writes to .punkcheck |
||||
set last_completion [$event targetset_last_complete] |
||||
|
||||
if {[llength $last_completion]} { |
||||
#adding a source causes it to be checksummed |
||||
$event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source |
||||
#---------- |
||||
set changeinfo [$event targetset_source_changes] |
||||
if {\ |
||||
[llength [dict get $changeinfo changed]]\ |
||||
} { |
||||
puts stdout "changed" |
||||
puts stdout $changeinfo |
||||
} else { |
||||
puts stdout "No changes detected in $projectdir/src/doc tree" |
||||
} |
||||
} else { |
||||
#no previous completion-record for this target - must assume changed - no need to trigger checksumming |
||||
puts stdout "No existing record of doc build in .punkcheck. Assume it needs to be rebuilt." |
||||
} |
||||
|
||||
|
||||
$event destroy |
||||
$installer destroy |
||||
|
||||
cd $original_wd |
||||
} |
||||
proc validate {args} { |
||||
set argd [punk::args::parse $args withdef { |
||||
@id -id ::punk::mix::commandset::doc::validate |
||||
-- -type none -optional 1 -help "end of options marker --" |
||||
-individual -type boolean -default 1 |
||||
@values -min 0 -max -1 |
||||
patterns -default {*.man} -type any -multiple 1 |
||||
}] |
||||
set opt_individual [tcl::dict::get $argd opts -individual] |
||||
set patterns [tcl::dict::get $argd values patterns] |
||||
|
||||
|
||||
#todo - run and validate punk::docgen output |
||||
set projectdir [punk::repo::find_project] |
||||
if {$projectdir eq ""} { |
||||
puts stderr "No current project dir - unable to check doc status" |
||||
return |
||||
} |
||||
if {![file exists $projectdir/src/doc]} { |
||||
set result "No documentation source found. Expected .man files in doctools format at $projectdir/src/doc" |
||||
return $result |
||||
} |
||||
set original_wd [pwd] |
||||
set docroot $projectdir/src/doc |
||||
cd $docroot |
||||
|
||||
if {!$opt_individual && "*.man" in $patterns} { |
||||
if {[catch { |
||||
dtplite validate $docroot |
||||
} errM]} { |
||||
puts stderr "commandset::doc::validate failed for projectdir '$projectdir'" |
||||
puts stderr "docroot '$docroot'" |
||||
puts stderr "dtplite error was: $errM" |
||||
} |
||||
} else { |
||||
foreach p $patterns { |
||||
set treefiles [punk::path::treefilenames $p] |
||||
foreach path $treefiles { |
||||
puts stdout "dtplite validate $path" |
||||
dtplite validate $path |
||||
} |
||||
} |
||||
} |
||||
|
||||
#punk::mix::cli::lib::kettle_call lib validate-doc |
||||
|
||||
cd $original_wd |
||||
} |
||||
|
||||
namespace eval collection { |
||||
variable pkg |
||||
set pkg punk::mix::commandset::doc |
||||
|
||||
namespace export * |
||||
namespace path [namespace parent] |
||||
|
||||
} |
||||
|
||||
namespace eval lib { |
||||
variable pkg |
||||
set pkg punk::mix::commandset::doc |
||||
proc do_docgen {{project_subpath modules}} { |
||||
#Extract doctools comments from source code |
||||
set projectdir [punk::repo::find_project] |
||||
set output_base [file join $projectdir src docgen] |
||||
set codesource_path [file join $projectdir $project_subpath] |
||||
if {![file isdirectory $codesource_path]} { |
||||
puts stderr "WARNING punk::mix::commandset::doc unable to find codesource_path $codesource_path during do_docgen - skipping inline doctools generation" |
||||
return |
||||
} |
||||
if {[file isdirectory $output_base]} { |
||||
if {[catch { |
||||
file delete -force $output_base |
||||
}]} { |
||||
error "do_docgen failed to delete existing output base folder: $output_base" |
||||
} |
||||
} |
||||
file mkdir $output_base |
||||
|
||||
set matched_paths [punk::path::treefilenames -dir $codesource_path -antiglob_paths {**/mix/templates/** **/project_layouts/** **/decktemplates/** **/_aside **/_aside/**} *.tm] |
||||
set count 0 |
||||
set newdocs [list] |
||||
set docgen_header_comments "" |
||||
append docgen_header_comments {[comment {--- punk::docgen generated from inline doctools comments ---}]} \n |
||||
append docgen_header_comments {[comment {--- punk::docgen DO NOT EDIT DOCS HERE UNLESS YOU REMOVE THESE COMMENT LINES ---}]} \n |
||||
append docgen_header_comments {[comment {--- punk::docgen overwrites this file ---}]} \n |
||||
foreach fullpath $matched_paths { |
||||
puts stdout "do_docgen processing: $fullpath" |
||||
set doctools [punk::docgen::get_doctools_comments $fullpath] |
||||
if {$doctools ne ""} { |
||||
set fname [file tail $fullpath] |
||||
set mod_tail [file rootname $fname] |
||||
set relpath [punk::path::relative $codesource_path [file dirname $fullpath]] |
||||
if {$relpath eq "."} { |
||||
set relpath "" |
||||
} |
||||
set tailsegs [file split $relpath] |
||||
set module_fullname [join $tailsegs ::]::$mod_tail |
||||
set target_docname $fname.man |
||||
set this_outdir [file join $output_base $relpath] |
||||
|
||||
if {[string length $fname] > 99} { |
||||
#output needs to be tarballed to do checksum change tests in a reasonably straightforward and not-too-terribly slow way. |
||||
#hack - review. Determine exact limit - test if tcllib tar fixed or if it's a limit of the particular tar format |
||||
#work around tcllib tar filename length limit ( somewhere around 100?) This seems to be a limit on the length of a particular segment in the path.. not whole path length? |
||||
#this case only came up because docgen used to path munge to long filenames - but left because we know there is a limit and renaming fixes it - even if it's ugly - but still allows doc generation. |
||||
#review - if we're checking fname - should also test length of whole path and determine limits for tar |
||||
package require md5 |
||||
if {[package vsatisfies [package present md5] 2- ] } { |
||||
set md5opt "-hex" |
||||
} else { |
||||
set md5opt "" |
||||
} |
||||
set target_docname [md5::md5 {*}$md5opt [encoding convertto utf-8 $fullpath]]_overlongfilename.man |
||||
puts stderr "WARNING - overlong file name - renaming $fullpath" |
||||
puts stderr " to [file dirname $fullpath]/$target_docname" |
||||
} |
||||
|
||||
file mkdir $this_outdir |
||||
puts stdout "saving [string length $doctools] bytes of doctools output from file $relpath/$fname" |
||||
set outfile [file join $this_outdir $target_docname] |
||||
set fd [open $outfile w] |
||||
fconfigure $fd -translation binary |
||||
puts -nonewline $fd $docgen_header_comments$doctools |
||||
close $fd |
||||
incr count |
||||
lappend newdocs [list $module_fullname $outfile] |
||||
} |
||||
} |
||||
return [list count $count docs $newdocs base $output_base] |
||||
} |
||||
|
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::doc [namespace eval punk::mix::commandset::doc { |
||||
variable pkg punk::mix::commandset::doc |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,94 +0,0 @@
|
||||
# -*- 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::mix::templates 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
package require punk::cap |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::templates { |
||||
variable pkg punk::mix::templates |
||||
variable cap_provider |
||||
|
||||
namespace eval capsystem { |
||||
if {[info commands capprovider.registration] eq ""} { |
||||
punk::cap::class::interface_capprovider.registration create capprovider.registration |
||||
oo::objdefine capprovider.registration { |
||||
method get_declarations {} { |
||||
set decls [list] |
||||
lappend decls [list punk.templates {path templates pathtype adhoc vendor _project}] ;#todo - split out to a different provider package? |
||||
|
||||
lappend decls [list punk.templates {path templates pathtype module vendor punk}] |
||||
#only punk::templates is allowed to register a _multivendor path - review |
||||
#other punk.template providers should use module, absolute, currentproject and shellproject pathtypes only |
||||
lappend decls [list punk.templates {path src/decktemplates pathtype currentproject_multivendor vendor punk}] |
||||
lappend decls [list punk.templates {path decktemplates pathtype shellproject_multivendor vendor punk}] |
||||
|
||||
|
||||
#we need a way to ensure we don't pull updates from a remote repo into a local project that is actually the same project ? review! |
||||
#need flags as to whether/how provider allows template updates that are out of sync with the provider pkg version |
||||
#perhaps a separate .txt file (alongside buildversion and description txt files) that has some package require statements (we can't put them in the template itself as the filled template may have nothing to do with the punk.templates provider) |
||||
lappend decls [list punk.templates {path src/decktemplates/vendor/punk pathtype currentproject vendor punk allowupdates 0 repo "https://www.gitea1.intx.com.au/jn/punkshell" reposubdir "src/decktemplates/vendor/punk"}] |
||||
lappend decls [list punk.isbogus {provider punk::mix::templates something blah}] ;#some capability for which there is no handler to validate - therefore no warning will result. |
||||
#review - we should report unhandled caps somewhere, or provide a mechanism to detect/report. |
||||
#we don't want to warn at the time this provider is loaded - as handler may legitimately be loaded later. |
||||
return $decls |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {[info commands provider] eq ""} { |
||||
punk::cap::class::interface_capprovider.provider create provider punk::mix::templates |
||||
oo::objdefine provider { |
||||
method register {{capabilityname_glob *}} { |
||||
#puts registering punk::mix::templates $capabilityname |
||||
next $capabilityname_glob |
||||
} |
||||
method capabilities {} { |
||||
next |
||||
} |
||||
} |
||||
} |
||||
|
||||
# -- --- |
||||
#provider api |
||||
# -- --- |
||||
#none - declarations only |
||||
#todo - template folder install/update/status methods? |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::templates [namespace eval punk::mix::templates { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
Binary file not shown.
Binary file not shown.
@ -1,161 +0,0 @@
|
||||
#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} { |
||||
set app_folders [punk::config::configure running 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 *}} { |
||||
set apps_folder [punk::config::configure running 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 |
||||
}] |
||||
|
||||
|
||||
|
||||
@ -1,193 +0,0 @@
|
||||
|
||||
|
||||
package require punk::mix::util |
||||
package require punk::args |
||||
|
||||
tcl::namespace::eval ::punk::overlay { |
||||
#based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend |
||||
# extend an ensemble-like routine with the routines in some namespace |
||||
# |
||||
# e.g custom_from_base ::punk::mix::cli ::punk::mix::base |
||||
# |
||||
proc custom_from_base {routine base} { |
||||
if {![tcl::string::match ::* $routine]} { |
||||
set resolved [uplevel 1 [list ::tcl::namespace::which $routine]] |
||||
if {$resolved eq {}} { |
||||
error [list {no such routine} $routine] |
||||
} |
||||
set routine $resolved |
||||
} |
||||
set routinens [tcl::namespace::qualifiers $routine] |
||||
if {$routinens eq {::}} { |
||||
set routinens {} |
||||
} |
||||
set routinetail [tcl::namespace::tail $routine] |
||||
|
||||
if {![tcl::string::match ::* $base]} { |
||||
set base [uplevel 1 [ |
||||
list [tcl::namespace::which namespace] current]]::$base |
||||
} |
||||
|
||||
if {![tcl::namespace::exists $base]} { |
||||
error [list {no such namespace} $base] |
||||
} |
||||
|
||||
set base [tcl::namespace::eval $base [ |
||||
list [tcl::namespace::which namespace] current]] |
||||
|
||||
|
||||
#while 1 { |
||||
# set renamed ${routinens}::${routinetail}_[info cmdcount] |
||||
# if {[namespace which $renamed] eq {}} break |
||||
#} |
||||
|
||||
tcl::namespace::eval $routine [ |
||||
::list tcl::namespace::ensemble configure $routine -unknown [ |
||||
::list ::apply {{base ensemble subcommand args} { |
||||
::list ${base}::_redirected $ensemble $subcommand |
||||
}} $base |
||||
] |
||||
] |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${routine}::util |
||||
#namespace eval ${routine}::util { |
||||
#::namespace import ::punk::mix::util::* |
||||
#} |
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ${base}::lib::* ${routine}::lib |
||||
#namespace eval ${routine}::lib [string map [list <base> $base] { |
||||
# ::namespace import <base>::lib::* |
||||
#}] |
||||
|
||||
tcl::namespace::eval ${routine}::lib [tcl::string::map [list <base> $base <routine> $routine] { |
||||
if {[tcl::namespace::exists <base>::lib]} { |
||||
::set current_paths [tcl::namespace::path] |
||||
if {"<routine>" ni $current_paths} { |
||||
::lappend current_paths <routine> |
||||
} |
||||
tcl::namespace::path $current_paths |
||||
} |
||||
}] |
||||
|
||||
tcl::namespace::eval $routine { |
||||
::set exportlist [::list] |
||||
::foreach cmd [tcl::info::commands [tcl::namespace::current]::*] { |
||||
::set c [tcl::namespace::tail $cmd] |
||||
if {![tcl::string::match _* $c]} { |
||||
::lappend exportlist $c |
||||
} |
||||
} |
||||
tcl::namespace::export {*}$exportlist |
||||
} |
||||
|
||||
return $routine |
||||
} |
||||
punk::args::define { |
||||
@id -id ::punk::overlay::import_commandset |
||||
@cmd -name punk::overlay::import_commandset\ |
||||
-summary\ |
||||
"Import commands into caller's namespace with optional prefix and separator."\ |
||||
-help\ |
||||
"Import commands that have been exported by another namespace into the caller's |
||||
namespace. Usually a prefix and optionally a separator should be used. |
||||
This is part of the punk::mix CLI commandset infrastructure - design in flux. |
||||
Todo - .toml configuration files for defining CLI configurations." |
||||
@values |
||||
prefix -type string |
||||
separator -type string -help\ |
||||
"A string, usually punctuation, to separate the prefix and the command name |
||||
of the final imported command. The value \"::\" is disallowed in this context." |
||||
cmdnamespace -type string -help\ |
||||
"Namespace from which to import commands. Commands are those that have been exported." |
||||
} |
||||
#load *exported* commands from cmdnamespace into caller's namespace - prefixing each command with $prefix |
||||
#Note: commandset may be imported by different CLIs with different bases *at the same time* |
||||
#so we don't make commands from the cli or its base available automatically (will generally require fully-qualified commands to use code from cli/base) |
||||
#we do load punk::mix::util::* into the util subnamespace even though the commandset might not be loaded in a cli using punk::mix::base i.e punk::mix::util is a common dependency for CLIs. |
||||
#commandsets designed to be used with a specific cli/base may choose to do their own import e.g with util::namespace_import_pattern_to_namespace_noclobber and/or set namespace path if they |
||||
#want the convenience of using lib:xxx with commands coming from those packages. |
||||
#This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. |
||||
#The basic principle is that the commandset is loaded into the caller(s) with a prefix |
||||
#- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) |
||||
proc import_commandset {prefix separator cmdnamespace} { |
||||
set bad_seps [list "::"] |
||||
if {$separator in $bad_seps} { |
||||
error "import_commandset invalid separator '$separator'" |
||||
} |
||||
if {$prefix in $bad_seps} { |
||||
error "import_commandset invalid prefix '$prefix'" |
||||
} |
||||
if {"$prefix$separator" in $bad_seps} { |
||||
error "import_commandset invalid prefix/separator combination '$prefix$separator'" |
||||
} |
||||
if {"[string index $prefix end][string index $separator 0]" in $bad_seps} { |
||||
error "import_commandset invalid prefix/separator combination '$prefix$separator'" |
||||
} |
||||
#review - do we allow prefixes/separators such as a::b? |
||||
|
||||
#namespace may or may not be a package |
||||
# allow with or without leading :: |
||||
if {[tcl::string::range $cmdnamespace 0 1] eq "::"} { |
||||
set cmdpackage [tcl::string::range $cmdnamespace 2 end] |
||||
} else { |
||||
set cmdpackage $cmdnamespace |
||||
set cmdnamespace ::$cmdnamespace |
||||
} |
||||
|
||||
if {![tcl::namespace::exists $cmdnamespace]} { |
||||
#only do package require if the namespace not already present |
||||
catch {package require $cmdpackage} pkg_load_info |
||||
#recheck |
||||
if {![tcl::namespace::exists $cmdnamespace]} { |
||||
set prov [package provide $cmdpackage] |
||||
if {[tcl::string::length $prov]} { |
||||
set provinfo "(package $cmdpackage is present with version $prov)" |
||||
} else { |
||||
set provinfo "(package $cmdpackage not present)" |
||||
} |
||||
error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Pkg_load_result: $pkg_load_info Usage: import_commandset prefix separator namespace" |
||||
} |
||||
} |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util |
||||
|
||||
#let child namespace 'lib' resolve parent namespace and thus util::xxx |
||||
tcl::namespace::eval ${cmdnamespace}::lib [tcl::string::map [list <cmdns> $cmdnamespace] { |
||||
::set nspaths [tcl::namespace::path] |
||||
if {"<cmdns>" ni $nspaths} { |
||||
::lappend nspaths <cmdns> |
||||
} |
||||
tcl::namespace::path $nspaths |
||||
}] |
||||
|
||||
set imported_commands [list] |
||||
set imported_tails [list] |
||||
set nscaller [uplevel 1 [list tcl::namespace::current]] |
||||
if {[catch { |
||||
#review - noclobber? |
||||
tcl::namespace::eval ${nscaller}::temp_import [list tcl::namespace::import ${cmdnamespace}::*] |
||||
foreach cmd [tcl::info::commands ${nscaller}::temp_import::*] { |
||||
set cmdtail [tcl::namespace::tail $cmd] |
||||
if {$cmdtail eq "_default"} { |
||||
set import_as ${nscaller}::${prefix} |
||||
} else { |
||||
set import_as ${nscaller}::${prefix}${separator}${cmdtail} |
||||
} |
||||
rename $cmd $import_as |
||||
lappend imported_commands $import_as |
||||
lappend imported_tails [namespace tail $import_as] |
||||
} |
||||
#make imported commands exported so they are available to the ensemble |
||||
tcl::namespace::eval ${nscaller} [list namespace export {*}$imported_tails] |
||||
} errM]} { |
||||
puts stderr "Error loading commandset $prefix $separator $cmdnamespace" |
||||
puts stderr "err: $errM" |
||||
} |
||||
return $imported_commands |
||||
} |
||||
} |
||||
|
||||
|
||||
package provide punk::overlay [tcl::namespace::eval punk::overlay { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,276 +0,0 @@
|
||||
# -*- 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 repl codethread}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {codethread for repl - root interpreter}] [comment {-- Description at end of page heading --}] |
||||
#[require punk::repl::codethread] |
||||
#[keywords module repl] |
||||
#[description] |
||||
#[para] This is part of the infrastructure required for the punk::repl to operate |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !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" |
||||
#} |
||||
|
||||
variable run_command_cache |
||||
|
||||
proc is_running {} { |
||||
variable running |
||||
return $running |
||||
} |
||||
proc runscript {script} { |
||||
|
||||
#puts stderr "->runscript" |
||||
variable replthread_cond |
||||
#variable output_stdout |
||||
#set output_stdout "" |
||||
#variable output_stderr |
||||
#set 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 |
||||
} |
||||
interp eval code [list set ::punk::repl::codethread::output_stdout ""] |
||||
interp eval code [list set ::punk::repl::codethread::output_stderr ""] |
||||
|
||||
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 status [catch { |
||||
#shennanigans to keep compiled script around after call. |
||||
#otherwise when $script goes out of scope - internal rep of vars set in script changes. |
||||
#The shimmering may be no big deal(?) - but debug/analysis using tcl::unsupported::representation becomes impossible. |
||||
interp eval code [list ::punk::lib::set_clone ::codeinterp::clonescript $script] ;#like objclone |
||||
interp eval code { |
||||
lappend ::codeinterp::run_command_cache $::codeinterp::clonescript |
||||
if {[llength $::codeinterp::run_command_cache] > 2000} { |
||||
set ::codeinterp::run_command_cache [lrange $::codeinterp::run_command_cache 1750 end][unset ::codeinterp::run_command_cache] |
||||
} |
||||
tcl::namespace::inscope $::punk::ns::ns_current $::codeinterp::clonescript |
||||
} |
||||
} 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] |
||||
|
||||
@ -1,836 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.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::winlnk 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license MIT |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin punkshell_module_punk::winlnk 0 0.1.0] |
||||
#[copyright "2024"] |
||||
#[titledesc {windows shortcut .lnk library}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {punk::winlnk}] [comment {-- Description at end of page heading --}] |
||||
#[require punk::winlnk] |
||||
#[keywords module shortcut lnk parse windows crossplatform] |
||||
#[description] |
||||
#[para] Tools for reading windows shortcuts (.lnk files) on any platform |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of punk::winlnk |
||||
#[subsection Concepts] |
||||
#[para] Windows shortcuts are a binary format file with a .lnk extension |
||||
#[para] Shell Link (.LNK) Binary File Format is documented in [lb]MS_SHLLINK[rb].pdf published by Microsoft. |
||||
#[para] Revision 8.0 published 2024-04-23 |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by punk::winlnk |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
|
||||
#TODO - logger |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Base namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::winlnk { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
#variable xyz |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace punk::winlnk}] |
||||
#[para] Core API functions for punk::winlnk |
||||
#[list_begin definitions] |
||||
|
||||
|
||||
variable magic_HeaderSize "0000004C" ;#HeaderSize MUST equal this |
||||
variable magic_LinkCLSID "00021401-0000-0000-C000-000000000046" ;#LinkCLSID MUST equal this |
||||
|
||||
proc Get_contents {path {bytes all}} { |
||||
if {![file exists $path] || [file type $path] ne "file"} { |
||||
error "punk::winlnk::get_contents cannot find a filesystem object of type 'file' at location: $path" |
||||
} |
||||
set fd [open $path r] |
||||
chan configure $fd -translation binary -encoding iso8859-1 |
||||
if {$bytes eq "all"} { |
||||
set data [read $fd] |
||||
} else { |
||||
set data [read $fd $bytes] |
||||
} |
||||
close $fd |
||||
return $data |
||||
} |
||||
proc Contents_check_header {contents} { |
||||
variable magic_HeaderSize |
||||
variable magic_LinkCLSID |
||||
expr {[Header_Get_HeaderSize $contents] eq $magic_HeaderSize && [Header_Get_LinkCLSID $contents] eq $magic_LinkCLSID} |
||||
} |
||||
|
||||
#LinkFlags - 4 bytes - specifies information about the shell link and the presence of optional portions of the structure. |
||||
proc Show_LinkFlags {contents} { |
||||
set 4bytes [string range $contents 20 23] |
||||
set r [binary scan $4bytes i val] ;# i for little endian 32-bit signed int |
||||
puts "val: $val" |
||||
set declist [scan [string reverse $4bytes] %c%c%c%c] |
||||
set fmt [string repeat %08b 4] |
||||
puts "LinkFlags:[format $fmt {*}$declist]" |
||||
|
||||
set r [binary scan $4bytes b32 val] |
||||
puts "bscan-le: $val" |
||||
set r [binary scan [string reverse $4bytes] b32 val] |
||||
puts "bscan-2 : $val" |
||||
} |
||||
variable LinkFlags |
||||
set LinkFlags [dict create\ |
||||
hasLinkTargetIDList 1\ |
||||
HasLinkInfo 2\ |
||||
HasName 4\ |
||||
HasRelativePath 8\ |
||||
HasWorkingDir 16\ |
||||
HasArguments 32\ |
||||
HasIconLocation 64\ |
||||
IsUnicode 128\ |
||||
ForceNoLinkInfo 256\ |
||||
HasExpString 512\ |
||||
RunInSeparateProcess 1024\ |
||||
Unused1 2048\ |
||||
HasDarwinID 4096\ |
||||
RunAsUser 8192\ |
||||
HasExpIcon 16394\ |
||||
NoPidlAlias 32768\ |
||||
Unused2 65536\ |
||||
RunWithShimLayer 131072\ |
||||
ForceNoLinkTrack 262144\ |
||||
EnableTargetMetadata 524288\ |
||||
DisableLinkPathTracking 1048576\ |
||||
DisableKnownFolderTracking 2097152\ |
||||
DisableKnownFolderAlias 4194304\ |
||||
AllowLinkToLink 8388608\ |
||||
UnaliasOnSave 16777216\ |
||||
PreferEnvironmentPath 33554432\ |
||||
KeepLocalIDListForUNCTarget 67108864\ |
||||
] |
||||
variable LinkFlagLetters [list A B C D E F G H I J K L M N O P Q R S T U V W X Y Z AA] |
||||
proc Header_Has_LinkFlag {contents flagname} { |
||||
variable LinkFlags |
||||
variable LinkFlagLetters |
||||
if {[string length $flagname] <= 2} { |
||||
set idx [lsearch $LinkFlagLetters $flagname] |
||||
if {$idx < 0} { |
||||
error "punk::winlnk::Header_Has_LinkFlag error - flagname $flagname not known" |
||||
} |
||||
set binflag [expr {2**$idx}] |
||||
set allflags [Header_Get_LinkFlags $contents] |
||||
return [expr {$allflags & $binflag}] |
||||
} |
||||
if {[dict exists $LinkFlags $flagname]} { |
||||
set binflag [dict get $LinkFlags $flagname] |
||||
set allflags [Header_Get_LinkFlags $contents] |
||||
return [expr {$allflags & $binflag}] |
||||
} else { |
||||
error "punk::winlnk::Header_Has_LinkFlag error - flagname $flagname not known" |
||||
} |
||||
} |
||||
|
||||
#MS-SHLLINK.pdf documents the .lnk file format in detail, but here is a brief overview of the structure of a .lnk file: |
||||
#protocol revision 10.0 (November 2025) https://winprotocoldocs-bhdugrdyduf5h2e4.b02.azurefd.net/MS-SHLLINK/%5bMS-SHLLINK%5d.pdf |
||||
|
||||
|
||||
#SHELL_LINK_HEADER structure is 76 bytes long and starts at the beginning of the file |
||||
#offset hex:0x00 dec:0 4 bytes |
||||
#Header size (HeaderSize) (must be 0x0000004C for .lnk files) |
||||
proc Header_Get_HeaderSize {contents} { |
||||
set 4bytes [split [string range $contents 0 3] ""] |
||||
set hex4 "" |
||||
foreach b [lreverse $4bytes] { |
||||
set dec [scan $b %c] ;# 0-255 decimal |
||||
set HH [format %2.2llX $dec] |
||||
append hex4 $HH |
||||
} |
||||
return $hex4 |
||||
} |
||||
|
||||
|
||||
#offset hex:0x04 dec:4 16 bytes |
||||
#LinkCLSID (must be 00021401-0000-0000-C000-000000000046 for .lnk files) |
||||
proc Header_Get_LinkCLSID {contents} { |
||||
set 16bytes [string range $contents 4 19] |
||||
#CLSID hex textual representation is split as 4-2-2-2-6 bytes(hex pairs) |
||||
#e.g We expect 00021401-0000-0000-C000-000000000046 for .lnk files |
||||
#for endianness - it is little endian all the way but the split is 4-2-2-1-1-1-1-1-1-1-1 REVIEW |
||||
#(so it can appear as mixed endianness if you don't know the splits) |
||||
#https://devblogs.microsoft.com/oldnewthing/20220928-00/?p=107221 |
||||
#This is based on COM textual representation of GUIDS |
||||
#Apparently a CLSID is a GUID that identifies a COM object |
||||
set clsid "" |
||||
set s1 [tcl::string::range $16bytes 0 3] |
||||
set declist [scan [string reverse $s1] %c%c%c%c] |
||||
set fmt "%02X%02X%02X%02X" |
||||
append clsid [format $fmt {*}$declist] |
||||
|
||||
append clsid - |
||||
set s2 [tcl::string::range $16bytes 4 5] |
||||
set declist [scan [string reverse $s2] %c%c] |
||||
set fmt "%02X%02X" |
||||
append clsid [format $fmt {*}$declist] |
||||
|
||||
append clsid - |
||||
set s3 [tcl::string::range $16bytes 6 7] |
||||
set declist [scan [string reverse $s3] %c%c] |
||||
append clsid [format $fmt {*}$declist] |
||||
|
||||
append clsid - |
||||
#now treat bytes individually - so no endianness conversion |
||||
set declist [scan [tcl::string::range $16bytes 8 9] %c%c] |
||||
append clsid [format $fmt {*}$declist] |
||||
|
||||
append clsid - |
||||
set scan [string repeat %c 6] |
||||
set fmt [string repeat %02X 6] |
||||
set declist [scan [tcl::string::range $16bytes 10 15] $scan] |
||||
append clsid [format $fmt {*}$declist] |
||||
|
||||
return $clsid |
||||
} |
||||
|
||||
|
||||
#offset hex:0x14 dec:20 4 bytes |
||||
#Link flags (LinkFlags) - bit field specifying information about the shell link and the presence of optional portions of the structure. |
||||
#HasLinkTargetIDList bit 0 (0x00000001) - if set, a LinkTargetIDList structure is present immediately following the header |
||||
#HasLinkInfo bit 1 (0x00000002) - if set, a LinkInfo structure is present immediately following the header (or the LinkTargetIDList if that is present) |
||||
#HasName bit 2 (0x00000004) - if set, a null-terminated string containing the name of the link is present immediately following the header (or the LinkTargetIDList and LinkInfo if they are present) |
||||
#HasRelativePath bit 3 (0x00000008) - if set, a null-terminated string containing the relative path of the link target is present immediately following the header (or the LinkTargetIDList, LinkInfo and Name if they are present) |
||||
#HasWorkingDir bit 4 (0x00000010) - if set, a null-terminated string containing the working directory of the link target is present immediately following the header (or the LinkTargetIDList, LinkInfo, Name and Relative Path if they are present) |
||||
#HasArguments bit 5 (0x00000020) - if set, a null-terminated string containing the command line arguments for the link target is present immediately following the header (or the LinkTargetIDList, LinkInfo, Name, Relative Path and Working Dir if they are present) |
||||
#HasIconLocation bit 6 (0x00000040) - if set, a null-terminated string containing the location of the icon for the link is present immediately following the header (or the LinkTargetIDList, LinkInfo, Name, Relative Path, Working Dir and Arguments if they are present) |
||||
#IsUnicode bit 7 (0x00000080) - if set, the strings in the link are stored in Unicode (UTF-16LE) format; if not set, the strings are stored in ANSI format (usually the system's default code page) |
||||
#ForceNoLinkInfo bit 8 (0x00000100) - if set, the LinkInfo structure is not stored in the file even if the HasLinkInfo bit is set; this can be used to force the link to be resolved using only the information in the header and the optional strings, without using the LinkInfo structure |
||||
#HasExpString bit 9 (0x00000200) - if set, a null-terminated string containing an "environment variable" style string is present immediately following the header (or the LinkTargetIDList, LinkInfo, Name, Relative Path, Working Dir, Arguments and Icon Location if they are present); this string can contain environment variable references (e.g. %USERPROFILE%) that can be expanded to obtain the actual path of the link target |
||||
#RunInSeparateProcess bit 10 (0x00000400) - if set, the link target should be run in a separate process; if not set, the link target may be run in the same process as the caller |
||||
#Unused1 bit 11 (0x00000800) - reserved for future use; should be set to 0 |
||||
#HasDarwinID bit 12 (0x00001000) - if set, a null-terminated string containing a "Darwin ID" is present immediately following the header (or the LinkTargetIDList, LinkInfo, Name, Relative Path, Working Dir, Arguments, Icon Location and ExpString if they are present); this string can be used to identify the link target in a way that is independent of the file system (e.g. for links to Control Panel items or special folders) |
||||
#RunAsUser bit 13 (0x00002000) - if set, the link target should be run with the permissions of the user specified in the HasDarwinID string; if not set, the link target should be run with the permissions of the caller |
||||
#HasExpIcon bit 14 (0x00004000) - if set, a null-terminated string containing an "environment variable" style string for the icon location is present immediately following the header (or the LinkTargetIDList, LinkInfo, Name, Relative Path, Working Dir, Arguments, Icon Location, ExpString and DarwinID if they are present); this string can contain environment variable references that can be expanded to obtain the actual path of the icon for the link |
||||
#NoPidlAlias bit 15 (0x00008000) - if set, the link target should not be resolved using the PIDL alias mechanism; this can be used to prevent the link from being resolved to a different target if the original target is moved or renamed |
||||
#Unused2 bit 16 (0x00010000) - reserved for future use; should be set to 0 |
||||
#RunWithShimLayer bit 17 (0x00020000) - if set, the link target should be run with the application compatibility shim layer; if not set, the link target should be run without the shim layer |
||||
#ForceNoLinkTrack bit 18 (0x00040000) - if set, the link target should not be tracked by the shell's link tracking mechanism; this can be used to prevent the link from being automatically updated if the target is moved or renamed |
||||
#EnableTargetMetadata bit 19 (0x00080000) - if set, the link target should have metadata enabled; this can be used to allow the link to store additional information about the target (e.g. for links to files, the link can store the file's attributes, creation time, access time and modification time) |
||||
#DisableLinkPathTracking bit 20 (0x00100000) - if set, the link target should not be tracked by the shell's link path tracking mechanism; this can be used to prevent the link from being automatically updated if the target is moved or renamed based on its path |
||||
#DisableKnownFolderTracking bit 21 (0x00200000) - if set, the link target should not be tracked by the shell's known folder tracking mechanism; this can be used to prevent the link from being automatically updated if the target is moved or renamed based on its known folder ID |
||||
#DisableKnownFolderAlias bit 22 (0x00400000) - if set, the link target should not be aliased to a known folder; this can be used to prevent the link from being resolved to a different target if the original target is moved or renamed based on its known folder ID |
||||
#AllowLinkToLink bit 23 (0x00800000) - if set, the link target can be another link; if not set, the link target should not be another link (i.e. it should be a file or directory); this can be used to prevent the link from being resolved to a different target if the original target is moved or renamed based on the fact that it is a link |
||||
#UnaliasOnSave bit 24 (0x01000000) - if set, the link should be unaliased when it is saved; this can be used to prevent the link from being resolved to a different target if the original target is moved or renamed based on the fact that it is a link |
||||
#PreferEnvironmentPath bit 25 (0x02000000) - if set, the link should prefer to resolve the target using environment variable references; this can be used to allow the link to be resolved correctly even if the target is moved or renamed, as long as the environment variable references still point to the correct location |
||||
#KeepLocalIDListForUNCTarget bit 26 (0x04000000) - if set, the link should keep the local ID list for UNC targets; this can be used to allow the link to be resolved correctly even if the target is moved or renamed, as long as the local ID list still points to the correct location |
||||
# - the presence of these flags indicates the presence of optional structures in the .lnk file and also provides information about how to interpret the data in the file |
||||
proc Header_Get_LinkFlags {contents} { |
||||
set 4bytes [string range $contents 20 23] |
||||
set r [binary scan $4bytes i val] ;# i for little endian 32-bit signed int |
||||
return $val |
||||
} |
||||
|
||||
#offset hex:0x18 dec:24 4 bytes |
||||
#File attributes (FileAttributes) - bit field specifying the file attributes of the link target (if the EnableTargetMetadata flag is set in the LinkFlags field); this field is a bitwise combination of the following values: |
||||
proc Header_Get_FileAttributes {contents} { |
||||
if {![Header_Has_LinkFlag $contents "EnableTargetMetadata"]} { |
||||
return {} |
||||
} |
||||
set 4bytes [string range $contents 24 27] |
||||
set r [binary scan $4bytes i val] ;# i for little endian 32-bit signed int |
||||
set attrlist {} |
||||
if {$val & 0x00000001} {lappend attrlist "READONLY"} |
||||
if {$val & 0x00000002} {lappend attrlist "HIDDEN"} |
||||
if {$val & 0x00000004} {lappend attrlist "SYSTEM"} |
||||
if {$val & 0x00000010} {lappend attrlist "DIRECTORY"} |
||||
if {$val & 0x00000020} {lappend attrlist "ARCHIVE"} |
||||
if {$val & 0x00000040} {lappend attrlist "DEVICE"} |
||||
if {$val & 0x00000080} {lappend attrlist "NORMAL"} |
||||
if {$val & 0x00000100} {lappend attrlist "TEMPORARY"} |
||||
if {$val & 0x00000200} {lappend attrlist "SPARSE_FILE"} |
||||
if {$val & 0x00000400} {lappend attrlist "REPARSE_POINT"} |
||||
if {$val & 0x00000800} {lappend attrlist "COMPRESSED"} |
||||
if {$val & 0x00001000} {lappend attrlist "OFFLINE"} |
||||
if {$val & 0x00002000} {lappend attrlist "NOT_CONTENT_INDEXED"} |
||||
if {$val & 0x00004000} {lappend attrlist "ENCRYPTED"} |
||||
return $attrlist |
||||
} |
||||
proc Header_Get_FileAttributes_Raw {contents} { |
||||
if {![Header_Has_LinkFlag $contents "EnableTargetMetadata"]} { |
||||
return 0 |
||||
} |
||||
set 4bytes [string range $contents 24 27] |
||||
set r [binary scan $4bytes i val] ;# i for little endian 32-bit signed int |
||||
return $val |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
#offset hex:0x1C dec:28 8 bytes |
||||
#creation date and time (CreationTime) (FILETIME structure - 64-bit value representing the number of 100-nanosecond intervals since January 1, 1601 (UTC)) |
||||
proc Header_Get_CreationTime {contents} { |
||||
set 8bytes [string range $contents 28 35] |
||||
set r [binary scan $8bytes w val] ;# w for little endian 64-bit signed int |
||||
#convert FILETIME to human readable format - this is a bit complex because FILETIME is in 100-nanosecond intervals since January 1, 1601 (UTC) |
||||
#we can convert it to seconds and then to a human readable format |
||||
set seconds [expr {$val / 10000000.0}] |
||||
set epoch_seconds [expr {round($seconds) - 11644473600}] ;# number of seconds between January 1, 1601 and January 1, 1970 |
||||
set human_time [clock format $epoch_seconds -format "%Y-%m-%d %H:%M:%S" -gmt true] |
||||
return $human_time |
||||
} |
||||
proc Header_Get_CreationTime_Raw {contents} { |
||||
set 8bytes [string range $contents 28 35] |
||||
set r [binary scan $8bytes w val] ;# w for little endian 64-bit signed int |
||||
return $val |
||||
} |
||||
|
||||
#offset 36 8 bytes |
||||
#last access date and time (AccessTime) (FILETIME structure - 64-bit value representing the number of 100-nanosecond intervals since January 1, 1601 (UTC)) |
||||
proc Header_Get_AccessTime {contents} { |
||||
set 8bytes [string range $contents 36 43] |
||||
set r [binary scan $8bytes w val] ;# w for little endian 64-bit signed int |
||||
#convert FILETIME to human readable format - this is a bit complex because FILETIME is in 100-nanosecond intervals since January 1, 1601 (UTC) |
||||
#we can convert it to seconds and then to a human readable format |
||||
set seconds [expr {$val / 10000000.0}] |
||||
set epoch_seconds [expr {round($seconds) - 11644473600}] ;# number of seconds between January 1, 1601 and January 1, 1970 |
||||
set human_time [clock format $epoch_seconds -format "%Y-%m-%d %H:%M:%S" -gmt true] |
||||
return $human_time |
||||
} |
||||
proc Header_Get_AccessTime_Raw {contents} { |
||||
set 8bytes [string range $contents 36 43] |
||||
set r [binary scan $8bytes w val] ;# w for little endian 64-bit signed int |
||||
return $val |
||||
} |
||||
|
||||
#offset hex:0x2C dec:44 8 bytes |
||||
#last modification date and time (WriteTime) (FILETIME structure - 64-bit value representing the number of 100-nanosecond intervals since January 1, 1601 (UTC)) |
||||
proc Header_Get_WriteTime {contents} { |
||||
set 8bytes [string range $contents 44 51] |
||||
set r [binary scan $8bytes w val] ;# w for little endian 64-bit signed int |
||||
#convert FILETIME to human readable format - this is a bit complex because FILETIME is in 100-nanosecond intervals since January 1, 1601 (UTC) |
||||
#we can convert it to seconds and then to a human readable format |
||||
set seconds [expr {$val / 10000000.0}] |
||||
set epoch_seconds [expr {round($seconds) - 11644473600}] ;# number of seconds between January 1, 1601 and January 1, 1970 |
||||
set human_time [clock format $epoch_seconds -format "%Y-%m-%d %H:%M:%S" -gmt true] |
||||
return $human_time |
||||
} |
||||
proc Header_Get_WriteTime_Raw {contents} { |
||||
set 8bytes [string range $contents 44 51] |
||||
set r [binary scan $8bytes w val] ;# w for little endian 64-bit signed int |
||||
return $val |
||||
} |
||||
|
||||
#offset hex:0x34 dec:52 Bytes:4 - unsigned int |
||||
#file size in bytes (of target - low 32 bits if >4GB) |
||||
proc Header_Get_FileSize {contents} { |
||||
set 4bytes [string range $contents 52 55] |
||||
set r [binary scan $4bytes i val] |
||||
return $val |
||||
} |
||||
|
||||
#offset hex:0x38 dec:56 Bytes:4 - signed integer |
||||
#icon index value |
||||
proc Header_Get_IconIndex {contents} { |
||||
set 4bytes [string range $contents 56 59] |
||||
set r [binary scan $4bytes i val] |
||||
return $val |
||||
} |
||||
|
||||
#offset hex:0x3C dec:60 Bytes:4 - unsigned integer |
||||
#SW_SHOWNORMAL 0x00000001 |
||||
#SW_SHOWMAXIMIZED 0x00000001 |
||||
#SW_SHOWMINNOACTIVE 0x00000007 |
||||
# - all other values MUST be treated as SW_SHOWNORMAL |
||||
proc Header_Get_ShowCommand {contents} { |
||||
set 4bytes [string range $contents 60 63] |
||||
set r [binary scan $4bytes i val] |
||||
return $val |
||||
} |
||||
|
||||
#offset hex:0x40 dec:64 Bytes:2 |
||||
#Hot key |
||||
proc Header_Get_HotKey {contents} { |
||||
# Existing code that extracts the raw 16‑bit hotkey value: |
||||
set raw [Header_Get_HotKey_Raw $contents] |
||||
# The low byte holds the virtual‑key, high byte holds modifier flags |
||||
set vk [expr {$raw & 0xFF}] |
||||
set mods [expr {($raw >> 8) & 0xFF}] |
||||
set name [_vk_to_name $vk] |
||||
set modStr [_modifiers_to_string $mods] |
||||
if {$modStr eq ""} { |
||||
return $name |
||||
} else { |
||||
return "${modStr}+${name}" |
||||
} |
||||
} |
||||
proc Header_Get_HotKey_Raw {contents} { |
||||
set 2bytes [string range $contents 64 65] |
||||
set r [binary scan $2bytes s val] ;#short |
||||
return $val |
||||
} |
||||
proc _modifiers_to_string {mods} { |
||||
set parts {} |
||||
if {$mods & 0x01} {lappend parts "Shift"} |
||||
if {$mods & 0x02} {lappend parts "Ctrl"} |
||||
if {$mods & 0x04} {lappend parts "Alt"} |
||||
if {$mods & 0x08} {lappend parts "Win"} ;# optional |
||||
return [join $parts "+"] |
||||
} |
||||
proc _vk_to_name {vk} { |
||||
# Minimal map – extend as needed |
||||
array set vkMap { |
||||
0x00 "No key assigned" |
||||
0x08 Backspace 0x09 Tab 0x0D Return |
||||
0x10 Shift 0x11 Control 0x12 Alt |
||||
0x20 Space 0x21 PageUp 0x22 PageDown |
||||
0x23 End 0x24 Home 0x25 Left |
||||
0x26 Up 0x27 Right 0x28 Down |
||||
0x2D Insert 0x2E Delete |
||||
0x70 F1 0x71 F2 0x72 F3 |
||||
0x73 F4 0x74 F5 0x75 F6 |
||||
0x76 F7 0x77 F8 0x78 F9 |
||||
0x79 F10 0x7A F11 0x7B F12 |
||||
0x7c F13 0x7d F14 0x7e F15 |
||||
0x7f F16 0x80 F17 0x81 F18 |
||||
0x82 F19 0x83 F20 0x84 F21 |
||||
0x85 F22 0x86 F23 0x87 F24 |
||||
0x90 "NUM LOCK" 0x91 "SCROLL LOCK" |
||||
} |
||||
if {[info exists vkMap($vk)]} { |
||||
return $vkMap($vk) |
||||
} else { |
||||
if {$vk >= 0x30 && $vk <= 0x39} { |
||||
return [format "%c" $vk] ;# 0-9 |
||||
} elseif {$vk >= 0x41 && $vk <= 0x5A} { |
||||
return [format "%c" $vk] ;# A-Z |
||||
} |
||||
# fallback: hex representation |
||||
return [format "0x%02X" $vk] |
||||
} |
||||
} |
||||
|
||||
#offset hex:0x42 dec:66 Bytes:2 - reserved1 |
||||
proc Header_Get_Reserved1 {contents} { |
||||
set 2bytes [string range $contents 66 67] |
||||
set r [binary scan $2bytes s val] ;#short |
||||
return $val |
||||
} |
||||
|
||||
#offset hex:0x44 dec:68 Bytes:4 - reserved2 |
||||
proc Header_Get_Reserved2 {contents} { |
||||
set 4bytes [string range $contents 68 71] |
||||
set r [binary scan $4bytes i val] ;# i for little endian 32-bit signed int |
||||
return $val |
||||
} |
||||
|
||||
#offset hex:0x48 dec:72 Bytes:4 - reserved3 |
||||
proc Header_Get_Reserved3 {contents} { |
||||
set 4bytes [string range $contents 72 75] |
||||
set r [binary scan $4bytes i val] ;# i for little endian 32-bit signed int |
||||
return $val |
||||
} |
||||
|
||||
#end of 76 byte header |
||||
|
||||
proc Get_LinkTargetIDList_size {contents} { |
||||
if {[Header_Has_LinkFlag $contents "A"]} { |
||||
set 2bytes [string range $contents 76 77] |
||||
set r [binary scan $2bytes s val] ;#short |
||||
#logger |
||||
#puts stderr "LinkTargetIDList_size: $val" |
||||
return $val |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
proc Get_LinkInfo_content {contents} { |
||||
set idlist_size [Get_LinkTargetIDList_size $contents] |
||||
if {$idlist_size == 0} { |
||||
set offset 0 |
||||
} else { |
||||
set offset [expr {2 + $idlist_size}] ;#LinkTargetIdList IDListSize field + value |
||||
} |
||||
set linkinfo_start [expr {76 + $offset}] |
||||
if {[Header_Has_LinkFlag $contents "B"]} { |
||||
#puts stderr "linkinfo_start: $linkinfo_start" |
||||
set 4bytes [string range $contents $linkinfo_start $linkinfo_start+3] |
||||
binary scan $4bytes i val ;#size *including* these 4 bytes |
||||
set linkinfo_content [string range $contents $linkinfo_start [expr {$linkinfo_start + $val -1}]] |
||||
return [dict create linkinfo_start $linkinfo_start size $val next_start [expr {$linkinfo_start + $val}] content $linkinfo_content] |
||||
} else { |
||||
return [dict create linkinfo_start $linkinfo_start size 0 next_start $linkinfo_start content ""] |
||||
} |
||||
} |
||||
|
||||
proc LinkInfo_get_fields {linkinfocontent} { |
||||
set 4bytes [string range $linkinfocontent 0 3] |
||||
binary scan $4bytes i val ;#size *including* these 4 bytes |
||||
set bytes_linkinfoheadersize [string range $linkinfocontent 4 7] |
||||
set bytes_linkinfoflags [string range $linkinfocontent 8 11] |
||||
set r [binary scan $4bytes i flags] ;# i for little endian 32-bit signed int |
||||
#puts "linkinfoflags: $flags" |
||||
|
||||
set localbasepath "" |
||||
set commonpathsuffix "" |
||||
|
||||
#REVIEW - flags problem? |
||||
if {$flags & 1} { |
||||
#VolumeIDAndLocalBasePath |
||||
#logger |
||||
#puts stderr "VolumeIDAndLocalBasePath" |
||||
} |
||||
if {$flags & 2} { |
||||
#logger |
||||
#puts stderr "CommonNetworkRelativeLinkAndPathSuffix" |
||||
} |
||||
set bytes_volumeid_offset [string range $linkinfocontent 12 15] |
||||
set bytes_localbasepath_offset [string range $linkinfocontent 16 19] ;# a |
||||
set bytes_commonnetworkrelativelinkoffset [string range $linkinfocontent 20 23] |
||||
set bytes_commonpathsuffix_offset [string range $linkinfocontent 24 27] ;# a |
||||
|
||||
binary scan $bytes_localbasepath_offset i bp_offset |
||||
if {$bp_offset > 0} { |
||||
set tail [string range $linkinfocontent $bp_offset end] |
||||
set stringterminator 0 |
||||
set i 0 |
||||
set localbasepath "" |
||||
#TODO |
||||
while {!$stringterminator & $i < 100} { |
||||
set c [string index $tail $i] |
||||
if {$c eq "\x00"} { |
||||
set stringterminator 1 |
||||
} else { |
||||
append localbasepath $c |
||||
} |
||||
incr i |
||||
} |
||||
} |
||||
binary scan $bytes_commonpathsuffix_offset i cps_offset |
||||
if {$cps_offset > 0} { |
||||
set tail [string range $linkinfocontent $cps_offset end] |
||||
set stringterminator 0 |
||||
set i 0 |
||||
set commonpathsuffix "" |
||||
#TODO |
||||
while {!$stringterminator && $i < 100} { |
||||
set c [string index $tail $i] |
||||
if {$c eq "\x00"} { |
||||
set stringterminator 1 |
||||
} else { |
||||
append commonpathsuffix $c |
||||
} |
||||
incr i |
||||
} |
||||
} |
||||
|
||||
|
||||
return [dict create localbasepath $localbasepath commonpathsuffix $commonpathsuffix] |
||||
} |
||||
|
||||
proc contents_get_info {contents} { |
||||
|
||||
#todo - return something like the perl lnk-parse-1.0.pl script? |
||||
|
||||
#Link File: C:/repo/jn/tclmodules/tomlish/src/modules/test/#modpod-tomlish-0.1.0/suites/all/arrays_1.toml#roundtrip+roundtrip_files+arrays_1.toml.fauxlink.lnk |
||||
#Link Flags: HAS SHELLIDLIST | POINTS TO FILE/DIR | NO DESCRIPTION | HAS RELATIVE PATH STRING | HAS WORKING DIRECTORY | NO CMD LINE ARGS | NO CUSTOM ICON | |
||||
#File Attributes: ARCHIVE |
||||
#Create Time: Sun Jul 14 2024 10:41:34 |
||||
#Last Accessed time: Sat Sept 21 2024 02:46:10 |
||||
#Last Modified Time: Tue Sept 10 2024 17:16:07 |
||||
#Target Length: 479 |
||||
#Icon Index: 0 |
||||
#ShowWnd: 1 SW_NORMAL |
||||
#HotKey: 0 |
||||
#(App Path:) Remaining Path: repo\jn\tclmodules\tomlish\src\modules\test\#modpod-tomlish-0.1.0\suites\roundtrip\roundtrip_files\arrays_1.toml |
||||
#Relative Path: ..\roundtrip\roundtrip_files\arrays_1.toml |
||||
#Working Dir: C:\repo\jn\tclmodules\tomlish\src\modules\test\#modpod-tomlish-0.1.0\suites\roundtrip\roundtrip_files |
||||
|
||||
variable LinkFlags |
||||
set flags_enabled [list] |
||||
dict for {k v} $LinkFlags { |
||||
if {[Header_Has_LinkFlag $contents $k] > 0} { |
||||
lappend flags_enabled $k |
||||
} |
||||
} |
||||
|
||||
set showcommand_val [Header_Get_ShowCommand $contents] |
||||
switch -- $showcommand_val { |
||||
1 { |
||||
set showwnd [list 1 SW_SHOWNORMAL] |
||||
} |
||||
3 { |
||||
set showwnd [list 3 SW_SHOWMAXIMIZED] |
||||
} |
||||
7 { |
||||
set showwnd [list 7 SW_SHOWMINNOACTIVE] |
||||
} |
||||
default { |
||||
set showwnd [list $showcommand_val SW_SHOWNORMAL-effective] |
||||
} |
||||
} |
||||
|
||||
set linkinfo_content_dict [Get_LinkInfo_content $contents] |
||||
set localbase_path "" |
||||
set suffix_path "" |
||||
set linkinfocontent [dict get $linkinfo_content_dict content] |
||||
set link_target "" |
||||
if {$linkinfocontent ne ""} { |
||||
set linkfields [LinkInfo_get_fields $linkinfocontent] |
||||
set localbase_path [dict get $linkfields localbasepath] |
||||
set suffix_path [dict get $linkfields commonpathsuffix] |
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
set link_target [file join $localbase_path $suffix_path] |
||||
} else { |
||||
set suffix_path [string trimleft [string map {\\ /} $suffix_path] /] |
||||
if {[regexp {([a-zA-Z]):\\(.*)} $localbase_path _match drive_letter tail]} { |
||||
set localbase_path [string map {\\ /} $localbase_path] |
||||
set tail [string trimleft [string map {\\ /} $tail] /] |
||||
set link_target "" |
||||
#shortcut basepath is a windows path with drive letter - try to resolve it on unix by looking for a corresponding mount from fstab or a point under /mnt |
||||
set mountinfo [exec mount] |
||||
foreach line [split $mountinfo "\n"] { |
||||
#review - a more specific mount target might exist that includes the drive letter as part of the mount point name and is a longer prefix of the localbase_path |
||||
#- we should probably look for the longest prefix match rather than just the drive letter |
||||
if {[regexp -nocase -- [string cat ^$drive_letter {:\\\s+on\s+(\S+)}] $line _match mount_point]} { |
||||
set link_target [file join $mount_point $tail $suffix_path] |
||||
break |
||||
} |
||||
} |
||||
if {$link_target eq ""} { |
||||
#review - under what circumstances could this happen? If the drive letter doesn't match any mount points, then /mnt/drive_letter should generally already have been found above above |
||||
# - However, it may be possible for /mnt/drive_Letter to still exist even if it's not reflected in the output of mount or the output of mount is in an unexpected format. |
||||
|
||||
#nothing in mount result matches the drive letter - try looking for a mount point under /mnt with the drive letter as the name |
||||
if {[file exists /mnt/$drive_letter]} { |
||||
set link_target [file join /mnt/$drive_letter $tail $suffix_path] |
||||
} else { |
||||
if {$drive_letter eq [string tolower $drive_letter]]} { |
||||
set op_drive_letter [string toupper $drive_letter] |
||||
} else { |
||||
set op_drive_letter [string tolower $drive_letter] |
||||
} |
||||
if {[file exists /mnt/$op_drive_letter]} { |
||||
set link_target [file join /mnt/$op_drive_letter $tail $suffix_path] |
||||
} else { |
||||
#leave as is except for backslashes converted to forward |
||||
#- probably won't resolve correctly unless the unix system has a folder named drive_letter: in the current folder with a copy of the original filestructure. |
||||
set link_target [file join $localbase_path $suffix_path] |
||||
} |
||||
} |
||||
} else { |
||||
#shortcut basepath is a windows path with drive letter and we found a matching mount point - link_target is set to the resolved path |
||||
} |
||||
} else { |
||||
#shortcut basepath doesn't match expected windows path format - just join it with the suffix and hope for the best |
||||
#could be something like a network path or it could be something else entirely |
||||
set link_target [file join $localbase_path $suffix_path] |
||||
} |
||||
} |
||||
} |
||||
|
||||
set result [dict create\ |
||||
link_target $link_target\ |
||||
link_flags $flags_enabled\ |
||||
file_attributes [Header_Get_FileAttributes $contents]\ |
||||
creation_time [Header_Get_CreationTime $contents]\ |
||||
access_time [Header_Get_AccessTime $contents]\ |
||||
write_time [Header_Get_WriteTime $contents]\ |
||||
target_length [Header_Get_FileSize $contents]\ |
||||
icon_index "<unimplemented>"\ |
||||
showwnd "$showwnd"\ |
||||
hotkey [Header_Get_HotKey $contents]\ |
||||
relative_path "?"\ |
||||
] |
||||
} |
||||
|
||||
proc file_check_header {path} { |
||||
#*** !doctools |
||||
#[call [fun file_check_header] [arg path] ] |
||||
#[para]Return 0|1 |
||||
#[para]Determines if the .lnk file specified in path has a valid header for a windows shortcut |
||||
set c [Get_contents $path 20] |
||||
return [Contents_check_header $c] |
||||
} |
||||
namespace eval argdoc { |
||||
variable PUNKARGS |
||||
lappend PUNKARGS [list { |
||||
@id -id ::punk::winlnk::resolve |
||||
@cmd -name punk::winlnk::resolve\ |
||||
-summary\ |
||||
"Return information about a .lnk file (windows shortcut)"\ |
||||
-help\ |
||||
"Return a dict of info obtained by parsing the binary data in a windows .lnk file. |
||||
If the .lnk header check fails, then the .lnk file probably isn't really a shortcut |
||||
file and the dictionary will contain an 'error' key." |
||||
@values -min 1 -max 1 |
||||
path -type string -help "Path to the .lnk file to resolve" |
||||
}] |
||||
} |
||||
proc resolve {path} { |
||||
#*** !doctools |
||||
#[call [fun resolve] [arg path] ] |
||||
#[para] Return a dict of info obtained by parsing the binary data in a windows .lnk file |
||||
#[para] If the .lnk header check fails, then the .lnk file probably isn't really a shortcut file and the dictionary will contain an 'error' key |
||||
set c [Get_contents $path] |
||||
if {[Contents_check_header $c]} { |
||||
return [contents_get_info $c] |
||||
} else { |
||||
return [dict create error "lnk_header_check_failed"] |
||||
} |
||||
} |
||||
namespace eval argdoc { |
||||
variable PUNKARGS |
||||
lappend PUNKARGS [list { |
||||
@id -id ::punk::winlnk::file_show_info |
||||
@cmd -name punk::winlnk::file_show_info\ |
||||
-summary\ |
||||
"Show information about a .lnk file (windows shortcut)"\ |
||||
-help\ |
||||
"Print to stdout the information obtained by parsing the binary data in a windows .lnk file, in a human readable format. |
||||
If the .lnk header check fails, then the .lnk file probably isn't really a shortcut file and an error message will be printed." |
||||
@values -min 1 -max 1 |
||||
path -type string -help "Path to the .lnk file to resolve" |
||||
}] |
||||
} |
||||
proc file_show_info {path} { |
||||
package require punk::lib |
||||
punk::lib::showdict [resolve $path] * |
||||
} |
||||
namespace eval argdoc { |
||||
variable PUNKARGS |
||||
lappend PUNKARGS [list { |
||||
@id -id ::punk::winlnk::target |
||||
@cmd -name punk::winlnk::target\ |
||||
-summary\ |
||||
"Return the target path of a .lnk file (windows shortcut)"\ |
||||
-help\ |
||||
"Return the target path of the .lnk file specified in path. |
||||
This is a convenience function that extracts the target path from the .lnk file and returns it directly, |
||||
without all the additional information that resolve provides. If the .lnk header check fails, then |
||||
the .lnk file probably isn't really a shortcut file and an error message will be returned." |
||||
@values -min 1 -max 1 |
||||
path -type string -help "Path to the .lnk file to resolve" |
||||
}] |
||||
} |
||||
proc target {path} { |
||||
#*** !doctools |
||||
#[call [fun target] [arg path] ] |
||||
#[para]Return the target path of the .lnk file specified in path |
||||
set info [resolve $path] |
||||
if {[dict exists $info error]} { |
||||
error [dict get $info error] |
||||
} else { |
||||
return [dict get $info link_target] |
||||
} |
||||
} |
||||
|
||||
#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" |
||||
#} |
||||
|
||||
|
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::winlnk ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::winlnk::lib { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::winlnk::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::winlnk::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
#tcl::namespace::eval punk::winlnk::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::winlnk::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
|
||||
|
||||
#} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::punk::winlnk |
||||
} |
||||
## Ready |
||||
package provide punk::winlnk [tcl::namespace::eval punk::winlnk { |
||||
variable pkg punk::winlnk |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
@ -1,761 +0,0 @@
|
||||
# -*- 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.3.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 JMN |
||||
# (C) 2009 Path Thoyts <patthyts@users.sourceforge.net> |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::zip 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin shellspy_module_punk::zip 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::zip] |
||||
#[keywords module] |
||||
#[description] |
||||
#[para] - |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of punk::zip |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by punk::zip |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
package require punk::args |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
#[item] [package {punk::args}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# oo::class namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#tcl::namespace::eval punk::zip::class { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::zip::class}] |
||||
#[para] class definitions |
||||
#if {[tcl::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::zip { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
#variable xyz |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace punk::zip}] |
||||
#[para] Core API functions for punk::zip |
||||
#[list_begin definitions] |
||||
|
||||
proc Path_a_atorbelow_b {path_a path_b} { |
||||
return [expr {[StripPath $path_b $path_a] ne $path_a}] |
||||
} |
||||
proc Path_a_at_b {path_a path_b} { |
||||
return [expr {[StripPath $path_a $path_b] eq "." }] |
||||
} |
||||
|
||||
proc Path_strip_alreadynormalized_prefixdepth {path prefix} { |
||||
if {$prefix eq ""} { |
||||
return $path |
||||
} |
||||
set pathparts [file split $path] |
||||
set prefixparts [file split $prefix] |
||||
if {[llength $prefixparts] >= [llength $pathparts]} { |
||||
return "" |
||||
} |
||||
return [file join \ |
||||
{*}[lrange \ |
||||
$pathparts \ |
||||
[llength $prefixparts] \ |
||||
end]] |
||||
} |
||||
|
||||
#StripPath - borrowed from tcllib fileutil |
||||
# ::fileutil::stripPath -- |
||||
# |
||||
# If the specified path references/is a path in prefix (or prefix itself) it |
||||
# is made relative to prefix. Otherwise it is left unchanged. |
||||
# In the case of it being prefix itself the result is the string '.'. |
||||
# |
||||
# Arguments: |
||||
# prefix prefix to strip from the path. |
||||
# path path to modify |
||||
# |
||||
# Results: |
||||
# path The (possibly) modified path. |
||||
|
||||
if {[string equal $::tcl_platform(platform) windows]} { |
||||
# Windows. While paths are stored with letter-case preserved al |
||||
# comparisons have to be done case-insensitive. For reference see |
||||
# SF Tcllib Bug 2499641. |
||||
|
||||
proc StripPath {prefix path} { |
||||
# [file split] is used to generate a canonical form for both |
||||
# paths, for easy comparison, and also one which is easy to modify |
||||
# using list commands. |
||||
|
||||
set prefix [file split $prefix] |
||||
set npath [file split $path] |
||||
|
||||
if {[string equal -nocase $prefix $npath]} { |
||||
return "." |
||||
} |
||||
|
||||
if {[string match -nocase "${prefix} *" $npath]} { |
||||
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] |
||||
} |
||||
return $path |
||||
} |
||||
} else { |
||||
proc StripPath {prefix path} { |
||||
# [file split] is used to generate a canonical form for both |
||||
# paths, for easy comparison, and also one which is easy to modify |
||||
# using list commands. |
||||
|
||||
set prefix [file split $prefix] |
||||
set npath [file split $path] |
||||
|
||||
if {[string equal $prefix $npath]} { |
||||
return "." |
||||
} |
||||
|
||||
if {[string match "${prefix} *" $npath]} { |
||||
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] |
||||
} |
||||
return $path |
||||
} |
||||
} |
||||
|
||||
proc Timet_to_dos {time_t} { |
||||
#*** !doctools |
||||
#[call [fun Timet_to_dos] [arg time_t]] |
||||
#[para] convert a unix timestamp into a DOS timestamp for ZIP times. |
||||
#[example { |
||||
# DOS timestamps are 32 bits split into bit regions as follows: |
||||
# 24 16 8 0 |
||||
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ |
||||
# |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s| |
||||
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ |
||||
#}] |
||||
set s [clock format $time_t -format {%Y %m %e %k %M %S}] |
||||
scan $s {%d %d %d %d %d %d} year month day hour min sec |
||||
expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) |
||||
| ($hour << 11) | ($min << 5) | ($sec >> 1)} |
||||
} |
||||
|
||||
proc walk {args} { |
||||
#*** !doctools |
||||
#[call [fun walk] [arg ?options?] [arg base]] |
||||
#[para] Walk a directory tree rooted at base |
||||
#[para] the -excludes list can be a set of glob expressions to match against files and avoid |
||||
#[para] e.g |
||||
#[example { |
||||
# punk::zip::walk -exclude {CVS/* *~.#*} library |
||||
#}] |
||||
|
||||
set argd [punk::args::get_dict { |
||||
*proc -name punk::zip::walk |
||||
-excludes -default "" -help "list of glob expressions to match against files and exclude" |
||||
-subpath -default "" |
||||
*values -min 1 -max -1 |
||||
base |
||||
fileglobs -default {*} -multiple 1 |
||||
} $args] |
||||
set base [dict get $argd values base] |
||||
set fileglobs [dict get $argd values fileglobs] |
||||
set subpath [dict get $argd opts -subpath] |
||||
set excludes [dict get $argd opts -excludes] |
||||
|
||||
|
||||
set imatch [list] |
||||
foreach fg $fileglobs { |
||||
lappend imatch [file join $subpath $fg] |
||||
} |
||||
|
||||
set result {} |
||||
#set imatch [file join $subpath $match] |
||||
set files [glob -nocomplain -tails -types f -directory $base -- {*}$imatch] |
||||
foreach file $files { |
||||
set excluded 0 |
||||
foreach glob $excludes { |
||||
if {[string match $glob $file]} { |
||||
set excluded 1 |
||||
break |
||||
} |
||||
} |
||||
if {!$excluded} {lappend result $file} |
||||
} |
||||
foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] { |
||||
set subdir_entries [walk -subpath $dir -excludes $excludes $base {*}$fileglobs] |
||||
if {[llength $subdir_entries]>0} { |
||||
#NOTE: trailing slash required for entries to be recognised as 'file type' = "directory" |
||||
#This is true for 2024 Tcl9 mounted zipfs at least. zip utilities such as 7zip seem(icon correct) to recognize dirs with or without trailing slash |
||||
#Although there are attributes on some systems to specify if entry is a directory - it appears trailing slash should always be used for folder names. |
||||
set result [list {*}$result "$dir/" {*}$subdir_entries] |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
|
||||
proc extract_zip_prefix {infile outfile} { |
||||
set inzip [open $infile r] |
||||
fconfigure $inzip -encoding iso8859-1 -translation binary |
||||
if {[file exists $outfile]} { |
||||
error "outfile $outfile already exists - please remove first" |
||||
} |
||||
chan seek $inzip 0 end |
||||
set insize [tell $inzip] ;#faster (including seeks) than calling out to filesystem using file size - but should be equivalent |
||||
chan seek $inzip 0 start |
||||
#only scan last 64k - cover max signature size?? review |
||||
if {$insize < 65559} { |
||||
set tailsearch_start 0 |
||||
} else { |
||||
set tailsearch_start [expr {$insize - 65559}] |
||||
} |
||||
chan seek $inzip $tailsearch_start start |
||||
set scan [read $inzip] |
||||
#EOCD - End Of Central Directory record |
||||
set start_of_end [string last "\x50\x4b\x05\x06" $scan] |
||||
puts stdout "==>start_of_end: $start_of_end" |
||||
|
||||
if {$start_of_end == -1} { |
||||
#no zip cdr - consider entire file to be the zip prefix |
||||
set baseoffset $insize |
||||
} else { |
||||
set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] |
||||
chan seek $inzip $filerelative_eocd_posn |
||||
set cdir_record_plus [read $inzip] ;#can have trailing data |
||||
binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||
#rule out a false positive from within a nonzip (e.g plain exe) |
||||
#There exists for example a PK\5\6 in a plain tclsh, but it doesn't appear to be zip related. |
||||
#It doesn't seem to occur near the end - so perhaps not an issue - but we'll do some basic checks anyway |
||||
#we only support single disk - so we'll validate a bit more by requiring disknbr and ctrldirdisk to be zeros |
||||
#todo - just search for Pk\5\6\0\0\0\0 in the first place? //review |
||||
if {$eocd(disknbr) + $eocd(ctrldirdisk) != 0} { |
||||
#review - should keep searching? |
||||
#for now we assume not a zip |
||||
set baseoffset $insize |
||||
} else { |
||||
#use the central dir size to jump back tko start of central dir |
||||
#determine if diroffset is file or archive relative |
||||
|
||||
set filerelative_cdir_start [expr {$filerelative_eocd_posn - $eocd(dirsize)}] |
||||
puts stdout "---> [read $inzip 4]" |
||||
if {$filerelative_cdir_start > $eocd(diroffset)} { |
||||
#easy case - 'archive' offset - (and one of the reasons I prefer archive-offset - it makes finding the 'prefix' easier |
||||
#though we are assuming zip offsets are not corrupted |
||||
set baseoffset [expr {$filerelative_cdir_start - $eocd(diroffset)}] |
||||
} else { |
||||
#hard case - either no prefix - or offsets have been adjusted to be file relative. |
||||
#we could scan from top (ugly) - and with binary prefixes we could get false positives in the data that look like PK\3\4 headers |
||||
#we could either work out the format for all possible executables that could be appended (across all platforms) and understand where they end? |
||||
#or we just look for the topmost PK\3\4 header pointed to by a CDR record - and assume the CDR is complete |
||||
|
||||
#step one - read all the CD records and find the highest pointed to local file record (which isn't necessarily the first - but should get us above most if not all of the zip data) |
||||
#we can't assume they're ordered in any particular way - so we in theory have to look at them all. |
||||
set baseoffset "unknown" |
||||
chan seek $inzip $filerelative_cdir_start start |
||||
#binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||
# eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||
#load the whole central dir into cdir |
||||
|
||||
#todo! loop through all cdr file headers - find highest offset? |
||||
#tclZipfs.c just looks at first file header in Central Directory |
||||
#looking at all entries would be more robust - but we won't work harder than tclZipfs.c for now //REVIEW |
||||
|
||||
set cdirdata [read $inzip $eocd(dirsize)] |
||||
binary scan $cdirdata issssssiiisssssii cdir(signature) cdir(_vermadeby) cdir(_verneeded) cdir(gpbitflag) cdir(compmethod) cdir(lastmodifiedtime) cdir(lastmodifieddate)\ |
||||
cdir(uncompressedcrc32) cdir(compressedsize) cdir(uncompressedsize) cdir(filenamelength) cdir(extrafieldlength) cdir(filecommentlength) cdir(disknbr)\ |
||||
cdir(internalfileattributes) cdir(externalfileatributes) cdir(relativeoffset) |
||||
|
||||
#since we're in this branch - we assume cdir(relativeoffset) is from the start of the file |
||||
chan seek $inzip $cdir(relativeoffset) |
||||
#let's at least check that we landed on a local file header.. |
||||
set local_file_header_beginning [read $inzip 28]; #local_file_header without the file name and extra field |
||||
binary scan $local_file_header_beginning isssssiiiss lfh(signature) lfh(_verneeded) lfh(gpbitflag) lfh(compmethod) lfh(lastmodifiedtime) lfh(lastmodifieddate)\ |
||||
lfh(uncompressedcrc32) lfh(compressedsize) lfh(uncompressedsize) lfh(filenamelength) lfh(extrafieldlength) |
||||
#dec2hex 67324752 = 4034B50 = PK\3\4 |
||||
puts stdout "1st local file header sig: $lfh(signature)" |
||||
if {$lfh(signature) == 67324752} { |
||||
#looks like a local file header |
||||
#use our cdir(relativeoffset) as the start of the zip-data (//review - possible embedded password + end marker preceeding this) |
||||
set baseoffset $cdir(relativeoffset) |
||||
} |
||||
} |
||||
puts stdout "filerel_cdirstart: $filerelative_cdir_start recorded_offset: $eocd(diroffset)" |
||||
} |
||||
} |
||||
puts stdout "baseoffset: $baseoffset" |
||||
#expect CDFH PK\1\2 |
||||
#above the CDFH - we expect a bunch of PK\3\4 records - (possibly not all of them pointed to by the CDR) |
||||
#above that we expect: *possibly* a stored password with trailing marker - then the prefixed exe/script |
||||
|
||||
if {![string is integer -strict $baseoffset]} { |
||||
error "unable to determine zip baseoffset of file $infile" |
||||
} |
||||
|
||||
if {$baseoffset < $insize} { |
||||
set out [open $outfile w] |
||||
fconfigure $out -encoding iso8859-1 -translation binary |
||||
chan seek $inzip 0 start |
||||
chan copy $inzip $out -size $baseoffset |
||||
close $out |
||||
close $inzip |
||||
} else { |
||||
close $inzip |
||||
file copy $infile $outfile |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
# Mkzipfile -- |
||||
# |
||||
# FIX ME: should handle the current offset for non-seekable channels |
||||
# |
||||
proc Mkzipfile {zipchan base path {comment ""}} { |
||||
#*** !doctools |
||||
#[call [fun Mkzipfile] [arg zipchan] [arg base] [arg path] [arg ?comment?]] |
||||
#[para] Add a single file to a zip archive |
||||
#[para] The zipchan channel should already be open and binary. |
||||
#[para] You can provide a -comment for the file. |
||||
#[para] The return value is the central directory record that will need to be used when finalizing the zip archive. |
||||
|
||||
set fullpath [file join $base $path] |
||||
set mtime [Timet_to_dos [file mtime $fullpath]] |
||||
set utfpath [encoding convertto utf-8 $path] |
||||
set utfcomment [encoding convertto utf-8 $comment] |
||||
set flags [expr {(1<<11)}] ;# utf-8 comment and path |
||||
set method 0 ;# store 0, deflate 8 |
||||
set attr 0 ;# text or binary (default binary) |
||||
set version 20 ;# minumum version req'd to extract |
||||
set extra "" |
||||
set crc 0 |
||||
set size 0 |
||||
set csize 0 |
||||
set data "" |
||||
set seekable [expr {[tell $zipchan] != -1}] |
||||
if {[file isdirectory $fullpath]} { |
||||
set attrex 0x41ff0010 ;# 0o040777 (drwxrwxrwx) |
||||
#set attrex 0x40000010 |
||||
} elseif {[file executable $fullpath]} { |
||||
set attrex 0x81ff0080 ;# 0o100777 (-rwxrwxrwx) |
||||
} else { |
||||
set attrex 0x81b60020 ;# 0o100666 (-rw-rw-rw-) |
||||
if {[file extension $fullpath] in {".tcl" ".txt" ".c"}} { |
||||
set attr 1 ;# text |
||||
} |
||||
} |
||||
|
||||
if {[file isfile $fullpath]} { |
||||
set size [file size $fullpath] |
||||
if {!$seekable} {set flags [expr {$flags | (1 << 3)}]} |
||||
} |
||||
|
||||
|
||||
set offset [tell $zipchan] |
||||
set local [binary format a4sssiiiiss PK\03\04 \ |
||||
$version $flags $method $mtime $crc $csize $size \ |
||||
[string length $utfpath] [string length $extra]] |
||||
append local $utfpath $extra |
||||
puts -nonewline $zipchan $local |
||||
|
||||
if {[file isfile $fullpath]} { |
||||
# If the file is under 2MB then zip in one chunk, otherwize we use |
||||
# streaming to avoid requiring excess memory. This helps to prevent |
||||
# storing re-compressed data that may be larger than the source when |
||||
# handling PNG or JPEG or nested ZIP files. |
||||
if {$size < 0x00200000} { |
||||
set fin [open $fullpath rb] |
||||
set data [read $fin] |
||||
set crc [zlib crc32 $data] |
||||
set cdata [zlib deflate $data] |
||||
if {[string length $cdata] < $size} { |
||||
set method 8 |
||||
set data $cdata |
||||
} |
||||
close $fin |
||||
set csize [string length $data] |
||||
puts -nonewline $zipchan $data |
||||
} else { |
||||
set method 8 |
||||
set fin [open $fullpath rb] |
||||
set zlib [zlib stream deflate] |
||||
while {![eof $fin]} { |
||||
set data [read $fin 4096] |
||||
set crc [zlib crc32 $data $crc] |
||||
$zlib put $data |
||||
if {[string length [set zdata [$zlib get]]]} { |
||||
incr csize [string length $zdata] |
||||
puts -nonewline $zipchan $zdata |
||||
} |
||||
} |
||||
close $fin |
||||
$zlib finalize |
||||
set zdata [$zlib get] |
||||
incr csize [string length $zdata] |
||||
puts -nonewline $zipchan $zdata |
||||
$zlib close |
||||
} |
||||
|
||||
if {$seekable} { |
||||
# update the header if the output is seekable |
||||
set local [binary format a4sssiiii PK\03\04 \ |
||||
$version $flags $method $mtime $crc $csize $size] |
||||
set current [tell $zipchan] |
||||
seek $zipchan $offset |
||||
puts -nonewline $zipchan $local |
||||
seek $zipchan $current |
||||
} else { |
||||
# Write a data descriptor record |
||||
set ddesc [binary format a4iii PK\7\8 $crc $csize $size] |
||||
puts -nonewline $zipchan $ddesc |
||||
} |
||||
} |
||||
|
||||
#PK\x01\x02 Cdentral directory file header |
||||
#set v1 0x0317 ;#upper byte 03 -> UNIX lower byte 23 -> 2.3 |
||||
set v1 0x0017 ;#upper byte 00 -> MS_DOS and OS/2 (FAT/VFAT/FAT32 file systems) |
||||
|
||||
set hdr [binary format a4ssssiiiisssssii PK\01\02 $v1 \ |
||||
$version $flags $method $mtime $crc $csize $size \ |
||||
[string length $utfpath] [string length $extra]\ |
||||
[string length $utfcomment] 0 $attr $attrex $offset] |
||||
append hdr $utfpath $extra $utfcomment |
||||
return $hdr |
||||
} |
||||
|
||||
#### REVIEW!!! |
||||
#JMN - review - this looks to be offset relative to start of file - (same as 2024 Tcl 'mkzip mkimg') |
||||
# we probably want offsets to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) |
||||
#### |
||||
|
||||
# zip::mkzip -- |
||||
# |
||||
# eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt |
||||
# |
||||
proc mkzip {args} { |
||||
#*** !doctools |
||||
#[call [fun mkzip] [arg ?options?] [arg filename]] |
||||
#[para] Create a zip archive in 'filename' |
||||
#[para] If a file already exists, an error will be raised. |
||||
set argd [punk::args::get_dict { |
||||
*proc -name punk::zip::mkzip -help "Create a zip archive in 'filename'" |
||||
*opts |
||||
-return -default "pretty" -choices {pretty list none} -help "mkzip can return a list of the files and folders added to the archive |
||||
the option -return pretty is the default and uses the punk::lib pdict/plist system |
||||
to return a formatted list for the terminal |
||||
" |
||||
-zipkit -default 0 -type none -help "" |
||||
-runtime -default "" -help "specify a prefix file |
||||
e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir output.zip |
||||
will create a self-extracting zip archive from the subdir/ folder. |
||||
" |
||||
-comment -default "" -help "An optional comment for the archive" |
||||
-directory -default "" -help "The new zip archive will scan for contents within this folder or current directory if not provided" |
||||
-base -default "" -help "The new zip archive will be rooted in this directory if provided |
||||
it must be a parent of -directory" |
||||
-exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} |
||||
*values -min 1 -max -1 |
||||
filename -default "" -help "name of zipfile to create" |
||||
globs -default {*} -multiple 1 -help "list of glob patterns to match. |
||||
Only directories with matching files will be included in the archive" |
||||
} $args] |
||||
|
||||
set filename [dict get $argd values filename] |
||||
if {$filename eq ""} { |
||||
error "mkzip filename cannot be empty string" |
||||
} |
||||
if {[regexp {[?*]} $filename]} { |
||||
#catch a likely error where filename is omitted and first glob pattern is misinterpreted as zipfile name |
||||
error "mkzip filename should not contain glob characters ? *" |
||||
} |
||||
if {[file exists $filename]} { |
||||
error "mkzip filename:$filename already exists" |
||||
} |
||||
dict for {k v} [dict get $argd opts] { |
||||
switch -- $k { |
||||
-comment { |
||||
dict set argd opts $k [encoding convertto utf-8 $v] |
||||
} |
||||
-directory - -base { |
||||
dict set argd opts $k [file normalize $v] |
||||
} |
||||
} |
||||
} |
||||
|
||||
array set opts [dict get $argd opts] |
||||
|
||||
|
||||
if {$opts(-directory) ne ""} { |
||||
if {$opts(-base) ne ""} { |
||||
#-base and -directory have been normalized already |
||||
if {![Path_a_atorbelow_b $opts(-directory) $opts(-base)]} { |
||||
error "punk::zip::mkzip -base $opts(-base) must be above -directory $opts(-directory)" |
||||
} |
||||
set base $opts(-base) |
||||
set relpath [Path_strip_alreadynormalized_prefixdepth $opts(-directory) $opts(-base)] |
||||
} else { |
||||
set base $opts(-directory) |
||||
set relpath "" |
||||
} |
||||
set paths [walk -exclude $opts(-exclude) -subpath $relpath -- $base {*}[dict get $argd values globs]] |
||||
|
||||
set norm_filename [file normalize $filename] |
||||
set norm_dir [file normalize $opts(-directory)] ;#we only care if filename below -directory (which is where we start scanning) |
||||
if {[Path_a_atorbelow_b $norm_filename $norm_dir]} { |
||||
#check that we aren't adding the zipfile to itself |
||||
#REVIEW - now that we open zipfile after scanning - this isn't really a concern! |
||||
#keep for now in case we can add an -update or a -force facility (or in case we modify to add to zip as we scan for members?) |
||||
#In the case of -force - we may want to delay replacement of original until scan is done? |
||||
|
||||
#try to avoid looping on all paths and performing (somewhat) expensive file normalizations on each |
||||
#1st step is to check the patterns and see if our zipfile is already excluded - in which case we need not check the paths |
||||
set self_globs_match 0 |
||||
foreach g [dict get $argd values globs] { |
||||
if {[string match $g [file tail $filename]]} { |
||||
set self_globs_match 1 |
||||
break |
||||
} |
||||
} |
||||
if {$self_globs_match} { |
||||
#still dangerous |
||||
set self_excluded 0 |
||||
foreach e $opts(-exclude) { |
||||
if {[string match $e [file tail $filename]]} { |
||||
set self_excluded 1 |
||||
break |
||||
} |
||||
} |
||||
if {!$self_excluded} { |
||||
#still dangerous - likely to be in resultset - check each path |
||||
#puts stderr "zip file $filename is below directory $opts(-directory)" |
||||
set self_is_matched 0 |
||||
set i 0 |
||||
foreach p $paths { |
||||
set norm_p [file normalize [file join $opts(-directory) $p]] |
||||
if {[Path_a_at_b $norm_filename $norm_p]} { |
||||
set self_is_matched 1 |
||||
break |
||||
} |
||||
incr i |
||||
} |
||||
if {$self_is_matched} { |
||||
puts stderr "WARNING - zipfile being created '$filename' was matched. Excluding this file. Relocate the zip, or use -exclude patterns to avoid this message" |
||||
set paths [lremove $paths $i] |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} else { |
||||
set paths [list] |
||||
set dir [pwd] |
||||
if {$opts(-base) ne ""} { |
||||
if {![Path_a_atorbelow_b $dir $opts(-base)]} { |
||||
error "punk::zip::mkzip -base $opts(-base) must be above current directory" |
||||
} |
||||
set relpath [Path_strip_alreadynormalized_prefixdepth [file normalize $dir] [file normalize $opts(-base)]] |
||||
} else { |
||||
set relpath "" |
||||
} |
||||
set base $opts(-base) |
||||
|
||||
set matches [glob -nocomplain -type f -- {*}[dict get $argd values globs]] |
||||
foreach m $matches { |
||||
if {$m eq $filename} { |
||||
#puts stderr "--> excluding $filename" |
||||
continue |
||||
} |
||||
set isok 1 |
||||
foreach e [concat $opts(-exclude) $filename] { |
||||
if {[string match $e $m]} { |
||||
set isok 0 |
||||
break |
||||
} |
||||
} |
||||
if {$isok} { |
||||
lappend paths [file join $relpath $m] |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {![llength $paths]} { |
||||
return "" |
||||
} |
||||
|
||||
set zf [open $filename wb] |
||||
if {$opts(-runtime) ne ""} { |
||||
set rt [open $opts(-runtime) rb] |
||||
fcopy $rt $zf |
||||
close $rt |
||||
} elseif {$opts(-zipkit)} { |
||||
#TODO - update to zipfs ? |
||||
#see modpod |
||||
set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n" |
||||
append zkd "package require vfs::zip\n" |
||||
append zkd "vfs::zip::Mount \[info script\] \[info script\]\n" |
||||
append zkd "if {\[file exists \[file join \[info script\] main.tcl\]\]} {\n" |
||||
append zkd " source \[file join \[info script\] main.tcl\]\n" |
||||
append zkd "}\n" |
||||
append zkd \x1A |
||||
puts -nonewline $zf $zkd |
||||
} |
||||
|
||||
#todo - subtract this from the endrec offset.. and any ... ? |
||||
set dataStartOffset [tell $zf] ;#the overall file offset of the start of data section //JMN 2024 |
||||
|
||||
set count 0 |
||||
set cd "" |
||||
|
||||
set members [list] |
||||
foreach path $paths { |
||||
#puts $path |
||||
lappend members $path |
||||
append cd [Mkzipfile $zf $base $path] ;#path already includes relpath |
||||
incr count |
||||
} |
||||
set cdoffset [tell $zf] |
||||
set endrec [binary format a4ssssiis PK\05\06 0 0 \ |
||||
$count $count [string length $cd] $cdoffset\ |
||||
[string length $opts(-comment)]] |
||||
append endrec $opts(-comment) |
||||
puts -nonewline $zf $cd |
||||
puts -nonewline $zf $endrec |
||||
close $zf |
||||
|
||||
set result "" |
||||
switch -exact -- $opts(-return) { |
||||
list { |
||||
set result $members |
||||
} |
||||
pretty { |
||||
if {[info commands showlist] ne ""} { |
||||
set result [plist -channel none members] |
||||
} else { |
||||
set result $members |
||||
} |
||||
} |
||||
none { |
||||
set result "" |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::zip ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::zip::lib { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::zip::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::zip::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
#tcl::namespace::eval punk::zip::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::zip::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
|
||||
|
||||
#} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::zip [tcl::namespace::eval punk::zip { |
||||
variable pkg punk::zip |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
@ -1,239 +0,0 @@
|
||||
#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" |
||||
} |
||||
} |
||||
|
||||
} |
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in new issue