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