12 changed files with 7200 additions and 87 deletions
File diff suppressed because it is too large
Load Diff
@ -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] |
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
@ -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 |
||||||
File diff suppressed because it is too large
Load Diff
@ -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] |
||||||
|
|
||||||
Loading…
Reference in new issue