You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
399 lines
17 KiB
399 lines
17 KiB
# -*- 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 999999.0a1.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 |
|
} |
|
|
|
#Pluggable size-query provider: a command prefix invoked as {*}$size_query_provider <consoleobj> |
|
#returning a dict {columns <int> rows <int>} - or an empty dict/error when size cannot be |
|
#determined. The base ::opunk::Console::size method consults it (after the fast -winsize path and |
|
#capability gating) so channel-based consoles gain ANSI query mechanisms when an integrating layer |
|
#registers one (punk::console registers console_size_provider) - while this class carries no |
|
#dependency on that machinery, and non-channel subclasses simply override size and never touch it. |
|
variable size_query_provider |
|
if {![info exists size_query_provider]} { |
|
set size_query_provider "" |
|
} |
|
} |
|
|
|
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. Resolution order for the base (channel-pair) class: |
|
# 1. chan -winsize on the output channel (fast, no query) |
|
# 2. capability gate: if the console cannot respond to queries (settled, or heuristically for |
|
# an unsettled console) -> the configured default size, with no query emission |
|
# 3. the pluggable ::opunk::console::size_query_provider when registered (e.g punk::console's |
|
# ANSI cursor-report mechanisms) |
|
# 4. the configured default size |
|
#Non-channel subclasses (e.g a tk text widget acting as a terminal) override this method |
|
#entirely - none of the channel/provider logic is imposed on them. |
|
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] |
|
} |
|
} |
|
} |
|
if {![can_respond $this]} { |
|
return [my.get.o_default_size $this] |
|
} |
|
if {$::opunk::console::size_query_provider ne ""} { |
|
if {![catch {{*}$::opunk::console::size_query_provider $this} sized]} { |
|
if {[dict size $sized] && [string is integer -strict [dict get $sized columns]] && [string is integer -strict [dict get $sized rows]]} { |
|
return $sized |
|
} |
|
} |
|
} |
|
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 999999.0a1.0 |
|
}] |
|
return
|
|
|