jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

punk::ansi fixes and improvements, bootsupport modules

master
Julian Noble 11 months ago
parent
e994ec51b6
commit
604d363d92
12 changed files with 7200 additions and 87 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 12
      src/bootsupport/include_modules.config
  2. 1028
      src/bootsupport/modules/punk/ansi-0.1.0.tm
  3. 625
      src/bootsupport/modules/punk/args-0.1.0.tm
  4. 1921
      src/bootsupport/modules/punk/char-0.1.0.tm
  5. 916
      src/bootsupport/modules/punk/console-0.1.0.tm
  6. 1710
      src/bootsupport/modules/punk/fileline-0.1.0.tm
  7. 619
      src/bootsupport/modules/punk/lib-0.1.0.tm
  8. 36
      src/embedded/man/files/punk/_module_ansi-0.1.0.tm.n
  9. 57
      src/embedded/md/doc/files/punk/_module_ansi-0.1.0.tm.md
  10. 18
      src/embedded/www/doc/files/punk/_module_ansi-0.1.0.tm.html
  11. 280
      src/modules/punk/ansi-999999.0a1.0.tm
  12. 65
      src/modules/shellfilter-0.1.8.tm

12
src/bootsupport/include_modules.config
Unescape View File

@ -7,14 +7,19 @@ set bootsupport_modules [list\
src/vendormodules oolib\
src/vendormodules http\
modules punkcheck\
modules punk::ns\
modules punk::path\
modules punk::ansi\
modules punk::args\
modules punk::cap\
modules punk::cap::handlers::caphandler\
modules punk::cap::handlers::scriptlibs\
modules punk::cap::handlers::templates\
modules punk::char\
modules punk::console\
modules punk::du\
modules punk::encmime\
modules punk::fileline\
modules punk::docgen\
modules punk::lib\
modules punk::mix\
modules punk::mix::base\
modules punk::mix::cli\
@ -29,9 +34,10 @@ set bootsupport_modules [list\
modules punk::mix::commandset::project\
modules punk::mix::commandset::repo\
modules punk::mix::commandset::scriptwrap\
modules punk::ns\
modules punk::overlay\
modules punk::path\
modules punk::repo\
modules punk::encmime\
modules punk::tdl\
modules punk::winpath\
]

1028
src/bootsupport/modules/punk/ansi-0.1.0.tm
View File

File diff suppressed because it is too large Load Diff

625
src/bootsupport/modules/punk/args-0.1.0.tm
Unescape View File

@ -0,0 +1,625 @@
# -*- 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::args 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_punk::args 0 0.1.0]
#[copyright "2024"]
#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}]
#[moddesc {args to option-value dict and values dict}] [comment {-- Description at end of page heading --}]
#[require punk::args]
#[keywords module proc args arguments parse]
#[description]
#[para]Utilities for parsing proc args
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of punk::args
#[subsection Concepts]
#[para]There are 2 main conventions for parsing a proc args list
#[list_begin enumerated]
#[enum]
#[para]leading option-value pairs followed by a list of values (Tk style)
#[enum]
#[para]leading list of values followed by option-value pairs (Tcl style)
#[list_end]
#[para]punk::args is focused on the 1st convention (Tk style): parsing of args in leading option-value pair style - even for non-Tk usage.
#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"]
#[para]but having the core values elements at the end of args is more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style.
#[para]The basic principle is that a call to punk::args::opts_vals is made near the beginning of the proc e.g
#[example_begin]
# proc dofilestuff {args} {
# lassign [lb]dict values [lb]punk::args {
# -directory -default ""
# -translation -default binary
# } $args[rb][rb] opts values
#
# puts "translation is [lb]dict get $opts -translation[rb]"
# foreach f [lb]dict values $values[rb] {
# puts "doing stuff with file: $f"
# }
# }
#[example_end]
#*** !doctools
#[subsection Notes]
#[para]There are alternative args parsing packages such as:
#[list_begin enumerated]
#[enum]argp
#[enum]The tcllib set of TEPAM modules
#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation.
#[list_end]
#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable.
#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences
#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences.
#[para]TEPAM is a mature solution and is widely available as it is included in tcllib.
#[para]Serious consideration should be given to using TEPAM if suitable for your project.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by punk::args
#[list_begin itemized]
package require Tcl 8.6
#*** !doctools
#[item] [package {Tcl 8.6}]
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::args::class {
#*** !doctools
#[subsection {Namespace punk::args::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 punk::args {
namespace export *
#variable xyz
#*** !doctools
#[subsection {Namespace punk::args}]
#[para] Core API functions for punk::args
#[list_begin definitions]
#generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values
#If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags.
#only supports -flag val pairs, not solo options
#If an option is supplied multiple times - only the last value is used.
proc opts_values {optionspecs rawargs args} {
#*** !doctools
#[call [fun opts_values] [arg optionspecs] [arg rawargs] [opt {option value...}]]
#[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values
#[para]Returns a dict of the form: opts <options_dict> values <values_dict>
#[para]ARGUMENTS:
#[list_begin arguments]
#[arg_def multiline-string optionspecs]
#[para] This a block of text with records delimited by newlines (lf or crlf) - but with multiline values allowed if properly quoted/braced
#[para]'info complete' is used to determine if a record spans multiple lines due to multiline values
#[para]Each optionspec line must be of the form:
#[para]-optionname -key val -key2 val2...
#[para]where the valid keys for each option specification are: -default -type -range -choices -optional
#[arg_def list rawargs]
#[para] This is a list of the arguments to parse. Usually it will be the \$args value from the containing proc
#[list_end]
#[para]
#consider line-processing example below for we need info complete to determine record boundaries
#punk::args::opt_values {
# -opt1 -default {}
# -opt2 -default {
# etc
# } -multiple 1
#} $args
set optionspecs [string map [list \r\n \n] $optionspecs]
set known_argspecs [list -default -type -range -choices -nocase -optional -multiple -validate_without_ansi -allow_ansi -strip_ansi]
set optspec_defaults [dict create\
-optional 1\
-allow_ansi 1\
-validate_without_ansi 0\
-strip_ansi 0\
-nocase 0\
]
set required_opts [list]
set required_vals [list]
set arg_info [dict create]
set defaults_dict_opts [dict create]
set defaults_dict_values [dict create]
#first process dashed and non-dashed argspecs without regard to whether non-dashed are at the beginning or end
set value_names [list]
set records [list]
set linebuild ""
foreach rawline [split $optionspecs \n] {
set recordsofar [string cat $linebuild $rawline]
if {![info complete $recordsofar]} {
append linebuild [string trimleft $rawline] \n
} else {
lappend records [string cat $linebuild $rawline]
set linebuild ""
}
}
foreach ln $records {
set trimln [string trim $ln]
if {$trimln eq ""} {
continue
}
if {[string index $trimln 0] eq "#"} {
continue
}
set argname [lindex $trimln 0]
set argspecs [lrange $trimln 1 end]
if {[string match -* $argname]} {
dict set argspecs -ARGTYPE option
set is_opt 1
} else {
dict set argspecs -ARGTYPE value
lappend value_names $argname
set is_opt 0
}
if {[llength $argspecs] %2 != 0} {
error "punk::args::opts_values - bad optionspecs line for argument '$argname' Remaining items on line must be in paired option-value format - received '$argspecs'"
}
dict for {spec specval} $argspecs {
if {$spec ni [concat $known_argspecs -ARGTYPE]} {
error "punk::args::opts_values - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs"
}
}
set argspecs [dict merge $optspec_defaults $argspecs]
dict set arg_info $argname $argspecs
if {![dict get $argspecs -optional]} {
if {$is_opt} {
lappend required_opts $argname
} else {
lappend required_vals $argname
}
}
if {[dict exists $arg_info $argname -default]} {
if {$is_opt} {
dict set defaults_dict_opts $argname [dict get $arg_info $argname -default]
} else {
dict set defaults_dict_values $argname [dict get $arg_info $argname -default]
}
}
}
#puts "--> [info frame -2] <--"
set cmdinfo [dict get [info frame -2] cmd]
#we can't treat cmdinfo as a list - it may be something like {command {*}$args} in which case lindex $cmdinfo 0 won't work
#hopefully first word is a plain proc name if this function was called in the normal manner - directly from a proc
#we will break at first space and assume the lhs of that will give enough info to be reasonable - (alternatively we could use entire cmdinfo - but it might be big and ugly)
set caller [regexp -inline {\S+} $cmdinfo]
#if called from commandline or some other contexts such as outside of a proc in a namespace - caller may just be "namespace"
if {$caller eq "namespace"} {
set caller "punk::args::opts_values called from namespace"
}
# ------------------------------
if {$caller ne "punk::args::opts_values"} {
#check our own args
lassign [punk::args::opts_values "-anyopts -default 0\n -minvalues -default 0\n -maxvalues -default -1" $args] _o ownopts _v ownvalues
if {[llength $ownvalues] > 0} {
error "punk::args::opts_values expected: a multiline text block of option-specifications, a list of args and at most three option pairs -minvalues <int>, -maxvalues <int>, -anyopts true|false - got extra arguments: '$ownvalues'"
}
set opt_minvalues [dict get $ownopts -minvalues]
set opt_maxvalues [dict get $ownopts -maxvalues]
set opt_anyopts [dict get $ownopts -anyopts]
} else {
#don't check our own args if we called ourself
set opt_minvalues 0
set opt_maxvalues 0
set opt_anyopts 0
}
# ------------------------------
if {[set eopts [lsearch $rawargs "--"]] >= 0} {
set values [lrange $rawargs $eopts+1 end]
set arglist [lrange $rawargs 0 $eopts-1]
} else {
if {[lsearch $rawargs -*] >= 0} {
#to support option values with leading dash e.g -offset -1 , we can't just take the last flagindex
set i 0
foreach {k v} $rawargs {
if {![string match -* $k]} {
break
}
if {$i+1 >= [llength $rawargs]} {
#no value for last flag
error "bad options for $caller. No value supplied for last option $k"
}
incr i 2
}
set arglist [lrange $rawargs 0 $i-1]
set values [lrange $rawargs $i end]
} else {
set values $rawargs ;#no -flags detected
set arglist [list]
}
}
#confirm any valnames before last don't have -multiple key
foreach valname [lrange $value_names 0 end-1] {
if {[dict exists $arg_info $valname -multiple ]} {
error "bad key -multiple on argument spec for '$valname'. Only the last value argument specification can be marked -multiple"
}
}
set values_dict [dict create]
set validx 0
set in_multiple ""
foreach valname $value_names val $values {
if {$validx+1 > [llength $values]} {
break
}
if {$valname ne ""} {
if {[dict exists $arg_info $valname -multiple] && [dict get $arg_info $valname -multiple]} {
dict lappend values_dict $valname $val
set in_multiple $valname
} else {
dict set values_dict $valname $val
}
} else {
if {$in_multiple ne ""} {
dict lappend values_dict $in_multiple $val
} else {
dict set values_dict $validx $val
}
}
incr validx
}
if {$opt_maxvalues == -1} {
#only check min
if {[llength $values] < $opt_minvalues} {
error "bad number of trailing values for $caller. Got [llength $values] values. Expected at least $opt_minvalues"
}
} else {
if {[llength $values] < $opt_minvalues || [llength $values] > $opt_maxvalues} {
if {$opt_minvalues == $opt_maxvalues} {
error "bad number of trailing values for $caller. Got [llength $values] values. Expected exactly $opt_minvalues"
} else {
error "bad number of trailing values for $caller. Got [llength $values] values. Expected between $opt_minvalues and $opt_maxvalues inclusive"
}
}
}
#opts explicitly marked as -optional 0 must be present - regardless of -anyopts (which allows us to ignore additional opts to pass on to next call)
#however - if -anyopts is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call
#We will always require exact matches for all required opts to avoid this risk, even though an ultimately-called function may not require the full-length option-name REVIEW
#The aim is to allow a wrapper function to specify a default value for an option (and/or other changes/restrictions to a particular option or two) - without having to re-specify all the options for the underlying function.
#without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level
#For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true
foreach r $required_opts {
if {$r ni [dict keys $arglist]} {
error "Required option missing for $caller. '$r' is marked with -optional false - so must be present in its full-length form"
}
}
foreach r $required_vals {
if {$r ni [dict keys $values_dict]} {
error "Required value missing for $caller. '$r' is marked with -optional false - so must be present"
}
}
if {!$opt_anyopts} {
set checked_args [dict create]
for {set i 0} {$i < [llength $arglist]} {incr i} {
#allow this to error out with message indicating expected flags
set val [lindex $arglist $i+1]
set fullopt [tcl::prefix match -message "options for $caller. Unexpected option" [dict keys $arg_info] [lindex $arglist $i]]
if {[dict exists $arg_info $fullopt -multiple] && [dict get $arg_info $fullopt -multiple]} {
dict lappend checked_args $fullopt $val
} else {
dict set checked_args $fullopt $val
}
incr i ;#skip val
}
} else {
#still need to use tcl::prefix match to normalize - but don't raise an error
set checked_args [dict create]
dict for {k v} $arglist {
if {![catch {tcl::prefix::match [dict keys $arg_info] $k} fullopt]} {
if {[dict exists $arg_info $fullopt -multiple] && [dict get $arg_info $fullopt -multiple]} {
dict lappend checked_args $fullopt $v
} else {
dict set checked_args $fullopt $v
}
} else {
#opt was unspecified
dict set checked_args $k $v
}
}
}
set opts [dict merge $defaults_dict_opts $checked_args]
#assert - checked_args keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options
set values [dict merge $defaults_dict_values $values_dict]
#todo - allow defaults outside of choices/ranges
#check types,ranges,choices
set opts_and_values [concat $opts $values]
set combined_defaults [concat $defaults_dict_values $defaults_dict_opts] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash
dict for {o v} $opts_and_values {
if {[dict exists $arg_info $o -multiple] && [dict get $arg_info $o -multiple]} {
set vlist $v
} else {
set vlist [list $v]
}
if {[dict exists $arg_info $o -validate_without_ansi] && [dict get $arg_info $o -validate_without_ansi]} {
set validate_without_ansi 1
package require punk::ansi
} else {
set validate_without_ansi 0
}
if {[dict exists $arg_info $o -allow_ansi] && [dict get $arg_info $o -allow_ansi]} {
set allow_ansi 1
} else {
package require punk::ansi
set allow_ansi 0
}
foreach e $vlist {
if {!$allow_ansi} {
if {[punk::ansi::ta::detect $e]} {
error "Option $o for $caller contains ansi - but -allow_ansi is false. Received: '$e'"
}
}
}
set vlist_check [list]
foreach e $vlist {
if {$validate_without_ansi} {
lappend vlist_check [punk::ansi::stripansi $e]
} else {
lappend vlist_check $e
}
}
set is_default 0
foreach e $vlist e_check $vlist_check {
if {[dict exists $combined_defaults $o] && ($e_check eq [dict get $combined_defaults $o])} {
incr is_default
}
}
if {$is_default eq [llength $vlist]} {
set is_default true
}
#we want defaults to pass through - even if they don't pass the checks that would be required for a specified value
#If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review.
if {!$is_default} {
if {[dict exists $arg_info $o -type]} {
set type [dict get $arg_info $o -type]
if {[string tolower $type] in {int integer double}} {
if {[string tolower $type] in {int integer}} {
foreach e $vlist e_check $vlist_check {
if {![string is integer -strict $e_check]} {
error "Option $o for $caller requires type 'integer'. Received: '$e'"
}
}
} elseif {[string tolower $type] in {double}} {
foreach e $vlist e_check $vlist_check {
if {![string is double -strict $e_check]} {
error "Option $o for $caller requires type 'double'. Received: '$e'"
}
}
}
#todo - small-value double comparisons with error-margin? review
if {[dict exists $arg_info $o -range]} {
lassign [dict get $arg_info $o -range] low high
foreach e $vlist e_check $vlist_check {
if {$e_check < $low || $e_check > $high} {
error "Option $o for $caller must be between $low and $high. Received: '$e'"
}
}
}
} elseif {[string tolower $type] in {bool boolean}} {
foreach e $vlist e_check $vlist_check {
if {![string is boolean -strict $e_check]} {
error "Option $o for $caller requires type 'boolean'. Received: '$e'"
}
}
} elseif {[string tolower $type] in {alnum alpha ascii control digit graph lower print punct space upper wordchar xdigit}} {
foreach e $vlist e_check $vlist_check {
if {![string is [string tolower $type] $e_check]} {
error "Option $o for $caller requires type '[string tolower $type]'. Received: '$e'"
}
}
} elseif {[string tolower $type] in {file directory existingfile existingdirectory}} {
foreach e $vlist e_check $vlist_check {
if {!([string length $e_check]>0 && ![regexp {[\"*?<>\;]} $e_check])} {
error "Option $o for $caller requires type '[string tolower $type]'. Received: '$e' which doesn't look like it could be a file or directory"
}
}
if {[string tolower $type] in {existingfile}} {
foreach e $vlist e_check $vlist_check {
if {![file exists $e_check]} {
error "Option $o for $caller requires type '[string tolower $type]'. Received: '$e' which is not an existing file"
}
}
} elseif {[string tolower $type] in {existingdirectory}} {
foreach e $vlist e_check $vlist_check {
if {![file isdirectory $e_check]} {
error "Option $o for $caller requires type '[string tolower $type]'. Received: '$e' which is not an existing directory"
}
}
}
} elseif {[string tolower $type] in {char character}} {
foreach e $vlist e_check $vlist_check {
if {[string length != 1]} {
error "Option $o for $caller requires type '[string tolower $type]'. Received: '$e' which is not a single character"
}
}
}
}
if {[dict exists $arg_info $o -choices]} {
set choices [dict get $arg_info $o -choices]
set nocase [dict get $arg_info $o -nocase]
foreach e $vlist e_check $vlist_check {
if {$nocase} {
set casemsg "(case insensitive)"
set choices_test [string tolower $choices]
set v_test [string tolower $e_check]
} else {
set casemsg "(case sensitive)"
set v_test $e_check
set choices_test $choices
}
if {$v_test ni $choices_test} {
error "Option $o for $caller must be one of the listed values $choices $casemsg. Received: '$e'"
}
}
}
}
if {[dict exists $arg_info $o -strip_ansi] && [dict get $arg_info $o -strip_ansi]} {
set stripped_list [list]
foreach e $vlist {
lappend stripped_list [punk::ansi::stripansi $e]
}
if {[dict exists $arg_info $o -multiple] && [dict get $arg_info $o -multiple]} {
if {[dict get $arg_info $o -ARGTYPE] eq "option"} {
dict set opts $o $stripped_list
} else {
dict set values $o $stripped_list
}
} else {
if {[dict get $arg_info $o -ARGTYPE] eq "option"} {
dict set opts $o [lindex $stripped_list 0]
} else {
dict set values [lindex $stripped_list 0]
}
}
}
}
#maintain order of opts $opts values $values as caller may use lassign.
return [dict create opts $opts values $values]
}
#proc sample1 {p1 args} {
# #*** !doctools
# #[call [fun sample1] [arg p1] [opt {?option value...?}]]
# #[para]Description of sample1
# return "ok"
#}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::args ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::args::lib {
namespace export *
namespace path [namespace parent]
#*** !doctools
#[subsection {Namespace punk::args::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::args::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
namespace eval punk::args::system {
#*** !doctools
#[subsection {Namespace punk::args::system}]
#[para] Internal functions that are not part of the API
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::args [namespace eval punk::args {
variable pkg punk::args
variable version
set version 0.1.0
}]
return
#*** !doctools
#[manpage_end]

1921
src/bootsupport/modules/punk/char-0.1.0.tm
View File

File diff suppressed because it is too large Load Diff

916
src/bootsupport/modules/punk/console-0.1.0.tm
Unescape View File

@ -0,0 +1,916 @@
# -*- 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::console 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
##e.g package require frobz
package require punk::ansi
if {"windows" eq $::tcl_platform(platform)} {
#package require zzzload
#zzzload::pkg_require twapi
}
#see https://learn.microsoft.com/en-us/windows/console/classic-vs-vt
#https://learn.microsoft.com/en-us/windows/console/creating-a-pseudoconsole-session
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::console {
variable has_twapi 0
#punk::console namespace - contains *directly* acting functions - some based on ansi escapes from the 'ansi' sub namespace, some on local system calls or executable calls wrapped in the 'local' sub namespace
#directly acting means they write to stdout to cause the console to peform the action, or they perform the action immediately via other means.
#punk::console::ansi contains a subset of punk::ansi, but with emission to stdout as opposed to simply returning the ansi sequence.
#punk::console::local functions are used by punk::console commands when there is no ansi equivalent
#ansi escape sequences are possibly preferable esp if terminal is remote to process running punk::console
# punk::local commands may be more performant in some circumstances where console is directly attached, but it shouldn't be assumed. e.g ansi::titleset outperforms local::titleset on windows with twapi.
namespace eval ansi {
#ansi escape sequence based terminal/console control functions
namespace export *
}
namespace eval local {
#non-ansi terminal/console control functions
#e.g external utils system API's.
namespace export *
}
if {"windows" eq $::tcl_platform(platform)} {
proc enableAnsi {} {
#loopavoidancetoken (don't remove)
internal::define_windows_procs
internal::abort_if_loop
tailcall enableAnsi
}
proc enableRaw {{channel stdin}} {
#loopavoidancetoken (don't remove)
internal::define_windows_procs
internal::abort_if_loop
tailcall enableRaw $channel
}
proc disableRaw {{channel stdin}} {
#loopavoidancetoken (don't remove)
internal::define_windows_procs
internal::abort_if_loop
tailcall disableRaw $channel
}
} else {
proc enableAnsi {} {
#todo?
}
proc enableRaw {{channel stdin}} {
set sttycmd [auto_execok stty]
exec {*}$sttycmd raw -echo <@$channel
}
proc disableRaw {{channel stdin}} {
set sttycmd [auto_execok stty]
exec {*}$sttycmd raw echo <@$channel
}
}
proc enable_mouse {} {
puts -nonewline stdout \x1b\[?1000h
puts -nonewline stdout \x1b\[?1003h
puts -nonewline stdout \x1b\[?1015h
puts -nonewline stdout \x1b\[?1006h
flush stdout
}
proc disable_mouse {} {
puts -nonewline stdout \x1b\[?1000l
puts -nonewline stdout \x1b\[?1003l
puts -nonewline stdout \x1b\[?1015l
puts -nonewline stdout \x1b\[?1006l
flush stdout
}
proc enable_bracketed_paste {} {
puts -nonewline stdout \x1b\[?2004h
}
proc disable_bracketed_paste {} {
puts -nonewline stdout \x1b\[?2004l
}
proc start_application_mode {} {
#need loop to read events?
puts -nonewline stdout \x1b\[?1049h ;#alt screen
enable_mouse
#puts -nonewline stdout \x1b\[?25l ;#hide cursor
puts -nonewline stdout \x1b\[?1003h\n
enable_bracketed_paste
}
namespace eval internal {
proc abort_if_loop {{failmsg ""}} {
#puts "il1 [info level 1]"
#puts "thisproc: [lindex [info level 0] 0]"
set would_loop [uplevel 1 {expr {[string match *loopavoidancetoken* [info body [namespace tail [lindex [info level 0] 0]]]]}}]
#puts "would_loop: $would_loop"
if {$would_loop} {
set procname [uplevel 1 {namespace tail [lindex [info level 0] 0]}]
if {$failmsg eq ""} {
set errmsg "[namespace current] Failed to redefine procedure $procname"
} else {
set errmsg $failmsg
}
error $errmsg
}
}
proc define_windows_procs {} {
package require zzzload
set loadstate [zzzload::pkg_require twapi]
if {$loadstate ni [list failed]} {
#review zzzload usage
#puts stdout "=========== console loading twapi ============="
zzzload::pkg_wait twapi
package require twapi ;#should be fast once twapi dll loaded in zzzload thread
set ::punk::console::has_twapi 1
#todo - move some of these to the punk::console::local sub-namespace - as they use APIs rather than in-band ANSI to do their work.
#enableAnsi seems like it should be directly under punk::console .. but then it seems inconsistent if other local console-mode setting functions aren't.
#Find a compromise to organise things somewhat sensibly..
proc [namespace parent]::enableAnsi {} {
#output handle modes
#Enable virtual terminal processing (sometimes off in older windows terminals)
#ENABLE_PROCESSED_OUTPUT = 0x0001
#ENABLE_WRAP_AT_EOL_OUTPUT = 0x0002
#ENABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004
#DISABLE_NEWLINE_AUTO_RETURN = 0x0008
set h_out [twapi::get_console_handle stdout]
set oldmode_out [twapi::GetConsoleMode $h_out]
set newmode_out [expr {$oldmode_out | 5}] ;#5?
twapi::SetConsoleMode $h_out $newmode_out
#input handle modes
#ENABLE_PROCESSED_INPUT 0x0001
#ENABLE_LINE_INPUT 0x0002
#ENABLE_ECHO_INPUT 0x0004
#ENABLE_WINDOW_INPUT 0x0008 (default off when a terminal created)
#ENABLE_MOUSE_INPUT 0x0010
#ENABLE_INSERT_MODE 0X0020
#ENABLE_QUICK_EDIT_MODE 0x0040
#ENABLE_VIRTUAL_TERMINAL_INPUT 0x0200 (default off when a terminal created) (512)
set h_in [twapi::get_console_handle stdin]
set oldmode_in [twapi::GetConsoleMode $h_in]
set newmode_in [expr {$oldmode_in | 8}]
twapi::SetConsoleMode $h_in $newmode_in
return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]]
}
proc [namespace parent]::disableAnsi {} {
set h_out [twapi::get_console_handle stdout]
set oldmode_out [twapi::GetConsoleMode $h_out]
set newmode_out [expr {$oldmode_out & ~5}]
twapi::SetConsoleMode $h_out $newmode_out
set h_in [twapi::get_console_handle stdin]
set oldmode_in [twapi::GetConsoleMode $h_in]
set newmode_in [expr {$oldmode_in & ~8}]
twapi::SetConsoleMode $h_in $newmode_in
return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]]
}
proc [namespace parent]::enableProcessedInput {} {
set h_in [twapi::get_console_handle stdin]
set oldmode_in [twapi::GetConsoleMode $h_in]
set newmode_in [expr {$oldmode_in | 1}]
twapi::SetConsoleMode $h_in $newmode_in
return [list stdin [list from $oldmode_in to $newmode_in]]
}
proc [namespace parent]::disableProcessedInput {} {
set h_in [twapi::get_console_handle stdin]
set oldmode_in [twapi::GetConsoleMode $h_in]
set newmode_in [expr {$oldmode_in & ~1}]
twapi::SetConsoleMode $h_in $newmode_in
return [list stdin [list from $oldmode_in to $newmode_in]]
}
proc [namespace parent]::enableRaw {{channel stdin}} {
#review - change to modify_console_input_mode
set console_handle [twapi::GetStdHandle -10]
set oldmode [twapi::GetConsoleMode $console_handle]
set newmode [expr {$oldmode & ~6}] ;# Turn off the echo and line-editing bits
twapi::SetConsoleMode $console_handle $newmode
return [list stdin [list from $oldmode to $newmode]]
}
proc [namespace parent]::disableRaw {{channel stdin}} {
set console_handle [twapi::GetStdHandle -10]
set oldmode [twapi::GetConsoleMode $console_handle]
set newmode [expr {$oldmode | 6}] ;# Turn on the echo and line-editing bits
twapi::SetConsoleMode $console_handle $newmode
return [list stdin [list from $oldmode to $newmode]]
}
} else {
if {$loadstate eq "failed"} {
puts stderr "punk::console falling back to stty because twapi load failed"
proc [namespace parent]::enableAnsi {} {
puts stderr "punk::console::enableAnsi todo"
}
proc [namespace parent]::enableRaw {{channel stdin}} {
set sttycmd [auto_execok stty]
exec {*}$sttycmd raw -echo <@$channel
}
proc [namespace parent]::disableRaw {{channel stdin}} {
set sttycmd [auto_execok stty]
exec {*}$sttycmd raw echo <@$channel
}
}
}
}
proc ansi_response_handler {chan accumulatorvar waitvar} {
set status [catch {read $chan 1} bytes]
if { $status != 0 } {
# Error on the channel
fileevent stdin readable {}
puts "error reading $chan: $bytes"
set $waitvar [list error_read status $status bytes $bytes]
} elseif {$bytes ne ""} {
# Successfully read the channel
#puts "got: [string length $bytes]"
upvar $accumulatorvar chunk
append chunk $bytes
if {$bytes eq "R"} {
fileevent stdin readable {}
set $waitvar ok
}
} elseif { [eof $chan] } {
fileevent stdin readable {}
# End of file on the channel
#review
puts "ansi_response_handler end of file"
set $waitvar eof
} elseif { [fblocked $chan] } {
# Read blocked. Just return
} else {
fileevent stdin readable {}
# Something else
puts "ansi_response_handler can't happen"
set $waitvar error_unknown
}
}
} ;#end namespace eval internal
variable colour_disabled 0
# https://no-color.org
if {[info exists ::env(NO_COLOR)]} {
if {$::env(NO_COLOR) ne ""} {
set colour_disabled 1
}
}
namespace eval ansi {
proc a+ {args} {
puts -nonewline [::punk::ansi::a+ {*}$args]
}
}
proc ansi+ {args} {
variable colour_disabled
if {$colour_disabled == 1} {
return
}
#stdout
tailcall ansi::a+ {*}$args
}
proc get_ansi+ {args} {
variable colour_disabled
if {$colour_disabled == 1} {
return
}
tailcall punk::ansi::a+ {*}$args
}
namespace eval ansi {
proc a {args} {
puts -nonewline [::punk::ansi::a {*}$args]
}
}
proc ansi {args} {
variable colour_disabled
if {$colour_disabled == 1} {
return
}
#stdout
tailcall ansi::a {*}$args
}
proc get_ansi {args} {
variable colour_disabled
if {$colour_disabled == 1} {
return
}
tailcall punk::ansi::a {*}$args
}
namespace eval ansi {
proc a? {args} {
puts -nonewline stdout [::punk::ansi::a? {*}$args]
}
}
proc ansi? {args} {
#stdout
tailcall ansi::a? {*}$args
}
proc get_ansi? {args} {
tailcall ::punk::ansi::a? {*}$args
}
proc colour {{onoff {}}} {
variable colour_disabled
if {[string length $onoff]} {
set onoff [string tolower $onoff]
if {$onoff in [list 1 on true yes]} {
interp alias "" a+ "" punk::console::ansi+
set colour_disabled 0
} elseif {$onoff in [list 0 off false no]} {
interp alias "" a+ "" control::no-op
set colour_disabled 1
} else {
error "punk::console::colour expected 0|1|on|off|true|false|yes|no"
}
}
catch {repl::reset_prompt}
return [expr {!$colour_disabled}]
}
namespace eval ansi {
proc reset {} {
puts -nonewline stdout [punk::ansi::reset]
}
}
namespace import ansi::reset
namespace eval ansi {
proc clear {} {
puts -nonewline stdout [punk::ansi::clear]
}
proc clear_above {} {
puts -nonewline stdout [punk::ansi::clear_above]
}
proc clear_below {} {
puts -nonewline stdout [punk::ansi::clear_below]
}
proc clear_all {} {
puts -nonewline stdout [punk::ansi::clear_all]
}
}
namespace import ansi::clear
namespace import ansi::clear_above
namespace import ansi::clear_below
namespace import ansi::clear_all
namespace eval local {
proc set_codepage_output {cpname} {
#todo
if {"windows" eq $::tcl_platform(platform)} {
twapi::set_console_output_codepage $cpname
} else {
error "set_codepage_output unimplemented on $::tcl_platform(platform)"
}
}
proc set_codepage_input {cpname} {
#todo
if {"windows" eq $::tcl_platform(platform)} {
twapi::set_console_input_codepage $cpname
} else {
error "set_codepage_input unimplemented on $::tcl_platform(platform)"
}
}
}
namespace import local::set_codepage_output
namespace import local::set_codepage_input
proc get_cursor_pos {} {
set ::punk::console::chunk ""
set accumulator ::punk::console::chunk
set waitvar ::punk::console::chunkdone
set existing_handler [fileevent stdin readable]
set $waitvar ""
#todo - test and save rawstate so we don't disableRaw if terminal was already raw
enableRaw
fconfigure stdin -blocking 0
fileevent stdin readable [list ::punk::console::internal::ansi_response_handler stdin $accumulator $waitvar]
puts -nonewline stdout \033\[6n ;flush stdout
after 0 {update idletasks}
#e.g \033\[46;1R
#todo - reset
set info ""
if {[set $waitvar] eq ""} {
vwait $waitvar
}
disableRaw
if {[string length $existing_handler]} {
fileevent stdin readable $existing_handler
}
set info [set $accumulator]
#set punk::console::chunk ""
set data [string range $info 2 end-1]
return $data
}
proc get_cursor_pos_list {} {
return [split [get_cursor_pos] ";"]
}
#terminals lie. This should be a reasonable (albeit relatively slow) test of actual width - but some terminals seem to miscalculate.
#todo - a visual interactive test/questionnaire to ask user if things are lining up or if the terminal is telling fibs about cursor position.
#todo - determine if these anomalies are independent of font
#punk::ansi should be able to glean widths from unicode data files - but this may be incomplete - todo - compare with what terminal actually does.
proc test_char_width {char_or_string {emit 0}} {
if {!$emit} {
puts -nonewline stdout \033\[2K\033\[1G ;#2K erase line 1G cursor at col1
}
lassign [split [punk::console::get_cursor_pos] ";"] _row1 col1
puts -nonewline stdout $char_or_string
lassign [split [punk::console::get_cursor_pos] ";"] _row2 col2
if {!$emit} {
puts -nonewline stdout \033\[2K\033\[1G
}
flush stdout;#if we don't flush - a subsequent stderr write could move the cursor to a newline and interfere with our 2K1G erasure and cursor repositioning.
return [expr {$col2 - $col1}]
}
namespace eval ansi {
proc cursor_on {} {
puts -nonewline stdout [punk::ansi::cursor_on]
}
proc cursor_off {} {
puts -nonewline stdout [punk::ansi::cursor_off]
}
}
namespace import ansi::cursor_on
namespace import ansi::cursor_off
namespace eval local {
proc titleset {windowtitle} {
if {"windows" eq $::tcl_platform(platform)} {
if {![catch {twapi::set_console_title $windowtitle} result]} {
return $windowtitle
} else {
error "punk::console::titleset failed to set title - try punk::console::ansi::titleset"
}
} else {
error "punk::console::titleset has no local mechanism to set the window title on this platform. try punk::console::ansi::titleset"
}
}
proc titleget {} {
if {"windows" eq $::tcl_platform(platform)} {
if {![catch {twapi::get_console_title} result]} {
return $result
} else {
error "punk::console::titleset failed to set title - ensure twapi is available"
}
} else {
#titleget - https://invisible-island.net/xterm/xterm.faq.html#how2_title
# won't work on all platforms/terminals - but may be worth implementing
error "punk::console::titleget has no local mechanism to get the window title on this platform."
}
}
}
namespace eval ansi {
proc titleset {windowtitle} {
puts -nonewline stdout [punk::ansi::titleset $windowtitle]
}
}
namespace import ansi::titleset
#no known pure-ansi solution
proc titleget {} {
return [local::titleget]
}
proc infocmp_test {} {
set cmd1 [auto_execok infocmp]
if {[string length $cmd1]} {
puts stderr "infocmp seems to be available"
return [exec {*}$cmd1]
} else {
puts stderr "infcmp doesn't seem to be present"
set tcmd [auto_execok tput]
if {[string length $tcmd]} {
puts stderr "tput seems to be available. Try something like: tput -S - (freebsd)"
}
}
}
proc test_cursor_pos {} {
enableRaw
puts -nonewline stdout \033\[6n ;flush stdout
fconfigure stdin -blocking 0
set info [read stdin 20] ;#
after 1
if {[string first "R" $info] <=0} {
append info [read stdin 20]
}
disableRaw
set data [string range [string trim $info] 2 end-1]
return [split $data ";"]
}
namespace eval ansi {
proc move {row col} {
puts -nonewline stdout [punk::ansi::move $row $col]
}
proc move_forward {row col} {
puts -nonewline stdout [punk::ansi::move_forward $row $col]
}
proc move_back {row col} {
puts -nonewline stdout [punk::ansi::move_back $row $col]
}
proc move_up {row col} {
puts -nonewline stdout [punk::ansi::move_up $row $col]
}
proc move_down {row col} {
puts -nonewline stdout [punk::ansi::move_down $row $col]
}
proc move_emit {row col data args} {
puts -nonewline stdout [punk::ansi::move_emit $row $col $data {*}$args]
}
proc move_emit_return {row col data args} {
lassign [punk::console::get_cursor_pos_list] orig_row orig_col
set out ""
append out [punk::ansi::move_emit $row $col $data {*}$args]
if {!$is_in_raw} {
incr orig_row -1
}
move $orig_row $orig_col
}
}
namespace import ansi::move
namespace import ansi::move_emit
namespace import ansi::move_forward
namespace import ansi::move_back
namespace import ansi::move_up
namespace import ansi::move_down
proc move_emit_return {row col data args} {
#todo detect if in raw mode or not?
set is_in_raw 0
lassign [punk::console::get_cursor_pos_list] orig_row orig_col
move_emit $row $col $data
foreach {row col data} $args {
move_emit $row $col $data
}
if {!$is_in_raw} {
incr orig_row -1
}
move $orig_row $orig_col
return ""
}
proc move_call_return {row col script} {
lassign [punk::console::get_cursor_pos_list] orig_row orig_col
move $row $col
uplevel 1 $script
move $orig_row $orig_col
}
#this doesn't work - we would need an internal virtual screen structure to pick up cursor attributes from arbitrary locations
# ncurses and its ilk may have something like that - but we specifically want to avoid curses libraries
proc pick {row col} {
lassign [punk::console::get_cursor_pos_list] orig_row orig_col
set test ""
#set test [a green Yellow]
move_emit $row $col $test\0337
puts -nonewline \0338\033\[${orig_row}\;${orig_col}H
}
proc pick_emit {row col data} {
set test ""
#set test [a green Purple]
lassign [punk::console::get_cursor_pos_list] orig_row orig_col
move_emit $row $col $test\0337
puts -nonewline \0338\033\[${orig_row}\;${orig_col}H$data
}
# -- --- --- --- --- ---
namespace eval ansi {
proc test_decaln {} {
puts -nonewline stdout [punk::ansi::test_decaln]
}
}
namespace import ansi::test_decaln
namespace eval clock {
#map chars of chars "0" to "?"" ie 0x30 to x3f
variable fontmap1 {
7C CE DE F6 E6 C6 7C 00
30 70 30 30 30 30 FC 00
78 CC 0C 38 60 CC FC 00
78 CC 0C 38 0C CC 78 00
1C 3C 6C CC FE 0C 1E 00
FC C0 F8 0C 0C CC 78 00
38 60 C0 F8 CC CC 78 00
FC CC 0C 18 30 30 30 00
78 CC CC 78 CC CC 78 00
78 CC CC 7C 0C 18 70 00
00 18 18 00 00 18 18 00
00 18 18 00 00 18 18 30
18 30 60 C0 60 30 18 00
00 00 7E 00 7E 00 00 00
60 30 18 0C 18 30 60 00
3C 66 0C 18 18 00 18 00
}
#libungif extras
append fontmap1 {
7c 82 9a aa aa 9e 7c 00
38 6c c6 c6 fe c6 c6 00
fc c6 c6 fc c6 c6 fc 00
}
#https://github.com/Distrotech/libungif/blob/master/lib/gif_font.c
variable fontmap {
}
#ascii row 0x00 to 0x1F control chars
#(cp437 glyphs)
append fontmap {
00 00 00 00 00 00 00 00
3c 42 a5 81 bd 42 3c 00
3c 7e db ff c3 7e 3c 00
00 ee fe fe 7c 38 10 00
10 38 7c fe 7c 38 10 00
00 3c 18 ff ff 08 18 00
10 38 7c fe fe 10 38 00
00 00 18 3c 18 00 00 00
ff ff e7 c3 e7 ff ff ff
00 3c 42 81 81 42 3c 00
ff c3 bd 7e 7e bd c3 ff
1f 07 0d 7c c6 c6 7c 00
00 7e c3 c3 7e 18 7e 18
04 06 07 04 04 fc f8 00
0c 0a 0d 0b f9 f9 1f 1f
00 92 7c 44 c6 7c 92 00
00 00 60 78 7e 78 60 00
00 00 06 1e 7e 1e 06 00
18 7e 18 18 18 18 7e 18
66 66 66 66 66 00 66 00
ff b6 76 36 36 36 36 00
7e c1 dc 22 22 1f 83 7e
00 00 00 7e 7e 00 00 00
18 7e 18 18 7e 18 00 ff
18 7e 18 18 18 18 18 00
18 18 18 18 18 7e 18 00
00 04 06 ff 06 04 00 00
00 20 60 ff 60 20 00 00
00 00 00 c0 c0 c0 ff 00
00 24 66 ff 66 24 00 00
00 00 10 38 7c fe 00 00
00 00 00 fe 7c 38 10 00
}
#chars SP to "/" row 0x20 to 0x2f
append fontmap {
00 00 00 00 00 00 00 00
30 30 30 30 30 00 30 00
66 66 00 00 00 00 00 00
6c 6c fe 6c fe 6c 6c 00
10 7c d2 7c 86 7c 10 00
f0 96 fc 18 3e 72 de 00
30 48 30 78 ce cc 78 00
0c 0c 18 00 00 00 00 00
10 60 c0 c0 c0 60 10 00
10 0c 06 06 06 0c 10 00
00 54 38 fe 38 54 00 00
00 18 18 7e 18 18 00 00
00 00 00 00 00 00 18 70
00 00 00 7e 00 00 00 00
00 00 00 00 00 00 18 00
02 06 0c 18 30 60 c0 00
}
#chars "0" to "?"" row 0x30 to 0x3f
append fontmap {
7c c6 c6 c6 c6 c6 7c 00
18 38 78 18 18 18 3c 00
7c c6 06 0c 30 60 fe 00
7c c6 06 3c 06 c6 7c 00
0e 1e 36 66 fe 06 06 00
fe c0 c0 fc 06 06 fc 00
7c c6 c0 fc c6 c6 7c 00
fe 06 0c 18 30 60 60 00
7c c6 c6 7c c6 c6 7c 00
7c c6 c6 7e 06 c6 7c 00
00 30 00 00 00 30 00 00
00 30 00 00 00 30 20 00
00 1c 30 60 30 1c 00 00
00 00 7e 00 7e 00 00 00
00 70 18 0c 18 70 00 00
7c c6 0c 18 30 00 30 00
}
#chars "@" to "O" row 0x40 to 0x4f
append fontmap {
7c 82 9a aa aa 9e 7c 00
38 6c c6 c6 fe c6 c6 00
fc c6 c6 fc c6 c6 fc 00
7c c6 c6 c0 c0 c6 7c 00
f8 cc c6 c6 c6 cc f8 00
fe c0 c0 fc c0 c0 fe 00
fe c0 c0 fc c0 c0 c0 00
7c c6 c0 ce c6 c6 7e 00
c6 c6 c6 fe c6 c6 c6 00
78 30 30 30 30 30 78 00
1e 06 06 06 c6 c6 7c 00
c6 cc d8 f0 d8 cc c6 00
c0 c0 c0 c0 c0 c0 fe 00
c6 ee fe d6 c6 c6 c6 00
c6 e6 f6 de ce c6 c6 00
7c c6 c6 c6 c6 c6 7c 00
}
#chars "P" to "_" row 0x50 to 0x5f
append fontmap {
fc c6 c6 fc c0 c0 c0 00
7c c6 c6 c6 c6 c6 7c 06
fc c6 c6 fc c6 c6 c6 00
78 cc 60 30 18 cc 78 00
fc 30 30 30 30 30 30 00
c6 c6 c6 c6 c6 c6 7c 00
c6 c6 c6 c6 c6 6c 38 00
c6 c6 c6 d6 fe ee c6 00
c6 c6 6c 38 6c c6 c6 00
c3 c3 66 3c 18 18 18 00
fe 0c 18 30 60 c0 fe 00
3c 30 30 30 30 30 3c 00
c0 60 30 18 0c 06 03 00
3c 0c 0c 0c 0c 0c 3c 00
00 38 6c c6 00 00 00 00
00 00 00 00 00 00 00 ff
}
#chars "`" to "o" row 0x60 to 0x6f
append fontmap {
30 30 18 00 00 00 00 00
00 00 7c 06 7e c6 7e 00
c0 c0 fc c6 c6 e6 dc 00
00 00 7c c6 c0 c0 7e 00
06 06 7e c6 c6 ce 76 00
00 00 7c c6 fe c0 7e 00
1e 30 7c 30 30 30 30 00
00 00 7e c6 ce 76 06 7c
c0 c0 fc c6 c6 c6 c6 00
18 00 38 18 18 18 3c 00
18 00 38 18 18 18 18 f0
c0 c0 cc d8 f0 d8 cc 00
38 18 18 18 18 18 3c 00
00 00 cc fe d6 c6 c6 00
00 00 fc c6 c6 c6 c6 00
00 00 7c c6 c6 c6 7c 00
}
#chars "p" to DEL row 0x70 to 0x7f
append fontmap {
00 00 fc c6 c6 e6 dc c0
00 00 7e c6 c6 ce 76 06
00 00 6e 70 60 60 60 00
00 00 7c c0 7c 06 fc 00
30 30 7c 30 30 30 1c 00
00 00 c6 c6 c6 c6 7e 00
00 00 c6 c6 c6 6c 38 00
00 00 c6 c6 d6 fe 6c 00
00 00 c6 6c 38 6c c6 00
00 00 c6 c6 ce 76 06 7c
00 00 fc 18 30 60 fc 00
0e 18 18 70 18 18 0e 00
18 18 18 00 18 18 18 00
e0 30 30 1c 30 30 e0 00
00 00 70 9a 0e 00 00 00
00 00 18 3c 66 ff 00 00
}
proc bigstr {str row col} {
variable fontmap
#curses attr off reverse
#a noreverse
set reverse 0
set output ""
set charno 0
foreach char [split $str {}] {
binary scan $char c f
set index [expr {$f * 8}]
for {set line 0} {$line < 8} {incr line} {
set bitline 0x[lindex $fontmap [expr {$index + $line}]]
binary scan [binary format c $bitline] B8 charline
set cix 0
foreach c [split $charline {}] {
if {$c} {
append output [punk::ansi::move_emit [expr {$row + $line}] [expr {$col + $charno * 8 + $cix}] "[a reverse] [a noreverse]"]
#curses attr on reverse
#curses move [expr $row + $line] [expr $col + $charno * 8 + $cix]
#curses puts " "
}
incr cix
}
}
incr charno
}
return $output
}
proc display1 {} {
#punk::console::clear
punk::console::move_call_return 20 20 {punk::console::clear_above}
flush stdout
punk::console::move_call_return 0 0 {puts stdout [bigstr [clock format [clock seconds] -format %H:%M:%S] 10 5]}
after 2000 {punk::console::clock::display}
}
proc display {} {
lassign [punk::console::get_cursor_pos_list] orig_row orig_col
punk::console::move 20 20
punk::console::clear_above
punk::console::move 0 0
puts -nonewline [bigstr [clock format [clock seconds] -format %H:%M:%S] 10 5]
punk::console::move $orig_row $orig_col
#after 2000 {punk::console::clock::display}
}
proc displaystr {str} {
lassign [punk::console::get_cursor_pos_list] orig_row orig_col
punk::console::move 20 20
punk::console::clear_above
punk::console::move 0 0
puts -nonewline [bigstr $str 10 5]
punk::console::move $orig_row $orig_col
}
}
proc test {} {
set high_unicode_length [string length \U00010000]
set can_high_unicode 0
set can_regex_high_unicode 0
set can_terminal_report_dingbat_width 0
set can_terminal_report_diacritic_width 0
if {$high_unicode_length != 1} {
puts stderr "punk::console WARNING: no modern unicode support in this Tcl version. High unicode values not properly supported. (string length \\U00010000 : $high_unicode_length should be 1)"
} else {
set can_high_unicode 1
set can_regex_high_unicode [string match [regexp -all -inline {[\U80-\U0010FFFF]} \U0001F525] \U0001F525]
if {!$can_regex_high_unicode} {
puts stderr "punk::console warning: TCL version cannot perform braced regex of high unicode"
}
}
set dingbat_heavy_plus_width [punk::console::test_char_width \U2795] ;#review - may be font dependent. We chose a wide dingbat as a glyph that is hopefully commonly renderable - and should display 2 wide.
#This will give a false report that terminal can't report width if the glyph (or replacement glyph) is actually being rendered 1 wide.
#we can't distinguish without user interaction?
if {$dingbat_heavy_plus_width == 2} {
set can_terminal_report_dingbat_width 1
} else {
puts stderr "punk::console warning: terminal either not displaying wide unicode as wide, or unable to report width properly."
}
set diacritic_width [punk::console::test_char_width a\u0300]
if {$diacritic_width == 1} {
set can_terminal_report_diacritic_width 1
} else {
puts stderr "punk::console warning: terminal unable to report diacritic width properly."
}
if {$can_high_unicode && $can_regex_high_unicode && $can_terminal_report_dingbat_width && $can_terminal_report_diacritic_width} {
set result [list result ok]
} else {
set result [list result error]
}
return $result
}
#run the test and allow warnings to be emitted to stderr on package load. User should know the terminal and/or Tcl version are not optimal for unicode character work
#set testresult [test1]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::console [namespace eval punk::console {
variable version
set version 0.1.0
}]
return

1710
src/bootsupport/modules/punk/fileline-0.1.0.tm
View File

File diff suppressed because it is too large Load Diff

619
src/bootsupport/modules/punk/lib-0.1.0.tm
Unescape View File

@ -0,0 +1,619 @@
# -*- 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: punkshell/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::lib 0.1.0
# Meta platform tcl
# Meta license BSD
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_punk::lib 0 0.1.0]
#[copyright "2024"]
#[titledesc {punk general utility functions}] [comment {-- Name section and table of contents description --}]
#[moddesc {punk library}] [comment {-- Description at end of page heading --}]
#[require punk::lib]
#[keywords module utility lib]
#[description]
#[para]This is a set of utility functions that are commonly used across punk modules or are just considered to be general-purpose functions.
#[para]The base set includes string and math functions but has no specific theme
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of punk::lib
#[subsection Concepts]
#[para]The punk::lib modules should have no strong dependencies other than Tcl
#[para]Dependendencies that only affect display or additional functionality may be included - but should fail gracefully if not present, and only when a function is called that uses one of these soft dependencies.
#[para]This requirement for no strong dependencies, means that many utility functions that might otherwise seem worthy of inclusion here are not present.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by punk::lib
#[list_begin itemized]
package require Tcl 8.6
#*** !doctools
#[item] [package {Tcl 8.6}]
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::lib::class {
#*** !doctools
#[subsection {Namespace punk::lib::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 punk::lib {
namespace export *
#variable xyz
#*** !doctools
#[subsection {Namespace punk::lib}]
#[para] Core API functions for punk::lib
#[list_begin definitions]
#proc sample1 {p1 n args} {
# #*** !doctools
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]]
# #[para]Description of sample1
# #[para] Arguments:
# # [list_begin arguments]
# # [arg_def tring p1] A description of string argument p1.
# # [arg_def integer n] A description of integer argument n.
# # [list_end]
# return "ok"
#}
proc K {x y} {return $x}
#*** !doctools
#[call [fun K] [arg x] [arg y]]
#[para]The K-combinator function - returns the first argument, x and discards y
#[para]see [uri https://wiki.tcl-lang.org/page/K]
#[para]It is used in cases where command-substitution at the calling-point performs some desired effect.
proc hex2dec {args} {
#*** !doctools
#[call [fun hex2dec] [opt {option value...}] [arg list_largeHex]]
#[para]Convert a list of (possibly large) unprefixed hex strings to their decimal values
#[para]hex2dec accepts and ignores internal underscores in the same manner as Tcl 8.7+ numbers e.g hex2dec FF_FF returns 65535
#[para]Leading and trailing underscores are ignored as a matter of implementation convenience - but this shouldn't be relied upon.
#[para]Leading or trailing whitespace in each list member is allowed e.g hex2dec " F" returns 15
#[para]Internal whitespace e.g "F F" is not permitted - but a completely empty element "" is allowed and will return 0
set list_largeHex [lindex $args end]
set argopts [lrange $args 0 end-1]
if {[llength $argopts]%2 !=0} {
error "[namespace current]::hex2dec arguments prior to list_largeHex must be option/value pairs - received '$argopts'"
}
set defaults [dict create\
-validate 1\
-empty_as_hex "INVALID set -empty_as_hex to a hex string e.g FF if empty values should be replaced"\
]
set known_opts [dict keys $defaults]
set fullopts [dict create]
dict for {k v} $argopts {
dict set fullopts [tcl::prefix match -message "options for hex2dec. Unexpected option" $known_opts $k] $v
}
set opts [dict merge $defaults $fullopts]
# -- --- --- ---
set opt_validate [dict get $opts -validate]
set opt_empty [dict get $opts -empty_as_hex]
# -- --- --- ---
set list_largeHex [lmap h $list_largeHex[unset list_largeHex] {string map [list _ ""] [string trim $h]}]
if {$opt_validate} {
#Note appended F so that we accept list of empty strings as per the documentation
if {![string is xdigit -strict [join $list_largeHex ""]F ]} {
error "[namespace current]::hex2dec error: non-hex digits encountered after stripping underscores and leading/trailing whitespace for each element\n $list_largeHex"
}
}
if {![string is xdigit -strict [string map [list _ ""] $opt_empty]]} {
#mapping empty string to a value destroys any advantage of -scanonly
#todo - document that -scanonly has 2 restrictions - each element must be valid hex and less than 7 chars long
#set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {0} : {[set v]}}]
if {[lsearch $list_largeHex ""] >=0} {
error "[namespace current]::hex2dec error: empty values in list cannot be mapped to non-hex $opt_empty"
}
} else {
set opt_empty [string trim [string map [list _ ""] $opt_empty]]
if {[set first_empty [lsearch $list_largeHex ""]] >= 0} {
#set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {$opt_empty} : {$v}}]
set nonempty_head [lrange $list_largeHex 0 $first_empty-1]
set list_largeHex [concat $nonempty_head [lmap v [lrange $list_largeHex $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]]
}
}
return [scan $list_largeHex [string repeat %llx [llength $list_largeHex]]]
}
proc dec2hex {args} {
#*** !doctools
#[call [fun dex2hex] [opt {option value...}] [arg list_decimals]]
#[para]Convert a list of decimal integers to a list of hex values
#[para] -width <int> can be used to make each hex value at least int characters wide, with leading zeroes.
#[para] -case upper|lower determines the case of the hex letters in the output
set list_decimals [lindex $args end]
set argopts [lrange $args 0 end-1]
if {[llength $argopts]%2 !=0} {
error "[namespace current]::dec2hex arguments prior to list_decimals must be option/value pairs - received '$argopts'"
}
set defaults [dict create\
-width 1\
-case upper\
-empty_as_decimal "INVALID set -empty_as_decimal to a number if empty values should be replaced"\
]
set known_opts [dict keys $defaults]
set fullopts [dict create]
dict for {k v} $argopts {
dict set fullopts [tcl::prefix match -message "options for [namespace current]::dec2hex. Unexpected option" $known_opts $k] $v
}
set opts [dict merge $defaults $fullopts]
# -- --- --- ---
set opt_width [dict get $opts -width]
set opt_case [dict get $opts -case]
set opt_empty [dict get $opts -empty_as_decimal]
# -- --- --- ---
set resultlist [list]
if {[string tolower $opt_case] eq "upper"} {
set spec X
} elseif {[string tolower $opt_case] eq "lower"} {
set spec x
} else {
error "[namespace current]::dec2hex unknown value '$opt_case' for -case expected upper|lower"
}
set fmt "%${opt_width}.${opt_width}ll${spec}"
set list_decimals [lmap d $list_decimals[unset list_decimals] {string map [list _ ""] [string trim $d]}]
if {![string is digit -strict [string map [list _ ""] $opt_empty]]} {
if {[lsearch $list_decimals ""] >=0} {
error "[namespace current]::dec2hex error: empty values in list cannot be mapped to non-decimal $opt_empty"
}
} else {
set opt_empty [string map [list _ ""] $opt_empty]
if {[set first_empty [lsearch $list_decimals ""]] >= 0} {
set nonempty_head [lrange $list_decimals 0 $first_empty-1]
set list_decimals [concat $nonempty_head [lmap v [lrange $list_decimals $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]]
}
}
return [format [lrepeat [llength $list_decimals] $fmt] {*}$list_decimals]
}
proc log2 x "expr {log(\$x)/[expr log(2)]}"
#*** !doctools
#[call [fun log2] [arg x]]
#[para]log base2 of x
#[para]This uses a 'live' proc body - the divisor for the change of base is computed once at definition time
#[para](courtesy of RS [uri https://wiki.tcl-lang.org/page/Additional+math+functions])
proc logbase {b x} {
#*** !doctools
#[call [fun logbase] [arg b] [arg x]]
#[para]log base b of x
#[para]This function uses expr's natural log and the change of base division.
#[para]This means for example that we can get results like: logbase 10 1000 = 2.9999999999999996
#[para]Use expr's log10() function or tcl::mathfunc::log10 for base 10
expr {log($x)/log($b)}
}
proc factors {x} {
#*** !doctools
#[call [fun factors] [arg x]]
#[para]Return a sorted list of the positive factors of x where x > 0
#[para]For x = 0 we return only 0 and 1 as technically any number divides zero and there are an infinite number of factors. (including zero itself in this context)*
#[para]This is a simple brute-force implementation that iterates all numbers below the square root of x to check the factors
#[para]Because the implementation is so simple - the performance is very reasonable for numbers below at least a few 10's of millions
#[para]See tcllib math::numtheory::factors for a more complex implementation - which seems to be slower for 'small' numbers
#[para]Comparisons were done with some numbers below 17 digits long
#[para]For seriously big numbers - this simple algorithm would no doubt be outperformed by more complex algorithms.
#[para]The numtheory library stores some data about primes etc with each call - so may become faster when being used on more numbers
#but has the disadvantage of being slower for 'small' numbers and using more memory.
#[para]If the largest factor below x is needed - the greatestOddFactorBelow and GreatestFactorBelow functions are a faster way to get there than computing the whole list, even for small values of x
#[para]* Taking x=0; Notion of x being divisible by integer y being: There exists an integer p such that x = py
#[para] In other mathematical contexts zero may be considered not to divide anything.
set factors [list 1]
set j 2
set max [expr {sqrt($x)}]
while {$j <= $max} {
if {($x % $j) == 0} {
lappend factors $j [expr {$x / $j}]
}
incr j
}
lappend factors $x
return [lsort -unique -integer $factors]
}
proc oddFactors {x} {
#*** !doctools
#[call [fun oddFactors] [arg x]]
#[para]Return a list of odd integer factors of x, sorted in ascending order
set j 2
set max [expr {sqrt($x)}]
set factors [list 1]
while {$j <= $max} {
if {$x % $j == 0} {
set other [expr {$x / $j}]
if {$other % 2 != 0} {
if {$other ni $factors} {
lappend factors $other
}
}
if {$j % 2 != 0} {
if {$j ni $factors} {
lappend factors $j
}
}
}
incr j
}
return [lsort -integer -increasing $factors]
}
proc greatestFactorBelow {x} {
#*** !doctools
#[call [fun greatestFactorBelow] [arg x]]
#[para]Return the largest factor of x excluding itself
#[para]factor functions can be useful for console layout calculations
#[para]See Tcllib math::numtheory for more extensive implementations
if {$x % 2 == 0 || $x == 0} {
return [expr {$x / 2}]
}
set j 3
set max [expr {sqrt($x)}]
while {$j <= $max} {
if {$x % $j == 0} {
return [expr {$x / $j}]
}
incr j 2
}
return 1
}
proc greatestOddFactorBelow {x} {
#*** !doctools
#[call [fun greatestOddFactorBelow] [arg x]]
#[para]Return the largest odd integer factor of x excluding x itself
if {$x %2 == 0} {
return [greatestOddFactor $x]
}
set j 3
#dumb brute force - time taken to compute is wildly variable on big numbers
#todo - use a (memoized?) generator of primes to reduce the search space
#tcllib math::numtheory has suitable functions - but do we want that dependency here? Testing shows brute-force often faster for small numbers.
set god 1
set max [expr {sqrt($x)}]
while { $j <= $max} {
if {$x % $j == 0} {
set other [expr {$x / $j}]
if {$other % 2 == 0} {
set god $j
} else {
set god [expr {$x / $j}]
#lowest j - so other side must be highest
break
}
}
incr j 2
}
return $god
}
proc greatestOddFactor {x} {
#*** !doctools
#[call [fun greatestOddFactor] [arg x]]
#[para]Return the largest odd integer factor of x
#[para]For an odd value of x - this will always return x
if {$x % 2 != 0 || $x == 0} {
return $x
}
set r [expr {$x / 2}]
while {$r % 2 == 0} {
set r [expr {$r / 2}]
}
return $r
}
proc gcd {n m} {
#*** !doctools
#[call [fun gcd] [arg n] [arg m]]
#[para]Return the greatest common divisor of m and n
#[para]Straight from Lars Hellström's math::numtheory library in Tcllib
#[para]Graphical use:
#[para]An a by b rectangle can be covered with square tiles of side-length c,
#[para]only if c is a common divisor of a and b
#
# Apply Euclid's good old algorithm
#
if { $n > $m } {
set t $n
set n $m
set m $t
}
while { $n > 0 } {
set r [expr {$m % $n}]
set m $n
set n $r
}
return $m
}
proc lcm {n m} {
#*** !doctools
#[call [fun gcd] [arg n] [arg m]]
#[para]Return the lowest common multiple of m and n
#[para]Straight from Lars Hellström's math::numtheory library in Tcllib
#[para]
set gcd [gcd $n $m]
return [expr {$n*$m/$gcd}]
}
proc commonDivisors {x y} {
#*** !doctools
#[call [fun commonDivisors] [arg x] [arg y]]
#[para]Return a list of all the common factors of x and y
#[para](equivalent to factors of their gcd)
return [factors [gcd $x $y]]
}
#experimental only - there are better/faster ways
proc sieve n {
set primes [list]
if {$n < 2} {return $primes}
set nums [dict create]
for {set i 2} {$i <= $n} {incr i} {
dict set nums $i ""
}
set next 2
set limit [expr {sqrt($n)}]
while {$next <= $limit} {
for {set i $next} {$i <= $n} {incr i $next} {dict unset nums $i}
lappend primes $next
dict for {next -} $nums break
}
return [concat $primes [dict keys $nums]]
}
proc sieve2 n {
set primes [list]
if {$n < 2} {return $primes}
set nums [dict create]
for {set i 2} {$i <= $n} {incr i} {
dict set nums $i ""
}
set next 2
set limit [expr {sqrt($n)}]
while {$next <= $limit} {
for {set i $next} {$i <= $n} {incr i $next} {dict unset nums $i}
lappend primes $next
#dict for {next -} $nums break
set next [lindex $nums 0]
}
return [concat $primes [dict keys $nums]]
}
proc hasglobs {str} {
#*** !doctools
#[call [fun hasglobs] [arg str]]
#[para]Return a boolean indicating whether str contains any of the glob characters: * ? [lb] [rb]
#[para]hasglobs uses append to preserve Tcls internal representation for str - so it should help avoid shimmering in the few cases where this may matter.
regexp {[*?\[\]]} [append obj2 $str {}] ;# int-rep preserving
}
proc trimzero {number} {
#*** !doctools
#[call [fun trimzero] [arg number]]
#[para]Return number with left-hand-side zeros trimmed off - unless all zero
#[para]If number is all zero - a single 0 is returned
set trimmed [string trimleft $number 0]
if {[string length $trimmed] == 0} {
set trimmed 0
}
return $trimmed
}
proc substring_count {str substring} {
#*** !doctools
#[call [fun substring_count] [arg str] [arg substring]]
#[para]Search str and return number of occurrences of substring
#faster than lsearch on split for str of a few K
if {$substring eq ""} {return 0}
set occurrences [expr {[string length $str]-[string length [string map [list $substring {}] $str]]}]
return [expr {$occurrences / [string length $substring]}]
}
proc dict_merge_ordered {defaults main} {
#*** !doctools
#[call [fun dict_merge_ordered] [arg defaults] [arg main]]
#[para]The standard dict merge accepts multiple dicts with values from dicts to the right (2nd argument) taking precedence.
#[para]When merging with a dict of default values - this means that any default key/vals that weren't in the main dict appear in the output before the main data.
#[para]This function merges the two dicts whilst maintaining the key order of main followed by defaults.
#1st merge (inner merge) with wrong values taking precedence - but right key-order - then (outer merge) restore values
return [dict merge [dict merge $main $defaults] $main]
}
proc askuser {question} {
#*** !doctools
#[call [fun askuser] [arg question]]
#[para]A very basic utility to read an answer from stdin
#[para]The prompt is written to the terminal and then it waits for a user to type something
#[para]stdin is temporarily configured to blocking and then put back in its original state in case it wasn't already so.
#[para]The user must hit enter to submit the response
#[para]The return value is the string if any that was typed prior to hitting enter.
#[para]The question argument can be manually colourised using the various punk::ansi funcitons
#[example_begin]
# set answer [lb]punk::lib::askuser "[lb]a+ green bold[rb]Do you want to proceed? (Y|N)[lb]a[rb]"[rb]
# if {[lb]string match y* [lb]string tolower $answer[rb][rb]} {
# puts "Proceeding"
# } else {
# puts "Cancelled by user"
# }
#[example_end]
puts stdout $question
flush stdout
set stdin_state [fconfigure stdin]
try {
fconfigure stdin -blocking 1
set answer [gets stdin]
} finally {
fconfigure stdin -blocking [dict get $stdin_state -blocking]
}
return $answer
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#todo - way to generate 'internal' docs separately?
#*** !doctools
#[section Internal]
namespace eval punk::lib::system {
#*** !doctools
#[subsection {Namespace punk::lib::system}]
#[para] Internal functions that are not part of the API
#[list_begin definitions]
proc mostFactorsBelow {n} {
##*** !doctools
#[call [fun mostFactorsBelow] [arg n]]
#[para]Find the number below $n which has the greatest number of factors
#[para]This will get slow quickly as n increases (100K = 1s+ 2024)
set most 0
set mostcount 0
for {set i 1} {$i < $n} {incr i} {
set fc [llength [punk::lib::factors $i]]
if {$fc > $mostcount} {
set most $i
set mostcount $fc
}
}
return [list number $most numfactors $mostcount]
}
proc factorCountBelow_punk {n} {
##*** !doctools
#[call [fun factorCountBelow] [arg n]]
#[para]For numbers 1 to n - keep a tally of the total count of factors
#[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result
#[para]and as a rudimentary performance comparison
#[para]gets slow quickly!
set tally 0
for {set i 1} {$i <= $n} {incr i} {
incr tally [llength [punk::lib::factors $i]]
}
return $tally
}
proc factorCountBelow_numtheory {n} {
##*** !doctools
#[call [fun factorCountBelow] [arg n]]
#[para]For numbers 1 to n - keep a tally of the total count of factors
#[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result
#[para]and as a rudimentary performance comparison
#[para]gets slow quickly! (significantly slower than factorCountBelow_punk)
package require math::numtheory
set tally 0
for {set i 1} {$i <= $n} {incr i} {
incr tally [llength [math::numtheory::factors $i]]
}
return $tally
}
proc factors2 {x} {
##*** !doctools
#[call [fun factors2] [arg x]]
#[para]Return a sorted list of factors of x
#[para]A similar brute-force mechanism to factors - but keeps result ordering as we go.
set smallfactors [list 1]
set j 2
set max [expr {sqrt($x)}]
while {$j < $max} {
if {($x % $j) == 0} {
lappend smallfactors $j
lappend largefactors [expr {$x / $j}]
}
incr j
}
#handle sqrt outside loop so we don't have to sort/dedup or check list membership in main loop
if {($x % $j) == 0} {
if {$j == ($x / $j)} {
lappend smallfactors $j
}
}
return [concat $smallfactors [lreverse $largefactors] $x]
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::lib::system ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::lib [namespace eval punk::lib {
variable pkg punk::lib
variable version
set version 0.1.0
}]
return
#*** !doctools
#[manpage_end]

36
src/embedded/man/files/punk/_module_ansi-0.1.0.tm.n
Unescape View File

@ -334,6 +334,8 @@ package require \fBpunk::ansi \fR
.sp
\fBlength\fR \fItext\fR
.sp
\fBindex\fR \fIstring\fR \fIindex\fR
.sp
.BE
.SH DESCRIPTION
.PP
@ -550,6 +552,40 @@ Return the character length after stripping ansi codes - not the printing length
.SS "NAMESPACE PUNK::ANSI::ANSISTRING"
.PP
punk::ansi::string ensemble
.TP
\fBindex\fR \fIstring\fR \fIindex\fR
.sp
Takes a string that possibly contains ansi codes such as colour,underline etc (SGR codes)
.sp
Returns the character (with applied ansi effect) at position index
.sp
The string could contain non SGR ansi codes - and these will (mostly) be ignored, so shouldn't affect the output\&.
.sp
Some terminals don't hide 'privacy message' and other strings within an ESC X ESC ^ or ESC _ sequence (terminated by ST)
.sp
It's arguable some of these are application specific - but this function takes the view that they are probably non-displaying - so index won't see them\&.
.sp
If the caller wants just the character - they should use a normal string index after calling stripansi, or call stripansi afterwards\&.
.sp
As any operation using end-+<int> will need to strip ansi to precalculate the length anyway; the caller should probably just use stripansi and standard string index if the ansi coded output isn't required and they are using and end-based index\&.
.sp
In fact, any operation where the ansi info isn't required in the output would probably be slightly more efficiently obtained by using stripansi and normal string operations on that\&.
.sp
The returned character will (possibly) have a leading ansi escape sequence but no trailing escape sequence - even if the string was taken from a position immediately before a reset or other SGR ansi code
.sp
The ansi-code prefix in the returned string is built up by concatenating previous SGR ansi codes seen - but it is optimised to re-start the process if any full SGR reset is encountered\&.
.sp
The code sequence doesn't detect individual properties being turned on and then off again, only full resets; so in some cases the ansi-prefix may not be as short as it could be\&.
.sp
This shouldn't make any difference to the visual output - but a possible future enhancement is something to produce the shortest ansi sequence possible
.sp
Notes:
.sp
This function has to split the whole string into plaintext & ansi codes even for a very low index
.sp
Some sort of generator that parses more of the string as required might be more efficient for large chunks\&.
.sp
For end-x operations we have to pre-calculate the content-length by stripping the ansi - which is also potentially sub-optimal
.PP
.SH KEYWORDS
ansi, console, module, string, terminal

57
src/embedded/md/doc/files/punk/_module_ansi-0.1.0.tm.md
Unescape View File

@ -71,6 +71,7 @@ package require punk::ansi
[__detect\_sgr__ *text*](#27)
[__strip__ *text*](#28)
[__length__ *text*](#29)
[__index__ *string* *index*](#30)
# <a name='description'></a>DESCRIPTION
@ -322,6 +323,62 @@ https://github\.com/perlancar/perl\-Text\-ANSI\-Util/blob/master/lib/Text/ANSI/B
punk::ansi::string ensemble
- <a name='30'></a>__index__ *string* *index*
Takes a string that possibly contains ansi codes such as colour,underline
etc \(SGR codes\)
Returns the character \(with applied ansi effect\) at position index
The string could contain non SGR ansi codes \- and these will \(mostly\) be
ignored, so shouldn't affect the output\.
Some terminals don't hide 'privacy message' and other strings within an ESC
X ESC ^ or ESC \_ sequence \(terminated by ST\)
It's arguable some of these are application specific \- but this function
takes the view that they are probably non\-displaying \- so index won't see
them\.
If the caller wants just the character \- they should use a normal string
index after calling stripansi, or call stripansi afterwards\.
As any operation using end\-\+<int> will need to strip ansi to precalculate
the length anyway; the caller should probably just use stripansi and
standard string index if the ansi coded output isn't required and they are
using and end\-based index\.
In fact, any operation where the ansi info isn't required in the output
would probably be slightly more efficiently obtained by using stripansi and
normal string operations on that\.
The returned character will \(possibly\) have a leading ansi escape sequence
but no trailing escape sequence \- even if the string was taken from a
position immediately before a reset or other SGR ansi code
The ansi\-code prefix in the returned string is built up by concatenating
previous SGR ansi codes seen \- but it is optimised to re\-start the process
if any full SGR reset is encountered\.
The code sequence doesn't detect individual properties being turned on and
then off again, only full resets; so in some cases the ansi\-prefix may not
be as short as it could be\.
This shouldn't make any difference to the visual output \- but a possible
future enhancement is something to produce the shortest ansi sequence
possible
Notes:
This function has to split the whole string into plaintext & ansi codes even
for a very low index
Some sort of generator that parses more of the string as required might be
more efficient for large chunks\.
For end\-x operations we have to pre\-calculate the content\-length by
stripping the ansi \- which is also potentially sub\-optimal
# <a name='keywords'></a>KEYWORDS
[ansi](\.\./\.\./\.\./index\.md\#ansi), [console](\.\./\.\./\.\./index\.md\#console),

18
src/embedded/www/doc/files/punk/_module_ansi-0.1.0.tm.html
Unescape View File

@ -164,6 +164,7 @@
<li><a href="#27"><b class="function">detect_sgr</b> <i class="arg">text</i></a></li>
<li><a href="#28"><b class="function">strip</b> <i class="arg">text</i></a></li>
<li><a href="#29"><b class="function">length</b> <i class="arg">text</i></a></li>
<li><a href="#30"><b class="function">index</b> <i class="arg">string</i> <i class="arg">index</i></a></li>
</ul>
</div>
</div>
@ -300,6 +301,23 @@
<div id="subsection5" class="doctools_subsection"><h3><a name="subsection5">Namespace punk::ansi::ansistring</a></h3>
<p>punk::ansi::string ensemble</p>
<dl class="doctools_definitions">
<dt><a name="30"><b class="function">index</b> <i class="arg">string</i> <i class="arg">index</i></a></dt>
<dd><p>Takes a string that possibly contains ansi codes such as colour,underline etc (SGR codes)</p>
<p>Returns the character (with applied ansi effect) at position index</p>
<p>The string could contain non SGR ansi codes - and these will (mostly) be ignored, so shouldn't affect the output.</p>
<p>Some terminals don't hide 'privacy message' and other strings within an ESC X ESC ^ or ESC _ sequence (terminated by ST)</p>
<p>It's arguable some of these are application specific - but this function takes the view that they are probably non-displaying - so index won't see them.</p>
<p>If the caller wants just the character - they should use a normal string index after calling stripansi, or call stripansi afterwards.</p>
<p>As any operation using end-+&lt;int&gt; will need to strip ansi to precalculate the length anyway; the caller should probably just use stripansi and standard string index if the ansi coded output isn't required and they are using and end-based index.</p>
<p>In fact, any operation where the ansi info isn't required in the output would probably be slightly more efficiently obtained by using stripansi and normal string operations on that.</p>
<p>The returned character will (possibly) have a leading ansi escape sequence but no trailing escape sequence - even if the string was taken from a position immediately before a reset or other SGR ansi code</p>
<p>The ansi-code prefix in the returned string is built up by concatenating previous SGR ansi codes seen - but it is optimised to re-start the process if any full SGR reset is encountered.</p>
<p>The code sequence doesn't detect individual properties being turned on and then off again, only full resets; so in some cases the ansi-prefix may not be as short as it could be.</p>
<p>This shouldn't make any difference to the visual output - but a possible future enhancement is something to produce the shortest ansi sequence possible</p>
<p>Notes:</p>
<p>This function has to split the whole string into plaintext &amp; ansi codes even for a very low index</p>
<p>Some sort of generator that parses more of the string as required might be more efficient for large chunks.</p>
<p>For end-x operations we have to pre-calculate the content-length by stripping the ansi - which is also potentially sub-optimal</p></dd>
</dl>
</div>
</div>

280
src/modules/punk/ansi-999999.0a1.0.tm
Unescape View File

@ -105,8 +105,12 @@ namespace eval punk::ansi {
#NOTE - we are assuming an OSC or DCS started with one type of sequence (7 or 8bit) can be terminated by either 7 or 8 bit ST (or BEL e.g wezterm )
#This using a different type of ST to that of the opening sequence is presumably unlikely in the wild - but who knows?
variable standalone_codes
set standalone_codes [list \x1bc "" \x1b7 "" \x1b8 "" \x1bM "" \x1bE "" \x1bD "" \x1bH "" \x1b= "" \x1b> "" \x1b#3 "" \x1b#4 "" \x1b#5 "" \x1b#6 "" \x1b#8 ""]
#review - there doesn't seem to be an \x1b#7
# https://espterm.github.io/docs/VT100%20escape%20codes.html
#self-contained 2 byte ansi escape sequences - review more?
variable ansi_2byte_codes_dict
set ansi_2byte_codes_dict [dict create\
"reset_terminal" "\u001bc"\
"save_cursor_posn" "\u001b7"\
@ -133,6 +137,7 @@ namespace eval punk::ansi {
#todo - character set selection - SS2 SS3 - how are they terminated? REVIEW
variable escape_terminals ;#dict
variable standalone_codes ;#map to empty string
set text [convert_g0 $text]
@ -145,9 +150,7 @@ namespace eval punk::ansi {
#\x1b#6 double-width line
#\x1b#8 dec test fill screen
set clean_map_2b [list \x1bc "" \x1b7 "" \x1b8 "" \x1bM "" \x1bE "" \x1bD "" \x1bH "" \x1b= "" \x1b> ""]
set clean_map_3b [list \x1b#3 "" \x1b#4 "" \x1b#5 "" \x1b#6 "" \x1b#8 ""]
set text [string map [concat $clean_map_2b $clean_map_3b] $text]
set text [string map $standalone_codes $text]
#we process char by char - line-endings whether \r\n or \n should be processed as per any other character.
#line endings can theoretically occur within an ansi escape sequence payload (review e.g title?)
@ -169,7 +172,7 @@ namespace eval punk::ansi {
if {$u in $endseq} {
set in_escapesequence 0
} elseif {$uv in $endseq} {
set in_escapseequence 2b ;#flag next byte as last in sequence
set in_escapesequence 2b ;#flag next byte as last in sequence
}
} else {
#handle both 7-bit and 8-bit CSI and OSC
@ -179,7 +182,7 @@ namespace eval punk::ansi {
set in_escapesequence OSC
} elseif {[regexp {^(?:\033P|\u0090)} $uv]} {
set in_escapesequence DCS
} elseif {[regexp {^(?:\033X|\u0098|\033^|\u009E|\033_|\u009F)} $uv]} {
} elseif {[regexp {^(?:\033X|\u0098|\033\^|\u009E|\033_|\u009F)} $uv]} {
#SOS,PM,APC - all terminated with ST
set in_escapesequence MISC
} else {
@ -248,7 +251,7 @@ namespace eval punk::ansi {
proc colourmap1 {{bgname White}} {
package require textblock
set bg [textblock::block 3 33 "[a+ $bgname] [a]"]
set bg [textblock::block 33 3 "[a+ $bgname] [a]"]
set colormap ""
for {set i 0} {$i <= 7} {incr i} {
append colormap "_[a+ white bold 48\;5\;$i] $i [a]"
@ -258,7 +261,7 @@ namespace eval punk::ansi {
}
proc colourmap2 {{bgname White}} {
package require textblock
set bg [textblock::block 3 39 "[a+ $bgname] [a]"]
set bg [textblock::block 39 3 "[a+ $bgname] [a]"]
set colormap ""
for {set i 8} {$i <= 15} {incr i} {
append colormap "_[a+ black normal 48\;5\;$i] $i [a]" ;#black normal is blacker than black bold - which often displays as a grey
@ -691,6 +694,7 @@ namespace eval punk::ansi {
return "\u0090+q$payload\u009c"
}
namespace eval codetype {
#Functions that operate on a single ansi code sequence - not a sequence, and not codes embedded in another string
proc is_sgr {code} {
#SGR (Select Graphic Rendition) - codes ending in 'm' - e.g colour/underline
#we will accept and pass through the less common colon separator (ITU Open Document Architecture)
@ -707,7 +711,7 @@ namespace eval punk::ansi {
regexp {\033\[0*m$} $code
}
#whether this code has 0 (or equivalently empty) parameter (but may set others)
#if an SGR code as a reset in it - we don't need to carry forward any previous SGR codes
#if an SGR code has a reset in it - we don't need to carry forward any previous SGR codes
#it generally only makes sense for the reset to be the first entry - otherwise the code has ineffective portions
#However - detecting zero or empty parameter in other positions requires knowing all other codes that may allow zero or empty params.
#We will only look at initial parameter as this is the well-formed normal case.
@ -773,14 +777,35 @@ namespace eval punk::ansi::ta {
#OSC - termnate with BEL (\a \007) or ST (string terminator \033\\)
# 8-byte string terminator is \x9c (\u009c)
#test - non-greedy
variable re_esc_osc1 {(?:\033\]).*?\007}
variable re_esc_osc2 {(?:\033\]).*?\033\\}
variable re_esc_osc3 {(?:\u009d).*?\u009c}
#non-greedy via "*?" doesn't seem to work like this..
#variable re_esc_osc1 {(?:\033\]).*?\007}
#variable re_esc_osc2 {(?:\033\]).*?\033\\}
#variable re_esc_osc3 {(?:\u009d).*?\u009c}
#non-greedy by excluding ST terminators
#TODO - FIX? see re_ST below
variable re_esc_osc1 {(?:\033\])(?:[^\007]*)\007}
variable re_esc_osc2 {(?:\033\])(?:[^\033]*)\033\\}
variable re_esc_osc3 {(?:\u009d)(?:[^\u009c]*)?\u009c}
variable re_osc_open {(?:\033\]|\u009d).*}
variable re_ansi_detect "${re_csi_open}|${re_esc_osc1}|${re_esc_osc2}"
#standalone_codes [list \x1bc "" \x1b7 "" \x1b8 "" \x1bM "" \x1bE "" \x1bD "" \x1bH "" \x1b= "" \x1b> "" \x1b#3 "" \x1b#4 "" \x1b#5 "" \x1b#5 "" \x1b#6 "" \x1b#8 ""]
variable re_standalones {(?:\x1bc|\x1b7|\x1b8|\x1bM|\x1bE|\x1bD|\x1bD|\x1bH|\x1b=|\x1b>|\x1b#3|\x1b#4|\x1b#5|\x1b#6|\x1b#8)}
#see stripansi
set re_start_ST {^(?:\033X|\u0098|\033\^|\u009E|\033_|\u009F)}
#ST terminators [list \007 \033\\ \u009c]
#regex to capture the start of string/privacy message/application command block including the contents and string terminator (ST)
#non-greedy by exclusion of ST terminators in body
#!!!
#TODO - fix. we need to match \033\\ not just \033 ! could be colour codes nested in a privacy msg/string
#This will currently terminate the code too early in this case
#we also need to track the start of ST terminated code and not add it for replay (in the ansistring functions)
variable re_ST {(?:\033X|\u0098|\033\^|\u009E|\033_|\u009F)(?:[^\033\007\u009c]*)(?:\033\\|\007|\u009c)}
variable re_ansi_detect "${re_csi_open}|${re_esc_osc1}|${re_esc_osc2}|${re_standalones}|${re_start_ST}"
#detect any ansi escapes
#review - only detect 'complete' codes - or just use the opening escapes for performance?
@ -851,7 +876,9 @@ namespace eval punk::ansi::ta {
variable re_esc_osc1
variable re_esc_osc2
variable re_csi_code
punk::ansi::internal::splitx $text "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}"
variable re_standalones
variable re_ST
punk::ansi::internal::splitx $text "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}|${re_standalones}|${re_ST}"
}
# -- --- --- --- --- ---
@ -871,7 +898,9 @@ namespace eval punk::ansi::ta {
variable re_esc_osc1
variable re_esc_osc2
variable re_csi_code
set re "(?:${re_csi_code}|${re_esc_osc1}|${re_esc_osc2})+"
variable re_standalones
variable re_ST
set re "(?:${re_csi_code}|${re_standalones}|${re_ST}|${re_esc_osc1}|${re_esc_osc2})+"
return [_perlish_split $re $text]
}
#like split_codes - but each ansi-escape is split out separately (with empty string of plaintext between codes so odd/even plain ansi still holds)
@ -879,7 +908,9 @@ namespace eval punk::ansi::ta {
variable re_esc_osc1
variable re_esc_osc2
variable re_csi_code
set re "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}"
variable re_standalones
variable re_ST
set re "${re_csi_code}|${re_standalones}|${re_ST}|${re_esc_osc1}|${re_esc_osc2}"
return [_perlish_split $re $text]
}
@ -890,10 +921,26 @@ namespace eval punk::ansi::ta {
}
set list [list]
set start 0
#We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW
while {[regexp -start $start -indices -- $re $text match]} {
lassign $match matchStart matchEnd
#puts "->start $start ->match $matchStart $matchEnd"
if {$matchEnd < $matchStart} {
lappend list [string range $text $start $matchStart-1] [string index $text $matchStart]
incr start
if {$start >= [string length $text]} {
break
}
continue
}
lappend list [string range $text $start $matchStart-1] [string range $text $matchStart $matchEnd]
set start [expr {$matchEnd+1}]
#?
if {$start >= [string length $text]} {
break
}
}
lappend list [string range $text $start end]
return $list
@ -915,15 +962,210 @@ namespace eval punk::ansi::ansistring {
#[list_begin definitions]
namespace path [list ::punk::ansi ::punk::ansi::ta]
namespace ensemble create
namespace export length
namespace export length trim trimleft trimright index
#todo - expose _splits_ methods so caller can work efficiently with the splits themselves
#we need to consider whether these can be agnostic towards splits from split_codes vs split_codes_single
proc length {string} {
string length [ansistrip $string]
string length [stripansi $string]
}
proc trimleft {string args} {
set intext 0
set out ""
#for split_codes only first or last pt can be empty string
foreach {pt ansiblock} [split_codes $string] {
if {!$intext} {
if {$pt eq "" || [regexp {^\s+$} $pt]} {
append out $ansiblock
} else {
append out [string trimleft $pt]$ansiblock
set intext 1
}
} else {
append out $pt$ansiblock
}
}
return $out
}
proc trimright {string} {
if {$string eq ""} {return ""} ;#excludes the case where split_codes would return nothing
set rtrimmed_list [lreverse [_splits_trimleft [lreverse [split_codes $string]]]]
return [join $rtrimmed_list ""]
}
proc trim {string} {
#make sure we do our ansi-scanning split only once - so use list-based trim operations
#order of left vs right probably makes zero difference - as any reduction the first operation can do is only in terms of characters at other end of list - not in total list length
#we save a single function call by calling both here rather than _splits_trim
join [_splits_trimright [_splits_trimleft [split_codes $string]]] ""
}
proc index {string index} {
#*** !doctools
#[call [fun index] [arg string] [arg index]]
#[para]Takes a string that possibly contains ansi codes such as colour,underline etc (SGR codes)
#[para]Returns the character (with applied ansi effect) at position index
#[para]The string could contain non SGR ansi codes - and these will (mostly) be ignored, so shouldn't affect the output.
#[para]Some terminals don't hide 'privacy message' and other strings within an ESC X ESC ^ or ESC _ sequence (terminated by ST)
#[para]It's arguable some of these are application specific - but this function takes the view that they are probably non-displaying - so index won't see them.
#[para]todo: SGR codes within ST-terminated strings not yet ignored properly
#[para]If the caller wants just the character - they should use a normal string index after calling stripansi, or call stripansi afterwards.
#[para]As any operation using end-+<int> will need to strip ansi to precalculate the length anyway; the caller should probably just use stripansi and standard string index if the ansi coded output isn't required and they are using and end-based index.
#[para]In fact, any operation where the ansi info isn't required in the output would probably be slightly more efficiently obtained by using stripansi and normal string operations on that.
#[para]The returned character will (possibly) have a leading ansi escape sequence but no trailing escape sequence - even if the string was taken from a position immediately before a reset or other SGR ansi code
#[para]The ansi-code prefix in the returned string is built up by concatenating previous SGR ansi codes seen - but it is optimised to re-start the process if any full SGR reset is encountered.
#[para]The code sequence doesn't detect individual properties being turned on and then off again, only full resets; so in some cases the ansi-prefix may not be as short as it could be.
#[para]This shouldn't make any difference to the visual output - but a possible future enhancement is something to produce the shortest ansi sequence possible
#[para]Notes:
#[para]This function has to split the whole string into plaintext & ansi codes even for a very low index
#[para]Some sort of generator that parses more of the string as required might be more efficient for large chunks.
#[para]For end-x operations we have to pre-calculate the content-length by stripping the ansi - which is also potentially sub-optimal
set splits [split_codes_single $string]; #we get empty pt(plaintext) between each ansi code that is in a run
#todo - end-x +/-x+/-x etc
set original_index $index
set index [string map [list _ ""] $index]
#short-circuit some trivial cases
if {[string is integer -strict $index]} {
if {$index < 0} {return ""}
#this only short-circuits an index greater than length including ansi-chars
#we don't want to spend cycles stripping ansi for this test so code below will still have to handle index just larger than content-length but still less than entire length
if {$index > [string length $string]} {return ""}
} else {
if {[string match end* $index]} {
#for end- we will probably have to blow a few cycles stripping first and calculate the length
if {$index ne "end"} {
set op [string index $index 3]
set offset [string range $index 4 end]
if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"}
if {$op eq "+" && $offset != 0} {
return ""
}
} else {
set offset 0
}
#by now, if op = + then offset = 0 so we only need to handle the minus case
set payload_len [punk::ansi::ansistring::length $string] ;#a little bit wasteful - but hopefully no big deal
if {$offset == 0} {
set index [expr {$payload_len-1}]
} else {
set index [expr {($payload_len-1) - $offset}]
}
if {$index < 0} {
#don't waste time splitting and looping the string
return ""
}
} else {
#we are trying to avoid evaluating unbraced expr of potentially insecure origin
regexp {^([+-]{0,1})(.*)} $index _match sign tail ;#should always match - even empty string
if {[string is integer -strict $tail]} {
#plain +-<int>
if {$op eq "-"} {
#return nothing for negative indices as per Tcl's lindex etc
return ""
}
set index $tail
} else {
if {[regexp {(.*)([+-])(.*)} $index _match a op b]} {
if {[string is integer -strict $a] && [string is integer -strict $b]} {
if {$op eq "-"} {
set index [expr {$a - $b}]
} else {
set index [expr {$a + $b}]
}
} else {
error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"
}
} else {
error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"
}
}
}
}
#any pt could be empty if using split_codes_single (or just first and last pt if split_codes)
set low -1
set high -1
set pt_index -2
set pt_found -1
set char ""
set codes_in_effect ""
#we can't only apply leading sequence from previous code - as there may be codes in effect from earlier, so we have to track as we go
#(this would apply even if we used split_codes - but then we would need to do further splitting of each codeset anyway)
foreach {pt code} $splits {
incr pt_index 2
if {$pt ne ""} {
set low [expr {$high + 1}] ;#last high
incr high [string length $pt]
}
if {$pt ne "" && ($index >= $low && $index <= $high)} {
set pt_found $pt_index
set char [string index $pt $index-$low]
break
}
if {[punk::ansi::codetype::is_sgr_reset $code]} {
#we can throw away previous codes_in_effect
set codes_in_effect ""
} else {
#may have partial resets - but we don't want to track individual states of SGR features
#A possible feature would be some function to optimise an ansi code sequence - which we could then apply at the end.
#we don't apply non SGR codes to our output. This is probably what is wanted - but should be reviewed.
#Review - consider if any other types of code make sense to retain in the output in this context.
if {[punk::ansi::codetype::is_sgr $code]} {
append codes_in_effect $code
}
}
}
if {$pt_found >= 0} {
return $codes_in_effect$char
} else {
return ""
}
}
proc _splits_trimleft {sclist} {
set intext 0
set outlist [list]
foreach {pt ansiblock} $sclist {
if {!$intext} {
if {$pt eq "" || [regexp {^\s+$} $pt]} {
lappend outlist "" $ansiblock
} else {
lappend outlist [string trimleft $pt] $ansiblock
set intext 1
}
} else {
lappend outlist $pt $ansiblock
}
}
return $outlist
}
proc _splits_trimright {sclist} {
set intext 0
set outlist [list]
foreach {pt ansiblock} [lreverse $sclist] {
if {!$intext} {
if {$pt eq "" || [regexp {^\s+$} $pt]} {
lappend outlist "" $ansiblock
} else {
lappend outlist [string trimright $pt] $ansiblock
set intext 1
}
} else {
lappend outlist $pt $ansiblock
}
}
return [lreverse $outlist]
}
proc _splits_trim {sclist} {
return [_splits_trimright [_splits_trimleft $sclist]]
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::ansi::ta ---}]

65
src/modules/shellfilter-0.1.8.tm
Unescape View File

@ -147,71 +147,6 @@ namespace eval shellfilter::ansi2 {
variable SGR_map
set SGR_map [dict merge $SGR_colour_map $SGR_setting_map]
proc colourmap1 {{bgname White}} {
package require textblock
set bg [textblock::block 3 33 "[a+ $bgname] [a=]"]
set colormap ""
for {set i 0} {$i <= 7} {incr i} {
append colormap "_[a+ white bold 48\;5\;$i] $i [a=]"
}
set map1 [overtype::left -transparent _ $bg "\n$colormap"]
return $map1
}
proc colourmap2 {{bgname White}} {
package require textblock
set bg [textblock::block 3 39 "[a+ $bgname] [a=]"]
set colormap ""
for {set i 8} {$i <= 15} {incr i} {
append colormap "_[a+ black normal 48\;5\;$i] $i [a=]" ;#black normal is blacker than black bold - which often displays as a grey
}
set map2 [overtype::left -transparent _ $bg "\n$colormap"]
return $map2
}
proc ? {args} {
variable SGR_setting_map
variable SGR_colour_map
if {![llength $args]} {
set out ""
append out $SGR_setting_map \n
append out $SGR_colour_map \n
try {
set bgname "White"
set map1 [colourmap1 $bgname]
set map1 [overtype::centre -transparent 1 $map1 "[a= black $bgname]Standard colours[a=]"]
set map2 [colourmap2 $bgname]
set map2 [overtype::centre -transparent 1 $map2 "[a= black $bgname]High-intensity colours[a=]"]
append out [textblock::join [textblock::join $map1 " "] $map2] \n
#append out $map1[a=] \n
#append out $map2[a=] \n
} on error {result options} {
puts stderr "Failed to draw colormap"
puts stderr "$result"
} finally {
return $out
}
} else {
set result [list]
set rmap [lreverse $map]
foreach i $args {
if {[string is integer -strict $i]} {
if {[dict exists $rmap $i]} {
lappend result $i [dict get $rmap $i]
}
} else {
if {[dict exists $map $i]} {
lappend result $i [dict get $map $i]
}
}
}
return $result
}
}
proc + {args} {
#don't disable ansi here.
#we want this to be available to call even if ansi is off

Write Preview
Loading…
Cancel
Save