46 changed files with 1446 additions and 53 deletions
@ -0,0 +1,83 @@ |
|||||||
|
#A basic utility script to cat a file to another with optional string prefix and suffix |
||||||
|
#does not interpret escapes e.g \n in arguments - review |
||||||
|
#Used for example by zig.build or other systems to avoid problems with redirecting echo/cat etc |
||||||
|
#2024 - zig.build.addSystemCommand doesn't seem to support pipelines |
||||||
|
|
||||||
|
#padding |
||||||
|
#padding |
||||||
|
#padding |
||||||
|
#padding |
||||||
|
#padding |
||||||
|
#padding |
||||||
|
#padding |
||||||
|
|
||||||
|
set usage "usage: interpreter scriptname -startnl 0|1 -prefix <string> -prefixnl 0|1 -suffix <string> -suffixnl 0|1 -input <filename> -inputnl 0|1 -output <filename>" |
||||||
|
set defaults [dict create\ |
||||||
|
-startnl 0\ |
||||||
|
-crlf 0\ |
||||||
|
-prefix ""\ |
||||||
|
-prefixnl 0\ |
||||||
|
-suffix ""\ |
||||||
|
-suffixnl 0\ |
||||||
|
-input ""\ |
||||||
|
-inputnl 0\ |
||||||
|
-output \uFFEF\ |
||||||
|
] |
||||||
|
if {"windows" eq $::tcl_platform(platform)} { |
||||||
|
package require punk::winrun |
||||||
|
package require twapi |
||||||
|
set rawcmdline [twapi::get_process_commandline [pid]] |
||||||
|
set allargs [punk::winrun::unquote_wintcl $rawcmdline] |
||||||
|
#first 2 args are the interpreter and the script |
||||||
|
set scriptargs [lrange $allargs 2 end] |
||||||
|
} else { |
||||||
|
set scriptargs $::argv |
||||||
|
} |
||||||
|
#puts stdout "scriptargs:$scriptargs" |
||||||
|
if {[llength $scriptargs] % 2 != 0} { |
||||||
|
puts stderr $usage |
||||||
|
exit 1 |
||||||
|
} |
||||||
|
set opts [dict merge $defaults $scriptargs] |
||||||
|
#puts stdout "opts:$opts" |
||||||
|
if {[dict get $opts -output] eq "\uFFEF"} { |
||||||
|
puts stderr $usage |
||||||
|
exit 2 |
||||||
|
} |
||||||
|
set infile [dict get $opts -input] |
||||||
|
set filedata "" |
||||||
|
if {$infile ne ""} { |
||||||
|
if {![file exists $infile]} { |
||||||
|
puts stderr "Unable to read input file '$infile'" |
||||||
|
exit 3 |
||||||
|
} |
||||||
|
set fd [open $infile r] |
||||||
|
set filedata [read $fd] |
||||||
|
close $fd |
||||||
|
} |
||||||
|
set startnl "" |
||||||
|
set prefixnl "" |
||||||
|
set suffixnl "" |
||||||
|
set inputnl "" |
||||||
|
if {[dict get $opts -startnl]} { |
||||||
|
set startnl \n |
||||||
|
} |
||||||
|
if {[dict get $opts -prefixnl]} { |
||||||
|
set prefixnl \n |
||||||
|
} |
||||||
|
if {[dict get $opts -suffixnl]} { |
||||||
|
set suffixnl \n |
||||||
|
} |
||||||
|
if {[dict get $opts -inputnl]} { |
||||||
|
set inputnl \n |
||||||
|
} |
||||||
|
set data "$startnl[dict get $opts -prefix]$prefixnl$filedata$inputnl[dict get $opts -suffix]$suffixnl" |
||||||
|
set fdout [open [dict get $opts -output] w] |
||||||
|
if {[dict get $opts -crlf] == 0} { |
||||||
|
chan configure $fdout -translation binary |
||||||
|
} |
||||||
|
puts -nonewline $fdout $data |
||||||
|
close $fdout |
||||||
|
catch {puts stdout ok} |
||||||
|
exit 0 |
||||||
|
|
||||||
@ -0,0 +1,410 @@ |
|||||||
|
# base64.tcl -- |
||||||
|
# |
||||||
|
# Encode/Decode base64 for a string |
||||||
|
# Stephen Uhler / Brent Welch (c) 1997 Sun Microsystems |
||||||
|
# The decoder was done for exmh by Chris Garrigues |
||||||
|
# |
||||||
|
# Copyright (c) 1998-2000 by Ajuba Solutions. |
||||||
|
# See the file "license.terms" for information on usage and redistribution |
||||||
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||||
|
|
||||||
|
# Version 1.0 implemented Base64_Encode, Base64_Decode |
||||||
|
# Version 2.0 uses the base64 namespace |
||||||
|
# Version 2.1 fixes various decode bugs and adds options to encode |
||||||
|
# Version 2.2 is much faster, Tcl8.0 compatible |
||||||
|
# Version 2.2.1 bugfixes |
||||||
|
# Version 2.2.2 bugfixes |
||||||
|
# Version 2.3 bugfixes and extended to support Trf |
||||||
|
# Version 2.4.x bugfixes |
||||||
|
|
||||||
|
# @mdgen EXCLUDE: base64c.tcl |
||||||
|
|
||||||
|
package require Tcl 8.2- |
||||||
|
namespace eval ::base64 { |
||||||
|
namespace export encode decode |
||||||
|
} |
||||||
|
|
||||||
|
package provide base64 2.5 |
||||||
|
|
||||||
|
if {[package vsatisfies [package require Tcl] 8.6]} { |
||||||
|
proc ::base64::encode {args} { |
||||||
|
binary encode base64 -maxlen 76 {*}$args |
||||||
|
} |
||||||
|
|
||||||
|
proc ::base64::decode {string} { |
||||||
|
# Tcllib is strict with respect to end of input, yet lax for |
||||||
|
# invalid characters outside of that. |
||||||
|
regsub -all -- {[^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/]} $string {} string |
||||||
|
binary decode base64 -strict $string |
||||||
|
} |
||||||
|
|
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
if {![catch {package require Trf 2.0}]} { |
||||||
|
# Trf is available, so implement the functionality provided here |
||||||
|
# in terms of calls to Trf for speed. |
||||||
|
|
||||||
|
# ::base64::encode -- |
||||||
|
# |
||||||
|
# Base64 encode a given string. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# args ?-maxlen maxlen? ?-wrapchar wrapchar? string |
||||||
|
# |
||||||
|
# If maxlen is 0, the output is not wrapped. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# A Base64 encoded version of $string, wrapped at $maxlen characters |
||||||
|
# by $wrapchar. |
||||||
|
|
||||||
|
proc ::base64::encode {args} { |
||||||
|
# Set the default wrapchar and maximum line length to match |
||||||
|
# the settings for MIME encoding (RFC 3548, RFC 2045). These |
||||||
|
# are the settings used by Trf as well. Various RFCs allow for |
||||||
|
# different wrapping characters and wraplengths, so these may |
||||||
|
# be overridden by command line options. |
||||||
|
set wrapchar "\n" |
||||||
|
set maxlen 76 |
||||||
|
|
||||||
|
if { [llength $args] == 0 } { |
||||||
|
error "wrong # args: should be \"[lindex [info level 0] 0]\ |
||||||
|
?-maxlen maxlen? ?-wrapchar wrapchar? string\"" |
||||||
|
} |
||||||
|
|
||||||
|
set optionStrings [list "-maxlen" "-wrapchar"] |
||||||
|
for {set i 0} {$i < [llength $args] - 1} {incr i} { |
||||||
|
set arg [lindex $args $i] |
||||||
|
set index [lsearch -glob $optionStrings "${arg}*"] |
||||||
|
if { $index == -1 } { |
||||||
|
error "unknown option \"$arg\": must be -maxlen or -wrapchar" |
||||||
|
} |
||||||
|
incr i |
||||||
|
if { $i >= [llength $args] - 1 } { |
||||||
|
error "value for \"$arg\" missing" |
||||||
|
} |
||||||
|
set val [lindex $args $i] |
||||||
|
|
||||||
|
# The name of the variable to assign the value to is extracted |
||||||
|
# from the list of known options, all of which have an |
||||||
|
# associated variable of the same name as the option without |
||||||
|
# a leading "-". The [string range] command is used to strip |
||||||
|
# of the leading "-" from the name of the option. |
||||||
|
# |
||||||
|
# FRINK: nocheck |
||||||
|
set [string range [lindex $optionStrings $index] 1 end] $val |
||||||
|
} |
||||||
|
|
||||||
|
# [string is] requires Tcl8.2; this works with 8.0 too |
||||||
|
if {[catch {expr {$maxlen % 2}}]} { |
||||||
|
return -code error "expected integer but got \"$maxlen\"" |
||||||
|
} elseif {$maxlen < 0} { |
||||||
|
return -code error "expected positive integer but got \"$maxlen\"" |
||||||
|
} |
||||||
|
|
||||||
|
set string [lindex $args end] |
||||||
|
set result [::base64 -mode encode -- $string] |
||||||
|
|
||||||
|
# Trf's encoder implicitly uses the settings -maxlen 76, |
||||||
|
# -wrapchar \n for its output. We may have to reflow this for |
||||||
|
# the settings chosen by the user. A second difference is that |
||||||
|
# Trf closes the output with the wrap char sequence, |
||||||
|
# always. The code here doesn't. Therefore 'trimright' is |
||||||
|
# needed in the fast cases. |
||||||
|
|
||||||
|
if {($maxlen == 76) && [string equal $wrapchar \n]} { |
||||||
|
# Both maxlen and wrapchar are identical to Trf's |
||||||
|
# settings. This is the super-fast case, because nearly |
||||||
|
# nothing has to be done. Only thing to do is strip a |
||||||
|
# terminating wrapchar. |
||||||
|
set result [string trimright $result] |
||||||
|
} elseif {$maxlen == 76} { |
||||||
|
# wrapchar has to be different here, length is the |
||||||
|
# same. We can use 'string map' to transform the wrap |
||||||
|
# information. |
||||||
|
set result [string map [list \n $wrapchar] \ |
||||||
|
[string trimright $result]] |
||||||
|
} elseif {$maxlen == 0} { |
||||||
|
# Have to reflow the output to no wrapping. Another fast |
||||||
|
# case using only 'string map'. 'trimright' is not needed |
||||||
|
# here. |
||||||
|
|
||||||
|
set result [string map [list \n ""] $result] |
||||||
|
} else { |
||||||
|
# Have to reflow the output from 76 to the chosen maxlen, |
||||||
|
# and possibly change the wrap sequence as well. |
||||||
|
|
||||||
|
# Note: After getting rid of the old wrap sequence we |
||||||
|
# extract the relevant segments from the string without |
||||||
|
# modifying the string. Modification, i.e. removal of the |
||||||
|
# processed part, means 'shifting down characters in |
||||||
|
# memory', making the algorithm O(n^2). By avoiding the |
||||||
|
# modification we stay in O(n). |
||||||
|
|
||||||
|
set result [string map [list \n ""] $result] |
||||||
|
set l [expr {[string length $result]-$maxlen}] |
||||||
|
for {set off 0} {$off < $l} {incr off $maxlen} { |
||||||
|
append res [string range $result $off [expr {$off+$maxlen-1}]] $wrapchar |
||||||
|
} |
||||||
|
append res [string range $result $off end] |
||||||
|
set result $res |
||||||
|
} |
||||||
|
|
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
# ::base64::decode -- |
||||||
|
# |
||||||
|
# Base64 decode a given string. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# string The string to decode. Characters not in the base64 |
||||||
|
# alphabet are ignored (e.g., newlines) |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# The decoded value. |
||||||
|
|
||||||
|
proc ::base64::decode {string} { |
||||||
|
regsub -all {\s} $string {} string |
||||||
|
::base64 -mode decode -- $string |
||||||
|
} |
||||||
|
|
||||||
|
} else { |
||||||
|
# Without Trf use a pure tcl implementation |
||||||
|
|
||||||
|
namespace eval base64 { |
||||||
|
variable base64 {} |
||||||
|
variable base64_en {} |
||||||
|
|
||||||
|
# We create the auxiliary array base64_tmp, it will be unset later. |
||||||
|
variable base64_tmp |
||||||
|
variable i |
||||||
|
|
||||||
|
set i 0 |
||||||
|
foreach char {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z \ |
||||||
|
a b c d e f g h i j k l m n o p q r s t u v w x y z \ |
||||||
|
0 1 2 3 4 5 6 7 8 9 + /} { |
||||||
|
set base64_tmp($char) $i |
||||||
|
lappend base64_en $char |
||||||
|
incr i |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# Create base64 as list: to code for instance C<->3, specify |
||||||
|
# that [lindex $base64 67] be 3 (C is 67 in ascii); non-coded |
||||||
|
# ascii chars get a {}. we later use the fact that lindex on a |
||||||
|
# non-existing index returns {}, and that [expr {} < 0] is true |
||||||
|
# |
||||||
|
|
||||||
|
# the last ascii char is 'z' |
||||||
|
variable char |
||||||
|
variable len |
||||||
|
variable val |
||||||
|
|
||||||
|
scan z %c len |
||||||
|
for {set i 0} {$i <= $len} {incr i} { |
||||||
|
set char [format %c $i] |
||||||
|
set val {} |
||||||
|
if {[info exists base64_tmp($char)]} { |
||||||
|
set val $base64_tmp($char) |
||||||
|
} else { |
||||||
|
set val {} |
||||||
|
} |
||||||
|
lappend base64 $val |
||||||
|
} |
||||||
|
|
||||||
|
# code the character "=" as -1; used to signal end of message |
||||||
|
scan = %c i |
||||||
|
set base64 [lreplace $base64 $i $i -1] |
||||||
|
|
||||||
|
# remove unneeded variables |
||||||
|
unset base64_tmp i char len val |
||||||
|
|
||||||
|
namespace export encode decode |
||||||
|
} |
||||||
|
|
||||||
|
# ::base64::encode -- |
||||||
|
# |
||||||
|
# Base64 encode a given string. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# args ?-maxlen maxlen? ?-wrapchar wrapchar? string |
||||||
|
# |
||||||
|
# If maxlen is 0, the output is not wrapped. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# A Base64 encoded version of $string, wrapped at $maxlen characters |
||||||
|
# by $wrapchar. |
||||||
|
|
||||||
|
proc ::base64::encode {args} { |
||||||
|
set base64_en $::base64::base64_en |
||||||
|
|
||||||
|
# Set the default wrapchar and maximum line length to match |
||||||
|
# the settings for MIME encoding (RFC 3548, RFC 2045). These |
||||||
|
# are the settings used by Trf as well. Various RFCs allow for |
||||||
|
# different wrapping characters and wraplengths, so these may |
||||||
|
# be overridden by command line options. |
||||||
|
set wrapchar "\n" |
||||||
|
set maxlen 76 |
||||||
|
|
||||||
|
if { [llength $args] == 0 } { |
||||||
|
error "wrong # args: should be \"[lindex [info level 0] 0]\ |
||||||
|
?-maxlen maxlen? ?-wrapchar wrapchar? string\"" |
||||||
|
} |
||||||
|
|
||||||
|
set optionStrings [list "-maxlen" "-wrapchar"] |
||||||
|
for {set i 0} {$i < [llength $args] - 1} {incr i} { |
||||||
|
set arg [lindex $args $i] |
||||||
|
set index [lsearch -glob $optionStrings "${arg}*"] |
||||||
|
if { $index == -1 } { |
||||||
|
error "unknown option \"$arg\": must be -maxlen or -wrapchar" |
||||||
|
} |
||||||
|
incr i |
||||||
|
if { $i >= [llength $args] - 1 } { |
||||||
|
error "value for \"$arg\" missing" |
||||||
|
} |
||||||
|
set val [lindex $args $i] |
||||||
|
|
||||||
|
# The name of the variable to assign the value to is extracted |
||||||
|
# from the list of known options, all of which have an |
||||||
|
# associated variable of the same name as the option without |
||||||
|
# a leading "-". The [string range] command is used to strip |
||||||
|
# of the leading "-" from the name of the option. |
||||||
|
# |
||||||
|
# FRINK: nocheck |
||||||
|
set [string range [lindex $optionStrings $index] 1 end] $val |
||||||
|
} |
||||||
|
|
||||||
|
# [string is] requires Tcl8.2; this works with 8.0 too |
||||||
|
if {[catch {expr {$maxlen % 2}}]} { |
||||||
|
return -code error "expected integer but got \"$maxlen\"" |
||||||
|
} elseif {$maxlen < 0} { |
||||||
|
return -code error "expected positive integer but got \"$maxlen\"" |
||||||
|
} |
||||||
|
|
||||||
|
set string [lindex $args end] |
||||||
|
|
||||||
|
set result {} |
||||||
|
set state 0 |
||||||
|
set length 0 |
||||||
|
|
||||||
|
|
||||||
|
# Process the input bytes 3-by-3 |
||||||
|
|
||||||
|
binary scan $string c* X |
||||||
|
|
||||||
|
foreach {x y z} $X { |
||||||
|
ADD [lindex $base64_en [expr {($x >>2) & 0x3F}]] |
||||||
|
if {$y != {}} { |
||||||
|
ADD [lindex $base64_en [expr {(($x << 4) & 0x30) | (($y >> 4) & 0xF)}]] |
||||||
|
if {$z != {}} { |
||||||
|
ADD [lindex $base64_en [expr {(($y << 2) & 0x3C) | (($z >> 6) & 0x3)}]] |
||||||
|
ADD [lindex $base64_en [expr {($z & 0x3F)}]] |
||||||
|
} else { |
||||||
|
set state 2 |
||||||
|
break |
||||||
|
} |
||||||
|
} else { |
||||||
|
set state 1 |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
if {$state == 1} { |
||||||
|
ADD [lindex $base64_en [expr {(($x << 4) & 0x30)}]] |
||||||
|
ADD = |
||||||
|
ADD = |
||||||
|
} elseif {$state == 2} { |
||||||
|
ADD [lindex $base64_en [expr {(($y << 2) & 0x3C)}]] |
||||||
|
ADD = |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
proc ::base64::ADD {x} { |
||||||
|
# The line length check is always done before appending so |
||||||
|
# that we don't get an extra newline if the output is a |
||||||
|
# multiple of $maxlen chars long. |
||||||
|
|
||||||
|
upvar 1 maxlen maxlen length length result result wrapchar wrapchar |
||||||
|
if {$maxlen && $length >= $maxlen} { |
||||||
|
append result $wrapchar |
||||||
|
set length 0 |
||||||
|
} |
||||||
|
append result $x |
||||||
|
incr length |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# ::base64::decode -- |
||||||
|
# |
||||||
|
# Base64 decode a given string. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# string The string to decode. Characters not in the base64 |
||||||
|
# alphabet are ignored (e.g., newlines) |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# The decoded value. |
||||||
|
|
||||||
|
proc ::base64::decode {string} { |
||||||
|
if {[string length $string] == 0} {return ""} |
||||||
|
|
||||||
|
set base64 $::base64::base64 |
||||||
|
set output "" ; # Fix for [Bug 821126] |
||||||
|
set nums {} |
||||||
|
|
||||||
|
binary scan $string c* X |
||||||
|
lappend X 61 ;# force a terminator |
||||||
|
foreach x $X { |
||||||
|
set bits [lindex $base64 $x] |
||||||
|
if {$bits >= 0} { |
||||||
|
if {[llength [lappend nums $bits]] == 4} { |
||||||
|
foreach {v w z y} $nums break |
||||||
|
set a [expr {($v << 2) | ($w >> 4)}] |
||||||
|
set b [expr {(($w & 0xF) << 4) | ($z >> 2)}] |
||||||
|
set c [expr {(($z & 0x3) << 6) | $y}] |
||||||
|
append output [binary format ccc $a $b $c] |
||||||
|
set nums {} |
||||||
|
} |
||||||
|
} elseif {$bits == -1} { |
||||||
|
# = indicates end of data. Output whatever chars are |
||||||
|
# left, if any. |
||||||
|
if {![llength $nums]} break |
||||||
|
# The encoding algorithm dictates that we can only |
||||||
|
# have 1 or 2 padding characters. If x=={}, we must |
||||||
|
# (*) have 12 bits of input (enough for 1 8-bit |
||||||
|
# output). If x!={}, we have 18 bits of input (enough |
||||||
|
# for 2 8-bit outputs). |
||||||
|
# |
||||||
|
# (*) If we don't then the input is broken (bug 2976290). |
||||||
|
|
||||||
|
foreach {v w z} $nums break |
||||||
|
|
||||||
|
# Bug 2976290 |
||||||
|
if {$w == {}} { |
||||||
|
return -code error "Not enough data to process padding" |
||||||
|
} |
||||||
|
|
||||||
|
set a [expr {($v << 2) | (($w & 0x30) >> 4)}] |
||||||
|
if {$z == {}} { |
||||||
|
append output [binary format c $a ] |
||||||
|
} else { |
||||||
|
set b [expr {(($w & 0xF) << 4) | (($z & 0x3C) >> 2)}] |
||||||
|
append output [binary format cc $a $b] |
||||||
|
} |
||||||
|
break |
||||||
|
} else { |
||||||
|
# RFC 2045 says that line breaks and other characters not part |
||||||
|
# of the Base64 alphabet must be ignored, and that the decoder |
||||||
|
# can optionally emit a warning or reject the message. We opt |
||||||
|
# not to do so, but to just ignore the character. |
||||||
|
continue |
||||||
|
} |
||||||
|
} |
||||||
|
return $output |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
return |
||||||
|
|
||||||
@ -0,0 +1,306 @@ |
|||||||
|
# Debug - a debug narrative logger. |
||||||
|
# -- Colin McCormack / originally Wub server utilities |
||||||
|
# |
||||||
|
# Debugging areas of interest are represented by 'tokens' which have |
||||||
|
# independantly settable levels of interest (an integer, higher is more detailed) |
||||||
|
# |
||||||
|
# Debug narrative is provided as a tcl script whose value is [subst]ed in the |
||||||
|
# caller's scope if and only if the current level of interest matches or exceeds |
||||||
|
# the Debug call's level of detail. This is useful, as one can place arbitrarily |
||||||
|
# complex narrative in code without unnecessarily evaluating it. |
||||||
|
# |
||||||
|
# TODO: potentially different streams for different areas of interest. |
||||||
|
# (currently only stderr is used. there is some complexity in efficient |
||||||
|
# cross-threaded streams.) |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## Requisites |
||||||
|
|
||||||
|
package require Tcl 8.5- |
||||||
|
|
||||||
|
namespace eval ::debug { |
||||||
|
namespace export -clear \ |
||||||
|
define on off prefix suffix header trailer \ |
||||||
|
names 2array level setting parray pdict \ |
||||||
|
nl tab hexl |
||||||
|
namespace ensemble create -subcommands {} |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## API & Implementation |
||||||
|
|
||||||
|
proc ::debug::noop {args} {} |
||||||
|
|
||||||
|
proc ::debug::debug {tag message {level 1}} { |
||||||
|
variable detail |
||||||
|
if {$detail($tag) < $level} { |
||||||
|
#puts stderr "$tag @@@ $detail($tag) >= $level" |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
variable prefix |
||||||
|
variable suffix |
||||||
|
variable header |
||||||
|
variable trailer |
||||||
|
variable fds |
||||||
|
|
||||||
|
if {[info exists fds($tag)]} { |
||||||
|
set fd $fds($tag) |
||||||
|
} else { |
||||||
|
set fd stderr |
||||||
|
} |
||||||
|
|
||||||
|
# Assemble the shown text from the user message and the various |
||||||
|
# prefixes and suffices (global + per-tag). |
||||||
|
|
||||||
|
set themessage "" |
||||||
|
if {[info exists prefix(::)]} { append themessage $prefix(::) } |
||||||
|
if {[info exists prefix($tag)]} { append themessage $prefix($tag) } |
||||||
|
append themessage $message |
||||||
|
if {[info exists suffix($tag)]} { append themessage $suffix($tag) } |
||||||
|
if {[info exists suffix(::)]} { append themessage $suffix(::) } |
||||||
|
|
||||||
|
# Resolve variables references and command invokations embedded |
||||||
|
# into the message with plain text. |
||||||
|
set code [catch { |
||||||
|
set smessage [uplevel 1 [list ::subst -nobackslashes $themessage]] |
||||||
|
set sheader [uplevel 1 [list ::subst -nobackslashes $header]] |
||||||
|
set strailer [uplevel 1 [list ::subst -nobackslashes $trailer]] |
||||||
|
} __ eo] |
||||||
|
|
||||||
|
# And dump an internal error if that resolution failed. |
||||||
|
if {$code} { |
||||||
|
if {[catch { |
||||||
|
set caller [info level -1] |
||||||
|
}]} { set caller GLOBAL } |
||||||
|
if {[string length $caller] >= 1000} { |
||||||
|
set caller "[string range $caller 0 200]...[string range $caller end-200 end]" |
||||||
|
} |
||||||
|
foreach line [split $caller \n] { |
||||||
|
puts -nonewline $fd "@@(DebugError from $tag ($eo): $line)" |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# From here we have a good message to show. We only shorten it a |
||||||
|
# bit if its a bit excessive in size. |
||||||
|
|
||||||
|
if {[string length $smessage] > 4096} { |
||||||
|
set head [string range $smessage 0 2048] |
||||||
|
set tail [string range $smessage end-2048 end] |
||||||
|
set smessage "${head}...(truncated)...$tail" |
||||||
|
} |
||||||
|
|
||||||
|
foreach line [split $smessage \n] { |
||||||
|
puts $fd "$sheader$tag | $line$strailer" |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# names - return names of debug tags |
||||||
|
proc ::debug::names {} { |
||||||
|
variable detail |
||||||
|
return [lsort [array names detail]] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::2array {} { |
||||||
|
variable detail |
||||||
|
set result {} |
||||||
|
foreach n [lsort [array names detail]] { |
||||||
|
if {[interp alias {} debug.$n] ne "::debug::noop"} { |
||||||
|
lappend result $n $detail($n) |
||||||
|
} else { |
||||||
|
lappend result $n -$detail($n) |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
# level - set level and fd for tag |
||||||
|
proc ::debug::level {tag {level ""} {fd {}}} { |
||||||
|
variable detail |
||||||
|
# TODO: Force level >=0. |
||||||
|
if {$level ne ""} { |
||||||
|
set detail($tag) $level |
||||||
|
} |
||||||
|
|
||||||
|
if {![info exists detail($tag)]} { |
||||||
|
set detail($tag) 1 |
||||||
|
} |
||||||
|
|
||||||
|
variable fds |
||||||
|
if {$fd ne {}} { |
||||||
|
set fds($tag) $fd |
||||||
|
} |
||||||
|
|
||||||
|
return $detail($tag) |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::header {text} { variable header $text } |
||||||
|
proc ::debug::trailer {text} { variable trailer $text } |
||||||
|
|
||||||
|
proc ::debug::define {tag} { |
||||||
|
if {[interp alias {} debug.$tag] ne {}} return |
||||||
|
off $tag |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# Set a prefix/suffix to use for tag. |
||||||
|
# The global (tag-independent) prefix/suffix is adressed through tag '::'. |
||||||
|
# This works because colon (:) is an illegal character for user-specified tags. |
||||||
|
|
||||||
|
proc ::debug::prefix {tag {theprefix {}}} { |
||||||
|
variable prefix |
||||||
|
set prefix($tag) $theprefix |
||||||
|
|
||||||
|
if {[interp alias {} debug.$tag] ne {}} return |
||||||
|
off $tag |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::suffix {tag {theprefix {}}} { |
||||||
|
variable suffix |
||||||
|
set suffix($tag) $theprefix |
||||||
|
|
||||||
|
if {[interp alias {} debug.$tag] ne {}} return |
||||||
|
off $tag |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# turn on debugging for tag |
||||||
|
proc ::debug::on {tag {level ""} {fd {}}} { |
||||||
|
variable active |
||||||
|
set active($tag) 1 |
||||||
|
level $tag $level $fd |
||||||
|
interp alias {} debug.$tag {} ::debug::debug $tag |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# turn off debugging for tag |
||||||
|
proc ::debug::off {tag {level ""} {fd {}}} { |
||||||
|
variable active |
||||||
|
set active($tag) 1 |
||||||
|
level $tag $level $fd |
||||||
|
interp alias {} debug.$tag {} ::debug::noop |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::setting {args} { |
||||||
|
if {[llength $args] == 1} { |
||||||
|
set args [lindex $args 0] |
||||||
|
} |
||||||
|
set fd stderr |
||||||
|
if {[llength $args] % 2} { |
||||||
|
set fd [lindex $args end] |
||||||
|
set args [lrange $args 0 end-1] |
||||||
|
} |
||||||
|
foreach {tag level} $args { |
||||||
|
if {$level > 0} { |
||||||
|
level $tag $level $fd |
||||||
|
interp alias {} debug.$tag {} ::debug::debug $tag |
||||||
|
} else { |
||||||
|
level $tag [expr {-$level}] $fd |
||||||
|
interp alias {} debug.$tag {} ::debug::noop |
||||||
|
} |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## Convenience commands. |
||||||
|
# Format arrays and dicts as multi-line message. |
||||||
|
# Insert newlines and tabs. |
||||||
|
|
||||||
|
proc ::debug::nl {} { return \n } |
||||||
|
proc ::debug::tab {} { return \t } |
||||||
|
|
||||||
|
proc ::debug::parray {a {pattern *}} { |
||||||
|
upvar 1 $a array |
||||||
|
if {![array exists array]} { |
||||||
|
error "\"$a\" isn't an array" |
||||||
|
} |
||||||
|
pdict [array get array] $pattern |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::pdict {dict {pattern *}} { |
||||||
|
set maxl 0 |
||||||
|
set names [lsort -dict [dict keys $dict $pattern]] |
||||||
|
foreach name $names { |
||||||
|
if {[string length $name] > $maxl} { |
||||||
|
set maxl [string length $name] |
||||||
|
} |
||||||
|
} |
||||||
|
set maxl [expr {$maxl + 2}] |
||||||
|
set lines {} |
||||||
|
foreach name $names { |
||||||
|
set nameString [format (%s) $name] |
||||||
|
lappend lines [format "%-*s = %s" \ |
||||||
|
$maxl $nameString \ |
||||||
|
[dict get $dict $name]] |
||||||
|
} |
||||||
|
return [join $lines \n] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::debug::hexl {data {prefix {}}} { |
||||||
|
set r {} |
||||||
|
|
||||||
|
# Convert the data to hex and to characters. |
||||||
|
binary scan $data H*@0a* hexa asciia |
||||||
|
|
||||||
|
# Replace non-printing characters in the data with dots. |
||||||
|
regsub -all -- {[^[:graph:] ]} $asciia {.} asciia |
||||||
|
|
||||||
|
# Pad with spaces to a full multiple of 32/16. |
||||||
|
set n [expr {[string length $hexa] % 32}] |
||||||
|
if {$n < 32} { append hexa [string repeat { } [expr {32-$n}]] } |
||||||
|
#puts "pad H [expr {32-$n}]" |
||||||
|
|
||||||
|
set n [expr {[string length $asciia] % 32}] |
||||||
|
if {$n < 16} { append asciia [string repeat { } [expr {16-$n}]] } |
||||||
|
#puts "pad A [expr {32-$n}]" |
||||||
|
|
||||||
|
# Reassemble formatted, in groups of 16 bytes/characters. |
||||||
|
# The hex part is handled in groups of 32 nibbles. |
||||||
|
set addr 0 |
||||||
|
while {[string length $hexa]} { |
||||||
|
# Get front group of 16 bytes each. |
||||||
|
set hex [string range $hexa 0 31] |
||||||
|
set ascii [string range $asciia 0 15] |
||||||
|
# Prep for next iteration |
||||||
|
set hexa [string range $hexa 32 end] |
||||||
|
set asciia [string range $asciia 16 end] |
||||||
|
|
||||||
|
# Convert the hex to pairs of hex digits |
||||||
|
regsub -all -- {..} $hex {& } hex |
||||||
|
|
||||||
|
# Add the hex and latin-1 data to the result buffer |
||||||
|
append r $prefix [format %04x $addr] { | } $hex { |} $ascii |\n |
||||||
|
incr addr 16 |
||||||
|
} |
||||||
|
|
||||||
|
# And done |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
|
||||||
|
namespace eval debug { |
||||||
|
variable detail ; # map: TAG -> level of interest |
||||||
|
variable prefix ; # map: TAG -> message prefix to use |
||||||
|
variable suffix ; # map: TAG -> message suffix to use |
||||||
|
variable fds ; # map: TAG -> handle of open channel to log to. |
||||||
|
variable header {} ; # per-line heading, subst'ed |
||||||
|
variable trailer {} ; # per-line ending, subst'ed |
||||||
|
|
||||||
|
# Notes: |
||||||
|
# - The tag '::' is reserved. "prefix" and "suffix" use it to store |
||||||
|
# the global message prefix / suffix. |
||||||
|
# - prefix and suffix are applied per message. |
||||||
|
# - header and trailer are per line. And should not generate multiple lines! |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## Ready |
||||||
|
|
||||||
|
package provide debug 1.0.6 |
||||||
|
return |
||||||
@ -0,0 +1,56 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Terminal packages - ANSI |
||||||
|
## Generic commands to define commands for code sequences. |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Requirements |
||||||
|
|
||||||
|
namespace eval ::term::ansi::code {} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## API. Escape clauses, plain and bracket |
||||||
|
## Used by 'define'd commands. |
||||||
|
|
||||||
|
proc ::term::ansi::code::esc {str} {return \033$str} |
||||||
|
proc ::term::ansi::code::escb {str} {esc \[$str} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## API. Define command for named control code, or constant. |
||||||
|
## (Simple definitions without arguments) |
||||||
|
|
||||||
|
proc ::term::ansi::code::define {name escape code} { |
||||||
|
proc [Qualified $name] {} [list ::term::ansi::code::$escape $code] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::term::ansi::code::const {name code} { |
||||||
|
proc [Qualified $name] {} [list return $code] |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Internal helper to construct fully-qualified names. |
||||||
|
|
||||||
|
proc ::term::ansi::code::Qualified {name} { |
||||||
|
if {![string match ::* $name]} { |
||||||
|
# Get the caller's namespace; append :: if it is not the |
||||||
|
# global namespace, for separation from the actual name. |
||||||
|
set ns [uplevel 2 [list namespace current]] |
||||||
|
if {$ns ne "::"} {append ns ::} |
||||||
|
set name $ns$name |
||||||
|
} |
||||||
|
return $name |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
|
||||||
|
namespace eval ::term::ansi::code { |
||||||
|
namespace export esc escb define const |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ready |
||||||
|
|
||||||
|
package provide term::ansi::code 0.2 |
||||||
|
|
||||||
|
## |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
@ -0,0 +1,108 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Terminal packages - ANSI - Attribute codes |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Requirements |
||||||
|
|
||||||
|
package require term::ansi::code ; # Constants |
||||||
|
|
||||||
|
namespace eval ::term::ansi::code::attr {} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## API. Symbolic names. |
||||||
|
|
||||||
|
proc ::term::ansi::code::attr::names {} { |
||||||
|
variable attr |
||||||
|
return $attr |
||||||
|
} |
||||||
|
|
||||||
|
proc ::term::ansi::code::attr::import {{ns attr} args} { |
||||||
|
if {![llength $args]} {set args *} |
||||||
|
set args ::term::ansi::code::attr::[join $args " ::term::ansi::code::attr::"] |
||||||
|
uplevel 1 [list namespace eval ${ns} [linsert $args 0 namespace import]] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Internal - Setup |
||||||
|
|
||||||
|
proc ::term::ansi::code::attr::DEF {name value} { |
||||||
|
variable attr |
||||||
|
const $name $value |
||||||
|
lappend attr $name |
||||||
|
namespace export $name |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::term::ansi::code::attr::INIT {} { |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## |
||||||
|
|
||||||
|
# Colors. Foreground <=> Text |
||||||
|
DEF fgblack 30 ; # Black |
||||||
|
DEF fgred 31 ; # Red |
||||||
|
DEF fggreen 32 ; # Green |
||||||
|
DEF fgyellow 33 ; # Yellow |
||||||
|
DEF fgblue 34 ; # Blue |
||||||
|
DEF fgmagenta 35 ; # Magenta |
||||||
|
DEF fgcyan 36 ; # Cyan |
||||||
|
DEF fgwhite 37 ; # White |
||||||
|
DEF fgdefault 39 ; # Default (Black) |
||||||
|
|
||||||
|
# Colors. Background. |
||||||
|
DEF bgblack 40 ; # Black |
||||||
|
DEF bgred 41 ; # Red |
||||||
|
DEF bggreen 42 ; # Green |
||||||
|
DEF bgyellow 43 ; # Yellow |
||||||
|
DEF bgblue 44 ; # Blue |
||||||
|
DEF bgmagenta 45 ; # Magenta |
||||||
|
DEF bgcyan 46 ; # Cyan |
||||||
|
DEF bgwhite 47 ; # White |
||||||
|
DEF bgdefault 49 ; # Default (Transparent) |
||||||
|
|
||||||
|
# Non-color attributes. Activation. |
||||||
|
DEF bold 1 ; # Bold |
||||||
|
DEF dim 2 ; # Dim |
||||||
|
DEF italic 3 ; # Italics |
||||||
|
DEF underline 4 ; # Underscore |
||||||
|
DEF blink 5 ; # Blink |
||||||
|
DEF revers 7 ; # Reverse |
||||||
|
DEF hidden 8 ; # Hidden |
||||||
|
DEF strike 9 ; # StrikeThrough |
||||||
|
|
||||||
|
# Non-color attributes. Deactivation. |
||||||
|
DEF nobold 22 ; # Bold |
||||||
|
DEF nodim __ ; # Dim |
||||||
|
DEF noitalic 23 ; # Italics |
||||||
|
DEF nounderline 24 ; # Underscore |
||||||
|
DEF noblink 25 ; # Blink |
||||||
|
DEF norevers 27 ; # Reverse |
||||||
|
DEF nohidden 28 ; # Hidden |
||||||
|
DEF nostrike 29 ; # StrikeThrough |
||||||
|
|
||||||
|
# Remainder |
||||||
|
DEF reset 0 ; # Reset |
||||||
|
|
||||||
|
## |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Data structures. |
||||||
|
|
||||||
|
namespace eval ::term::ansi::code::attr { |
||||||
|
namespace import ::term::ansi::code::const |
||||||
|
variable attr {} |
||||||
|
} |
||||||
|
|
||||||
|
::term::ansi::code::attr::INIT |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ready |
||||||
|
|
||||||
|
package provide term::ansi::code::attr 0.1 |
||||||
|
|
||||||
|
## |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
@ -0,0 +1,272 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Terminal packages - ANSI - Control codes |
||||||
|
|
||||||
|
## References |
||||||
|
# [0] Google: ansi terminal control |
||||||
|
# [1] http://vt100.net/docs/vt100-ug/chapter3.html |
||||||
|
# [2] http://www.termsys.demon.co.uk/vtansi.htm |
||||||
|
# [3] http://rrbrandt.dyndns.org:60000/docs/tut/redes/ansi.php |
||||||
|
# [4] http://www.dee.ufcg.edu.br/~rrbrandt/tools/ansi.html |
||||||
|
# [5] http://www.ecma-international.org/publications/standards/Ecma-048.htm |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Requirements |
||||||
|
|
||||||
|
package require term::ansi::code |
||||||
|
package require term::ansi::code::attr |
||||||
|
|
||||||
|
namespace eval ::term::ansi::code::ctrl {} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## API. Symbolic names. |
||||||
|
|
||||||
|
proc ::term::ansi::code::ctrl::names {} { |
||||||
|
variable ctrl |
||||||
|
return $ctrl |
||||||
|
} |
||||||
|
|
||||||
|
proc ::term::ansi::code::ctrl::import {{ns ctrl} args} { |
||||||
|
if {![llength $args]} {set args *} |
||||||
|
set args ::term::ansi::code::ctrl::[join $args " ::term::ansi::code::ctrl::"] |
||||||
|
uplevel 1 [list namespace eval $ns [linsert $args 0 namespace import]] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
|
||||||
|
## TODO = symbolic key codes for skd. |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Internal - Setup |
||||||
|
|
||||||
|
proc ::term::ansi::code::ctrl::DEF {name esc value} { |
||||||
|
variable ctrl |
||||||
|
define $name $esc $value |
||||||
|
lappend ctrl $name |
||||||
|
namespace export $name |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::term::ansi::code::ctrl::DEFC {name arguments script} { |
||||||
|
variable ctrl |
||||||
|
proc $name $arguments $script |
||||||
|
lappend ctrl $name |
||||||
|
namespace export $name |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::term::ansi::code::ctrl::INIT {} { |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## |
||||||
|
|
||||||
|
# Erasing |
||||||
|
|
||||||
|
DEF eeol escb K ; # Erase (to) End Of Line |
||||||
|
DEF esol escb 1K ; # Erase (to) Start Of Line |
||||||
|
DEF el escb 2K ; # Erase (current) Line |
||||||
|
DEF ed escb J ; # Erase Down (to bottom) |
||||||
|
DEF eu escb 1J ; # Erase Up (to top) |
||||||
|
DEF es escb 2J ; # Erase Screen |
||||||
|
|
||||||
|
# Scrolling |
||||||
|
|
||||||
|
DEF sd esc D ; # Scroll Down |
||||||
|
DEF su esc M ; # Scroll Up |
||||||
|
|
||||||
|
# Cursor Handling |
||||||
|
|
||||||
|
DEF ch escb H ; # Cursor Home |
||||||
|
DEF sc escb s ; # Save Cursor |
||||||
|
DEF rc escb u ; # Restore Cursor (Unsave) |
||||||
|
DEF sca esc 7 ; # Save Cursor + Attributes |
||||||
|
DEF rca esc 8 ; # Restore Cursor + Attributes |
||||||
|
|
||||||
|
# Tabbing |
||||||
|
|
||||||
|
DEF st esc H ; # Set Tab (@ current position) |
||||||
|
DEF ct escb g ; # Clear Tab (@ current position) |
||||||
|
DEF cat escb 3g ; # Clear All Tabs |
||||||
|
|
||||||
|
# Device Introspection |
||||||
|
|
||||||
|
DEF qdc escb c ; # Query Device Code |
||||||
|
DEF qds escb 5n ; # Query Device Status |
||||||
|
DEF qcp escb 6n ; # Query Cursor Position |
||||||
|
DEF rd esc c ; # Reset Device |
||||||
|
|
||||||
|
# Linewrap on/off |
||||||
|
|
||||||
|
DEF elw escb 7h ; # Enable Line Wrap |
||||||
|
DEF dlw escb 7l ; # Disable Line Wrap |
||||||
|
|
||||||
|
# Graphics Mode (aka use alternate font on/off) |
||||||
|
|
||||||
|
DEF eg esc F ; # Enter Graphics Mode |
||||||
|
DEF lg esc G ; # Exit Graphics Mode |
||||||
|
|
||||||
|
## |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Complex, parameterized codes |
||||||
|
|
||||||
|
# Select Character Set |
||||||
|
# Choose which char set is used for default and |
||||||
|
# alternate font. This does not change whether |
||||||
|
# default or alternate font are used |
||||||
|
|
||||||
|
DEFC scs0 {tag} {esc ($tag} ; # Set default character set |
||||||
|
DEFC scs1 {tag} {esc )$tag} ; # Set alternate character set |
||||||
|
|
||||||
|
# tags in A : United Kingdom Set |
||||||
|
# B : ASCII Set |
||||||
|
# 0 : Special Graphics |
||||||
|
# 1 : Alternate Character ROM Standard Character Set |
||||||
|
# 2 : Alternate Character ROM Special Graphics |
||||||
|
|
||||||
|
# Set Display Attributes |
||||||
|
|
||||||
|
DEFC sda {args} {escb [join $args \;]m} |
||||||
|
|
||||||
|
# Force Cursor Position (aka Go To) |
||||||
|
|
||||||
|
DEFC fcp {r c} {escb ${r}\;${c}f} |
||||||
|
|
||||||
|
# Cursor Up, Down, Forward, Backward |
||||||
|
|
||||||
|
DEFC cu {{n 1}} {escb [expr {$n == 1 ? "A" : "${n}A"}]} |
||||||
|
DEFC cd {{n 1}} {escb [expr {$n == 1 ? "B" : "${n}B"}]} |
||||||
|
DEFC cf {{n 1}} {escb [expr {$n == 1 ? "C" : "${n}C"}]} |
||||||
|
DEFC cb {{n 1}} {escb [expr {$n == 1 ? "D" : "${n}D"}]} |
||||||
|
|
||||||
|
# Scroll Screen (entire display, or between rows start end, inclusive). |
||||||
|
|
||||||
|
DEFC ss {args} { |
||||||
|
if {[llength $args] == 0} {return [escb r]} |
||||||
|
if {[llength $args] == 2} {foreach {s e} $args break ; return [escb ${s};${e}r]} |
||||||
|
return -code error "wrong\#args" |
||||||
|
} |
||||||
|
|
||||||
|
# Set Key Definition |
||||||
|
|
||||||
|
DEFC skd {code str} {escb $code\;\"$str\"p} |
||||||
|
|
||||||
|
# Terminal title |
||||||
|
|
||||||
|
DEFC title {str} {esc \]0\;$str\007} |
||||||
|
|
||||||
|
# Switch to and from character/box graphics. |
||||||
|
|
||||||
|
DEFC gron {} {esc (0} |
||||||
|
DEFC groff {} {esc (B} |
||||||
|
|
||||||
|
# Character graphics, box symbols |
||||||
|
# - 4 corners, 4 t-junctions, |
||||||
|
# one 4-way junction, 2 lines |
||||||
|
|
||||||
|
DEFC tlc {} {return [gron]l[groff]} ; # Top Left Corner |
||||||
|
DEFC trc {} {return [gron]k[groff]} ; # Top Right Corner |
||||||
|
DEFC brc {} {return [gron]j[groff]} ; # Bottom Right Corner |
||||||
|
DEFC blc {} {return [gron]m[groff]} ; # Bottom Left Corner |
||||||
|
|
||||||
|
DEFC ltj {} {return [gron]t[groff]} ; # Left T Junction |
||||||
|
DEFC ttj {} {return [gron]w[groff]} ; # Top T Junction |
||||||
|
DEFC rtj {} {return [gron]u[groff]} ; # Right T Junction |
||||||
|
DEFC btj {} {return [gron]v[groff]} ; # Bottom T Junction |
||||||
|
|
||||||
|
DEFC fwj {} {return [gron]n[groff]} ; # Four-Way Junction |
||||||
|
|
||||||
|
DEFC hl {} {return [gron]q[groff]} ; # Horizontal Line |
||||||
|
DEFC vl {} {return [gron]x[groff]} ; # Vertical Line |
||||||
|
|
||||||
|
# Optimize character graphics. The generator commands above create |
||||||
|
# way to many superfluous commands shifting into and out of the |
||||||
|
# graphics mode. The command below removes all shifts which are |
||||||
|
# not needed. To this end it also knows which characters will look |
||||||
|
# the same in both modes, to handle strings created outside this |
||||||
|
# package. |
||||||
|
|
||||||
|
DEFC groptim {string} { |
||||||
|
variable grforw |
||||||
|
variable grback |
||||||
|
set offon [groff][gron] |
||||||
|
set onoff [gron][groff] |
||||||
|
while {![string equal $string [set new [string map \ |
||||||
|
[list $offon {} $onoff {}] [string map \ |
||||||
|
$grback [string map \ |
||||||
|
$grforw $string]]]]]} { |
||||||
|
set string $new |
||||||
|
} |
||||||
|
return $string |
||||||
|
} |
||||||
|
|
||||||
|
## |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Higher level operations |
||||||
|
|
||||||
|
# Clear screen <=> CursorHome + EraseDown |
||||||
|
# Init (Fonts): Default ASCII, Alternate Graphics |
||||||
|
# Show a block of text at a specific location. |
||||||
|
|
||||||
|
DEFC clear {} {return [ch][ed]} |
||||||
|
DEFC init {} {return [scs0 B][scs1 0]} |
||||||
|
|
||||||
|
DEFC showat {r c text} { |
||||||
|
if {![string length $text]} {return {}} |
||||||
|
return [fcp $r $c][sca][join \ |
||||||
|
[split $text \n] \ |
||||||
|
[rca][cd][sca]][rca][cd] |
||||||
|
} |
||||||
|
|
||||||
|
## |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Attribute control (single attributes) |
||||||
|
|
||||||
|
foreach a [::term::ansi::code::attr::names] { |
||||||
|
DEF sda_$a escb [::term::ansi::code::attr::$a]m |
||||||
|
} |
||||||
|
|
||||||
|
## |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Data structures. |
||||||
|
|
||||||
|
namespace eval ::term::ansi::code::ctrl { |
||||||
|
namespace import ::term::ansi::code::define |
||||||
|
namespace import ::term::ansi::code::esc |
||||||
|
namespace import ::term::ansi::code::escb |
||||||
|
|
||||||
|
variable grforw |
||||||
|
variable grback |
||||||
|
variable _ |
||||||
|
|
||||||
|
foreach _ { |
||||||
|
! \" # $ % & ' ( ) * + , - . / |
||||||
|
0 1 2 3 4 5 6 7 8 9 : ; < = > |
||||||
|
? @ A B C D E F G H I J K L M |
||||||
|
N O P Q R S T U V W X Y Z [ ^ |
||||||
|
\\ ] |
||||||
|
} { |
||||||
|
lappend grforw \016$_ $_\016 |
||||||
|
lappend grback $_\017 \017$_ |
||||||
|
} |
||||||
|
unset _ |
||||||
|
} |
||||||
|
|
||||||
|
::term::ansi::code::ctrl::INIT |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ready |
||||||
|
|
||||||
|
package provide term::ansi::code::ctrl 0.3 |
||||||
|
|
||||||
|
## |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
@ -0,0 +1,93 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Terminal packages - ANSI - Higher level macros |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Requirements |
||||||
|
|
||||||
|
package require textutil::repeat |
||||||
|
package require textutil::tabify |
||||||
|
package require term::ansi::code::ctrl |
||||||
|
|
||||||
|
namespace eval ::term::ansi::code::macros {} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## API. Symbolic names. |
||||||
|
|
||||||
|
proc ::term::ansi::code::macros::import {{ns macros} args} { |
||||||
|
if {![llength $args]} {set args *} |
||||||
|
set args ::term::ansi::code::macros::[join $args " ::term::ansi::code::macros::"] |
||||||
|
uplevel 1 [list namespace eval ${ns} [linsert $args 0 namespace import]] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Higher level operations |
||||||
|
|
||||||
|
# Format a menu / framed block of text |
||||||
|
|
||||||
|
proc ::term::ansi::code::macros::menu {menu} { |
||||||
|
# Menu = dict (label => char) |
||||||
|
array set _ {} |
||||||
|
set shift 0 |
||||||
|
foreach {label c} $menu { |
||||||
|
if {[string first $c $label] < 0} { |
||||||
|
set shift 1 |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
set max 0 |
||||||
|
foreach {label c} $menu { |
||||||
|
set pos [string first $c $label] |
||||||
|
if {$shift || ($pos < 0)} { |
||||||
|
set xlabel "$c $label" |
||||||
|
set pos 0 |
||||||
|
} else { |
||||||
|
set xlabel $label |
||||||
|
} |
||||||
|
set len [string length $xlabel] |
||||||
|
if {$len > $max} {set max $len} |
||||||
|
set _($label) " [string replace $xlabel $pos $pos \ |
||||||
|
[cd::sda_fgred][cd::sda_bold][string index $xlabel $pos][cd::sda_reset]]" |
||||||
|
} |
||||||
|
|
||||||
|
append ms [cd::tlc][textutil::repeat::strRepeat [cd::hl] $max][cd::trc]\n |
||||||
|
foreach {l c} $menu {append ms $_($l)\n} |
||||||
|
append ms [cd::blc][textutil::repeat::strRepeat [cd::hl] $max][cd::brc] |
||||||
|
|
||||||
|
return [cd::groptim $ms] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::term::ansi::code::macros::frame {string} { |
||||||
|
set lines [split [textutil::tabify::untabify2 $string] \n] |
||||||
|
set max 0 |
||||||
|
foreach l $lines { |
||||||
|
if {[set len [string length $l]] > $max} {set max $len} |
||||||
|
} |
||||||
|
append fs [cd::tlc][textutil::repeat::strRepeat [cd::hl] $max][cd::trc]\n |
||||||
|
foreach l $lines { |
||||||
|
append fs [cd::vl]${l}[textutil::repeat::strRepeat " " [expr {$max-[string length $l]}]][cd::vl]\n |
||||||
|
} |
||||||
|
append fs [cd::blc][textutil::repeat::strRepeat [cd::hl] $max][cd::brc] |
||||||
|
return [cd::groptim $fs] |
||||||
|
} |
||||||
|
|
||||||
|
## |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Data structures. |
||||||
|
|
||||||
|
namespace eval ::term::ansi::code::macros { |
||||||
|
term::ansi::code::ctrl::import cd |
||||||
|
|
||||||
|
namespace export menu frame |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ready |
||||||
|
|
||||||
|
package provide term::ansi::code::macros 0.1 |
||||||
|
|
||||||
|
## |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
Loading…
Reference in new issue