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

performance refactoring, punk::args fixes

master
Julian Noble 6 months ago
parent
ac5a496f92
commit
8b32256c74
41 changed files with 1925 additions and 11217 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 1039
      src/bootsupport/modules/overtype-1.5.0.tm
  2. 963
      src/bootsupport/modules/overtype-1.5.1.tm
  3. 1037
      src/bootsupport/modules/overtype-1.5.3.tm
  4. 928
      src/bootsupport/modules/overtype-1.5.6.tm
  5. 998
      src/bootsupport/modules/overtype-1.5.7.tm
  6. 1756
      src/bootsupport/modules/overtype-1.5.9.tm
  7. 3292
      src/bootsupport/modules/overtype-1.6.0.tm
  8. 5
      src/modules/flagfilter-0.3.tm
  9. 4
      src/modules/funcl-0.1.tm
  10. 4
      src/modules/natsort-0.1.1.6.tm
  11. 6
      src/modules/patternpunk-1.1.tm
  12. 276
      src/modules/poshinfo-999999.0a1.0.tm
  13. 3
      src/modules/poshinfo-buildversion.txt
  14. 169
      src/modules/punk-0.1.tm
  15. 8
      src/modules/punk/ansi-999999.0a1.0.tm
  16. 120
      src/modules/punk/args-999999.0a1.0.tm
  17. 115
      src/modules/punk/cap-999999.0a1.0.tm
  18. 6
      src/modules/punk/cap/handlers/templates-999999.0a1.0.tm
  19. 376
      src/modules/punk/config-0.1.tm
  20. 1
      src/modules/punk/console-999999.0a1.0.tm
  21. 10
      src/modules/punk/du-999999.0a1.0.tm
  22. 8
      src/modules/punk/fileline-999999.0a1.0.tm
  23. 119
      src/modules/punk/lib-999999.0a1.0.tm
  24. 34
      src/modules/punk/mix-0.2.tm
  25. 2
      src/modules/punk/mix/base-0.1.tm
  26. 7
      src/modules/punk/mix/cli-0.3.tm
  27. 4
      src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm
  28. 4
      src/modules/punk/mix/templates/layouts/project/src/make.tcl
  29. 4
      src/modules/punk/mix/templates/modules/template_anyname-0.0.2.tm
  30. 89
      src/modules/punk/ns-999999.0a1.0.tm
  31. 17
      src/modules/punk/path-999999.0a1.0.tm
  32. 22
      src/modules/punk/repl-0.1.tm
  33. 28
      src/modules/punk/repl/codethread-999999.0a1.0.tm
  34. 6
      src/modules/punk/repo-999999.0a1.0.tm
  35. 8
      src/modules/punk/winpath-999999.0a1.0.tm
  36. 2
      src/modules/punkcheck-0.1.0.tm
  37. 110
      src/modules/shellfilter-0.1.9.tm
  38. 8
      src/modules/shellthread-1.6.1.tm
  39. 2
      src/modules/tcl9test-999999.0a1.0.tm
  40. 1550
      src/modules/textblock-999999.0a1.0.tm
  41. 2
      src/modules/winlibreoffice-999999.0a1.0.tm

1039
src/bootsupport/modules/overtype-1.5.0.tm
View File

File diff suppressed because it is too large Load Diff

963
src/bootsupport/modules/overtype-1.5.1.tm
Unescape View File

@ -1,963 +0,0 @@
# -*- 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) Julian Noble 2003-2023
#
# @@ Meta Begin
# Application overtype 1.5.1
# Meta platform tcl
# Meta license BSD
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin overtype_module_overtype 0 1.5.1]
#[copyright "2024"]
#[titledesc {overtype text layout - ansi aware}] [comment {-- Name section and table of contents description --}]
#[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}]
#[require overtype]
#[keywords module text ansi]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of overtype
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by overtype
#[list_begin itemized]
package require Tcl 8.6
package require textutil
package require punk::ansi ;#required to detect, split, strip and calculate lengths
package require punk::char ;#box drawing - and also unicode character width determination for proper layout of text with double-column-width chars
#*** !doctools
#[item] [package {Tcl 8.6}]
#[item] [package textutil]
#[item] [package punk::ansi]
#[para] - required to detect, split, strip and calculate lengths of text possibly containing ansi codes
#[item] [package punk::char]
#[para] - box drawing - and also unicode character width determination for proper layout of text with double-column-width chars
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
#Julian Noble <julian@precisium.com.au> - 2003
#Released under standard 'BSD license' conditions.
#
#todo - ellipsis truncation indicator for center,right
#v1.4 2023-07 - naive ansi color handling - todo - fix string range
# - need to extract and replace ansi codes?
namespace eval overtype {
namespace export *
variable default_ellipsis_horizontal "..." ;#fallback
variable default_ellipsis_vertical "..."
namespace eval priv {
proc _init {} {
upvar ::overtype::default_ellipsis_horizontal e_h
upvar ::overtype::default_ellipsis_vertical e_v
set e_h [format %c 0x2026] ;#Unicode Horizontal Ellipsis
set e_v [format %c 0x22EE]
#The unicode ellipsis looks more natural than triple-dash which is centred vertically whereas ellipsis is at floorline of text
#Also - unicode ellipsis has semantic meaning that other processors can interpret
#unicode does also provide a midline horizontal ellipsis 0x22EF
#set e [format %c 0x2504] ;#punk::char::charshort boxd_ltdshhz - Box Drawings Light Triple Dash Horizontal
#if {![catch {package require punk::char}]} {
# set e [punk::char::charshort boxd_ltdshhz]
#}
}
}
priv::_init
}
proc overtype::about {} {
return "Simple text formatting. Author JMN. BSD-License"
}
namespace eval overtype {
variable escape_terminals
#single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~).
dict set escape_terminals CSI [list @ \\ ^ _ ` | ~ 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 "\{" "\}"]
#dict set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic
dict set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals
#self-contained 2 byte ansi escape sequences - review more?
variable ansi_2byte_codes_dict
set ansi_2byte_codes_dict [dict create\
"reset_terminal" "\u001bc"\
"save_cursor_posn" "\u001b7"\
"restore_cursor_posn" "\u001b8"\
"cursor_up_one" "\u001bM"\
"NEL - Next Line" "\u001bE"\
"IND - Down one line" "\u001bD"\
"HTS - Set Tab Stop" "\u001bH"\
]
#debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway.
# "PM - Privacy Message" "\u001b^somethinghidden\033\\"\
}
#proc overtype::stripansi {text} {
# variable escape_terminals ;#dict
# variable ansi_2byte_codes_dict
# #important that we don't spend too much time on this for plain text that doesn't contain any escapes anyway
# if {[string first \033 $text] <0 && [string first \009c $text] <0} {
# #\033 same as \x1b
# return $text
# }
#
# set text [convert_g0 $text]
#
# #we process char by char - line-endings whether \r\n or \n should be processed as per any other character.
# #line endings can theoretically occur within an ansi escape sequence (review e.g title?)
# set inputlist [split $text ""]
# set outputlist [list]
#
# set 2bytecodes [dict values $ansi_2byte_codes_dict]
#
# set in_escapesequence 0
# #assumption - undertext already 'rendered' - ie no backspaces or carriagereturns or other cursor movement controls
# set i 0
# foreach u $inputlist {
# set v [lindex $inputlist $i+1]
# set uv ${u}${v}
# if {$in_escapesequence eq "2b"} {
# #2nd byte - done.
# set in_escapesequence 0
# } elseif {$in_escapesequence != 0} {
# set escseq [dict get $escape_terminals $in_escapesequence]
# if {$u in $escseq} {
# set in_escapesequence 0
# } elseif {$uv in $escseq} {
# set in_escapseequence 2b ;#flag next byte as last in sequence
# }
# } else {
# #handle both 7-bit and 8-bit CSI and OSC
# if {[regexp {^(?:\033\[|\u009b)} $uv]} {
# set in_escapesequence CSI
# } elseif {[regexp {^(?:\033\]|\u009c)} $uv]} {
# set in_escapesequence OSC
# } elseif {$uv in $2bytecodes} {
# #self-contained e.g terminal reset - don't pass through.
# set in_escapesequence 2b
# } else {
# lappend outputlist $u
# }
# }
# incr i
# }
# return [join $outputlist ""]
#}
proc overtype::string_columns {text} {
if {[punk::ansi::ta::detect $text]} {
error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with punk::ansi::stripansi. Alternatively try punk::ansi::printing_length"
}
return [punk::char::string_width $text]
}
#string range should generally be avoided for both undertext and overtext which contain ansi escapes and other cursor affecting chars such as \b and \r
proc overtype::left {args} {
# @c overtype starting at left (overstrike)
# @c can/should we use something like this?: 'format "%-*s" $len $overtext
variable default_ellipsis_horizontal
if {[llength $args] < 2} {
error {usage: ?-transparent [0|1]? ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext}
}
lassign [lrange $args end-1 end] underblock overblock
set defaults [dict create\
-ellipsis 0\
-ellipsistext $default_ellipsis_horizontal\
-overflow 0\
-transparent 0\
-exposed1 \uFFFD\
-exposed2 \uFFFD\
]
set known_opts [dict keys $defaults]
set argsflags [lrange $args 0 end-2]
dict for {k v} $argsflags {
if {$k ni $known_opts} {
error "overtype::left unknown option '$k'. Known options: $known_opts"
}
}
set opts [dict merge $defaults $argsflags]
# -- --- --- --- --- ---
set opt_transparent [dict get $opts -transparent]
set opt_ellipsistext [dict get $opts -ellipsistext]
set opt_exposed1 [dict get $opts -exposed1]
set opt_exposed2 [dict get $opts -exposed2]
# -- --- --- --- --- ---
set norm [list \r\n \n]
set underblock [string map $norm $underblock]
set overblock [string map $norm $overblock]
set underlines [split $underblock \n]
set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]]
set overlines [split $overblock \n]
set outputlines [list]
foreach undertext $underlines overtext $overlines {
set undertext_printlen [punk::ansi::printing_length $undertext]
set overlen [punk::ansi::printing_length $overtext]
set diff [expr {$overlen - $colwidth}]
#review
#append overtext "\033\[0m"
if {$diff > 0} {
#background line is narrower
set rendered [renderline -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow [dict get $opts -overflow] $undertext $overtext]
if {![dict get $opts -overflow]} {
#set overtext [string range $overtext 0 $colwidth-1] ;#string range won't be correct e.g if contains ansi codes or leading \r or \b etc
if {[dict get $opts -ellipsis]} {
set rendered [overtype::right $rendered $opt_ellipsistext]
}
}
lappend outputlines $rendered
} else {
#we know overtext is shorter or equal
lappend outputlines [renderline -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext]
}
}
return [join $outputlines \n]
}
namespace eval overtype::piper {
proc overcentre {args} {
if {[llength $args] < 2} {
error {usage: ?-bias left|right? ?-transparent [0|1|<regexp>]? ?-exposed1 <char>? ?-exposed2 <char>? ?-overflow [1|0]? overtext pipelinedata}
}
lassign [lrange $args end-1 end] over under
set argsflags [lrange $args 0 end-2]
tailcall overtype::centre {*}$argsflags $under $over
}
proc overleft {args} {
if {[llength $args] < 2} {
error {usage: ?-start <column>? ?-transparent [0|1|<regexp>]? ?-exposed1 <char>? ?-exposed2 <char>? ?-overflow [1|0]? overtext pipelinedata}
}
lassign [lrange $args end-1 end] over under
set argsflags [lrange $args 0 end-2]
tailcall overtype::left {*}$argsflags $under $over
}
}
#todo - left-right ellipsis ?
proc overtype::centre {args} {
variable default_ellipsis_horizontal
if {[llength $args] < 2} {
error {usage: ?-transparent [0|1]? ?-bias [left|right]? ?-overflow [1|0]? undertext overtext}
}
foreach {underblock overblock} [lrange $args end-1 end] break
set defaults [dict create\
-bias left\
-ellipsis 0\
-ellipsistext $default_ellipsis_horizontal\
-overflow 0\
-transparent 0\
-exposed1 \uFFFD\
-exposed2 \uFFFD\
]
set known_opts [dict keys $defaults]
set argsflags [lrange $args 0 end-2]
dict for {k v} $argsflags {
if {$k ni $known_opts} {
error "overtype::centre unknown option '$k'. Known options: $known_opts"
}
}
set opts [dict merge $defaults $argsflags]
# -- --- --- --- --- ---
set opt_transparent [dict get $opts -transparent]
set opt_ellipsistext [dict get $opts -ellipsistext]
set opt_exposed1 [dict get $opts -exposed1]
set opt_exposed2 [dict get $opts -exposed2]
# -- --- --- --- --- ---
set norm [list \r\n \n]
set underblock [string map $norm $underblock]
set overblock [string map $norm $overblock]
set underlines [split $underblock \n]
set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]]
set overlines [split $overblock \n]
set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]]
set outputlines [list]
foreach undertext $underlines overtext $overlines {
#set olen [punk::ansi::printing_length $overtext]
set ulen [punk::ansi::printing_length $undertext]
if {$ulen < $colwidth} {
set udiff [expr {$colwidth - $ulen}]
set undertext "$undertext[string repeat { } $udiff]"
}
#review
#append overtext "\033\[0m"
set under_exposed [expr {$colwidth - $overblock_width}]
if {$under_exposed > 0} {
#background block is wider
if {$under_exposed % 2 == 0} {
#even left/right exposure
set left_exposed [expr {$under_exposed / 2}]
} else {
set beforehalf [expr {$under_exposed / 2}] ;#1 less than half due to integer division
if {[string tolower [dict get $opts -bias]] eq "left"} {
set left_exposed $beforehalf
} else {
#bias to the right
set left_exposed [expr {$beforehalf + 1}]
}
}
if 0 {
set rhs [expr {$diff - $half - 1}]
set lhs [expr {$half - 1}]
set rhsoffset [expr {$rhs +1}]
set a [string range $undertext 0 $lhs]
set background [string range $undertext $lhs+1 end-$rhsoffset]
set b [renderline -transparent $opt_transparent $background $overtext]
set c [string range $undertext end-$rhs end]
lappend outputlines $a$b$c
}
lappend outputlines [renderline -start $left_exposed -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext]
} else {
#overlay wider or equal
set rendered [renderline -transparent $opt_transparent -overflow [dict get $opts -overflow] $undertext $overtext]
if {$under_exposed < 0} {
#overlay is wider - trim if overflow not specified in opts
if {![dict get $opts -overflow]} {
#lappend outputlines [string range $overtext 0 [expr {$colwidth - 1}]]
#set overtext [string range $overtext 0 $colwidth-1 ]
if {[dict get $opts -ellipsis]} {
set rendered [overtype::right $rendered $opt_ellipsistext]
}
}
} else {
#zero under_exposed - widths match
}
lappend outputlines $rendered
#lappend outputlines [renderline -transparent $opt_transparent $undertext $overtext]
}
}
return [join $outputlines \n]
}
proc overtype::right {args} {
variable default_ellipsis_horizontal
# @d !todo - implement overflow, length checks etc
if {[llength $args] < 2} {
error {usage: ?-overflow [1|0]? undertext overtext}
}
foreach {underblock overblock} [lrange $args end-1 end] break
set defaults [dict create\
-bias left\
-ellipsis 0\
-ellipsistext $default_ellipsis_horizontal\
-overflow 0\
-transparent 0\
-exposed1 \uFFFD\
-exposed2 \uFFFD\
]
set known_opts [dict keys $defaults]
set argsflags [lrange $args 0 end-2]
dict for {k v} $argsflags {
if {$k ni $known_opts} {
error "overtype::centre unknown option '$k'. Known options: $known_opts"
}
}
set opts [dict merge $defaults $argsflags]
# -- --- --- --- --- ---
set opt_transparent [dict get $opts -transparent]
set opt_ellipsis [dict get $opts -ellipsis]
set opt_ellipsistext [dict get $opts -ellipsistext]
set opt_overflow [dict get $opts -overflow]
set opt_exposed1 [dict get $opts -exposed1]
set opt_exposed2 [dict get $opts -exposed2]
# -- --- --- --- --- ---
set norm [list \r\n \n]
set underblock [string map $norm $underblock]
set overblock [string map $norm $overblock]
set underlines [split $underblock \n]
set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]]
set overlines [split $overblock \n]
set outputlines [list]
foreach undertext $underlines overtext $overlines {
set olen [punk::ansi::printing_length $overtext]
set ulen [punk::ansi::printing_length $undertext]
if {$ulen < $colwidth} {
set udiff [expr {$colwidth - $ulen}]
set undertext "$undertext[string repeat { } $udiff]"
}
#review
#append overtext "\033\[0m"
set overflowlength [expr {$olen - $colwidth}]
if {$overflowlength > 0} {
#overtext wider than undertext column
set rendered [renderline -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow $opt_overflow -start 0 $undertext $overtext]
if {!$opt_overflow} {
if {$opt_ellipsis} {
set rendered [overtype::right $rendered $opt_ellipsistext]
}
}
lappend outputlines $rendered
} else {
#lappend outputlines [string range $undertext 0 end-$olen]$overtext
lappend outputlines [renderline -transparent $opt_transparent -start [expr {$colwidth - $olen}] $undertext $overtext]
}
}
return [join $outputlines \n]
}
# -- --- --- --- --- --- --- --- --- --- ---
proc overtype::transparentline {args} {
foreach {under over} [lrange $args end-1 end] break
set argsflags [lrange $args 0 end-2]
set defaults [dict create\
-transparent 1\
-exposed 1 " "\
-exposed 2 " "\
]
set newargs [dict merge $defaults $argsflags]
tailcall overtype::renderline {*}$newargs $under $over
}
#renderline may not make sense as it is in the long run for blocks of text - but is handy in the single-line-handling form anyway.
# We are trying to handle ansi codes in a block of text which is acting like a mini-terminal in some sense.
#We can process standard cursor moves such as \b \r - but no way to respond to other cursor movements e.g moving to other lines.
#
namespace eval overtype::piper {
proc renderline {args} {
if {[llength $args] < 2} {
error {usage: ?-start <int>? ?-transparent [0|1|<regexp>]? ?-overflow [1|0]? overtext pipelinedata}
}
foreach {over under} [lrange $args end-1 end] break
set argsflags [lrange $args 0 end-2]
tailcall overtype::renderline {*}$argsflags $under $over
}
}
interp alias "" piper_renderline "" overtype::piper::renderline
#-returnextra to enable returning of overflow and length
# todo - use punk::ansi::ta::detect to short-circuit processing and do simple string calcs as an optimisation?
#review - DECSWL/DECDWL double width line codes - very difficult/impossible to align and compose with other elements
#todo - review transparency issues with single/double width characters!
proc overtype::renderline {args} {
if {[llength $args] < 2} {
error {usage: ?-start <int>? ?-transparent [0|1|<regexp>]? ?-overflow [1|0]? undertext overtext}
}
lassign [lrange $args end-1 end] under over
if {[string first \n $under] >=0 || [string first \n $over] >= 0} {
error "overtype::renderline not allowed to contain newlines"
}
set defaults [dict create\
-overflow 0\
-transparent 0\
-start 0\
-returnextra 0\
-exposed1 \uFFFD\
-exposed2 \uFFFD\
]
#exposed1 and exposed2 for first and second col of underying 2wide char which is truncated by transparency or overflow
set known_opts [dict keys $defaults]
set argsflags [lrange $args 0 end-2]
dict for {k v} $argsflags {
if {$k ni $known_opts} {
error "overtype::renderline unknown option '$k'. Known options: $known_opts"
}
}
set opts [dict merge $defaults $argsflags]
# -- --- --- --- --- --- --- --- --- --- --- ---
set opt_overflow [dict get $opts -overflow]
set opt_colstart [dict get $opts -start]
# -- --- --- --- --- --- --- --- --- --- --- ---
set opt_transparent [dict get $opts -transparent]
if {$opt_transparent eq "0"} {
set do_transparency 0
} else {
set do_transparency 1
if {$opt_transparent eq "1"} {
set opt_transparent {[\s]}
}
}
# -- --- --- --- --- --- --- --- --- --- --- ---
set opt_returnextra [dict get $opts -returnextra]
# -- --- --- --- --- --- --- --- --- --- --- ---
set opt_exposed1 [dict get $opts -exposed1]
set opt_exposed2 [dict get $opts -exposed2]
# -- --- --- --- --- --- --- --- --- --- --- ---
#-----
#
if {[string first \t $under] >= 0} {
#set under [textutil::tabify::untabify2 $under]
set under [textutil::tabify::untabifyLine $under 8] ;#8 is default for untabify2 - review
}
set overdata $over
if {[string first \t $over] >= 0} {
#set overdata [textutil::tabify::untabify2 $over]
set overdata [textutil::tabify::untabifyLine $over 8]
}
#-------
#ta_detect ansi and do simpler processing?
# -- --- --- --- --- --- --- ---
set undermap [punk::ansi::ta::split_codes_single $under]
set understacks [dict create]
set i_u -1
set i_o 0
set out [list]
set u_codestack [list]
set pt_underchars "" ;#for string_columns length calculation for overflow 0 truncation
set remainder [list] ;#for returnextra
foreach {pt code} $undermap {
#pt = plain text
append pt_underchars $pt
foreach ch [split $pt ""] {
set width [punk::char::string_width $ch]
incr i_u
dict set understacks $i_u $u_codestack
lappend out $ch
if {$width > 1} {
#presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?)
incr i_u
dict set understacks $i_u $u_codestack
lappend out ""
}
}
#underlay should already have been rendered and not have non-sgr codes - but let's check for and not stack them if other codes are here
if {[priv::is_sgr $code]} {
if {[priv::has_sgr_leadingreset $code]} {
set u_codestack [list $code]
} else {
lappend u_codestack $code
}
}
#consider also other codes that should be stacked..?
}
#trailing codes in effect for underlay
if {[llength $undermap]} {
dict set understacks [expr {$i_u + 1}] $u_codestack
}
# -- --- --- --- --- --- --- ---
####
#if opt_colstart - we need to build a space (or any singlewidth char really) padding on the left of the right number of columns.
#this will be processed as transparent - and handle doublewidth underlay characters appropriately
set startpad [string repeat " " $opt_colstart]
append startpad $overdata ;#overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency
set overmap [punk::ansi::ta::split_codes_single $startpad]
####
set overstacks [dict create]
set o_codestack [list]
set pt_overchars ""
foreach {pt code} $overmap {
append pt_overchars $pt
foreach ch [split $pt ""] {
dict set overstacks $i_o $o_codestack
incr i_o
}
if {[priv::is_sgr $code]} {
#only stack SGR (graphics rendition) codes - not title sets, cursor moves etc
if {[priv::has_sgr_leadingreset $code]} {
#m code which has sgr reset at start - no need to replay prior sgr codes
set o_codestack [list $code]
} else {
lappend o_codestack $code
}
}
}
# -- --- --- --- --- --- --- ---
set bs [format %c 0x08]
set idx 0 ;# line index (cursor - 1)
set idx_over -1
foreach {pt code} $overmap {
set ptchars [split $pt ""] ;#for lookahead
#emit plaintext chars first using existing SGR codes from under/over stack as appropriate
#then check if the following code is a cursor movement within the line and adjust index if so
foreach ch $ptchars {
incr idx_over
if {$ch eq "\r"} {
set idx $opt_colstart
} elseif {$ch eq "\b"} {
#review - backspace effect on double-width chars
if {$idx > $opt_colstart} {
incr idx -1
}
} elseif {($idx < $opt_colstart)} {
incr idx
} elseif {($do_transparency && [regexp $opt_transparent $ch])} {
#pre opt_colstart is effectively transparent (we have applied padding of required number of columns to left of overlay)
set owidth [punk::char::string_width $ch]
if {$idx > [llength $out]-1} {
lappend out " "
dict set understacks $idx [list] ;#review - use idx-1 codestack?
incr idx
} else {
set uwidth [punk::char::string_width [lindex $out $idx]]
if {[lindex $out $idx] eq ""} {
#2nd col of 2-wide char in underlay
incr idx
} elseif {$uwidth == 0} {
#e.g combining diacritic
incr idx
} elseif {$uwidth == 1} {
incr idx
if {$owidth > 1} {
incr idx
}
} elseif {$uwidth > 1} {
if {[punk::char::string_width $ch] == 1} {
#normal singlewide transparency
set next_pt_overchar [string index $pt_overchars $idx_over+1] ;#lookahead of next plain-text char in overlay
if {$next_pt_overchar eq ""} {
#special-case trailing transparent - no next_pt_overchar
incr idx
} else {
if {[regexp $opt_transparent $next_pt_overchar]} {
incr idx
} else {
#next overlay char is not transparent.. first-half of underlying 2wide char is exposed
priv::render_addchar $idx $opt_exposed1 [dict get $overstacks $idx_over]
incr idx
}
}
} else {
#2wide transparency over 2wide in underlay
incr idx
}
}
}
} else {
#non-transparent char in overlay
set owidth [punk::char::string_width $ch]
set uwidth [punk::char::string_width [lindex $out $idx]]
if {[lindex $out $idx] eq ""} {
#2nd col of 2wide char in underlay
priv::render_addchar $idx $ch [dict get $overstacks $idx_over]
incr idx
} elseif {$uwidth == 0} {
#e.g combining diacritic - increment before over char REVIEW
#arguably the previous overchar should have done this - ie lookahead for combiners?
priv::render_addchar $idx "" [dict get $overstacks $idx_over]
incr idx
priv::render_addchar $idx $ch [dict get $overstacks $idx_over]
incr idx
} elseif {$uwidth == 1} {
if {$owidth == 1} {
priv::render_addchar $idx $ch [dict get $overstacks $idx_over]
incr idx
} else {
priv::render_addchar $idx $ch [dict get $overstacks $idx_over]
incr idx
priv::render_addchar $idx "" [dict get $overstacks $idx_over]
}
} elseif {$uwidth > 1} {
if {$owidth == 1} {
priv::render_addchar $idx $ch [dict get $overstacks $idx_over]
incr idx
priv::render_addchar $idx $opt_exposed2 [dict get $overstacks $idx_over]
#don't incr idx - we are just putting a broken-indication in the underlay - which may get overwritten by next overlay char
} else {
#2wide over 2wide
priv::render_addchar $idx $ch [dict get $overstacks $idx_over]
incr idx
}
}
}
}
#check following code
if {![priv::is_sgr $code]} {
}
}
if {$opt_overflow == 0} {
#need to truncate to the width of the original undertext
#review - string_width vs printing_length here. undertext requirement to be already rendered therefore punk::char::string_width ok?
set num_under_columns [punk::char::string_width $pt_underchars] ;#plaintext underchars
}
#coalesce and replay codestacks for out char list
set outstring ""
set remstring "" ;#remainder after overflow point reached
set i 0
set cstack [list]
set prevstack [list]
set out_rawchars ""; #for overflow counting
set output_to "outstring" ;#var in effect depending on overflow
set in_overflow 0 ;#used to stop char-width scanning once in overflow
foreach ch $out {
append out_rawchars $ch
if {$opt_overflow == 0 && !$in_overflow} {
if {[set nextvisualwidth [punk::char::string_width $out_rawchars]] < $num_under_columns} {
} else {
#todo - check if we overflowed with a double-width char ?
#store visualwidth which may be short
set in_overflow 1
}
}
set cstack [dict get $understacks $i]
if {$cstack ne $prevstack} {
if {[llength $prevstack]} {
append $output_to \033\[m
}
foreach code $cstack {
append $output_to $code
}
}
append $output_to $ch
set prevstack $cstack
incr i
if {$in_overflow} {
set output_to "remstring"
}
}
if {[dict size $understacks] > 0} {
append $output_to [join [dict get $understacks [expr {[dict size $understacks]-1}]] ""] ;#tail codes
}
if {[string length $remstring]} {
#puts stderr "remainder:$remstring"
}
#pdict $understacks
if {$opt_returnextra} {
return [list $outstring $visualwidth [string length $outstring] $remstring]
} else {
return $outstring
}
#return [join $out ""]
}
proc overtype::test_renderline {} {
set t \uFF5E ;#2-wide tilde
set u \uFF3F ;#2-wide underscore
set missing \uFFFD
return [list $t $u A${t}B]
}
namespace eval overtype::priv {
#todo - move to punk::ansi::codetype
proc is_sgr {code} {
#SGR (Select Graphic Rendition) - codes ending in 'm' - e.g colour/underline
#we will accept and pass through the less common colon separator (ITU Open Document Architecture)
#Terminals should generally ignore it if they don't use it
regexp {\033\[[0-9;:]*m$} $code
}
proc is_cursor_move_in_line {code} {
#review - what about CSI n : m H where row n happens to be current line?
regexp {\033\[[0-9]*(:?C|D|G)$}
}
#pure SGR reset
proc is_sgr_reset {code} {
#todo 8-bit csi
regexp {\033\[0*m$} $code
}
#whether this code has 0 (or equivalently empty) parameter (but may set others)
#if an SGR code as a reset in it - we don't need to carry forward any previous SGR codes
#it generally only makes sense for the reset to be the first entry - otherwise the code has ineffective portions
#However - detecting zero or empty parameter in other positions requires knowing all other codes that may allow zero or empty params.
#We will only look at initial parameter as this is the well-formed normal case.
#Review - consider normalizing sgr codes to remove other redundancies such as setting fg or bg color twice in same code
proc has_sgr_leadingreset {code} {
set params ""
regexp {\033\[(.*)m} $code _match params
set plist [split $params ";"]
if {[string trim [lindex $plist 0] 0] eq ""} {
#e.g \033\[m \033\[0\;...m \033\[0000...m
return 1
} else {
return 0
}
}
#has_sgr_reset - rather than support this - create an sgr normalize function that removes dead params and brings reset to front of param list
proc render_addchar {i c stack} {
upvar out o
upvar understacks ustacks
set nxt [llength $o]
if {$i < $nxt} {
lset o $i $c
} else {
lappend o $c
}
dict set ustacks $i $stack
}
}
# -- --- --- --- --- --- --- --- --- --- ---
if 0 {
namespace eval overtype::ta {
namespace path ::overtype
# *based* on but not identical to:
#https://github.com/perlancar/perl-Text-ANSI-Util/blob/master/lib/Text/ANSI/BaseUtil.pm
#handle both 7-bit and 8-bit csi
#review - does codepage affect this? e.g ebcdic has 8bit csi in different position
#CSI
#variable re_csi_open {(?:\033\[|\u009b)[0-9;]+} ;#too specific - doesn't detect \033\[m
variable re_csi_open {(?:\033\[|\u009b])}
#colour and style
variable re_csi_colour {(?:\033\[|\u009b)[0-9;]*m} ;#e.g \033\[31m \033\[m \033\[0m \033\[m0000m
#single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~).
variable re_csi_code {(?:\033\[|\u009b])[0-9;]*[a-zA-Z\\@^_|~`]}
#OSC - termnate with BEL (\a \007) or ST (string terminator \033\\)
#variable re_esc_osc1 {(?:\033\]|\u009c).*\007}
#variable re_esc_osc2 {(?:\033\]|\u009c).*\033\\}
#test - non-greedy
variable re_esc_osc1 {(?:\033\]|\u009c).*?\007}
variable re_esc_osc2 {(?:\033\]|\u009c).*?\033\\}
variable re_ansi_detect "${re_csi_open}|${re_esc_osc1}|${re_esc_osc2}"
#detect any ansi escapes
#review - only detect 'complete' codes - or just use the opening escapes for performance?
#proc detect {text} {
# variable re_ansi_detect
# #variable re_csi_open
# #variable re_esc_osc1
# #variable re_esc_osc2
# #todo - other escape sequences
# #expr {[regexp $re_csi_open $text] || [regexp $re_esc_osc1 $text] || [regexp $re_esc_osc2 $text]}
# expr {[regexp $re_ansi_detect $text]}
#}
#not in perl ta
#proc detect_csi {text} {
# variable re_csi_colour
# expr {[regexp $re_csi_colour $text]}
#}
proc strip {text} {
tailcall punk::ansi::stripansi $text
}
#note this is character length after stripping ansi codes - not the printing length
proc length {text} {
string length [punk::ansi::stripansi $text]
}
# -- --- --- --- --- ---
#Split $text to a list containing alternating ANSI color codes and text.
#ANSI color codes are always on the second element, fourth, and so on.
#(ie plaintext on odd list-indices ansi on even indices)
# Example:
#ta_split_codes "" # => ""
#ta_split_codes "a" # => "a"
#ta_split_codes "a\e[31m" # => {"a" "\e[31m"}
#ta_split_codes "\e[31ma" # => {"" "\e[31m" "a"}
#ta_split_codes "\e[31ma\e[0m" # => {"" "\e[31m" "a" "\e[0m"}
#ta_split_codes "\e[31ma\e[0mb" # => {"" "\e[31m" "a" "\e[0m", "b"}
#ta_split_codes "\e[31m\e[0mb" # => {"" "\e[31m\e[0m" "b"}
#
#proc split_codes {text} {
# variable re_esc_osc1
# variable re_esc_osc2
# variable re_csi_code
# set re "(?:${re_csi_code}|${re_esc_osc1}|${re_esc_osc2})+"
# return [_perlish_split $re $text]
#}
##like split_codes - but each ansi-escape is split out separately (with empty string of plaintext between codes so odd/even plain ansi still holds)
#proc split_codes_single {text} {
# variable re_esc_osc1
# variable re_esc_osc2
# variable re_csi_code
# set re "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}"
# return [_perlish_split $re $text]
#}
##review - tcl greedy expressions may match multiple in one element
#proc _perlish_split {re text} {
# if {[string length $text] == 0} {
# return {}
# }
# set list [list]
# set start 0
# while {[regexp -start $start -indices -- $re $text match]} {
# lassign $match matchStart matchEnd
# lappend list [string range $text $start $matchStart-1] [string range $text $matchStart $matchEnd]
# set start [expr {$matchEnd+1}]
# }
# lappend list [string range $text $start end]
# return $list
#}
## -- --- --- --- --- ---
}
} ;# end if 0
# -- --- --- --- --- --- --- --- --- --- ---
namespace eval overtype {
interp alias {} ::overtype::center {} ::overtype::centre
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide overtype [namespace eval overtype {
variable version
set version 1.5.1
}]
return
#*** !doctools
#[manpage_end]

1037
src/bootsupport/modules/overtype-1.5.3.tm
View File

File diff suppressed because it is too large Load Diff

928
src/bootsupport/modules/overtype-1.5.6.tm
Unescape View File

@ -1,928 +0,0 @@
# -*- 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) Julian Noble 2003-2023
#
# @@ Meta Begin
# Application overtype 1.5.6
# Meta platform tcl
# Meta license BSD
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin overtype_module_overtype 0 1.5.6]
#[copyright "2024"]
#[titledesc {overtype text layout - ansi aware}] [comment {-- Name section and table of contents description --}]
#[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}]
#[require overtype]
#[keywords module text ansi]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of overtype
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by overtype
#[list_begin itemized]
package require Tcl 8.6
package require textutil
package require punk::lib ;#required for lines_as_list
package require punk::ansi ;#required to detect, split, strip and calculate lengths
package require punk::char ;#box drawing - and also unicode character width determination for proper layout of text with double-column-width chars
#*** !doctools
#[item] [package {Tcl 8.6}]
#[item] [package textutil]
#[item] [package punk::ansi]
#[para] - required to detect, split, strip and calculate lengths of text possibly containing ansi codes
#[item] [package punk::char]
#[para] - box drawing - and also unicode character width determination for proper layout of text with double-column-width chars
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
#Julian Noble <julian@precisium.com.au> - 2003
#Released under standard 'BSD license' conditions.
#
#todo - ellipsis truncation indicator for center,right
#v1.4 2023-07 - naive ansi color handling - todo - fix string range
# - need to extract and replace ansi codes?
namespace eval overtype {
namespace export *
variable default_ellipsis_horizontal "..." ;#fallback
variable default_ellipsis_vertical "..."
namespace eval priv {
proc _init {} {
upvar ::overtype::default_ellipsis_horizontal e_h
upvar ::overtype::default_ellipsis_vertical e_v
set e_h [format %c 0x2026] ;#Unicode Horizontal Ellipsis
set e_v [format %c 0x22EE]
#The unicode ellipsis looks more natural than triple-dash which is centred vertically whereas ellipsis is at floorline of text
#Also - unicode ellipsis has semantic meaning that other processors can interpret
#unicode does also provide a midline horizontal ellipsis 0x22EF
#set e [format %c 0x2504] ;#punk::char::charshort boxd_ltdshhz - Box Drawings Light Triple Dash Horizontal
#if {![catch {package require punk::char}]} {
# set e [punk::char::charshort boxd_ltdshhz]
#}
}
}
priv::_init
}
proc overtype::about {} {
return "Simple text formatting. Author JMN. BSD-License"
}
namespace eval overtype {
variable escape_terminals
#single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~).
dict set escape_terminals CSI [list @ \\ ^ _ ` | ~ 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 "\{" "\}"]
#dict set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic
dict set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals
#self-contained 2 byte ansi escape sequences - review more?
variable ansi_2byte_codes_dict
set ansi_2byte_codes_dict [dict create\
"reset_terminal" "\u001bc"\
"save_cursor_posn" "\u001b7"\
"restore_cursor_posn" "\u001b8"\
"cursor_up_one" "\u001bM"\
"NEL - Next Line" "\u001bE"\
"IND - Down one line" "\u001bD"\
"HTS - Set Tab Stop" "\u001bH"\
]
#debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway.
# "PM - Privacy Message" "\u001b^somethinghidden\033\\"\
}
#proc overtype::stripansi {text} {
# variable escape_terminals ;#dict
# variable ansi_2byte_codes_dict
# #important that we don't spend too much time on this for plain text that doesn't contain any escapes anyway
# if {[string first \033 $text] <0 && [string first \009c $text] <0} {
# #\033 same as \x1b
# return $text
# }
#
# set text [convert_g0 $text]
#
# #we process char by char - line-endings whether \r\n or \n should be processed as per any other character.
# #line endings can theoretically occur within an ansi escape sequence (review e.g title?)
# set inputlist [split $text ""]
# set outputlist [list]
#
# set 2bytecodes [dict values $ansi_2byte_codes_dict]
#
# set in_escapesequence 0
# #assumption - undertext already 'rendered' - ie no backspaces or carriagereturns or other cursor movement controls
# set i 0
# foreach u $inputlist {
# set v [lindex $inputlist $i+1]
# set uv ${u}${v}
# if {$in_escapesequence eq "2b"} {
# #2nd byte - done.
# set in_escapesequence 0
# } elseif {$in_escapesequence != 0} {
# set escseq [dict get $escape_terminals $in_escapesequence]
# if {$u in $escseq} {
# set in_escapesequence 0
# } elseif {$uv in $escseq} {
# set in_escapseequence 2b ;#flag next byte as last in sequence
# }
# } else {
# #handle both 7-bit and 8-bit CSI and OSC
# if {[regexp {^(?:\033\[|\u009b)} $uv]} {
# set in_escapesequence CSI
# } elseif {[regexp {^(?:\033\]|\u009c)} $uv]} {
# set in_escapesequence OSC
# } elseif {$uv in $2bytecodes} {
# #self-contained e.g terminal reset - don't pass through.
# set in_escapesequence 2b
# } else {
# lappend outputlist $u
# }
# }
# incr i
# }
# return [join $outputlist ""]
#}
proc overtype::string_columns {text} {
if {[punk::ansi::ta::detect $text]} {
#error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with punk::ansi::stripansi. Alternatively try punk::ansi::printing_length"
set text [punk::ansi::stripansi $text]
}
return [punk::char::string_width $text]
}
#string range should generally be avoided for both undertext and overtext which contain ansi escapes and other cursor affecting chars such as \b and \r
proc overtype::left {args} {
# @c overtype starting at left (overstrike)
# @c can/should we use something like this?: 'format "%-*s" $len $overtext
variable default_ellipsis_horizontal
if {[llength $args] < 2} {
error {usage: ?-transparent [0|1]? ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext}
}
lassign [lrange $args end-1 end] underblock overblock
set defaults [dict create\
-bias ignored\
-ellipsis 0\
-ellipsistext $default_ellipsis_horizontal\
-ellipsiswhitespace 0\
-overflow 0\
-transparent 0\
-exposed1 \uFFFD\
-exposed2 \uFFFD\
]
set known_opts [dict keys $defaults]
set argsflags [lrange $args 0 end-2]
dict for {k v} $argsflags {
if {$k ni $known_opts} {
error "overtype::left unknown option '$k'. Known options: $known_opts"
}
}
set opts [dict merge $defaults $argsflags]
# -- --- --- --- --- ---
set opt_transparent [dict get $opts -transparent]
set opt_ellipsistext [dict get $opts -ellipsistext]
set opt_ellipsiswhitespace [dict get $opts -ellipsiswhitespace]
set opt_exposed1 [dict get $opts -exposed1] ;#widechar_exposed_left - todo
set opt_exposed2 [dict get $opts -exposed2] ;#widechar_exposed_right - todo
# -- --- --- --- --- ---
set norm [list \r\n \n]
set underblock [string map $norm $underblock]
set overblock [string map $norm $overblock]
set underlines [split $underblock \n]
#set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]]
lassign [blocksize $underblock] _w colwidth _h colheight
set overlines [split $overblock \n]
#set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]]
lassign [blocksize $overblock] _w overblock_width _h overblock_height
set under_exposed_max [expr {$colwidth - $overblock_width}]
set right_exposed $under_exposed_max
set outputlines [list]
foreach undertext $underlines overtext $overlines {
set undertext_printlen [punk::ansi::printing_length $undertext]
if {$undertext_printlen < $colwidth} {
set udiff [expr {$colwidth - $undertext_printlen}]
set undertext "$undertext[string repeat { } $udiff]"
}
set overtext_printlen [punk::ansi::printing_length $overtext]
set overflowlength [expr {$overtext_printlen - $colwidth}]
#review
#append overtext "\033\[0m"
if {$overflowlength > 0} {
#background line is narrower than data in line
set rendered [renderline -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow [dict get $opts -overflow] $undertext $overtext]
if {![dict get $opts -overflow]} {
#set overtext [string range $overtext 0 $colwidth-1] ;#string range won't be correct e.g if contains ansi codes or leading \r or \b etc
if {[dict get $opts -ellipsis]} {
set show_ellipsis 1
if {!$opt_ellipsiswhitespace} {
#we don't want ellipsis if only whitespace was lost
set lostdata [string range $overtext end-[expr {$overflowlength-1}] end]
if {[string trim $lostdata] eq ""} {
set show_ellipsis 0
}
}
if {$show_ellipsis} {
set rendered [overtype::right $rendered $opt_ellipsistext]
}
}
}
lappend outputlines $rendered
} else {
#we know overtext data is shorter or equal (for this line)
lappend outputlines [renderline -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext]
}
}
return [join $outputlines \n]
}
namespace eval overtype::piper {
proc overcentre {args} {
if {[llength $args] < 2} {
error {usage: ?-bias left|right? ?-transparent [0|1|<regexp>]? ?-exposed1 <char>? ?-exposed2 <char>? ?-overflow [1|0]? overtext pipelinedata}
}
lassign [lrange $args end-1 end] over under
set argsflags [lrange $args 0 end-2]
tailcall overtype::centre {*}$argsflags $under $over
}
proc overleft {args} {
if {[llength $args] < 2} {
error {usage: ?-start <column>? ?-transparent [0|1|<regexp>]? ?-exposed1 <char>? ?-exposed2 <char>? ?-overflow [1|0]? overtext pipelinedata}
}
lassign [lrange $args end-1 end] over under
set argsflags [lrange $args 0 end-2]
tailcall overtype::left {*}$argsflags $under $over
}
}
#todo - left-right ellipsis ?
proc overtype::centre {args} {
variable default_ellipsis_horizontal
if {[llength $args] < 2} {
error {usage: ?-transparent [0|1]? ?-bias [left|right]? ?-overflow [1|0]? undertext overtext}
}
foreach {underblock overblock} [lrange $args end-1 end] break
#todo - vertical vs horizontal overflow for blocks
set defaults [dict create\
-bias left\
-ellipsis 0\
-ellipsistext $default_ellipsis_horizontal\
-ellipsiswhitespace 0\
-overflow 0\
-transparent 0\
-exposed1 \uFFFD\
-exposed2 \uFFFD\
]
set known_opts [dict keys $defaults]
set argsflags [lrange $args 0 end-2]
dict for {k v} $argsflags {
if {$k ni $known_opts} {
error "overtype::centre unknown option '$k'. Known options: $known_opts"
}
}
set opts [dict merge $defaults $argsflags]
# -- --- --- --- --- ---
set opt_transparent [dict get $opts -transparent]
set opt_ellipsis [dict get $opts -ellipsis]
set opt_ellipsistext [dict get $opts -ellipsistext]
set opt_ellipsiswhitespace [dict get $opts -ellipsiswhitespace]
set opt_exposed1 [dict get $opts -exposed1]
set opt_exposed2 [dict get $opts -exposed2]
# -- --- --- --- --- ---
set norm [list \r\n \n]
set underblock [string map $norm $underblock]
set overblock [string map $norm $overblock]
set underlines [split $underblock \n]
#set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]]
lassign [blocksize $underblock] _w colwidth _h colheight
set overlines [split $overblock \n]
#set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]]
lassign [blocksize $overblock] _w overblock_width _h overblock_height
set under_exposed_max [expr {$colwidth - $overblock_width}]
if {$under_exposed_max > 0} {
#background block is wider
if {$under_exposed_max % 2 == 0} {
#even left/right exposure
set left_exposed [expr {$under_exposed_max / 2}]
} else {
set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division
if {[string tolower [dict get $opts -bias]] eq "left"} {
set left_exposed $beforehalf
} else {
#bias to the right
set left_exposed [expr {$beforehalf + 1}]
}
}
} else {
set left_exposed 0
}
set outputlines [list]
foreach undertext $underlines overtext $overlines {
set overtext_datalen [punk::ansi::printing_length $overtext]
set ulen [punk::ansi::printing_length $undertext]
if {$ulen < $colwidth} {
set udiff [expr {$colwidth - $ulen}]
set undertext "$undertext[string repeat { } $udiff]"
}
set overflowlength [expr {$overtext_datalen - $colwidth}]
#review - right-to-left langs should elide on left! - extra option required
if {$overflowlength > 0} {
#overlay line wider or equal
set rendered [renderline -transparent $opt_transparent -overflow [dict get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext]
#overlay line data is wider - trim if overflow not specified in opts - and overtype an ellipsis at right if it was specified
if {![dict get $opts -overflow]} {
#lappend outputlines [string range $overtext 0 [expr {$colwidth - 1}]]
#set overtext [string range $overtext 0 $colwidth-1 ]
if {$opt_ellipsis} {
set show_ellipsis 1
if {!$opt_ellipsiswhitespace} {
#we don't want ellipsis if only whitespace was lost
set lostdata [string range $overtext end-[expr {$overflowlength-1}] end]
if {[string trim $lostdata] eq ""} {
set show_ellipsis 0
}
}
if {$show_ellipsis} {
set rendered [overtype::right $rendered $opt_ellipsistext]
}
}
}
lappend outputlines $rendered
#lappend outputlines [renderline -transparent $opt_transparent $undertext $overtext]
} else {
#background block is wider than or equal to data for this line
lappend outputlines [renderline -start $left_exposed -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext]
}
}
return [join $outputlines \n]
}
proc overtype::right {args} {
#NOT the same as align-right - which should be done to the overblock first if required
variable default_ellipsis_horizontal
# @d !todo - implement overflow, length checks etc
if {[llength $args] < 2} {
error {usage: ?-overflow [1|0]? undertext overtext}
}
foreach {underblock overblock} [lrange $args end-1 end] break
set defaults [dict create\
-bias ignored\
-ellipsis 0\
-ellipsistext $default_ellipsis_horizontal\
-ellipsiswhitespace 0\
-overflow 0\
-transparent 0\
-exposed1 \uFFFD\
-exposed2 \uFFFD\
]
set known_opts [dict keys $defaults]
set argsflags [lrange $args 0 end-2]
dict for {k v} $argsflags {
if {$k ni $known_opts} {
error "overtype::centre unknown option '$k'. Known options: $known_opts"
}
}
set opts [dict merge $defaults $argsflags]
# -- --- --- --- --- ---
set opt_transparent [dict get $opts -transparent]
set opt_ellipsis [dict get $opts -ellipsis]
set opt_ellipsistext [dict get $opts -ellipsistext]
set opt_ellipsiswhitespace [dict get $opts -ellipsiswhitespace]
set opt_overflow [dict get $opts -overflow]
set opt_exposed1 [dict get $opts -exposed1]
set opt_exposed2 [dict get $opts -exposed2]
# -- --- --- --- --- ---
set norm [list \r\n \n]
set underblock [string map $norm $underblock]
set overblock [string map $norm $overblock]
set underlines [split $underblock \n]
#set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]]
lassign [blocksize $underblock] _w colwidth _h colheight
set overlines [split $overblock \n]
#set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]]
lassign [blocksize $overblock] _w overblock_width _h overblock_height
set under_exposed_max [expr {$colwidth - $overblock_width}]
set left_exposed $under_exposed_max
set outputlines [list]
foreach undertext $underlines overtext $overlines {
set overtext_datalen [punk::ansi::printing_length $overtext]
set ulen [punk::ansi::printing_length $undertext]
if {$ulen < $colwidth} {
set udiff [expr {$colwidth - $ulen}]
puts xxx
set undertext "$undertext[string repeat { } $udiff]"
}
if {$overtext_datalen < $overblock_width} {
set odiff [expr {$overblock_width - $overtext_datalen}]
#padding always on right - if alignment is required it should be done to block beforehand - not here
set overtextpadding "$overtext[string repeat { } $odiff]"
}
set overflowlength [expr {$overtext_datalen - $colwidth}]
if {$overflowlength > 0} {
#raw overtext wider than undertext column
set rendered [renderline -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow $opt_overflow -start 0 $undertext $overtext]
if {!$opt_overflow} {
if {$opt_ellipsis} {
set show_ellipsis 1
if {!$opt_ellipsiswhitespace} {
#we don't want ellipsis if only whitespace was lost
set lostdata [string range $overtext end-[expr {$overflowlength-1}] end]
if {[string trim $lostdata] eq ""} {
set show_ellipsis 0
}
}
if {$show_ellipsis} {
set rendered [overtype::right $rendered $opt_ellipsistext]
}
}
}
lappend outputlines $rendered
} else {
#padded overtext
lappend outputlines [renderline -transparent $opt_transparent -start $left_exposed $undertext $overtext]
}
}
return [join $outputlines \n]
}
# -- --- --- --- --- --- --- --- --- --- ---
proc overtype::transparentline {args} {
foreach {under over} [lrange $args end-1 end] break
set argsflags [lrange $args 0 end-2]
set defaults [dict create\
-transparent 1\
-exposed 1 " "\
-exposed 2 " "\
]
set newargs [dict merge $defaults $argsflags]
tailcall overtype::renderline {*}$newargs $under $over
}
#renderline may not make sense as it is in the long run for blocks of text - but is handy in the single-line-handling form anyway.
# We are trying to handle ansi codes in a block of text which is acting like a mini-terminal in some sense.
#We can process standard cursor moves such as \b \r - but no way to respond to other cursor movements e.g moving to other lines.
#
namespace eval overtype::piper {
proc renderline {args} {
if {[llength $args] < 2} {
error {usage: ?-start <int>? ?-transparent [0|1|<regexp>]? ?-overflow [1|0]? overtext pipelinedata}
}
foreach {over under} [lrange $args end-1 end] break
set argsflags [lrange $args 0 end-2]
tailcall overtype::renderline {*}$argsflags $under $over
}
}
interp alias "" piper_renderline "" overtype::piper::renderline
#-returnextra to enable returning of overflow and length
# todo - use punk::ansi::ta::detect to short-circuit processing and do simple string calcs as an optimisation?
#review - DECSWL/DECDWL double width line codes - very difficult/impossible to align and compose with other elements
#todo - review transparency issues with single/double width characters!
proc overtype::renderline {args} {
if {[llength $args] < 2} {
error {usage: ?-start <int>? ?-transparent [0|1|<regexp>]? ?-overflow [1|0]? undertext overtext}
}
lassign [lrange $args end-1 end] under over
#should also rule out \v
if {[string first \n $over] >=0 || [string first \n $under] >= 0} {
error "overtype::renderline not allowed to contain newlines"
}
set defaults [dict create\
-overflow 0\
-transparent 0\
-start 0\
-returnextra 0\
-exposed1 \uFFFD\
-exposed2 \uFFFD\
]
#exposed1 and exposed2 for first and second col of underying 2wide char which is truncated by transparency or overflow
set known_opts [dict keys $defaults]
set argsflags [lrange $args 0 end-2]
dict for {k v} $argsflags {
if {$k ni $known_opts} {
error "overtype::renderline unknown option '$k'. Known options: $known_opts"
}
}
set opts [dict merge $defaults $argsflags]
# -- --- --- --- --- --- --- --- --- --- --- ---
set opt_overflow [dict get $opts -overflow]
set opt_colstart [dict get $opts -start]
# -- --- --- --- --- --- --- --- --- --- --- ---
set opt_transparent [dict get $opts -transparent]
if {$opt_transparent eq "0"} {
set do_transparency 0
} else {
set do_transparency 1
if {$opt_transparent eq "1"} {
set opt_transparent {[\s]}
}
}
# -- --- --- --- --- --- --- --- --- --- --- ---
set opt_returnextra [dict get $opts -returnextra]
# -- --- --- --- --- --- --- --- --- --- --- ---
set opt_exposed1 [dict get $opts -exposed1]
set opt_exposed2 [dict get $opts -exposed2]
# -- --- --- --- --- --- --- --- --- --- --- ---
#-----
#
if {[string first \t $under] >= 0} {
#set under [textutil::tabify::untabify2 $under]
set under [textutil::tabify::untabifyLine $under 8] ;#8 is default for untabify2 - review
}
set overdata $over
if {[string first \t $over] >= 0} {
#set overdata [textutil::tabify::untabify2 $over]
set overdata [textutil::tabify::untabifyLine $over 8]
}
#-------
#ta_detect ansi and do simpler processing?
# -- --- --- --- --- --- --- ---
set undermap [punk::ansi::ta::split_codes_single $under]
set understacks [dict create]
set i_u -1
set i_o 0
set out [list]
set u_codestack [list]
set pt_underchars "" ;#for string_columns length calculation for overflow 0 truncation
set remainder [list] ;#for returnextra
foreach {pt code} $undermap {
#pt = plain text
append pt_underchars $pt
foreach grapheme [punk::char::grapheme_split $pt] {
set width [punk::char::string_width $grapheme]
incr i_u
dict set understacks $i_u $u_codestack
lappend out $grapheme
if {$width > 1} {
incr i_u
#presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?)
#but what about emoji combinations etc - can they be wider than 2?
dict set understacks $i_u $u_codestack
lappend out ""
}
}
#underlay should already have been rendered and not have non-sgr codes - but let's retain the check for them and not stack them if other codes are here
#only stack SGR (graphics rendition) codes - not title sets, cursor moves etc
#order of if-else based on assumptions:
# that pure resets are fairly common - more so than leading resets with other info
# that non-sgr codes are not that common, so ok to check for resets before verifying it is actually SGR at all.
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set u_codestack [list]
} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} {
set u_codestack [list $code]
} elseif {[punk::ansi::codetype::is_sgr $code]} {
lappend u_codestack $code
}
#consider also if there are other codes that should be stacked..?
}
#trailing codes in effect for underlay
if {[llength $undermap]} {
dict set understacks [expr {$i_u + 1}] $u_codestack
}
# -- --- --- --- --- --- --- ---
####
#if opt_colstart - we need to build a space (or any singlewidth char really) padding on the left of the right number of columns.
#this will be processed as transparent - and handle doublewidth underlay characters appropriately
set startpad [string repeat " " $opt_colstart]
append startpad $overdata ;#overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency
set overmap [punk::ansi::ta::split_codes_single $startpad]
####
#set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+}
#as at 2024-02 punk::char::grapheme_split uses these - not aware of more complex graphemes
set overstacks [dict create]
set o_codestack [list]
set pt_overchars ""
foreach {pt code} $overmap {
append pt_overchars $pt
foreach grapheme [punk::char::grapheme_split $pt] {
dict set overstacks $i_o $o_codestack
incr i_o
}
if {[punk::ansi::codetype::is_sgr $code]} {
if {[punk::ansi::codetype::has_sgr_leadingreset $code]} {
#m code which has sgr reset at start - no need to replay prior sgr codes
set o_codestack [list $code]
} else {
lappend o_codestack $code
}
}
#only stack SGR (graphics rendition) codes - not title sets, cursor moves etc
#order of if-else based on assumptions:
# that pure resets are fairly common - more so than leading resets with other info
# that non-sgr codes are not that common, so ok to check for resets before verifying it is actually SGR at all.
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set o_codestack [list]
} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} {
set o_codestack [list $code]
} elseif {[punk::ansi::codetype::is_sgr $code]} {
lappend o_codestack $code
}
}
# -- --- --- --- --- --- --- ---
#potential problem - combinining diacritics directly following control chars like \r \b
set bs [format %c 0x08]
set idx 0 ;# line index (cursor - 1)
set idx_over -1
foreach {pt code} $overmap {
#set ptchars [split $pt ""] ;#for lookahead
set graphemes [punk::char::grapheme_split $pt]
#emit plaintext chars first using existing SGR codes from under/over stack as appropriate
#then check if the following code is a cursor movement within the line and adjust index if so
foreach ch $graphemes {
incr idx_over
if {$ch eq "\r"} {
set idx $opt_colstart
} elseif {$ch eq "\b"} {
#review - backspace effect on double-width chars
if {$idx > $opt_colstart} {
incr idx -1
}
} elseif {($idx < $opt_colstart)} {
incr idx
} elseif {($do_transparency && [regexp $opt_transparent $ch])} {
#pre opt_colstart is effectively transparent (we have applied padding of required number of columns to left of overlay)
set owidth [punk::char::string_width $ch]
if {$idx > [llength $out]-1} {
lappend out " "
dict set understacks $idx [list] ;#review - use idx-1 codestack?
incr idx
} else {
set uwidth [punk::char::string_width [lindex $out $idx]]
if {[lindex $out $idx] eq ""} {
#2nd col of 2-wide char in underlay
incr idx
} elseif {$uwidth == 0} {
#e.g control char ? combining diacritic ?
incr idx
} elseif {$uwidth == 1} {
incr idx
if {$owidth > 1} {
incr idx
}
} elseif {$uwidth > 1} {
if {[punk::char::string_width $ch] == 1} {
#normal singlewide transparency
set next_pt_overchar [string index $pt_overchars $idx_over+1] ;#lookahead of next plain-text char in overlay
if {$next_pt_overchar eq ""} {
#special-case trailing transparent - no next_pt_overchar
incr idx
} else {
if {[regexp $opt_transparent $next_pt_overchar]} {
incr idx
} else {
#next overlay char is not transparent.. first-half of underlying 2wide char is exposed
priv::render_addchar $idx $opt_exposed1 [dict get $overstacks $idx_over]
incr idx
}
}
} else {
#2wide transparency over 2wide in underlay
incr idx
}
}
}
} else {
#non-transparent char in overlay
set owidth [punk::char::string_width $ch]
set uwidth [punk::char::string_width [lindex $out $idx]]
if {[lindex $out $idx] eq ""} {
#2nd col of 2wide char in underlay
priv::render_addchar $idx $ch [dict get $overstacks $idx_over]
incr idx
} elseif {$uwidth == 0} {
#e.g combining diacritic - increment before over char REVIEW
#arguably the previous overchar should have done this - ie lookahead for combiners?
priv::render_addchar $idx "" [dict get $overstacks $idx_over]
incr idx
priv::render_addchar $idx $ch [dict get $overstacks $idx_over]
incr idx
} elseif {$uwidth == 1} {
if {$owidth == 1} {
priv::render_addchar $idx $ch [dict get $overstacks $idx_over]
incr idx
} else {
priv::render_addchar $idx $ch [dict get $overstacks $idx_over]
incr idx
priv::render_addchar $idx "" [dict get $overstacks $idx_over]
}
} elseif {$uwidth > 1} {
if {$owidth == 1} {
priv::render_addchar $idx $ch [dict get $overstacks $idx_over]
incr idx
priv::render_addchar $idx $opt_exposed2 [dict get $overstacks $idx_over]
#don't incr idx - we are just putting a broken-indication in the underlay - which may get overwritten by next overlay char
} else {
#2wide over 2wide
priv::render_addchar $idx $ch [dict get $overstacks $idx_over]
incr idx
}
}
}
}
#cursor movement?
#if {![punk::ansi::codetype::is_sgr $code]} {
#
#}
}
if {$opt_overflow == 0} {
#need to truncate to the width of the original undertext
#review - string_width vs printing_length here. undertext requirement to be already rendered therefore punk::char::string_width ok?
set num_under_columns [punk::char::string_width $pt_underchars] ;#plaintext underchars
}
#coalesce and replay codestacks for out char list
set outstring ""
set remstring "" ;#remainder after overflow point reached
set i 0
set cstack [list]
set prevstack [list]
set out_rawchars ""; #for overflow counting
set output_to "outstring" ;#var in effect depending on overflow
set in_overflow 0 ;#used to stop char-width scanning once in overflow
foreach ch $out {
append out_rawchars $ch
if {$opt_overflow == 0 && !$in_overflow} {
if {[set nextvisualwidth [punk::char::string_width $out_rawchars]] < $num_under_columns} {
} else {
#todo - check if we overflowed with a double-width char ?
#store visualwidth which may be short
set in_overflow 1
}
}
set cstack [dict get $understacks $i]
if {$cstack ne $prevstack} {
if {[llength $prevstack]} {
append $output_to \033\[m
}
foreach code $cstack {
append $output_to $code
}
}
append $output_to $ch
set prevstack $cstack
incr i
if {$in_overflow} {
set output_to "remstring"
}
}
if {[dict size $understacks] > 0} {
append $output_to [join [dict get $understacks [expr {[dict size $understacks]-1}]] ""] ;#tail codes
}
if {[string length $remstring]} {
#puts stderr "remainder:$remstring"
}
#pdict $understacks
if {$opt_returnextra} {
return [list $outstring $visualwidth [string length $outstring] $remstring]
} else {
return $outstring
}
#return [join $out ""]
}
proc overtype::test_renderline {} {
set t \uFF5E ;#2-wide tilde
set u \uFF3F ;#2-wide underscore
set missing \uFFFD
return [list $t $u A${t}B]
}
#same as textblock::size - but we don't want that circular dependency
proc overtype::blocksize {textblock} {
if {$textblock eq ""} {
return [dict create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings
}
set textblock [textutil::tabify::untabify2 $textblock]
#stripansi on entire block in one go rather than line by line - result should be the same - review - make tests
set textblock [punk::ansi::stripansi $textblock]
if {[string first \n $textblock] >= 0} {
set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::string_width $v}]]
} else {
set width [punk::char::string_width $textblock]
}
set num_le [expr {[string length $textblock]-[string length [string map [list \n {}] $textblock]]}] ;#faster than splitting into single-char list
#our concept of block-height is likely to be different to other line-counting mechanisms
set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le
return [dict create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [dict values [blocksize <data>]] width height
}
namespace eval overtype::priv {
#is actually addgrapheme?
proc render_addchar {i c stack} {
upvar out o
upvar understacks ustacks
set nxt [llength $o]
if {$i < $nxt} {
lset o $i $c
} else {
lappend o $c
}
dict set ustacks $i $stack
}
}
# -- --- --- --- --- --- --- --- --- --- ---
namespace eval overtype {
interp alias {} ::overtype::center {} ::overtype::centre
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide overtype [namespace eval overtype {
variable version
set version 1.5.6
}]
return
#*** !doctools
#[manpage_end]

998
src/bootsupport/modules/overtype-1.5.7.tm
Unescape View File

@ -1,998 +0,0 @@
# -*- 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) Julian Noble 2003-2023
#
# @@ Meta Begin
# Application overtype 1.5.7
# Meta platform tcl
# Meta license BSD
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin overtype_module_overtype 0 1.5.7]
#[copyright "2024"]
#[titledesc {overtype text layout - ansi aware}] [comment {-- Name section and table of contents description --}]
#[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}]
#[require overtype]
#[keywords module text ansi]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of overtype
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by overtype
#[list_begin itemized]
package require Tcl 8.6
package require textutil
package require punk::lib ;#required for lines_as_list
package require punk::ansi ;#required to detect, split, strip and calculate lengths
package require punk::char ;#box drawing - and also unicode character width determination for proper layout of text with double-column-width chars
#*** !doctools
#[item] [package {Tcl 8.6}]
#[item] [package textutil]
#[item] [package punk::ansi]
#[para] - required to detect, split, strip and calculate lengths of text possibly containing ansi codes
#[item] [package punk::char]
#[para] - box drawing - and also unicode character width determination for proper layout of text with double-column-width chars
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
#Julian Noble <julian@precisium.com.au> - 2003
#Released under standard 'BSD license' conditions.
#
#todo - ellipsis truncation indicator for center,right
#v1.4 2023-07 - naive ansi color handling - todo - fix string range
# - need to extract and replace ansi codes?
namespace eval overtype {
namespace export *
variable default_ellipsis_horizontal "..." ;#fallback
variable default_ellipsis_vertical "..."
namespace eval priv {
proc _init {} {
upvar ::overtype::default_ellipsis_horizontal e_h
upvar ::overtype::default_ellipsis_vertical e_v
set e_h [format %c 0x2026] ;#Unicode Horizontal Ellipsis
set e_v [format %c 0x22EE]
#The unicode ellipsis looks more natural than triple-dash which is centred vertically whereas ellipsis is at floorline of text
#Also - unicode ellipsis has semantic meaning that other processors can interpret
#unicode does also provide a midline horizontal ellipsis 0x22EF
#set e [format %c 0x2504] ;#punk::char::charshort boxd_ltdshhz - Box Drawings Light Triple Dash Horizontal
#if {![catch {package require punk::char}]} {
# set e [punk::char::charshort boxd_ltdshhz]
#}
}
}
priv::_init
}
proc overtype::about {} {
return "Simple text formatting. Author JMN. BSD-License"
}
namespace eval overtype {
variable escape_terminals
#single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~).
dict set escape_terminals CSI [list @ \\ ^ _ ` | ~ 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 "\{" "\}"]
#dict set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic
dict set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals
#self-contained 2 byte ansi escape sequences - review more?
variable ansi_2byte_codes_dict
set ansi_2byte_codes_dict [dict create\
"reset_terminal" "\u001bc"\
"save_cursor_posn" "\u001b7"\
"restore_cursor_posn" "\u001b8"\
"cursor_up_one" "\u001bM"\
"NEL - Next Line" "\u001bE"\
"IND - Down one line" "\u001bD"\
"HTS - Set Tab Stop" "\u001bH"\
]
#debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway.
# "PM - Privacy Message" "\u001b^somethinghidden\033\\"\
}
#proc overtype::stripansi {text} {
# variable escape_terminals ;#dict
# variable ansi_2byte_codes_dict
# #important that we don't spend too much time on this for plain text that doesn't contain any escapes anyway
# if {[string first \033 $text] <0 && [string first \009c $text] <0} {
# #\033 same as \x1b
# return $text
# }
#
# set text [convert_g0 $text]
#
# #we process char by char - line-endings whether \r\n or \n should be processed as per any other character.
# #line endings can theoretically occur within an ansi escape sequence (review e.g title?)
# set inputlist [split $text ""]
# set outputlist [list]
#
# set 2bytecodes [dict values $ansi_2byte_codes_dict]
#
# set in_escapesequence 0
# #assumption - undertext already 'rendered' - ie no backspaces or carriagereturns or other cursor movement controls
# set i 0
# foreach u $inputlist {
# set v [lindex $inputlist $i+1]
# set uv ${u}${v}
# if {$in_escapesequence eq "2b"} {
# #2nd byte - done.
# set in_escapesequence 0
# } elseif {$in_escapesequence != 0} {
# set escseq [dict get $escape_terminals $in_escapesequence]
# if {$u in $escseq} {
# set in_escapesequence 0
# } elseif {$uv in $escseq} {
# set in_escapseequence 2b ;#flag next byte as last in sequence
# }
# } else {
# #handle both 7-bit and 8-bit CSI and OSC
# if {[regexp {^(?:\033\[|\u009b)} $uv]} {
# set in_escapesequence CSI
# } elseif {[regexp {^(?:\033\]|\u009c)} $uv]} {
# set in_escapesequence OSC
# } elseif {$uv in $2bytecodes} {
# #self-contained e.g terminal reset - don't pass through.
# set in_escapesequence 2b
# } else {
# lappend outputlist $u
# }
# }
# incr i
# }
# return [join $outputlist ""]
#}
proc overtype::string_columns {text} {
if {[punk::ansi::ta::detect $text]} {
#error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with punk::ansi::stripansi. Alternatively try punk::ansi::printing_length"
set text [punk::ansi::stripansi $text]
}
return [punk::char::string_width $text]
}
#string range should generally be avoided for both undertext and overtext which contain ansi escapes and other cursor affecting chars such as \b and \r
proc overtype::left {args} {
# @c overtype starting at left (overstrike)
# @c can/should we use something like this?: 'format "%-*s" $len $overtext
variable default_ellipsis_horizontal
if {[llength $args] < 2} {
error {usage: ?-transparent [0|1]? ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext}
}
lassign [lrange $args end-1 end] underblock overblock
set defaults [dict create\
-bias ignored\
-ellipsis 0\
-ellipsistext $default_ellipsis_horizontal\
-ellipsiswhitespace 0\
-overflow 0\
-transparent 0\
-exposed1 \uFFFD\
-exposed2 \uFFFD\
]
set known_opts [dict keys $defaults]
set argsflags [lrange $args 0 end-2]
dict for {k v} $argsflags {
if {$k ni $known_opts} {
error "overtype::left unknown option '$k'. Known options: $known_opts"
}
}
set opts [dict merge $defaults $argsflags]
# -- --- --- --- --- ---
set opt_transparent [dict get $opts -transparent]
set opt_ellipsistext [dict get $opts -ellipsistext]
set opt_ellipsiswhitespace [dict get $opts -ellipsiswhitespace]
set opt_exposed1 [dict get $opts -exposed1] ;#widechar_exposed_left - todo
set opt_exposed2 [dict get $opts -exposed2] ;#widechar_exposed_right - todo
# -- --- --- --- --- ---
set norm [list \r\n \n]
set underblock [string map $norm $underblock]
set overblock [string map $norm $overblock]
set underlines [split $underblock \n]
#set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]]
lassign [blocksize $underblock] _w colwidth _h colheight
set overlines [split $overblock \n]
#set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]]
lassign [blocksize $overblock] _w overblock_width _h overblock_height
set under_exposed_max [expr {$colwidth - $overblock_width}]
set right_exposed $under_exposed_max
set outputlines [list]
foreach undertext $underlines overtext $overlines {
set undertext_printlen [punk::ansi::printing_length $undertext]
if {$undertext_printlen < $colwidth} {
set udiff [expr {$colwidth - $undertext_printlen}]
set undertext "$undertext[string repeat { } $udiff]"
}
set overtext_printlen [punk::ansi::printing_length $overtext]
set overflowlength [expr {$overtext_printlen - $colwidth}]
#review
#append overtext "\033\[0m"
if {$overflowlength > 0} {
#background line is narrower than data in line
set rendered [renderline -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow [dict get $opts -overflow] $undertext $overtext]
if {![dict get $opts -overflow]} {
#set overtext [string range $overtext 0 $colwidth-1] ;#string range won't be correct e.g if contains ansi codes or leading \r or \b etc
if {[dict get $opts -ellipsis]} {
set show_ellipsis 1
if {!$opt_ellipsiswhitespace} {
#we don't want ellipsis if only whitespace was lost
set lostdata [string range $overtext end-[expr {$overflowlength-1}] end]
if {[string trim $lostdata] eq ""} {
set show_ellipsis 0
}
}
if {$show_ellipsis} {
set rendered [overtype::right $rendered $opt_ellipsistext]
}
}
}
lappend outputlines $rendered
} else {
#we know overtext data is shorter or equal (for this line)
lappend outputlines [renderline -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext]
}
}
return [join $outputlines \n]
}
namespace eval overtype::piper {
proc overcentre {args} {
if {[llength $args] < 2} {
error {usage: ?-bias left|right? ?-transparent [0|1|<regexp>]? ?-exposed1 <char>? ?-exposed2 <char>? ?-overflow [1|0]? overtext pipelinedata}
}
lassign [lrange $args end-1 end] over under
set argsflags [lrange $args 0 end-2]
tailcall overtype::centre {*}$argsflags $under $over
}
proc overleft {args} {
if {[llength $args] < 2} {
error {usage: ?-startcolumn <column>? ?-transparent [0|1|<regexp>]? ?-exposed1 <char>? ?-exposed2 <char>? ?-overflow [1|0]? overtext pipelinedata}
}
lassign [lrange $args end-1 end] over under
set argsflags [lrange $args 0 end-2]
tailcall overtype::left {*}$argsflags $under $over
}
}
#todo - left-right ellipsis ?
proc overtype::centre {args} {
variable default_ellipsis_horizontal
if {[llength $args] < 2} {
error {usage: ?-transparent [0|1]? ?-bias [left|right]? ?-overflow [1|0]? undertext overtext}
}
foreach {underblock overblock} [lrange $args end-1 end] break
#todo - vertical vs horizontal overflow for blocks
set defaults [dict create\
-bias left\
-ellipsis 0\
-ellipsistext $default_ellipsis_horizontal\
-ellipsiswhitespace 0\
-overflow 0\
-transparent 0\
-exposed1 \uFFFD\
-exposed2 \uFFFD\
]
set known_opts [dict keys $defaults]
set argsflags [lrange $args 0 end-2]
dict for {k v} $argsflags {
if {$k ni $known_opts} {
error "overtype::centre unknown option '$k'. Known options: $known_opts"
}
}
set opts [dict merge $defaults $argsflags]
# -- --- --- --- --- ---
set opt_transparent [dict get $opts -transparent]
set opt_ellipsis [dict get $opts -ellipsis]
set opt_ellipsistext [dict get $opts -ellipsistext]
set opt_ellipsiswhitespace [dict get $opts -ellipsiswhitespace]
set opt_exposed1 [dict get $opts -exposed1]
set opt_exposed2 [dict get $opts -exposed2]
# -- --- --- --- --- ---
set norm [list \r\n \n]
set underblock [string map $norm $underblock]
set overblock [string map $norm $overblock]
set underlines [split $underblock \n]
#set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]]
lassign [blocksize $underblock] _w colwidth _h colheight
set overlines [split $overblock \n]
#set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]]
lassign [blocksize $overblock] _w overblock_width _h overblock_height
set under_exposed_max [expr {$colwidth - $overblock_width}]
if {$under_exposed_max > 0} {
#background block is wider
if {$under_exposed_max % 2 == 0} {
#even left/right exposure
set left_exposed [expr {$under_exposed_max / 2}]
} else {
set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division
if {[string tolower [dict get $opts -bias]] eq "left"} {
set left_exposed $beforehalf
} else {
#bias to the right
set left_exposed [expr {$beforehalf + 1}]
}
}
} else {
set left_exposed 0
}
set outputlines [list]
foreach undertext $underlines overtext $overlines {
set overtext_datalen [punk::ansi::printing_length $overtext]
set ulen [punk::ansi::printing_length $undertext]
if {$ulen < $colwidth} {
set udiff [expr {$colwidth - $ulen}]
set undertext "$undertext[string repeat { } $udiff]"
}
set overflowlength [expr {$overtext_datalen - $colwidth}]
#review - right-to-left langs should elide on left! - extra option required
if {$overflowlength > 0} {
#overlay line wider or equal
set rendered [renderline -transparent $opt_transparent -overflow [dict get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext]
#overlay line data is wider - trim if overflow not specified in opts - and overtype an ellipsis at right if it was specified
if {![dict get $opts -overflow]} {
#lappend outputlines [string range $overtext 0 [expr {$colwidth - 1}]]
#set overtext [string range $overtext 0 $colwidth-1 ]
if {$opt_ellipsis} {
set show_ellipsis 1
if {!$opt_ellipsiswhitespace} {
#we don't want ellipsis if only whitespace was lost
set lostdata [string range $overtext end-[expr {$overflowlength-1}] end]
if {[string trim $lostdata] eq ""} {
set show_ellipsis 0
}
}
if {$show_ellipsis} {
set rendered [overtype::right $rendered $opt_ellipsistext]
}
}
}
lappend outputlines $rendered
#lappend outputlines [renderline -transparent $opt_transparent $undertext $overtext]
} else {
#background block is wider than or equal to data for this line
lappend outputlines [renderline -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext]
}
}
return [join $outputlines \n]
}
proc overtype::right {args} {
#NOT the same as align-right - which should be done to the overblock first if required
variable default_ellipsis_horizontal
# @d !todo - implement overflow, length checks etc
if {[llength $args] < 2} {
error {usage: ?-overflow [1|0]? undertext overtext}
}
foreach {underblock overblock} [lrange $args end-1 end] break
set defaults [dict create\
-bias ignored\
-ellipsis 0\
-ellipsistext $default_ellipsis_horizontal\
-ellipsiswhitespace 0\
-overflow 0\
-transparent 0\
-exposed1 \uFFFD\
-exposed2 \uFFFD\
]
set known_opts [dict keys $defaults]
set argsflags [lrange $args 0 end-2]
dict for {k v} $argsflags {
if {$k ni $known_opts} {
error "overtype::centre unknown option '$k'. Known options: $known_opts"
}
}
set opts [dict merge $defaults $argsflags]
# -- --- --- --- --- ---
set opt_transparent [dict get $opts -transparent]
set opt_ellipsis [dict get $opts -ellipsis]
set opt_ellipsistext [dict get $opts -ellipsistext]
set opt_ellipsiswhitespace [dict get $opts -ellipsiswhitespace]
set opt_overflow [dict get $opts -overflow]
set opt_exposed1 [dict get $opts -exposed1]
set opt_exposed2 [dict get $opts -exposed2]
# -- --- --- --- --- ---
set norm [list \r\n \n]
set underblock [string map $norm $underblock]
set overblock [string map $norm $overblock]
set underlines [split $underblock \n]
#set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]]
lassign [blocksize $underblock] _w colwidth _h colheight
set overlines [split $overblock \n]
#set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]]
lassign [blocksize $overblock] _w overblock_width _h overblock_height
set under_exposed_max [expr {$colwidth - $overblock_width}]
set left_exposed $under_exposed_max
set outputlines [list]
foreach undertext $underlines overtext $overlines {
set overtext_datalen [punk::ansi::printing_length $overtext]
set ulen [punk::ansi::printing_length $undertext]
if {$ulen < $colwidth} {
set udiff [expr {$colwidth - $ulen}]
puts xxx
set undertext "$undertext[string repeat { } $udiff]"
}
if {$overtext_datalen < $overblock_width} {
set odiff [expr {$overblock_width - $overtext_datalen}]
#padding always on right - if alignment is required it should be done to block beforehand - not here
set overtextpadding "$overtext[string repeat { } $odiff]"
}
set overflowlength [expr {$overtext_datalen - $colwidth}]
if {$overflowlength > 0} {
#raw overtext wider than undertext column
set rendered [renderline -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow $opt_overflow -startcolumn 1 $undertext $overtext]
if {!$opt_overflow} {
if {$opt_ellipsis} {
set show_ellipsis 1
if {!$opt_ellipsiswhitespace} {
#we don't want ellipsis if only whitespace was lost
set lostdata [string range $overtext end-[expr {$overflowlength-1}] end]
if {[string trim $lostdata] eq ""} {
set show_ellipsis 0
}
}
if {$show_ellipsis} {
set rendered [overtype::right $rendered $opt_ellipsistext]
}
}
}
lappend outputlines $rendered
} else {
#padded overtext
lappend outputlines [renderline -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext]
}
}
return [join $outputlines \n]
}
# -- --- --- --- --- --- --- --- --- --- ---
proc overtype::transparentline {args} {
foreach {under over} [lrange $args end-1 end] break
set argsflags [lrange $args 0 end-2]
set defaults [dict create\
-transparent 1\
-exposed 1 " "\
-exposed 2 " "\
]
set newargs [dict merge $defaults $argsflags]
tailcall overtype::renderline {*}$newargs $under $over
}
#renderline may not make sense as it is in the long run for blocks of text - but is handy in the single-line-handling form anyway.
# We are trying to handle ansi codes in a block of text which is acting like a mini-terminal in some sense.
#We can process standard cursor moves such as \b \r - but no way to respond to other cursor movements e.g moving to other lines.
#
namespace eval overtype::piper {
proc renderline {args} {
if {[llength $args] < 2} {
error {usage: ?-start <int>? ?-transparent [0|1|<regexp>]? ?-overflow [1|0]? overtext pipelinedata}
}
foreach {over under} [lrange $args end-1 end] break
set argsflags [lrange $args 0 end-2]
tailcall overtype::renderline {*}$argsflags $under $over
}
}
interp alias "" piper_renderline "" overtype::piper::renderline
#-returnextra to enable returning of overflow and length
# todo - use punk::ansi::ta::detect to short-circuit processing and do simple string calcs as an optimisation?
#review - DECSWL/DECDWL double width line codes - very difficult/impossible to align and compose with other elements
#todo - review transparency issues with single/double width characters!
#bidi - need a base direction and concept of directional runs for RTL vs LTR - may be best handled at another layer?
proc overtype::renderline {args} {
if {[llength $args] < 2} {
error {usage: ?-info 0|1? ?-startcolumn <int>? ?-transparent [0|1|<regexp>]? ?-overflow [1|0]? undertext overtext}
}
lassign [lrange $args end-1 end] under over
#should also rule out \v
if {[string first \n $over] >=0 || [string first \n $under] >= 0} {
error "overtype::renderline not allowed to contain newlines"
}
set defaults [dict create\
-overflow 0\
-transparent 0\
-startcolumn 1\
-info 0\
-exposed1 \uFFFD\
-exposed2 \uFFFD\
]
#exposed1 and exposed2 for first and second col of underying 2wide char which is truncated by transparency or overflow
set known_opts [dict keys $defaults]
set argsflags [lrange $args 0 end-2]
dict for {k v} $argsflags {
if {$k ni $known_opts} {
error "overtype::renderline unknown option '$k'. Known options: $known_opts"
}
}
set opts [dict merge $defaults $argsflags]
# -- --- --- --- --- --- --- --- --- --- --- ---
set opt_overflow [dict get $opts -overflow]
set opt_colstart [dict get $opts -startcolumn] ;#start cursor column
# -- --- --- --- --- --- --- --- --- --- --- ---
set opt_transparent [dict get $opts -transparent]
if {$opt_transparent eq "0"} {
set do_transparency 0
} else {
set do_transparency 1
if {$opt_transparent eq "1"} {
set opt_transparent {[\s]}
}
}
# -- --- --- --- --- --- --- --- --- --- --- ---
set opt_returnextra [dict get $opts -info]
# -- --- --- --- --- --- --- --- --- --- --- ---
set opt_exposed1 [dict get $opts -exposed1]
set opt_exposed2 [dict get $opts -exposed2]
# -- --- --- --- --- --- --- --- --- --- --- ---
#-----
#
if {[string first \t $under] >= 0} {
#set under [textutil::tabify::untabify2 $under]
set under [textutil::tabify::untabifyLine $under 8] ;#8 is default for untabify2 - review
}
set overdata $over
if {[string first \t $over] >= 0} {
#set overdata [textutil::tabify::untabify2 $over]
set overdata [textutil::tabify::untabifyLine $over 8]
}
#-------
#ta_detect ansi and do simpler processing?
# -- --- --- --- --- --- --- ---
set undermap [punk::ansi::ta::split_codes_single $under]
set understacks [dict create]
set i_u -1
set i_o 0
set outcols [list]
set u_codestack [list]
set pt_underchars "" ;#for string_columns length calculation for overflow 0 truncation
set remainder [list] ;#for returnextra
foreach {pt code} $undermap {
#pt = plain text
append pt_underchars $pt
foreach grapheme [punk::char::grapheme_split $pt] {
set width [punk::char::string_width $grapheme]
incr i_u
dict set understacks $i_u $u_codestack
lappend outcols $grapheme
if {$width > 1} {
incr i_u
#presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?)
#but what about emoji combinations etc - can they be wider than 2?
dict set understacks $i_u $u_codestack
lappend outcols ""
}
}
#underlay should already have been rendered and not have non-sgr codes - but let's retain the check for them and not stack them if other codes are here
#only stack SGR (graphics rendition) codes - not title sets, cursor moves etc
#order of if-else based on assumptions:
# that pure resets are fairly common - more so than leading resets with other info
# that non-sgr codes are not that common, so ok to check for resets before verifying it is actually SGR at all.
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set u_codestack [list]
} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} {
set u_codestack [list $code]
} elseif {[punk::ansi::codetype::is_sgr $code]} {
lappend u_codestack $code
}
#consider also if there are other codes that should be stacked..?
}
#trailing codes in effect for underlay
if {[llength $undermap]} {
dict set understacks [expr {$i_u + 1}] $u_codestack
}
# -- --- --- --- --- --- --- ---
####
#if opt_colstart - we need to build a space (or any singlewidth char really) padding on the left of the right number of columns.
#this will be processed as transparent - and handle doublewidth underlay characters appropriately
set startpad [string repeat " " [expr {$opt_colstart -1}]]
append startpad $overdata ;#overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency
set overmap [punk::ansi::ta::split_codes_single $startpad]
####
set colcursor $opt_colstart
#set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+}
#as at 2024-02 punk::char::grapheme_split uses these - not aware of more complex graphemes
set overstacks [dict create]
set o_codestack [list]
set pt_overchars ""
foreach {pt code} $overmap {
append pt_overchars $pt
foreach grapheme [punk::char::grapheme_split $pt] {
dict set overstacks $i_o $o_codestack
incr i_o
}
if {[punk::ansi::codetype::is_sgr $code]} {
if {[punk::ansi::codetype::has_sgr_leadingreset $code]} {
#m code which has sgr reset at start - no need to replay prior sgr codes
set o_codestack [list $code]
} else {
lappend o_codestack $code
}
}
#only stack SGR (graphics rendition) codes - not title sets, cursor moves etc
#order of if-else based on assumptions:
# that pure resets are fairly common - more so than leading resets with other info
# that non-sgr codes are not that common, so ok to check for resets before verifying it is actually SGR at all.
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set o_codestack [list]
} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} {
set o_codestack [list $code]
} elseif {[punk::ansi::codetype::is_sgr $code]} {
lappend o_codestack $code
}
}
# -- --- --- --- --- --- --- ---
#potential problem - combinining diacritics directly following control chars like \r \b
set bs [format %c 0x08]
set idx 0 ;# line index (cursor - 1)
set idx_over -1
foreach {pt code} $overmap {
#set ptchars [split $pt ""] ;#for lookahead
set overlay_graphemes [punk::char::grapheme_split $pt]
#emit plaintext chars first using existing SGR codes from under/over stack as appropriate
#then check if the following code is a cursor movement within the line and adjust index if so
foreach ch $overlay_graphemes {
set within_undercols [expr {$idx <= [llength $outcols]-1}]
incr idx_over
if {$ch eq "\r"} {
set idx [expr {$opt_colstart -1}]
} elseif {$ch eq "\b"} {
#review - backspace effect on double-width chars
if {$idx > ($opt_colstart -1)} {
incr idx -1
}
} elseif {($idx < ($opt_colstart -1))} {
incr idx
} elseif {($do_transparency && [regexp $opt_transparent $ch])} {
#pre opt_colstart is effectively transparent (we have applied padding of required number of columns to left of overlay)
if {$idx > [llength $outcols]-1} {
lappend outcols " "
dict set understacks $idx [list] ;#review - use idx-1 codestack?
incr idx
} else {
set uwidth [punk::char::string_width [lindex $outcols $idx]]
if {[lindex $outcols $idx] eq ""} {
#2nd col of 2-wide char in underlay
incr idx
} elseif {$uwidth == 0} {
#e.g control char ? combining diacritic ?
incr idx
} elseif {$uwidth == 1} {
set owidth [punk::char::string_width $ch]
incr idx
if {$owidth > 1} {
incr idx
}
} elseif {$uwidth > 1} {
if {[punk::char::string_width $ch] == 1} {
#normal singlewide transparency
set next_pt_overchar [string index $pt_overchars $idx_over+1] ;#lookahead of next plain-text char in overlay
if {$next_pt_overchar eq ""} {
#special-case trailing transparent - no next_pt_overchar
incr idx
} else {
if {[regexp $opt_transparent $next_pt_overchar]} {
incr idx
} else {
#next overlay char is not transparent.. first-half of underlying 2wide char is exposed
priv::render_addchar $idx $opt_exposed1 [dict get $overstacks $idx_over]
incr idx
}
}
} else {
#2wide transparency over 2wide in underlay
incr idx
}
}
}
} else {
#non-transparent char in overlay
set uwidth [punk::char::string_width [lindex $outcols $idx]]
if {$within_undercols && [lindex $outcols $idx] eq ""} {
#2nd col of 2wide char in underlay
priv::render_addchar $idx $ch [dict get $overstacks $idx_over]
#JMN - this has to expose if our startposn chopped an underlay - but not if we already overwrote the first half of the widechar underlay grapheme
#e.g renderline \uFF21\uFF21--- a\uFF23\uFF23
#vs
# renderline -startcolumn 2 \uFF21---- \uFF23
if {[lindex $outcols $idx-1] != ""} {
#verified it's an empty following a filled - so it's a legit underlay remnant
#reset previous to an exposed 1st-half - but leave understacks code as is
priv::render_addchar [expr {$idx-1}] $opt_exposed1 [dict get $understacks [expr {$idx-1}]]
}
incr idx
} elseif {$uwidth == 0} {
if {$within_undercols} {
#e.g combining diacritic - increment before over char REVIEW
#arguably the previous overchar should have done this - ie lookahead for combiners?
priv::render_addchar $idx "" [dict get $overstacks $idx_over]
incr idx
priv::render_addchar $idx $ch [dict get $overstacks $idx_over]
incr idx
} else {
#overflow
priv::render_addchar $idx $ch [dict get $overstacks $idx_over]
incr idx
}
} elseif {$uwidth == 1} {
set owidth [punk::char::string_width $ch]
if {$owidth == 1} {
priv::render_addchar $idx $ch [dict get $overstacks $idx_over]
incr idx
} else {
priv::render_addchar $idx $ch [dict get $overstacks $idx_over]
incr idx
priv::render_addchar $idx "" [dict get $overstacks $idx_over]
#if next column in underlay empty - we've overwritten first half of underlying 2wide grapheme
#replace with rhs exposure in case there are no more overlay graphemes coming - use underlay's stack
if {[llength $outcols] >= [expr {$idx +2}] && [lindex $outcols $idx+1] eq ""} {
priv::render_addchar [expr {$idx+1}] $opt_exposed2 [dict get $understacks [expr {$idx+1}]]
}
incr idx
}
} elseif {$uwidth > 1} {
set owidth [punk::char::string_width $ch]
if {$owidth == 1} {
priv::render_addchar $idx $ch [dict get $overstacks $idx_over]
incr idx
priv::render_addchar $idx $opt_exposed2 [dict get $overstacks $idx_over]
#don't incr idx - we are just putting a broken-indication in the underlay - which may get overwritten by next overlay char
} else {
#2wide over 2wide
priv::render_addchar $idx $ch [dict get $overstacks $idx_over]
incr idx 2
}
}
}
}
#cursor movement?
#if {![punk::ansi::codetype::is_sgr $code]} {
#
#}
if {[punk::ansi::codetype::is_cursor_move_in_line $code]} {
}
set re_col_move {\x1b\[([0-9]*)(C|D|G)}
if {[regexp $re_col_move $code _match num type]} {
if {$type eq "C"} {
#left-arrow/move-back
if {$num eq ""} {set num 1}
incr idx -$num
if {$idx < $opt_colstart} {
set idx $opt_colstart
}
} elseif {$type eq "D"} {
#right-arrow/move forward
if {$num eq ""} {set num 1}
if {!$opt_overflow || ($idx + $num) <= [llength $outcols]-1} {
incr idx $num
if {$idx > [llength $outcols]-1} {
set idx [llength $outcols] -1
}
} else {
set idxstart $idx
set idxend [expr {[llength $outcols]-1}]
set moveend [expr {$idxend - $idxstart}]
incr idx $moveend
set stackinfo [dict get $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext
#pad outcols
set movemore [expr {$num - $moveend}]
#assert movemore always at least 1 or we wouldn't be in this branch
for {set m 1} {$m <= $movemore} {incr m} {
incr idx
priv::render_addchar $idx " " $stackinfo
}
}
} elseif {$type eq "G"} {
#move absolute column
#adjust to colstart - as column 1 is within overlay
#ie
set num [expr {$num + $opt_colstart}]
error "renderline absolute col move ESC G unimplemented"
}
}
}
if {$opt_overflow == 0} {
#need to truncate to the width of the original undertext
#review - string_width vs printing_length here. undertext requirement to be already rendered therefore punk::char::string_width ok?
set num_under_columns [punk::char::string_width $pt_underchars] ;#plaintext underchars
}
#coalesce and replay codestacks for outcols grapheme list
set outstring ""
set remstring "" ;#remainder after overflow point reached
set i 0
set cstack [list]
set prevstack [list]
set out_rawchars ""; #for overflow counting
set output_to "outstring" ;#var in effect depending on overflow
set in_overflow 0 ;#used to stop char-width scanning once in overflow
foreach ch $outcols {
append out_rawchars $ch
if {$opt_overflow == 0 && !$in_overflow} {
if {[set nextvisualwidth [punk::char::string_width $out_rawchars]] > $num_under_columns} {
#todo - check if we overflowed with a double-width char ?
#store visualwidth which may be short
set in_overflow 1
}
}
if {$in_overflow} {
set output_to "remstring"
}
set cstack [dict get $understacks $i]
if {$cstack ne $prevstack} {
if {[llength $prevstack]} {
append $output_to \033\[m
}
foreach code $cstack {
append $output_to $code
}
}
append $output_to $ch
set prevstack $cstack
incr i
}
if {[dict size $understacks] > 0} {
append $output_to [join [dict get $understacks [expr {[dict size $understacks]-1}]] ""] ;#tail codes
}
if {[string length $remstring]} {
#puts stderr "remainder:$remstring"
}
#pdict $understacks
if {$opt_returnextra} {
set cursorinfo ""
return [list result $outstring visualwidth - stringlen [string length $outstring] remainder $remstring cursor [expr {$idx + 1}]]
} else {
return $outstring
}
#return [join $out ""]
}
proc overtype::test_renderline {} {
set t \uFF5E ;#2-wide tilde
set u \uFF3F ;#2-wide underscore
set missing \uFFFD
return [list $t $u A${t}B]
}
#maintenance warning
#same as textblock::size - but we don't want that circular dependency
#block width and height can be tricky. e.g \v handled differently on different terminal emulators and can affect both
proc overtype::blocksize {textblock} {
if {$textblock eq ""} {
return [dict create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings
}
set textblock [textutil::tabify::untabify2 $textblock]
#stripansi on entire block in one go rather than line by line - result should be the same - review - make tests
set textblock [punk::ansi::stripansi $textblock]
if {[string first \n $textblock] >= 0} {
set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::string_width $v}]]
} else {
set width [punk::char::string_width $textblock]
}
set num_le [expr {[string length $textblock]-[string length [string map [list \n {}] $textblock]]}] ;#faster than splitting into single-char list
#our concept of block-height is likely to be different to other line-counting mechanisms
set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le
return [dict create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [dict values [blocksize <data>]] width height
}
namespace eval overtype::priv {
#is actually addgrapheme?
proc render_addchar {i c stack} {
upvar outcols o
upvar understacks ustacks
set nxt [llength $o]
if {$i < $nxt} {
lset o $i $c
} else {
lappend o $c
}
dict set ustacks $i $stack
}
}
# -- --- --- --- --- --- --- --- --- --- ---
namespace eval overtype {
interp alias {} ::overtype::center {} ::overtype::centre
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide overtype [namespace eval overtype {
variable version
set version 1.5.7
}]
return
#*** !doctools
#[manpage_end]

1756
src/bootsupport/modules/overtype-1.5.9.tm
View File

File diff suppressed because it is too large Load Diff

3292
src/bootsupport/modules/overtype-1.6.0.tm
View File

File diff suppressed because it is too large Load Diff

5
src/modules/flagfilter-0.3.tm
Unescape View File

@ -2078,10 +2078,11 @@ namespace eval flagfilter {
#todo - add flaggednew to required if all was specified?
#check invalid flags if not indicated in -extras , either explicitly or with 'extra'
set flags_from_required [get_flagged_only $required {}]
set known_flags [lsort -unique -nocase [concat [dict keys $defaults] $flags_from_required $soloflags]]
#set known_flags [lsort -unique -nocase [concat [dict keys $defaults] $flags_from_required $soloflags]] ;#why -nocase? why should -l and -L collapse to the uppercase version?
set known_flags [punk::lib::lunique_unordered [concat [dict keys $defaults] $flags_from_required $soloflags ]]
foreach spec $command_specs {
lassign $spec parentname pinfo
if {[string match -* $parentname]} {
if {[string match -* $parentname] && $parentname ni $known_flags} {
lappend known_flags $parentname
}
if {[dict exists $pinfo sub]} {

4
src/modules/funcl-0.1.tm
Unescape View File

@ -38,7 +38,7 @@ namespace eval funcl {
set end [lindex $args end]
if {[llength $end] == 1 && [arg_is_script_shaped $end]} {
set endfunc [string map [list <end> $end] {uplevel 1 [list if 1 <end> ]}]
set endfunc [string map "<end> $end" {uplevel 1 [list if 1 <end> ]}]
} else {
set endfunc $end
}
@ -232,7 +232,7 @@ namespace eval funcl {
}
set comp [list] ;#composition list
set end [lindex $args end]
if {[lindex $end 0] in [list "_fn" "_call"]} {
if {[lindex $end 0] in {_fn _call}]} {
#is_funcl
set endfunc [lindex $args end]
} else {

4
src/modules/natsort-0.1.1.6.tm
Unescape View File

@ -242,7 +242,7 @@ namespace eval natsort {
proc hex2dec {largeHex} {
#todo - use punk::lib::hex2dec - (scan supports ll so can do larger hex values directly)
set res 0
set largeHex [string map [list _ ""] $largeHex]
set largeHex [string map {_ {}} $largeHex]
if {[string length $largeHex] <=7} {
#scan can process up to FFFFFFF and does so quickly
return [scan $largeHex %x]
@ -392,7 +392,7 @@ namespace eval natsort {
proc get_char_count {str char} {
#faster than lsearch on split for str of a few K
expr {[string length $str]-[string length [string map [list $char {}] $str]]}
expr {[tcl::string::length $str]-[tcl::string::length [tcl::string::map "$char {}" $str]]}
}
proc build_key {chunk splitchars topdict tagconfig debug} {

6
src/modules/patternpunk-1.1.tm
Unescape View File

@ -92,7 +92,7 @@ set ::punk::bannerTemplate [string trim {
/ \
_+ +_
} \n]
>punk .. Property front_2003 [string trim [string map [list % \u2003] {
>punk .. Property front_2003 [string trim [string map "% \u2003" {
_|_
@%v%@
%~%
@ -119,7 +119,7 @@ set ::punk::bannerTemplate [string trim {
/ \
_+ +_
} \n]
>punk .. Property rhs_2003 [string trim [string map [list % \u2003] {
>punk .. Property rhs_2003 [string trim [string map "% \u2003" {
\\\_
\@%%>
|%~
@ -143,7 +143,7 @@ set ::punk::bannerTemplate [string trim {
/ \
_+ +_
} \n]
>punk .. Property lhs_2003 [string trim [string map [list % \u2003] {
>punk .. Property lhs_2003 [string trim [string map "% \u2003" {
_///
<%%@/
~%|

276
src/modules/poshinfo-999999.0a1.0.tm
Unescape View File

@ -0,0 +1,276 @@
# -*- 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.3.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 poshinfo 999999.0a1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_poshinfo 0 999999.0a1.0]
#[copyright "2024"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
#[require poshinfo]
#[keywords module]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of poshinfo
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by poshinfo
#[list_begin itemized]
package require Tcl 8.6-
package require punk::config
package require json ;#tcllib
#toml, yaml?
#*** !doctools
#[item] [package {Tcl 8.6}]
#[item] [package {punk::config}]
#[item] [package {json}]
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#tcl::namespace::eval poshinfo::class {
#*** !doctools
#[subsection {Namespace poshinfo::class}]
#[para] class definitions
#if {[tcl::info::commands [tcl::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
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval poshinfo {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
#variable xyz
#*** !doctools
#[subsection {Namespace poshinfo}]
#[para] Core API functions for poshinfo
#[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 info_from_filename {fname} {
#string based filename processing: we are deliberately avoiding test of file existence etc here
if {$fname eq ""} {
error "poshinfo::info_from_filename unable to determine name from empty string"
}
if {[string first . $fname] < 0} {
#theoretically we could have a file without dots - but it's more likely an error in this context
error "poshinfo::info_from_filename supplied value '$fname' doesn't look like a filename. Cowardly refusing to guess a shortname."
}
set ftail [file tail $fname]
set rootname [file rootname $ftail]
set format [string trimleft [file extension $ftail] .]
set parts [split $rootname .]
if {[lindex $parts end] eq "omp"} {
set type omp
set shortname [join [lrange $parts 0 end-1] .]
} else {
if {$rootname eq "schema"} {
set type schema
} else {
set type unknown
}
set shortname $rootname
}
return [dict create shortname $shortname format $format type $type]
}
proc themes_dict {{globfor *}} {
set running_config [punk::config::get running-config]
set posh_themes_path [tcl::dict::get $running_config posh_themes_path]
#posh_themes_path_extra ??
set themes [tcl::dict::create]
if {[string length $posh_themes_path]} {
if {[file exists $posh_themes_path]} {
set files [glob -nocomplain -directory $posh_themes_path -tails $globfor]
foreach ftail $files {
set themeinfo [info_from_filename $ftail]
set shortname [dict get $themeinfo shortname]
dict set themeinfo path [file join $posh_themes_path $ftail]
if {![dict exists $themes $shortname]} {
dict set themes $shortname [list $themeinfo]
} else {
dict lappend themes $shortname $themeinfo
}
}
}
}
return $themes
}
proc themes {{globfor *}} {
set themes [themes_dict $globfor]
set posh_theme [file normalize [punk::config::get_running_global posh_theme]]
set t [textblock::class::table new "Posh Themes"]
$t configure -show_header 1 -show_hseps 0
$t add_column -headers Shortname
$t add_column -headers Path
dict for {shortname themeinfolist} $themes {
#hack - support just one for now
set themeinfo [lindex $themeinfolist 0]
set path [dict get $themeinfo path]
$t add_row [list $shortname $path]
set fg ""
set bg ""
switch -- [dict get $themeinfo type] {
schema {
set bg Web-orange
}
omp {}
unknown {
set bg Web-red
}
default {
#we shouldn't be getting other values
set bg Web-yellow
}
}
if {$posh_theme eq [file normalize $path]} {
set fg web-limegreen
}
if {"$fg$bg" ne ""} {
$t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fg {*}$bg]
}
}
set result [$t print]
$t destroy
return $result
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace poshinfo ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval poshinfo::lib {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
tcl::namespace::path [tcl::namespace::parent]
#*** !doctools
#[subsection {Namespace poshinfo::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 poshinfo::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
#tcl::namespace::eval poshinfo::system {
#*** !doctools
#[subsection {Namespace poshinfo::system}]
#[para] Internal functions that are not part of the API
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide poshinfo [tcl::namespace::eval poshinfo {
variable pkg poshinfo
variable version
set version 999999.0a1.0
}]
return
#*** !doctools
#[manpage_end]

3
src/modules/poshinfo-buildversion.txt
Unescape View File

@ -0,0 +1,3 @@
0.1.0
#First line must be a semantic version number
#all other lines are ignored.

169
src/modules/punk-0.1.tm
Unescape View File

@ -1154,14 +1154,14 @@ namespace eval punk {
set script "proc $cmdname {leveldata} {"
append script \n [string map [list <selector> $selector] {set selector "<selector>"}] ;# script should only need for error msgs
set subindices [split $selector /]
append script \n [string map [list <subindices> [list $subindices] ] {set subindices <subindices>}]
append script \n [string map [list <subindices> [list $subindices]] {set subindices <subindices>}]
set action ?match ;#default assumption. Alternatively set to ?mismatch or ?mismatch-<somereason> and always break
append script \n {set action ?match}
#append script \n {set assigned ""} ;#review
set active_key_type ""
append script \n {# set activey_key_type ""}
set lhs $selector
append script \n [string map [list <selector> $selector ] {set lhs "<selector>"}]
append script \n [string map [list <selector> $selector] {set lhs "<selector>"}]
set rhs ""
append script \n {set rhs ""}
@ -1816,7 +1816,7 @@ namespace eval punk {
if {$end < 0} {
error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on]
}
append script \n [string map [list <e> $end] {
append script \n [string map "<e> $end" {
set end <e>
if {$end+1 > $len} {
set action ?mismatch-list-index-out-of-range
@ -1831,7 +1831,7 @@ namespace eval punk {
if {$endoffset > 0} {
error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end+x_out_of_bounds_for_all_data_while_bounds_check_on]
}
append script \n [string map [list <e_offset> $endoffset] {
append script \n [string map "<e_offset> $endoffset" {
set endoffset <e_offset>
if {abs($endoffset) >= $len} {
set action ?mismatch-list-index-out-of-range
@ -3426,11 +3426,11 @@ namespace eval punk {
#exclude quoted whitespace
proc arg_is_script_shaped {arg} {
if {[string first \n $arg] >= 0} {
if {[tcl::string::first \n $arg] >= 0} {
return 1
} elseif {[string first ";" $arg] >= 0} {
} elseif {[tcl::string::first ";" $arg] >= 0} {
return 1
} elseif {[string first " " $arg] >= 0 || [string first \t $arg] >= 0} {
} elseif {[tcl::string::first " " $arg] >= 0 || [tcl::string::first \t $arg] >= 0} {
lassign [_rhs_tail_split $arg] _ part2 ;#will have part2 if unquoted whitespace found
return [expr {$part2 ne ""}]
} else {
@ -3478,7 +3478,7 @@ namespace eval punk {
}
incr i
}
set tail [string range $fullrhs $i end]
set tail [tcl::string::range $fullrhs $i end]
return [list $equalsrhs $tail]
}
@ -4577,7 +4577,7 @@ namespace eval punk {
#----------------
#can't use know - because we don't want to return before original unknown body is called.
proc ::unknown {args} [string map [list] {
proc ::unknown {args} [string cat {
package require base64
#set ::punk::last_run_display [list]
#set ::repl::last_unknown [lindex $args 0] ;#jn
@ -5135,31 +5135,6 @@ namespace eval punk {
return $fullpath
}
#todo - something better - 'previous' rather than reverting to startup
proc channelcolors {{onoff {}}} {
upvar ::punk::config::running running_config
upvar ::punk::config::startup startup_config
if {![string length $onoff]} {
return [list stdout [dict get $running_config color_stdout] stderr [dict get $running_config color_stderr]]
} else {
set lower_onoff [string tolower $onoff]
switch -- $lower_onoff {
true - on - 1 {
dict set running_config color_stdout [dict get $startup_config color_stdout]
dict set running_config color_stderr [dict get $startup_config color_stderr]
}
false - off - 0 {
dict set running_config color_stdout ""
dict set running_config color_stderr ""
}
default {
error "channelcolors: invalid value $onoff - expected true|false|on|off|1|0"
}
}
}
return [list stdout [dict get $running_config color_stdout] stderr [dict get $running_config color_stderr]]
}
#useful for aliases e.g treemore -> xmore tree
proc xmore {args} {
@ -5525,6 +5500,9 @@ namespace eval punk {
#maint - punk::args has similar
#this is largely obsolete - uses dict for argspecs (defaults) instead of textblock as in punk::args
#textblock has more flexibility in some ways - but not as easy to manipulate especially with regards to substitutions
#todo - consider a simple wrapper for punk::args to allow calling with dict of just name and default?
#JMN
#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.
@ -5636,10 +5614,11 @@ namespace eval punk {
#dirfiles assumes we don't have glob chars in the filenames or paths - dirfiles_dict can be called directly with explicit -tailglob in the rare case that assumption doesn't hold
# dirfiles will test last segment (tail) of supplied searchspecs for fileness vs folderness (when no globchars present in tail) so that it can pass the appropriate flags downstream
proc dirfiles {args} {
set defaults [list\
-stripbase 1\
]
lassign [dict values [get_leading_opts_and_values $defaults $args]] opts searchspecs ;#implicit merge of opts over defaults
set argspecs {
-stripbase -default 1 -type boolean
}
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] opts searchspecs
set opt_stripbase [dict get $opts -stripbase]
@ -5716,13 +5695,18 @@ namespace eval punk {
#if caller supplies a tailglob as empty string - presume the caller hasn't set location to parentdir - and that last element is the search pattern.
# -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied
proc dirfiles_dict {args} {
set defaults [dict create\
-searchbase ""\
-tailglob "\uFFFF"\
-with_sizes "\uFFFF"\
-with_times "\uFFFF"\
]
lassign [dict values [get_leading_opts_and_values $defaults $args]] opts searchspecs
set argspecs {
*opts -any 0
-searchbase -default ""
-tailglob -default "\uFFFF"
#with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du)
-with_sizes -default "\uFFFF" -type string
-with_times -default "\uFFFF" -type string
*values -min 0 -max -1 -type string
}
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] opts vals
set searchspecs [dict values $vals]
#puts stderr "searchspecs: $searchspecs [llength $searchspecs]"
#puts stdout "arglist: $opts"
@ -5798,13 +5782,13 @@ namespace eval punk {
#leave up to listing-provider defaults
set next_opt_with_sizes ""
} else {
set next_opt_with_sizes "-with_sizes $opt_with_sizes"
set next_opt_with_sizes [list -with_sizes $opt_with_sizes]
}
if {$opt_with_times eq "\uFFFF"} {
#leave up to listing-provider defaults
set next_opt_with_times ""
} else {
set next_opt_with_times "-with_times $opt_with_times"
set next_opt_with_times [list -with_times $opt_with_times]
}
if {$in_vfs} {
set listing [punk::du::lib::du_dirlisting_tclvfs $location -glob $glob {*}$next_opt_with_sizes {*}$next_opt_with_times]
@ -5855,10 +5839,13 @@ namespace eval punk {
#we add dotfiles to flaggedhidden list in case there is some other mechanism that has flagged items as hidden
if {$::tcl_platform(platform) ne "windows"} {
lappend flaggedhidden {*}[lsearch -all -inline [concat $dirs $files] ".*"]
set flaggedhidden [lsort -unique $flaggedhidden]
#e.g we can have dupes in the case where there are vfs mounted files that appear as dirs
#as we will need to do a (nat)sort as a last step - it will be faster to not sort items prematurely
#set flaggedhidden [lsort -unique $flaggedhidden]
set flaggedhidden [punk::lib::lunique_unordered $flaggedhidden]
}
set dirs [lsort $dirs] ;#todo - natsort
set dirs [lsort $dirs] ;#todo - natsort
@ -5908,10 +5895,15 @@ namespace eval punk {
proc dirfiles_dict_as_lines {args} {
package require overtype
set defaults [list\
-stripbase 0\
]
lassign [dict values [get_leading_opts_and_values $defaults $args]] opts list_of_dicts ;#implicit merge of opts over defaults
set argspecs {
-stripbase -default 0 -type boolean
*values -min 1 -max -1 -type dict
}
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] opts vals
set list_of_dicts [dict values $vals]
# -- --- --- --- --- --- --- --- --- --- --- ---
set opt_stripbase [dict get $opts -stripbase]
@ -6176,7 +6168,7 @@ namespace eval punk {
proc delimit_number {unformattednumber {delim ","} {GroupSize 3}} {
set number [punk::objclone $unformattednumber]
set number [string map [list _ ""] $number]
set number [string map {_ ""} $number]
#normalize using expr - e.g 2e4 -> 20000.0
set number [expr {$number}]
# First, extract right hand part of number, up to and including decimal point
@ -6565,15 +6557,6 @@ namespace eval punk {
return $result
}
#proc list_as_lines {args} {
# set defaults [dict create\
# -joinchar "\n"\
# ]
# lassign [dict values [get_leading_opts_and_values $defaults $args -minvalues 1 -maxvalues 1]] opts values
# set opt_joinchar [dict get $opts -joinchar]
# set list [lindex $values 0]
# join $list $opt_joinchar
#}
#--------------------------------------------------
#some haskell-like operations
@ -6895,13 +6878,16 @@ namespace eval punk {
#An implementation of a notoriously controversial metric.
proc LOC {args} {
set defaults [dict create\
-dir "\uFFFF"\
-exclude_dupfiles 1\
-exclude_punctlines 1\
-punctchars [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?]\
]
lassign [dict values [get_leading_opts_and_values $defaults $args]] opts searchspecs ;#implicit merge of opts over defaults
set argspecs [subst {
-dir -default "\uFFFF"
-exclude_dupfiles -default 1 -type boolean
-exclude_punctlines -default 1 -type boolean
-punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] }
}]
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] opts vals
set searchspecs [dict values $vals]
# -- --- --- --- --- ---
set opt_dir [dict get $opts -dir]
if {$opt_dir eq "\uFFFF"} {
@ -7299,16 +7285,26 @@ namespace eval punk {
if {[punk::lib::system::has_script_var_bug]} {
append warningblock \n "minor warning: punk::lib::system::has_script_var_bug returned true! (string rep for list variable in script generated when script changed)"
}
if {[punk::lib::system::has_safeinterp_compile_bug]} {
set indent " "
append warningblock \n "[a+ web-red]warning: punk::lib::system::has_safeinterp_compile_bug returned true!" \n
append warningblock "${indent}(ensemble commands not compiled in safe interps - heavy performance impact in safe interps)" \n
append warningblock "${indent}see https://core.tcl-lang.org/tcl/tktview/1095bf7f75"
append warningblock [a]
}
}
set text ""
if {$topic in [list env environment]} {
set known $::punk::config::known_punk_env_vars
#todo - move to punk::config?
set known_punk $::punk::config::known_punk_env_vars
set known_other $::punk::config::known_other_env_vars
append text \n
set usetable 1
if {$usetable} {
set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]]
foreach v $known {
foreach v $known_punk {
if {[info exists ::env($v)]} {
set c2 [set ::env($v)]
} else {
@ -7319,8 +7315,24 @@ namespace eval punk {
$t configure_column 0 -headers [list "Punk environment vars"]
$t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {all}
append text [$t print]\n
set punktable [$t print]
$t destroy
set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]]
foreach v $known_other {
if {[info exists ::env($v)]} {
set c2 [set ::env($v)]
} else {
set c2 "(NOT SET)"
}
$t add_row [list $v $c2]
}
$t configure_column 0 -headers [list "Other environment vars"]
$t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {all}
set othertable [$t print]
$t destroy
append text [textblock::join $punktable " " $othertable]\n
} else {
append text $linesep\n
@ -7328,7 +7340,7 @@ namespace eval punk {
append text $linesep\n
set col1 [string repeat " " 25]
set col2 [string repeat " " 50]
foreach v $known {
foreach v $known_punk {
set c1 [overtype::left $col1 $v]
if {[info exists ::env($v)]} {
set c2 [overtype::left $col2 [set ::env($v)]
@ -7434,7 +7446,7 @@ namespace eval punk {
#NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed)
proc aliases {{glob *}} {
set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command
set ns_mapped [string map [list :: \uFFFF] $ns]
set ns_mapped [string map {:: \uFFFF} $ns]
#puts stderr "aliases ns: $ns_mapped"
set segments [split $ns_mapped \uFFFF] ;#include empty string before leading ::
if {![string length [lindex $segments end]]} {
@ -7454,7 +7466,7 @@ namespace eval punk {
set abs $a
}
set asegs [split [string map [list :: \uFFFF] $abs] \uFFFF]
set asegs [split [string map {:: \uFFFF} $abs] \uFFFF]
set acount [llength $asegs]
#puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments"
if {[expr {$acount - 1}] == $segcount} {
@ -7570,7 +7582,8 @@ namespace eval punk {
#file normalize {//host/share} -> //host/share
#To get back to some consistent cross platform behaviour - we will treat //something as a root/volume i.e we can't backtrack above it with ..
proc filepath_dotted_minimal {path} {
set path [string map [list \\ /] $path]
#set path [string map [list \\ /] $path]
set path [string map "\\\\ /" $path]
set doubleslash1_posn [string first // $path]
if {[punk::winpath::is_dos_device_path $path]} {
@ -7583,7 +7596,7 @@ namespace eval punk {
#e.g on freebsd: -> / sharehost share path etc
#however..also on windows: file split //sharehost -> / sharehost
#normalize by dropping leading slash before split - and then treating first 2 segments as a root
set normtail [string map [list //]]
set normtail [string map {// ""} $path]
set parts [file split [string range $path 1 end]]

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

@ -2406,7 +2406,9 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
underextendedoff {
#lremove any existing 4:1 etc
set e [struct::set difference $e [list 4:1 4:2 4:3 4:4 4:5]]
#NOTE struct::set result order can differ depending on whether tcl/critcl imp used
#set e [struct::set difference $e [list 4:1 4:2 4:3 4:4 4:5]]
set e [punk::lib::ldiff $e [list 4:1 4:2 4:3 4:4 4:5]]
lappend e 4:0
}
undersingle {
@ -2759,7 +2761,9 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
underextendedoff {
#lremove any existing 4:1 etc
set e [struct::set difference $e [list 4:1 4:2 4:3 4:4 4:5]]
#use of struct::set with critcl is fast, but will reorder e (with differences depending on tcl vs critcl)
#set e [struct::set difference $e [list 4:1 4:2 4:3 4:4 4:5]]
set e [punk::lib::ldiff $e [list 4:1 4:2 4:3 4:4 4:5]]
lappend e 4:0
}
undersingle {

120
src/modules/punk/args-999999.0a1.0.tm
Unescape View File

@ -191,9 +191,10 @@
#https://core.tcl-lang.org/tcl/tktview/1095bf7f75
#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here.
#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed)
#ensembles: array binary chan clock dict encoding info namespace string
#ensembles: array binary clock dict info namespace string
#possibly file too, although that is generally hidden/modified in a safe interp
#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc
#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp
#*** !doctools
#[subsection dependencies]
@ -304,6 +305,7 @@ tcl::namespace::eval punk::args {
set opt_required [list]
set val_required [list]
set arg_info [tcl::dict::create]
set arg_checks [tcl::dict::create]
set opt_defaults [tcl::dict::create]
set opt_names [list] ;#defined opts
set val_defaults [tcl::dict::create]
@ -411,7 +413,29 @@ tcl::namespace::eval punk::args {
-nominlen - -nomaxlen - -norange - -nochoices - -nochoicelabels {
tcl::dict::unset optspec_defaults $k
}
-type -
-type {
switch -- $v {
int - integer {
set v int
}
char - character {
set v char
}
bool - boolean {
set v bool
}
dict - dictionary {
set v dict
}
any - ansistring {
}
default {
#todo - disallow unknown types unless prefixed with custom-
}
}
tcl::dict::set optspec_defaults $k $v
}
-optional -
-allow_ansi -
-validate_without_ansi -
@ -444,7 +468,26 @@ tcl::namespace::eval punk::args {
-nominlen - -nomaxlen - -norange - -nochoices - -nochoicelabels {
tcl::dict::unset valspec_defaults $k
}
-type -
-type {
switch -- $v {
int - integer {
set v int
}
char - character {
set v char
}
bool - boolean {
set v bool
}
dict - dictionary {
set v dict
}
default {
#todo - disallow unknown types unless prefixed with custom-
}
}
tcl::dict::set valspec_defaults $k $v
}
-allow_ansi -
-validate_without_ansi -
-strip_ansi -
@ -480,7 +523,11 @@ tcl::namespace::eval punk::args {
}
#assert - we only get here if it is a value or flag specification line.
#assert argspecs has been set to the value of linespecs
set merged $optspec_defaults
if {$is_opt} {
set spec_merged $optspec_defaults
} else {
set spec_merged $valspec_defaults
}
foreach {spec specval} $argspecs {
#literal-key switch - bytecompiled to jumpTable
switch -- $spec {
@ -488,31 +535,38 @@ tcl::namespace::eval punk::args {
#normalize here so we don't have to test during actual args parsing in main function
switch -- [tcl::string::tolower $specval] {
int - integer {
tcl::dict::set merged -type int
tcl::dict::set spec_merged -type int
}
bool - boolean {
tcl::dict::set merged -type bool
tcl::dict::set spec_merged -type bool
}
char - character {
tcl::dict::set merged -type char
tcl::dict::set spec_merged -type char
}
dict - dictionary {
tcl::dict::set spec_merged -type dict
}
"" - none {
if {$is_opt} {
tcl::dict::set merged -type none
tcl::dict::set merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it.
tcl::dict::set spec_merged -type none
tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it.
lappend opt_solos $argname
} else {
#-solo only valid for flags
error "punk::args::get_dict - invalid -type 'none' for positional argument positional argument '$argname'"
}
}
any - ansistring {
tcl::dict::set spec_merged -type dict
}
default {
tcl::dict::set merged -type [tcl::string::tolower $specval]
#allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW
tcl::dict::set spec_merged -type [tcl::string::tolower $specval]
}
}
}
-default - -solo - -range - -choices - -choicelabels - -minlen - -maxlen - -nocase - -optional - -multiple - -validate_without_ansi - -allow_ansi - -strip_ansi - -help - -ARGTYPE {
tcl::dict::set merged $spec $specval
tcl::dict::set spec_merged $spec $specval
}
default {
set known_argspecs [list -default -type -range -choices -nocase -optional -multiple -validate_without_ansi -allow_ansi -strip_ansi -help]
@ -520,12 +574,12 @@ tcl::namespace::eval punk::args {
}
}
}
set argspecs $merged
#if {$is_opt} {
set argspecs $spec_merged
if {$is_opt} {
set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_without_ansi -allow_ansi] ;#leave things like -range -minlen
#} else {
# set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_without_ansi -allow_ansi] ;#leave things like -range -minlen
#}
} else {
set argchecks [tcl::dict::remove $argspecs -type -default -multiple -strip_ansi -validate_without_ansi -allow_ansi] ;#leave things like -range -minlen
}
tcl::dict::set arg_info $argname $argspecs
tcl::dict::set arg_checks $argname $argchecks
if {![tcl::dict::get $argspecs -optional]} {
@ -555,6 +609,10 @@ tcl::namespace::eval punk::args {
set spec_id "autoid_[incr id_counter]"
}
set opt_checks_defaults [tcl::dict::remove $optspec_defaults -type -default -multiple -strip_ansi -validate_without_ansi -allow_ansi] ;#leave things like -range -minlen
set val_checks_defaults [tcl::dict::remove $valspec_defaults -type -default -multiple -strip_ansi -validate_without_ansi -allow_ansi] ;#leave things like -range -minlen
set result [tcl::dict::create\
id $spec_id\
arg_info $arg_info\
@ -565,13 +623,14 @@ tcl::namespace::eval punk::args {
opt_any $opt_any\
opt_solos $opt_solos\
optspec_defaults $optspec_defaults\
valspec_defaults $valspec_defaults\
opt_checks_defaults $opt_checks_defaults\
val_defaults $val_defaults\
val_required $val_required\
val_names $val_names\
val_min $val_min\
val_max $val_max\
valspec_defaults $valspec_defaults\
val_checks_defaults $val_checks_defaults\
proc_info $proc_info\
]
tcl::dict::set argspec_cache $cache_key $result
@ -760,6 +819,7 @@ tcl::namespace::eval punk::args {
set newval [lindex $rawargs $i+1]
#opt was unspecified but is allowed due to *opt -any 1 - 'adhoc/passthrough' option
tcl::dict::set arg_info $a $optspec_defaults ;#use default settings for unspecified opt
tcl::dict::set arg_checks $a $opt_checks_defaults
if {[tcl::dict::get $arg_info $a -type] ne "none"} {
if {[tcl::dict::get $arg_info $a -multiple]} {
tcl::dict::lappend opts $a $newval
@ -822,6 +882,7 @@ tcl::namespace::eval punk::args {
} else {
tcl::dict::set values_dict $validx $val
tcl::dict::set arg_info $validx $valspec_defaults
tcl::dict::set arg_checks $validx $val_checks_defaults
lappend valnames_received $validx
}
}
@ -856,13 +917,23 @@ tcl::namespace::eval punk::args {
#safe interp note - cannot avoid struct::set difference ensemble as it could be c or tcl implementation and we don't have an option to call directly?
#example timing difference:
#struct::set difference {x} {a b}
#normal interp 0.18 u2 vs save interp 9.4us
if {[llength [set missing [struct::set difference $opt_required $flagsreceived]]]} {
#normal interp 0.18 u2 vs safe interp 9.4us
#if {[llength [set missing [struct::set difference $opt_required $flagsreceived]]]} {
# error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form"
#}
#if {[llength [set missing [struct::set difference $val_required $valnames_received]]]} {
# error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present"
#}
#for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us
if {[llength [set missing [punk::lib::ldiff $opt_required $flagsreceived]]]} {
error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form"
}
if {[llength [set missing [struct::set difference $val_required $valnames_received]]]} {
if {[llength [set missing [punk::lib::ldiff $val_required $valnames_received]]]} {
error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present"
}
#todo - allow defaults outside of choices/ranges
#check types,ranges,choices
@ -1004,6 +1075,13 @@ tcl::namespace::eval punk::args {
}
}
}
dict {
foreach e_check $vlist_check {
if {[llength $e_check] %2 != 0} {
error "Option $argname for [Get_caller] requires type 'dict' - must be key value pairs. Received: '$e_check'"
}
}
}
alnum -
alpha -
ascii -

115
src/modules/punk/cap-999999.0a1.0.tm
Unescape View File

@ -48,12 +48,12 @@ package require oolib
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::cap {
variable pkgcapsdeclared [dict create]
variable pkgcapsaccepted [dict create]
variable caps [dict create]
tcl::namespace::eval punk::cap {
variable pkgcapsdeclared [tcl::dict::create]
variable pkgcapsaccepted [tcl::dict::create]
variable caps [tcl::dict::create]
namespace eval class {
if {[info commands [namespace current]::interface_caphandler.registry] eq ""} {
if {[tcl::info::commands ::punk::cap::class::interface_caphandler.registry] eq ""} {
#*** !doctools
#[subsection {Namespace punk::cap::class}]
#[para] class definitions
@ -62,7 +62,7 @@ namespace eval punk::cap {
# [para] [emph {handler_classes}]
# [list_begin enumerated]
oo::class create [namespace current]::interface_caphandler.registry {
oo::class create ::punk::cap::class::interface_caphandler.registry {
#*** !doctools
#[enum] CLASS [class interface_caphandler.registry]
#[list_begin definitions]
@ -83,7 +83,7 @@ namespace eval punk::cap {
#[list_end]
}
oo::class create [namespace current]::interface_caphandler.sysapi {
oo::class create ::punk::cap::class::interface_caphandler.sysapi {
#*** !doctools
#[enum] CLASS [class interface_caphandler.sysapi]
#[list_begin definitions]
@ -103,7 +103,7 @@ namespace eval punk::cap {
# [list_begin enumerated]
#Provider classes
oo::class create [namespace current]::interface_capprovider.registration {
oo::class create ::punk::cap::class::interface_capprovider.registration {
#*** !doctools
# [enum] CLASS [class interface_cappprovider.registration]
# [para]Your provider package will need to instantiate this object under a sub-namespace called [namespace capsystem] within your package namespace.
@ -140,7 +140,7 @@ namespace eval punk::cap {
# [list_end]
}
oo::class create [namespace current]::interface_capprovider.provider {
oo::class create ::punk::cap::class::interface_capprovider.provider {
#*** !doctools
# [enum] CLASS [class interface_capprovider.provider]
# [para] Your provider package will need to instantiate this directly under it's own namespace with the command name of [emph {provider}]
@ -157,7 +157,7 @@ namespace eval punk::cap {
#*** !doctools
#[call class::interface_capprovider.provider [method constructor] [arg providerpkg]]
variable provider_pkg
if {$providerpkg in [list "" "::"]} {
if {$providerpkg in {"" "::"}} {
error "interface_capprovider.provider constructor error. Invalid provider '$providerpkg'"
}
if {![namespace exists ::$providerpkg]} {
@ -165,12 +165,12 @@ namespace eval punk::cap {
}
set registrationobj ::${providerpkg}::capsystem::capprovider.registration
if {[info commands $registrationobj] eq ""} {
if {[tcl::info::commands $registrationobj] eq ""} {
error "capprovider.provider constructor error. Missing capprovider.registration interface at '$obj' (command not found) interface_capprovider.regstration instantiation must precede interface_capprovider.provider"
}
set provider_pkg [string trim $providerpkg ""]
#review - what are we trying to achieve here?
set provider_pkg [tcl::string::trim $providerpkg ""]
}
method register {{capabilityname_glob *}} {
#*** !doctools
@ -232,13 +232,13 @@ namespace eval punk::cap {
#such unregistered capabilitynames may be used just to flag something, or have datamembers significant to callers cooperatively interested in that capname.
#we allow registering a capability with an empty handler (capnamespace) - but this means another handler could be registered later.
proc register_capabilityname {capname capnamespace} {
puts stderr "REGISTER_CAPABILITYNAME $capname $capnamespace"
#puts stderr "REGISTER_CAPABILITYNAME $capname $capnamespace"
variable caps
variable pkgcapsdeclared
variable pkgcapsaccepted
if {$capnamespace ne ""} {
#normalize with leading :: in case caller passed in package name rather than fully qualified namespace
if {![string match ::* $capnamespace]} {
if {![tcl::string::match ::* $capnamespace]} {
set capnamespace ::$capnamespace
}
}
@ -250,20 +250,21 @@ namespace eval punk::cap {
return
}
#assertion: capnamespace may or may not be empty string, capname may or may not already exist in caps dict, caps $capname providers may have existing entries.
dict set caps $capname handler $capnamespace
if {![dict exists $caps $capname providers]} {
dict set caps $capname providers [list]
tcl::dict::set caps $capname handler $capnamespace
if {![tcl::dict::exists $caps $capname providers]} {
tcl::dict::set caps $capname providers [list]
}
if {[llength [set providers [dict get $caps $capname providers]]]} {
if {[llength [set providers [tcl::dict::get $caps $capname providers]]]} {
#some provider(s) were in place before the handler was registered
if {[set capreg [punk::cap::capsystem::get_caphandler_registry $capname]] ne ""} {
foreach pkg $providers {
set fullcapabilitylist [dict get $pkgcapsdeclared $pkg]
foreach capspec $fullcapabilitylist {
set fullcapabilitylist [tcl::dict::get $pkgcapsdeclared $pkg]
set capname_capabilitylist [lsearch -all -inline -index 0 $fullcapabilitylist $capname]
foreach capspec $capname_capabilitylist {
lassign $capspec cn capdict
if {$cn ne $capname} {
continue
}
#if {$cn ne $capname} {
# continue
#}
if {[catch {$capreg pkg_register $pkg $capdict $fullcapabilitylist} do_register]} {
puts stderr "punk::cap::register_capabilityname '$capname' '$capnamespace' failed to register provider package '$pkg' - possible error in handler or provider"
puts stderr "error message:"
@ -271,22 +272,22 @@ namespace eval punk::cap {
set do_register 0
}
set list_accepted [dict get $pkgcapsaccepted $pkg]
set list_accepted [tcl::dict::get $pkgcapsaccepted $pkg]
if {$do_register} {
if {$capspec ni $list_accepted} {
dict lappend pkgcapsaccepted $pkg $capspec
tcl::dict::lappend pkgcapsaccepted $pkg $capspec
}
} else {
set posn [lsearch $list_accepted $capspec]
if {$posn >=0} {
set list_accepted [lreplace $list_accepted $posn $posn]
dict set pkgcapsaccepted $pkg $list_accepted
tcl::dict::set pkgcapsaccepted $pkg $list_accepted
}
}
}
#check if any accepted for this cap and remove from caps as necessary
set count 0
foreach accepted_capspec [dict get $pkgcapsaccepted $pkg] {
foreach accepted_capspec [tcl::dict::get $pkgcapsaccepted $pkg] {
if {[lindex $accepted_capspec 0] eq $capname} {
incr count
}
@ -295,7 +296,7 @@ namespace eval punk::cap {
set pkgposn [lsearch $providers $pkg]
if {$pkgposn >= 0} {
set updated_providers [lreplace $providers $posn $posn]
dict set caps $capname providers $updated_providers
tcl::dict::set caps $capname providers $updated_providers
}
}
}
@ -309,14 +310,14 @@ namespace eval punk::cap {
# [call [fun capability_exists] [arg capname]]
# Return a boolean indicating if the named capability exists (0|1)
variable caps
return [dict exists $caps $capname]
return [tcl::dict::exists $caps $capname]
}
proc capability_has_handler {capname} {
#*** !doctools
# [call [fun capability_has_handler] [arg capname]]
#Return a boolean indicating if the named capability has a handler package installed (0|1)
variable caps
return [expr {[dict exists $caps $capname handler] && [dict get $caps $capname handler] ne ""}]
return [expr {[tcl::dict::exists $caps $capname handler] && [tcl::dict::get $caps $capname handler] ne ""}]
}
proc capability_get_handler {capname} {
#*** !doctools
@ -324,8 +325,8 @@ namespace eval punk::cap {
#Return the base namespace of the active handler package for the named capability.
#[para] The base namespace for a handler will always be the package name, but prefixed with ::
variable caps
if {[dict exists $caps $capname]} {
return [dict get $caps $capname handler]
if {[tcl::dict::exists $caps $capname]} {
return [tcl::dict::get $caps $capname handler]
}
return ""
}
@ -338,8 +339,8 @@ namespace eval punk::cap {
}
proc get_providers {capname} {
variable caps
if {[dict exists $caps $capname]} {
return [dict get $caps $capname providers]
if {[tcl::dict::exists $caps $capname]} {
return [tcl::dict::get $caps $capname providers]
}
return [list]
}
@ -356,26 +357,26 @@ namespace eval punk::cap {
foreach {k v} $args {
switch -- $k {
-nowarnings {
dict set opts $k $v
tcl::dict::set opts $k $v
}
default {
error "Unrecognized option $k. Known options [dict keys $opts]"
error "Unrecognized option $k. Known options [tcl::dict::keys $opts]"
}
}
}
set warnings [expr {! [dict get $opts -nowarnings]}]
set warnings [expr {! [tcl::dict::get $opts -nowarnings]}]
if {[string match ::* $pkg]} {
set pkg [string range $pkg 2 end]
if {[tcl::string::match ::* $pkg]} {
set pkg [tcl::string::range $pkg 2 end]
}
if {[dict exists $pkgcapsaccepted $pkg]} {
set pkg_already_accepted [dict get $pkgcapsaccepted $pkg]
if {[tcl::dict::exists $pkgcapsaccepted $pkg]} {
set pkg_already_accepted [tcl::dict::get $pkgcapsaccepted $pkg]
} else {
set pkg_already_accepted [list]
}
package require $pkg
set providerapi ::${pkg}::provider
if {[info commands $providerapi] eq ""} {
if {[tcl::info::commands $providerapi] eq ""} {
error "register_package error. pkg '$pkg' doesn't seem to be a punk::cap capability provider (no object found at $providerapi)"
}
set defined_caps [$providerapi capabilities]
@ -397,13 +398,13 @@ namespace eval punk::cap {
if {[llength $capname] !=1} {
puts stderr "register_package error. pkg: '$pkg' An entry in the capability list doesn't appear to have a single-word name. Problematic entry:'$capspec'"
set reason "First element of capspec not a single-word name"
lappend errorlist [dict create msg $reason capspec $capspec]
lappend errorlist [tcl::dict::create msg $reason capspec $capspec]
continue
}
if {[expr {[llength $capdict] %2 != 0}]} {
puts stderr "register_package error. pkg:'$pkg' The second element for capname:'$capname' doesn't appear to be a valid dict. Problematic entry: '$capspec'"
set reason "The second element of the capspec isn't a valid dict"
lappend errorlist [dict create msg $reason capspec $capspec]
lappend errorlist [tcl::dict::create msg $reason capspec $capspec]
continue
}
if {$capspec in $pkg_already_accepted} {
@ -411,13 +412,13 @@ namespace eval punk::cap {
if {$warnings} {
puts stderr "WARNING: register_package pkg $pkg already has capspec marked as accepted: $capspec"
}
lappend warninglist [dict create msg "pkg $pkg already has this capspec marked as accepted" capspec $capspec]
lappend warninglist [tcl::dict::create msg "pkg $pkg already has this capspec marked as accepted" capspec $capspec]
continue
}
if {[dict exists $caps $capname]} {
set cap_pkgs [dict get $caps $capname providers]
if {[tcl::dict::exists $caps $capname]} {
set cap_pkgs [tcl::dict::get $caps $capname providers]
} else {
dict set caps $capname [dict create handler "" providers [list]]
dict set caps $capname [tcl::dict::create handler "" providers [list]]
set cap_pkgs [list]
}
#todo - if there's a caphandler - call it's init/validation callback for the pkg
@ -429,31 +430,31 @@ namespace eval punk::cap {
if {$do_register} {
if {$pkg ni $cap_pkgs} {
lappend cap_pkgs $pkg
dict set caps $capname providers $cap_pkgs
tcl::dict::set caps $capname providers $cap_pkgs
}
dict lappend pkgcapsaccepted $pkg $capspec ;#if pkg is being registered prior to handler-registration - the handler may undo this entry
tcl::dict::lappend pkgcapsaccepted $pkg $capspec ;#if pkg is being registered prior to handler-registration - the handler may undo this entry
}
}
#another call to register_pkg with same pkg may have been made (most likely with different capname) so we must append - but check not already present
#dict lappend pkgcapsdeclared $pkg $capabilitylist
if {[dict exists $pkgcapsdeclared $pkg]} {
if {[tcl::dict::exists $pkgcapsdeclared $pkg]} {
#review - untested
set mergecapspecs [dict get $pkgcapsdeclared $pkg]
set mergecapspecs [tcl::dict::get $pkgcapsdeclared $pkg]
foreach spec $capabilitylist {
if {$spec ni $mergecapspecs} {
lappend mergecapspecs $spec
}
}
dict set pkgcapsdeclared $pkg $mergecapspecs
tcl::dict::set pkgcapsdeclared $pkg $mergecapspecs
} else {
dict set pkgcapsdeclared $pkg $capabilitylist
tcl::dict::set pkgcapsdeclared $pkg $capabilitylist
}
set resultdict [list num_capabilities $capabilitylist_count num_accepted $accepted_count]
if {[llength $errorlist]} {
dict set resultdict errors $errorlist
tcl::dict::set resultdict errors $errorlist
}
if {[llength $warninglist]} {
dict set resultdict warnings $warninglist
tcl::dict::set resultdict warnings $warninglist
}
return $resultdict
}

6
src/modules/punk/cap/handlers/templates-999999.0a1.0.tm
Unescape View File

@ -61,7 +61,7 @@ namespace eval punk::cap::handlers::templates {
set path [dict get $capdict path]
set cname [string map [list . _] $capname]
set cname [string map {. _} $capname]
set multivendor_package_whitelist [list punk::mix::templates]
@ -226,7 +226,7 @@ namespace eval punk::cap::handlers::templates {
method pkg_unregister {pkg} {
upvar ::punk::cap::handlers::templates::handled_caps hcaps
foreach capname $hcaps {
set cname [string map [list . _] $capname]
set cname [string map {. _} $capname]
upvar ::punk::cap::handlers::templates::provider_info_$cname my_provider_info
dict unset my_provider_info $pkg
#destroy api objects?
@ -249,7 +249,7 @@ namespace eval punk::cap::handlers::templates {
constructor {capname} {
variable capabilityname
variable cname
set cname [string map [list . _] $capname]
set cname [string map {. _} $capname]
set capabilityname $capname
}
method folders {args} {

376
src/modules/punk/config-0.1.tm
Unescape View File

@ -4,106 +4,314 @@ tcl::namespace::eval punk::config {
variable startup ;#include env overrides
variable running
variable known_punk_env_vars
variable known_other_env_vars
variable vars
#todo - XDG_DATA_HOME etc
#https://specifications.freedesktop.org/basedir-spec/latest/
# see also: http://hiphish.github.io/blog/2020/08/30/dotfiles-were-a-mistake/
variable vars
set vars [list \
apps \
config \
configset \
scriptlib \
color_stdout \
color_stderr \
logfile_stdout \
logfile_stderr \
syslog_stdout \
syslog_stderr \
syslog_active \
exec_unknown \
]
#todo pkg punk::config
#defaults
tcl::dict::set startup configset .punkshell
tcl::dict::set startup exec_unknown true ;#whether to use exec instead of experimental shellfilter::run
#tcl::dict::set startup color_stdout [list cyan bold] ;#not a good idea to default
tcl::dict::set startup color_stdout [list]
#This wraps the stderr stream as it comes in with Ansi - probably best to default to empty.. but it's useful.
tcl::dict::set startup color_stderr [list red bold]
tcl::dict::set startup syslog_stdout "127.0.0.1:514"
tcl::dict::set startup syslog_stderr "127.0.0.1:514"
tcl::dict::set startup syslog_active 0
#default file logs to logs folder at same location as exe if writable, or empty string
tcl::dict::set startup logfile_stdout ""
tcl::dict::set startup logfile_stderr ""
set exename ""
catch {
#catch for safe interps
#safe base will return empty string, ordinary safe interp will raise error
set exename [tcl::info::nameofexecutable]
}
if {$exename ne ""} {
set exefolder [file dirname $exename]
set log_folder $exefolder/logs
tcl::dict::set startup scriptlib $exefolder/scriptlib
tcl::dict::set startup apps $exefolder/../../punkapps
if {[file exists $log_folder]} {
proc init {} {
variable defaults
variable startup
variable running
variable known_punk_env_vars
variable known_other_env_vars
set exename ""
catch {
#catch for safe interps
#safe base will return empty string, ordinary safe interp will raise error
set exename [tcl::info::nameofexecutable]
}
if {$exename ne ""} {
set exefolder [file dirname $exename]
#default file logs to logs folder at same level as exe if writable, or empty string
set log_folder [file normalize $exefolder/../logs]
#tcl::dict::set startup scriptlib $exefolder/scriptlib
#tcl::dict::set startup apps $exefolder/../../punkapps
#todo - use punk main.tcl location instead - exefolder doesn't work if system tclsh used etc
set default_scriptlib $exefolder/scriptlib
set default_apps $exefolder/../../punkapps
if {[file isdirectory $log_folder] && [file writable $log_folder]} {
tcl::dict::set startup logfile_stdout $log_folder/repl-exec-stdout.txt
tcl::dict::set startup logfile_stderr $log_folder/repl-exec-stderr.txt
#tcl::dict::set startup logfile_stdout $log_folder/repl-exec-stdout.txt
#tcl::dict::set startup logfile_stderr $log_folder/repl-exec-stderr.txt
set default_logfile_stdout $log_folder/repl-exec-stdout.txt
set default_logfile_stderr $log_folder/repl-exec-stderr.txt
} else {
set default_logfile_stdout ""
set default_logfile_stderr ""
}
} else {
#probably a safe interp - which cannot access info nameofexecutable even if access given to the location via punk::island
#review - todo?
#tcl::dict::set startup scriptlib ""
#tcl::dict::set startup apps ""
set default_scriptlib ""
set default_apps ""
set default_logfile_stdout ""
set default_logfile_stderr ""
}
} else {
#probably a safe interp - which cannot access info nameofexecutable even if access given to the location via punk::island
#review - todo?
tcl::dict::set startup scriptlib ""
tcl::dict::set startup apps ""
}
# exec_unknown ;#whether to use exec instead of experimental shellfilter::run
#startup color_stdout - parameters as suitable for punk::ansi::a+ (test with 'punk::ansi::a?') e.g "cyan bold" ;#not a good idea to default
set default_color_stdout ""
#This wraps the stderr stream as it comes in with Ansi - probably best to default to empty.. but it's useful.
set default_color_stderr "red bold"
#todo - load/write config file
#env vars override the configuration
#todo - define which configvars are settable in env
set known_punk_env_vars [list \
PUNK_APPS \
PUNK_CONFIG \
PUNK_CONFIGSET \
PUNK_SCRIPTLIB \
PUNK_EXECUNKNOWN \
PUNK_COLOR_STDERR \
PUNK_COLOR_STDOUT \
PUNK_LOGFILE_STDOUT \
PUNK_LOGFILE_STDERR \
PUNK_SYSLOG_STDOUT \
PUNK_SYSLOG_STDERR \
PUNK_SYSLOG_ACTIVE \
set homedir ""
if {[catch {
#depending on which build of tcl - some safe interps prior to bugfix https://core.tcl-lang.org/tcl/info/3aa487993f will return a homedir value in an unmodified safe interp
#other 'safe' interps may have explicitly made this available - we shouldn't override that decision here using interp issafe so we can't compensate for versions which shouldn't really be returning this in the safe interp
set homedir [file home]
} errM]} {
#tcl 8.6 doesn't have file home.. try again
if {[info exists ::env(HOME)]} {
set homedir $::env(HOME)
}
}
# per user xdg vars
# ---
set default_xdg_config_home "" ;#config data - portable
set default_xdg_data_home "" ;#data the user likely to want to be portable
set default_xdg_cache_home "" ;#local cache
set default_xdg_state_home "" ;#persistent user data such as logs, but not as important or as portable as those in xdg_data_home
# ---
set default_xdg_data_dirs "" ;#non-user specific
#xdg_config_dirs ?
#xdg_runtime_dir ?
#review. we are assuming if we can't get a home dir - then all the xdg vars including xdg_data_dirs aren't likely to be useful (as presumably filesystem access is absent)
#(safe interp generally won't have access to ::env either)
#This coupling doesn't necessarily hold - its possible the relevant env vars were copied to a safe interp - although that would be a policy that would make disabling 'info home' inconsistent.
if {$homedir ne ""} {
if {"windows" eq $::tcl_platform(platform)} {
#as much as I'd prefer to use ~/.local/share and ~/.config to keep them more consistent with unixlike platforms - the vast majority of apps put them where microsoft wants them.
#we have a choice of LOCALAPPDATA vs APPDATA (local to machine vs potentially roaming/redirected in a corporate environment)
#using the roaming location should not impact users who aren't using a domain controller but is potentially much more convenient for those who do.
if {[info exists ::env(APPDATA)]} {
set default_xdg_config_home $::env(APPDATA)
set default_xdg_data_home $::env(APPDATA)
}
#The xdg_cache_home should be kept local
if {[info exists ::env(LOCALAPPDATA)]} {
set default_xdg_cache_home $::env(LOCALAPPDATA)
set default_xdg_state_home $::env(LOCALAPPDATA)
}
if {[info exists ::env(PROGRAMDATA)]} {
#- equiv env(ALLUSERSPROFILE) ?
set default_xdg_data_dirs $::env(PROGRAMDATA)
}
} else {
#follow defaults as specified on freedesktop.org e.g https://specifications.freedesktop.org/basedir-spec/latest/ar01s03.html
set default_xdg_config_home [file join $homedir .config]
set default_xdg_data_home [file join $homedir .local share]
set default_xdg_cache_home [file join $homedir .cache]
set default_xdg_state_home [file join $homedir .local state]
set default_xdg_data_dirs /usr/local/share
}
}
set defaults [dict create\
apps $default_apps\
config ""\
configset ".punkshell"\
scriptlib $default_scriptlib\
color_stdout $default_color_stdout\
color_stderr $default_color_stderr\
logfile_stdout $default_logfile_stdout\
logfile_stderr $default_logfile_stderr\
logfile_active 0\
syslog_stdout "127.0.0.1:514"\
syslog_stderr "127.0.0.1:514"\
syslog_active 0\
exec_unknown true\
xdg_config_home $default_xdg_config_home\
xdg_data_home $default_xdg_data_home\
xdg_cache_home $default_xdg_cache_home\
xdg_state_home $default_xdg_state_home\
xdg_data_dirs $default_xdg_data_dirs\
theme_posh_override ""\
posh_theme ""\
posh_themes_path ""\
]
#override with env vars if set
variable evar
foreach evar $known_punk_env_vars {
if {[info exists ::env($evar)]} {
set f [set ::env($evar)]
if {$f ne "default"} {
#e.g PUNK_SCRIPTLIB -> scriptlib
set varname [tcl::string::tolower [tcl::string::range $evar 5 end]]
tcl::dict::set startup $varname $f
set startup $defaults
#load values from saved config file - $xdg_config_home/punk/punk.config ?
#typically we want env vars to override the stored config - as env vars conventionally used on some commandlines.
#that's possibly ok for the PUNK_ vars
#however.. others like the xdg vars and NOCOLOR may apply to other apps.. and we may want to override them from the saved config?
#making some env vars override saved config values and some not would be potentially confusing. may need one/more specific settings or env vars to determine which takes precedence?
#simpler is probably just to let env vars take precedence - and warn when saving or viewing config that the saved values are being overridden
#- requiring user to manually unset any unwanted env vars when launching?
#we are likely to want the saved configs for subshells/decks to override them however.
#todo - load/save config file
#todo - define which configvars are settable in env
set known_punk_env_vars [list \
PUNK_APPS\
PUNK_CONFIG\
PUNK_CONFIGSET\
PUNK_SCRIPTLIB\
PUNK_EXECUNKNOWN\
PUNK_COLOR_STDERR\
PUNK_COLOR_STDOUT\
PUNK_LOGFILE_STDOUT\
PUNK_LOGFILE_STDERR\
PUNK_LOGFILE_ACTIVE\
PUNK_SYSLOG_STDOUT\
PUNK_SYSLOG_STDERR\
PUNK_SYSLOG_ACTIVE\
PUNK_THEME_POSH_OVERRIDE\
]
#override with env vars if set
foreach evar $known_punk_env_vars {
if {[info exists ::env($evar)]} {
set f [set ::env($evar)]
if {$f ne "default"} {
#e.g PUNK_SCRIPTLIB -> scriptlib
set varname [tcl::string::tolower [tcl::string::range $evar 5 end]]
tcl::dict::set startup $varname $f
}
}
}
# https://no-color.org
#if {[info exists ::env(NO_COLOR)]} {
# if {$::env(NO_COLOR) ne ""} {
# set colour_disabled 1
# }
#}
set known_other_env_vars [list\
NO_COLOR\
XDG_CONFIG_HOME\
XDG_DATA_HOME\
XDG_CACHE_HOME\
XDG_STATE_HOME\
XDG_DATA_DIRS\
POSH_THEME\
POSH_THEMES_PATH\
]
foreach evar $known_other_env_vars {
if {[info exists ::env($evar)]} {
set f [set ::env($evar)]
if {$f ne "default"} {
set varname [tcl::string::tolower $evar]
tcl::dict::set startup $varname $f
}
}
}
#unset -nocomplain vars
set running [tcl::dict::create]
set running [tcl::dict::merge $running $startup]
}
init
#todo - consider how to divide up settings, categories, 'devices', decks etc
proc get_running_global {varname} {
variable running
if {[dict exists $running $varname]} {
return [dict get $running $varname]
}
error "No such global configuration item '$varname' found in running config"
}
proc get_startup_global {varname} {
variable startup
if {[dict exists $startup $varname]} {
return [dict get $startup $varname]
}
error "No such global configuration item '$varname' found in startup config"
}
proc get {whichconfig} {
variable startup
variable running
switch -- $whichconfig {
config - startup - startup-config - startup-configuration {
#show *startup* config - different behaviour may be confusing to those used to router startup and running configs
return $startup
}
running - running-config - running-configuration {
return $running
}
}
}
proc show {whichconfig} {
#todo - tables for console
variable startup
variable running
switch -- $whichconfig {
config - startup - startup-config - startup-configuration {
#show *startup* config - different behaviour may be confusing to those used to router startup and running configs
return [punk::print_dict $startup]
}
running - running-config - running-configuration {
return [punk::print_dict $running]
}
}
}
#e.g
# copy running-config startup-config
# copy startup-config test-config.cfg
# copy backup-config.cfg running-config
#review - consider the merge vs overwrite feature of some routers.. where copy to running-config does a merge rather than an overwrite ?
proc copy {fromconfig toconfig} {
error "sorry - unimplemented"
switch -- $toconfig {
}
}
unset -nocomplain evar
unset -nocomplain vars
set running [tcl::dict::create]
set running [tcl::dict::merge $running $startup]
}
#todo - move to cli?
::tcl::namespace::eval punk::config {
#todo - something better - 'previous' rather than reverting to startup
proc channelcolors {{onoff {}}} {
variable running
variable startup
if {![string length $onoff]} {
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]]
} else {
if {![string is boolean $onoff]} {
error "channelcolors: invalid value $onoff - expected boolean: true|false|on|off|1|0|yes|no"
}
if {$onoff} {
dict set running color_stdout [dict get $startup color_stdout]
dict set running color_stderr [dict get $startup color_stderr]
} else {
dict set running color_stdout ""
dict set running color_stderr ""
}
}
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]]
}
}
package provide punk::config [tcl::namespace::eval punk::config {

1
src/modules/punk/console-999999.0a1.0.tm
Unescape View File

@ -765,6 +765,7 @@ namespace eval punk::console {
} ;#end namespace eval internal
variable colour_disabled 0
#todo - move to punk::config
# https://no-color.org
if {[info exists ::env(NO_COLOR)]} {
if {$::env(NO_COLOR) ne ""} {

10
src/modules/punk/du-999999.0a1.0.tm
Unescape View File

@ -901,7 +901,7 @@ namespace eval punk::du {
set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*]
#set hlinks {}
set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. struct::set difference will remove
set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. struct::set difference will remove (?)
#set links [lsort -unique [concat $hlinks $links[unset links]]]
set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} * .*]
@ -913,18 +913,20 @@ namespace eval punk::du {
set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob]
set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob]
set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. struct::set difference will remove
set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. struct::set difference will remove (?)
set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob]
set files [glob -nocomplain -dir $folderpath -types f $opt_glob]
}
#note struct::set difference produces unordered result
#struct::set difference removes duplicates
#struct::set difference removes duplicates (but not always.. e.g if using tcl impl and 2nd element empty!)
#relying on struct::set to remove dupes is somewhat risky. It is not well documented - and behaviour of dupes in inputs is underspecified as it appears to be intended for mathematical 'sets'
#remove links and . .. from directories, remove links from files
#struct::set will affect order: tcl vs critcl give different ordering!
set files [struct::set difference [concat $hfiles $files[unset files]] $links]
set dirs [struct::set difference [concat $hdirs $dirs[unset dirs]] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]]
set links [lsort -unique [concat $links $hlinks]]
#set links [lsort -unique [concat $links $hlinks]]
#----

8
src/modules/punk/fileline-999999.0a1.0.tm
Unescape View File

@ -1555,10 +1555,10 @@ namespace eval punk::fileline::lib {
}
proc range_boundaries {start end chunksizes args} {
lassign [punk::get_leading_opts_and_values {\
-offset 0\
} $args] _opts opts _vals remainingargs
set argd [punk::args::get_dict {
-offset -default 0
} $args]
lassign [dict values $argd] opts remainingargs
}

119
src/modules/punk/lib-999999.0a1.0.tm
Unescape View File

@ -356,7 +356,62 @@ namespace eval punk::lib {
return [expr {[llength $i] == 0}]
}
#somewhat like struct::set difference - but order preserving, and doesn't treat as a 'set' so preserves dupes in fromlist
#struct::set difference may happen to preserve ordering when items are integers, but order can't be relied on,
# especially as struct::list has 2 differing implementations (tcl vs critcl) which return results with different ordering to each other.
proc ldiff {fromlist removeitems} {
set doomed [list]
foreach item $removeitems {
lappend doomed {*}[lsearch -all -exact $fromlist $item]
}
lremove $fromlist {*}$doomed
}
package require struct::set
if {[struct::set equal [struct::set union {a a} {}] {a}]} {
proc lunique_unordered {list} {
struct::set union $list {}
}
} else {
puts stderr "WARNING: struct::set union <list> <emptylist> no longer dedupes!"
proc lunique_unordered {list} {
tailcall lunique $list
}
}
#order-preserving
proc lunique {list} {
set doomed [list]
#expr 'in' probably faster than using a dict - for lists approx < 20,000 items. (wiki wisdom - url?)
for {set i 0} {$i < [llength $list]} {} {
set item [lindex $list $i]
lappend doomed {*}[lrange [lsearch -all -exact -start $i $list $item] 1 end]
while {[incr i] in $doomed} {}
}
lremove $list {*}$doomed
}
proc lunique1 {list} {
set doomed [list]
#expr 'in' probably faster than using a dict - for lists approx < 20,000 items. (wiki wisdom - url?)
set i 0
foreach item $list {
if {$i in $doomed} {
incr i
continue
}
lappend doomed {*}[lrange [lsearch -all -exact -start $i $list $item] 1 end]
incr i
}
puts --->doomed:$doomed
lremove $list {*}$doomed
}
proc lunique2 {list} {
set new {}
foreach item $list {
if {$item ni $new} {
lappend new $item
}
}
return $new
}
#The closure-like behaviour is *very* slow especially when called from a context such as the global namespace with lots of vars and large arrays such as ::env
proc lmapflat_closure {varnames list script} {
set result [list]
@ -447,8 +502,15 @@ namespace eval punk::lib {
return $result
}
proc lmapflat {varnames list script} {
concat {*}[uplevel 1 [list lmap $varnames $list $script]]
#proc lmapflat {varnames list script} {
# concat {*}[uplevel 1 [list lmap $varnames $list $script]]
#}
#lmap can accept multiple var list pairs
proc lmapflat {args} {
concat {*}[uplevel 1 [list lmap {*}$args]]
}
proc lmapflat2 {args} {
concat {*}[uplevel 1 lmap {*}$args]
}
proc dict_getdef {dictValue args} {
@ -1647,6 +1709,12 @@ namespace eval punk::lib {
return $result
}
proc temperature_f_to_c {deg_fahrenheit} {
return [expr {($deg_fahrenheit -32) * (5/9.0)}]
}
proc temperature_c_to_f {deg_celsius} {
return [expr {($deg_celsius * (9/5.0)) + 32}]
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::lib ---}]
}
@ -1685,6 +1753,51 @@ namespace eval punk::lib::system {
return false
}
}
proc has_safeinterp_compile_bug {{show 0}} {
#ensemble calls within safe interp not compiled
namespace eval [namespace current]::testcompile {
proc ensembletest {} {string index a 0}
}
set has_bug 0
set bytecode_outer [tcl::unsupported::disassemble proc [namespace current]::testcompile::ensembletest]
if {$show} {
puts outer:
puts $bytecode_outer
}
if {![interp issafe]} {
#test of safe subinterp only needed if we aren't already in a safe interp
if {![catch {
interp create x -safe
} errMsg]} {
x eval {proc ensembletest {} {string index a 0}}
set bytecode_safe [x eval {tcl::unsupported::disassemble proc ::ensembletest}]
if {$show} {
puts safe:
puts $bytecode_safe
}
interp delete x
#mainly we expect the safe interp might contain invokeStk - indicating not byte compiled (or we would see strindex instead)
#It's possible the interp we're running in is also not compiling ensembles.
#we could then get a result of 2 - which still indicates a problem
if {[string last "invokeStk" $bytecode_safe] >= 1} {
incr has_bug
}
} else {
#our failure to create a safe interp here doesn't necessarily mean the Tcl version doesn't have the problem - but we could end up returning zero if somehow safe interp can't be created from unsafe interp?
#unlikely - but we should warn
puts stderr "Unable to create a safe sub-interp to test - result only indicates status of current interpreter"
}
}
namespace delete [namespace current]::testcompile
if {[string last "invokeStk" $bytecode_outer] >= 1} {
incr has_bug
}
return $has_bug
}
proc mostFactorsBelow {n} {
##*** !doctools

34
src/modules/punk/mix-0.2.tm
Unescape View File

@ -1,25 +1,31 @@
package require punk::cap
package require punk::cap::handlers::templates ;#handler for templates cap
punk::cap::register_capabilityname punk.templates ::punk::cap::handlers::templates
package require punk::mix::templates ;#registers as provider pkg for 'punk.templates' capability with punk::cap
if {[catch {punk::mix::templates::provider register *} errM]} {
puts stderr "punk::mix failure during punk::mix::templates::provider register *"
puts stderr $errM
puts stderr "-----"
puts stderr $::errorInfo
tcl::namespace::eval punk::mix {
proc init {} {
package require punk::cap::handlers::templates ;#handler for templates cap
punk::cap::register_capabilityname punk.templates ::punk::cap::handlers::templates ;#time taken should generally be sub 200us
package require punk::mix::templates ;#registers as provider pkg for 'punk.templates' capability with punk::cap
set t [time {
if {[catch {punk::mix::templates::provider register *} errM]} {
puts stderr "punk::mix failure during punk::mix::templates::provider register *"
puts stderr $errM
puts stderr "-----"
puts stderr $::errorInfo
}
}]
puts stderr "->punk::mix::templates::provider register * t=$t"
}
init
}
package require punk::mix::base
package require punk::mix::cli
namespace eval punk::mix {
}
package provide punk::mix [namespace eval punk::mix {
package provide punk::mix [tcl::namespace::eval punk::mix {
variable version
set version 0.2

2
src/modules/punk/mix/base-0.1.tm
Unescape View File

@ -394,7 +394,7 @@ namespace eval punk::mix::base {
proc module_subpath {modulename} {
set modulename [string trim $modulename :]
set nsq [namespace qualifiers $modulename]
return [string map [list :: /] $nsq]
return [string map {:: /} $nsq]
}
proc get_build_workdir {path} {

7
src/modules/punk/mix/cli-0.3.tm
Unescape View File

@ -123,8 +123,9 @@ namespace eval punk::mix::cli {
}
#review - why can't we be anywhere in the project?
#also - if no make.tcl - can we use the running shell's make.tcl ? (after prompting user?)
if {([file tail $sourcefolder] ne "src") || (![file exists $sourcefolder/make.tcl])} {
puts stderr "deck make must be run from src folder containing make.tcl - unable to proceed (cwd: [pwd])"
puts stderr "dev make must be run from src folder containing make.tcl - unable to proceed (cwd: [pwd])"
if {[string length $project_base]} {
if {[file exists $project_base/src] && [string tolower [pwd]] ne [string tolower $project_base/src]} {
puts stderr "Try cd to $project_base/src"
@ -224,7 +225,7 @@ namespace eval punk::mix::cli {
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---
validate_name_not_empty_or_spaced $modulename -errorprefix $opt_errorprefix
set testname [string map [list :: ""] $modulename]
set testname [string map {:: {}} $modulename]
if {[string first : $testname] >=0} {
error "$opt_errorprefix '$modulename' can only contain paired colons"
}
@ -372,7 +373,7 @@ namespace eval punk::mix::cli {
}
set timeline [exec fossil timeline -n 5 -t ci]
set timeline [string map [list \r\n \n] $timeline]
set timeline [string map {\r\n \n} $timeline]
append result $timeline
if {$opt_v} {
set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes fossil]

4
src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm
Unescape View File

@ -251,7 +251,7 @@ namespace eval punk::mix::commandset::loadedlib {
}
set loadinfo [package ifneeded $libfound $ver]
set loadinfo [string map [list \r\n \n] $loadinfo]
set loadinfo [string map {\r\n \n} $loadinfo]
set loadinfo_lines [split $loadinfo \n]
if {[catch {llength $loadinfo}]} {
set loadinfo_is_listshaped 0
@ -316,7 +316,7 @@ namespace eval punk::mix::commandset::loadedlib {
#we only follow one level of package require redirection - seems unlikely/imprudent to follow arbitrarily in a while loop(?)
set libfound $lib_diversion_name
set loadinfo [package ifneeded $libfound $ver]
set loadinfo [string map [list \r\n \n] $loadinfo]
set loadinfo [string map {\r\n \n} $loadinfo]
set loadinfo_lines [split $loadinfo \n]
if {[catch {llength $loadinfo}]} {
set loadinfo_is_listshaped 0

4
src/modules/punk/mix/templates/layouts/project/src/make.tcl
Unescape View File

@ -281,7 +281,7 @@ if {$::punkmake::command eq "bootsupport"} {
foreach {relpath module} $bootsupport_modules {
set module [string trim $module :]
set module_subpath [string map [list :: /] [namespace qualifiers $module]]
set module_subpath [string map {:: /} [namespace qualifiers $module]]
set srclocation [file join $projectroot $relpath $module_subpath]
#puts stdout "$relpath $module $module_subpath $srclocation"
set pkgmatches [glob -nocomplain -dir $srclocation -tail [namespace tail $module]-*]
@ -617,7 +617,7 @@ if {[file exists $mapfile]} {
fconfigure $fdmap -translation binary
set mapdata [read $fdmap]
close $fdmap
set mapdata [string map [list \r\n \n] $mapdata]
set mapdata [string map {\r\n \n} $mapdata]
set missing [list]
foreach ln [split $mapdata \n] {
set ln [string trim $ln]

4
src/modules/punk/mix/templates/modules/template_anyname-0.0.2.tm
Unescape View File

@ -24,7 +24,7 @@ apply {code { #auto determine package name and version from name and placement o
}
set ver [join [lassign [split [file rootname [file tail [info script] ]] -] pkgtail] -]
set pkgns ${nsprefix}${pkgtail}
namespace eval $pkgns [string map [list <pkg> $pkgns <ver> $ver] $code]
tcl::namespace::eval $pkgns [string map [list <pkg> $pkgns <ver> $ver] $code]
package provide $pkgns $ver;# only provide package if code evaluated without error
} ::} {
#--------------------------------------
@ -40,7 +40,7 @@ apply {code { #auto determine package name and version from name and placement o
namespace eval [namespace current]::lib {
tcl::namespace::eval [tcl::namespace::current]::lib {
#proc test {args} {puts "[namespace current]::test got args: $args"}
}

89
src/modules/punk/ns-999999.0a1.0.tm
Unescape View File

@ -20,12 +20,12 @@
package require punk::lib
package require punk::args
namespace eval ::punk_dynamic::ns {
tcl::namespace::eval ::punk_dynamic::ns {
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::ns {
tcl::namespace::eval punk::ns {
variable ns_current "::"
variable ns_re_cache [dict create] ;#cache regular expressions used in globmatchns
namespace export nsjoin nsprefix nstail nsparts nseval nsimport_noclobber corp
@ -58,7 +58,7 @@ namespace eval punk::ns {
set has_globchars [regexp {[*?]} $ns_or_glob]
if {$is_absolute} {
if {!$has_globchars} {
if {![namespace exists $ns_or_glob]} {
if {![tcl::namespace::exists $ns_or_glob]} {
error "cannot change to namespace $ns_or_glob"
}
set ns_current $ns_or_glob
@ -71,7 +71,7 @@ namespace eval punk::ns {
} else {
if {!$has_globchars} {
set nsnext [nsjoin $ns_current $ns_or_glob]
if {![namespace exists $nsnext]} {
if {![tcl::namespace::exists $nsnext]} {
error "cannot change to namespace $ns_or_glob"
}
set ns_current $nsnext
@ -86,7 +86,7 @@ namespace eval punk::ns {
set ns_display "\n$ns_queried"
if {$ns_current eq $ns_queried} {
if {$ns_current in [info commands $ns_current] } {
if {![catch [list namespace ensemble configure $ns_current] ensemble_info]} {
if {![catch [list tcl::namespace::ensemble configure $ns_current] ensemble_info]} {
if {[llength $ensemble_info] > 0} {
#this namespace happens to match ensemble command.
#todo - keep cache of encountered ensembles from commands.. and examine namespace in the configure info.
@ -119,13 +119,13 @@ namespace eval punk::ns {
set nspath [nsjoinall $ns_current {*}$args]
}
set ns_exists [nseval [nsprefix $nspath] [list ::namespace exists [nstail $nspath] ]]
set ns_exists [nseval [nsprefix $nspath] [list ::tcl::namespace::exists [nstail $nspath] ]]
if {$ns_exists} {
error "Namespace $nspath already exists"
}
#namespace eval [nsprefix $nspath] [list namespace eval [nstail $nspath] {}]
nseval [nsprefix $nspath] [list ::namespace eval [nstail $nspath] {}]
#tcl::namespace::eval [nsprefix $nspath] [list tcl::namespace::eval [nstail $nspath] {}]
nseval [nsprefix $nspath] [list ::tcl::namespace::eval [nstail $nspath] {}]
n/ $nspath
}
@ -157,7 +157,7 @@ namespace eval punk::ns {
}
#recursive nseval - for introspection of weird namespace trees
#approx 10x slower than normal namespace eval - but still only a few microseconds.. fine for repl introspection
#approx 10x slower than normal tcl::namespace::eval - but still only a few microseconds.. fine for repl introspection
proc nseval_script {location} {
set parts [nsparts $location]
if {[lindex $parts 0] eq ""} {
@ -171,7 +171,7 @@ namespace eval punk::ns {
set i 0
set tails [lrepeat [llength $parts] ""]
foreach ns $parts {
set cmdlist [list ::namespace eval $ns]
set cmdlist [list ::tcl::namespace::eval $ns]
set t ""
if {$i > 0} {
append body " <lb>"
@ -194,7 +194,7 @@ namespace eval punk::ns {
set scr {[::list ::eval [::uplevel <i> {::set script}]]}
set up [expr {$i - 1}]
set scr [string map [list <i> $up] $scr]
set scr [string map "<i> $up" $scr]
set body [string map [list <script> $scr] $body]
return $body
@ -203,7 +203,7 @@ namespace eval punk::ns {
if {![string match ::* $fqns]} {
error "nseval only accepts a fully qualified namespace"
}
set loc [string map [list :: "_sep_"] $fqns]
set loc [string map {:: _sep_} $fqns]
#set cmd ::punk::pipecmds::nseval_$loc
set cmd ::punk_dynamic::ns::eval-$loc
if {$cmd ni [info commands $cmd]} {
@ -221,7 +221,7 @@ namespace eval punk::ns {
set tail [nstail $fqns]
#puts ">>> parent $parent tail $tail"
#set nslist [nseval $parent [list ::namespace children $tail]]
set nslist [namespace eval $parent [list ::namespace children $tail]]
set nslist [tcl::namespace::eval $parent [list ::tcl::namespace::children $tail]]
return [lsort $nslist]
}
@ -281,7 +281,7 @@ namespace eval punk::ns {
#
proc nsprefix {{nspath ""}} {
#normalize the common case of ::::
set nspath [string map [list :::: ::] $nspath]
set nspath [string map {:::: ::} $nspath]
set rawprefix [string range $nspath 0 end-[string length [nstail $nspath]]]
if {$rawprefix eq "::"} {
return $rawprefix
@ -299,8 +299,8 @@ namespace eval punk::ns {
#review - consider making -strict raise an error for unexpected sequences such as :::: or any situation with more than 2 colons together.
proc nstail {nspath args} {
#normalize the common case of ::::
set nspath [string map [list :::: ::] $nspath]
set mapped [string map [list :: \u0FFF] $nspath]
set nspath [string map {:::: ::} $nspath]
set mapped [string map {:: \u0FFF} $nspath]
set parts [split $mapped \u0FFF]
set defaults [list -strict 0]
@ -324,7 +324,7 @@ namespace eval punk::ns {
#Can be used to either support use of such namespaces/commands - or as part of validation to disallow them
#as opposed to silent behaviour of Tcl namespace commands which don't handle them consistently (for tcl 8.x anyway Review tcl 9)
#Note that for ::x:: the trailing :: cannot represent a trailing namespace part being an empty string
#This is because Tcl's 'namespace eval "" ""' reports 'only global namespace can have empty name'
#This is because Tcl's 'tcl::namespace::eval "" ""' reports 'only global namespace can have empty name'
#NOTE tcl allows creating ambiguous namespaces. e.g ::punk:::etc:::blah
# is this :: punk :etc :blah or :: punk :etc: blah
#clearly leading/trailing colons in namespaces and commands are just a bad idea.
@ -332,8 +332,8 @@ namespace eval punk::ns {
#This is important to support leading colon commands such as :/
# ie ::punk:::jjj:::etc -> :: punk :jjj :etc
proc nsparts {nspath} {
set nspath [string map [list :::: ::] $nspath]
set mapped [string map [list :: \u0FFF] $nspath]
set nspath [string map {:::: ::} $nspath]
set mapped [string map {:: \u0FFF} $nspath]
set parts [split $mapped \u0FFF]
if {[lindex $parts end] eq ""} {
@ -387,7 +387,8 @@ namespace eval punk::ns {
} elseif {$seg eq "**"} {
lappend pats {.*}
} else {
set seg [string map [list . {[.]}] $seg]
#set seg [string map [list . {[.]}] $seg]
set seg [string map {. [.]} $seg]
if {[regexp {[*?]} $seg]} {
set pat [string map [list ** {.*} * {[^:]*} ? {[^:]}] $seg]
lappend pats "$pat"
@ -469,14 +470,14 @@ namespace eval punk::ns {
set base $location
set tailparts $subnslist
}
if {![namespace exists $base]} {
if {![tcl::namespace::exists $base]} {
return [list]
}
#set parent [nsprefix $ns_absolute]
#set tail [nstail $ns_absolute]
#set allchildren [lsort [nseval $base [list ::namespace children]]]
set allchildren [lsort [namespace eval $base [list ::namespace children]]]
set allchildren [lsort [tcl::namespace::eval $base [list ::namespace children]]]
#puts "->base:$base tailparts:$tailparts allchildren: $allchildren"
#puts "->base:$base tailparts:$tailparts childcount: [llength $allchildren]"
@ -1084,8 +1085,8 @@ namespace eval punk::ns {
#JMN
set location $ch
set exportpatterns [namespace eval $location {::namespace export}]
set nspathlist [namespace eval $location {::namespace path}]
set exportpatterns [tcl::namespace::eval $location {::namespace export}]
set nspathlist [tcl::namespace::eval $location {::namespace path}]
set nspathdict [dict create]
if {$nspathcommands} {
foreach pathns $nspathlist {
@ -1104,7 +1105,7 @@ namespace eval punk::ns {
foreach p $exportpatterns {
if {[regexp {[*?]} $p]} {
#lappend matched {*}[nseval $location [list ::info commands [nsjoin ${location} $p]]]
lappend matched {*}[namespace eval $location [list ::info commands [nsjoin ${location} $p]]]
lappend matched {*}[tcl::namespace::eval $location [list ::info commands [nsjoin ${location} $p]]]
foreach m $matched {
lappend allexported [nstail $m]
}
@ -1113,8 +1114,8 @@ namespace eval punk::ns {
}
}
set allexported [lsort -unique $allexported]
#NOTE: info procs within namespace eval is different to 'info commands' within namespace eval (info procs doesn't look outside of namespace)
set allprocs [namespace eval $location {::info procs}]
#NOTE: info procs within tcl::namespace::eval is different to 'info commands' within tcl::namespace::eval (info procs doesn't look outside of namespace)
set allprocs [tcl::namespace::eval $location {::info procs}]
#set allprocs [nseval $location {::info procs}]
set childtails [lmap v $allchildren {nstail $v}]
set allaliases [list]
@ -1132,7 +1133,7 @@ namespace eval punk::ns {
set interp_aliases [interp aliases ""]
#use aliases glob - because aliases can be present with or without leading ::
#NOTE: alias may not have matching command in the relevant namespce (renamed alias) so we can't just start with commands and check if it's an alias if we want to show all aliases
set raw_aliases [namespace eval $location [list ::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval.
set raw_aliases [tcl::namespace::eval $location [list ::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval.
#set raw_aliases [nseval $location [list ::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval.
set aliases [list]
foreach a $raw_aliases {
@ -1375,8 +1376,8 @@ namespace eval punk::ns {
}
::set all_ns_commands [::info commands [::punk::ns::nsjoin $base $what]]
#important not to call namespace eval (or punk::ns::nseval) on non-existant base - or it will be created
::if {![::namespace exists $base]} {
#important not to call tcl::namespace::eval (or punk::ns::nseval) on non-existant base - or it will be created
::if {![::tcl::namespace::exists $base]} {
::continue
}
@ -1386,7 +1387,7 @@ namespace eval punk::ns {
#this was to support weird namespaces with leading/trailing colons - not an important usecase for the cost
::set matchedcommands [::pipeswitch {
::pipecase \
caseresult.= ::list $base $what |,basens/0,g/1> {namespace eval $basens [::list ::info commands $g]}
caseresult.= ::list $base $what |,basens/0,g/1> {tcl::namespace::eval $basens [::list ::info commands $g]}
}]
#lappend commandlist {*}[@@ok/result= $matchedcommands]
#need to pull result from matchedcommands dict
@ -1462,8 +1463,8 @@ namespace eval punk::ns {
}
::set all_ns_commands [::info commands [::punk::ns::nsjoin $base $what]]
#important not to call namespace eval (or punk::ns::nseval) on non-existant base - or it will be created
::if {![::namespace exists $base]} {
#important not to call tcl::namespace::eval (or punk::ns::nseval) on non-existant base - or it will be created
::if {![::tcl::namespace::exists $base]} {
::continue
}
::set all_ns_tails [::lmap v $all_ns_commands {::punk::ns::nstail $v}]
@ -1627,7 +1628,7 @@ namespace eval punk::ns {
}
namespace eval internal {
tcl::namespace::eval internal {
#maintenance: similar in punk::winrun
@ -1713,7 +1714,7 @@ namespace eval punk::ns {
}
default {
if {[string match ::* $pkg_or_existing_ns]} {
if {![namespace exists $pkg_or_existing_ns]} {
if {![tcl::namespace::exists $pkg_or_existing_ns]} {
set ver [package require [string range $pkg_or_existing_ns 2 end]]
} else {
set ver ""
@ -1725,7 +1726,7 @@ namespace eval punk::ns {
}
}
}
if {[namespace exists $ns]} {
if {[tcl::namespace::exists $ns]} {
if {[llength $cmdargs]} {
set binding {}
#if {[info level] == 1} {
@ -1736,10 +1737,10 @@ namespace eval punk::ns {
#}
#set vars [uplevel 1 {*}$get_vars]
#set vars [namespace eval $ns {info vars}]
#set vars [tcl::namespace::eval $ns {info vars}]
#review - upvar in apply within ns eval vs direct access of ${ns}::varname
set capture [namespace eval $ns {
set capture [tcl::namespace::eval $ns {
apply { varnames {
while {"prev_args[incr n]" in $varnames} {}
set capturevars [dict create]
@ -1811,8 +1812,8 @@ namespace eval punk::ns {
lassign [dict values [punk::args::get_dict $argspecs $args]] opts values
set sourcepattern [dict get $values sourcepattern]
set source_ns [namespace qualifiers $sourcepattern]
if {![namespace exists $source_ns]} {
set source_ns [tcl::namespace::qualifiers $sourcepattern]
if {![tcl::namespace::exists $source_ns]} {
error "nsimport_noclobber error namespace $source_ns not found"
}
set target_ns [dict get $opts -targetnamespace]
@ -1823,9 +1824,9 @@ namespace eval punk::ns {
set target_ns [punk::nsjoin $nscaller $target_ns]
}
set a_export_patterns [namespace eval $source_ns {namespace export}]
set a_export_patterns [tcl::namespace::eval $source_ns {namespace export}]
set a_commands [info commands $sourcepattern]
set a_tails [lmap v $a_commands {namespace tail $v}]
set a_tails [lmap v $a_commands {tcl::namespace::tail $v}]
set a_exported_tails [list]
foreach epattern $a_export_patterns {
set matches [lsearch -all -inline $a_tails $epattern]
@ -1837,7 +1838,7 @@ namespace eval punk::ns {
}
set imported_commands [list]
foreach e $a_exported_tails {
set imported [namespace eval $target_ns [string map [list <func> $e <a> $source_ns] {
set imported [tcl::namespace::eval $target_ns [string map [list <func> $e <a> $source_ns] {
set cmd ""
if {![catch {namespace import <a>::<func>}]} {
set cmd <func>
@ -1902,7 +1903,7 @@ namespace eval punk::ns {
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::ns [namespace eval punk::ns {
package provide punk::ns [tcl::namespace::eval punk::ns {
variable version
set version 999999.0a1.0
}]

17
src/modules/punk/path-999999.0a1.0.tm
Unescape View File

@ -131,7 +131,8 @@ namespace eval punk::path {
** {lappend pats {.*}}
default {
set seg [string map [list {^ {\^} $ {\$} [} {\[} ( {\(} \{ \\\{ \\ {\\}] $seg] ;#treat regex characters in the input as literals
set seg [string map [list . {[.]}] $seg]
#set seg [string map [list . {[.]}] $seg]
set seg [string map {. [.]} $seg]
if {[regexp {[*?]} $seg]} {
set pat [string map [list ** {.*} * {[^/]*} ? {[^/]}] $seg]
lappend pats "$pat"
@ -212,12 +213,14 @@ namespace eval punk::path {
#[para] list of path patterns to exclude - may include * and ** path segments e.g /usr/**
#[para]no natsorting - so order is dependent on filesystem
lassign [punk::get_leading_opts_and_values {
-directory "\uFFFF"
-call-depth-internal 0
-antiglob_paths {}
} $args] _o opts _v tailglobs
set argd [punk::args::get_dict {
-directory -default "\uFFFF"
-call-depth-internal -default 0 -type integer
-antiglob_paths -default {}
*values -min 0 -max -1 -type string
} $args]
lassign [dict values $argd] opts values
set tailglobs [dict values $values]
# -- --- --- --- --- --- ---
set opt_antiglob_paths [dict get $opts -antiglob_paths]
set CALLDEPTH [dict get $opts -call-depth-internal]

22
src/modules/punk/repl-0.1.tm
Unescape View File

@ -153,7 +153,7 @@ proc ::punk::repl::init_signal_handlers {} {
#avoid spurious triggers after interrupting a command..
#review - dodgy.. we just want to interrupt child processes but then still be able to interrupt repl
set ::punk::repl::signal_control_c 0
set preverr [string map [list "child killed" "child_killed"] $::errorInfo]
set preverr [string map {"child killed" "child_killed"} $::errorInfo]
catch {error $preverr} ;#for errorInfo display
return 42
} else {
@ -207,7 +207,7 @@ proc ::punk::repl::init_signal_handlers {} {
if {[lindex $::errorCode 0] eq "CHILDKILLED"} {
set signal_control_c 0
set preverr [string map [list "child killed" "child_killed"] $::errorInfo]
set preverr [string map {"child killed" "child_killed"} $::errorInfo]
catch {error $preverr} ;#for errorInfo display
return 42
}
@ -1635,12 +1635,12 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config
if {$chunklen == 1} {
#presume it's a keypress from terminal
set chunk [string map [list \r \n] $chunk]
set chunk [string map {\r \n} $chunk]
} else {
#maybe a paste? (or stdin to active shell loop - possibly with no terminal ? )
#we'd better check for crlf and/or plain lf. If found - presume any lone CR is to be left as is.
if {[string first \n $chunk] < 0} {
set chunk [string map [list \r \n] $chunk]
set chunk [string map {\r \n} $chunk]
}
#else -
#has lf - but what if last char is cr?
@ -2479,6 +2479,8 @@ namespace eval repl {
thread::send $codethread [string map [list %args% [list $opts]\
%argv0% [list $::argv0]\
%argv% [list $::argv]\
%argc% [list $::argc]\
%replthread% [thread::id]\
%replthread_cond% $codethread_cond\
%replthread_interp% [list $opt_callback_interp]\
@ -2486,6 +2488,8 @@ namespace eval repl {
%autopath% [list $::auto_path]\
] {
set ::argv0 %argv0%
set ::argv %argv%
set ::argc %argc%
tcl::tm::remove {*}[tcl::tm::list]
tcl::tm::add {*}%tmlist%
#this sets the auto_path in the thread but outside of the code interp that will be created.
@ -2599,7 +2603,7 @@ namespace eval repl {
return $stack
}
}
namespace eval ::repl::interphelpers::subrepl_ensemble {
namespace eval ::repl::interphelpers::subshell_ensemble {
namespace export {[a-z]*}
namespace ensemble create
proc punk {} {
@ -2645,6 +2649,8 @@ namespace eval repl {
punk::island::add code $p
}
}
#review argv0,argv,argc
interp eval code {
set ::argv0 %argv0%
set ::auto_path %autopath%
@ -2679,6 +2685,8 @@ namespace eval repl {
}
interp eval code {
set ::argv0 %argv0%
set ::argc 0
set ::argv {}
set ::auto_path %autopath%
#puts stdout "safe interp"
#flush stdout
@ -2727,6 +2735,8 @@ namespace eval repl {
interp create code
interp eval code {
set ::argv0 %argv0%
set ::argv %argv%
set ::argc %argc%
set ::auto_path %autopath%
tcl::tm::remove {*}[tcl::tm::list]
tcl::tm::add {*}%tmlist%
@ -2738,7 +2748,7 @@ namespace eval repl {
}
}
code alias repl ::repl::interphelpers::repl_ensemble
code alias subrepl ::repl::interphelpers::subrepl_ensemble
code alias subshell ::repl::interphelpers::subshell_ensemble
code alias quit ::repl::interphelpers::quit
code alias editbuf ::repl::interphelpers::editbuf
code alias colour ::repl::interphelpers::colour

28
src/modules/punk/repl/codethread-999999.0a1.0.tm
Unescape View File

@ -65,11 +65,11 @@ package require punk::config
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::repl::codethread::class {
#tcl::namespace::eval punk::repl::codethread::class {
#*** !doctools
#[subsection {Namespace punk::repl::codethread::class}]
#[para] class definitions
if {[info commands [namespace current]::interface_sample1] eq ""} {
#if {[info commands [tcl::namespace::current]::interface_sample1] eq ""} {
#*** !doctools
#[list_begin enumerated]
@ -91,8 +91,8 @@ namespace eval punk::repl::codethread::class {
#*** !doctools
#[list_end] [comment {--- end class enumeration ---}]
}
}
#}
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
@ -101,8 +101,8 @@ namespace eval punk::repl::codethread::class {
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::repl::codethread {
namespace export *
tcl::namespace::eval punk::repl::codethread {
tcl::namespace::export *
variable replthread
variable replthread_cond
variable running 0
@ -157,8 +157,8 @@ namespace eval punk::repl::codethread {
}
lappend outstack [shellfilter::stack::add stdout tee_to_var -settings {-varname ::punk::repl::codethread::output_stdout}]
if {[string length [dict get $running_config color_stderr]] && [punk::console::colour]} {
#lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr]]]
lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour cyan]]
lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr]]]
#lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour cyan]]
}
lappend errstack [shellfilter::stack::add stderr tee_to_var -settings {-varname ::punk::repl::codethread::output_stderr}]
@ -168,7 +168,7 @@ namespace eval punk::repl::codethread {
set scope [interp eval code [list set ::punk::ns::ns_current]]
set status [catch {
interp eval code [list namespace inscope $scope $script]
interp eval code [list tcl::namespace::inscope $scope $script]
} result]
@ -206,9 +206,9 @@ namespace eval punk::repl::codethread {
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::repl::codethread::lib {
namespace export *
namespace path [namespace parent]
tcl::namespace::eval punk::repl::codethread::lib {
tcl::namespace::export *
tcl::namespace::path [tcl::namespace::parent]
#*** !doctools
#[subsection {Namespace punk::repl::codethread::lib}]
#[para] Secondary functions that are part of the API
@ -233,7 +233,7 @@ namespace eval punk::repl::codethread::lib {
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
namespace eval punk::repl::codethread::system {
tcl::namespace::eval punk::repl::codethread::system {
#*** !doctools
#[subsection {Namespace punk::repl::codethread::system}]
#[para] Internal functions that are not part of the API
@ -243,7 +243,7 @@ namespace eval punk::repl::codethread::system {
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::repl::codethread [namespace eval punk::repl::codethread {
package provide punk::repl::codethread [tcl::namespace::eval punk::repl::codethread {
variable pkg punk::repl::codethread
variable version
set version 999999.0a1.0

6
src/modules/punk/repo-999999.0a1.0.tm
Unescape View File

@ -1303,7 +1303,7 @@ namespace eval punk::repo {
if {[catch {exec {*}$fossilcmd all ls} repolines]} {
error "fossil_get_configdb cannot find repositories"
} else {
set repolines [string map [list \r\n \n] $repolines]
set repolines [string map {\r\n \n} $repolines]
set repolist [split $repolines \n]
set dbcmd "fossil_get_configdb_tempdb"
foreach repodb $repolist {
@ -1383,12 +1383,12 @@ namespace eval punk::repo {
return [lindex [split $content \x1A] 0]
}
proc grep {pattern data} {
set data [string map [list \r\n \n] $data]
set data [string map {\r\n \n} $data]
return [lsearch -all -inline -glob [split $data \n] $pattern]
}
proc rgrep {pattern data} {
set data [string map [list \r\n \n] $data]
set data [string map {\r\n \n} $data]
return [lsearch -all -inline -regexp [split $data \n] $pattern]
}

8
src/modules/punk/winpath-999999.0a1.0.tm
Unescape View File

@ -31,10 +31,10 @@ namespace eval punk::winpath {
#\\servername\share etc or \\?\UNC\servername\share etc.
proc is_unc_path {path} {
set strcopy_path [punk::objclone $path]
set strcopy_path [string map [list \\ /] $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway)
set strcopy_path [string map {\\ /} $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway)
if {[string first "//" $strcopy_path] == 0} {
#check for "Dos device path" syntax
if {[string range $strcopy_path 0 3] in [list "//?/" "//./"]} {
if {[string range $strcopy_path 0 3] in {//?/ //./}} {
#Note that //./ doesn't appear to be supported in Tcl as at 2023-08 - but //?/ works (except for //?/UNC/Server/share)
if {[string range $strcopy_path 4 6] eq "UNC"} {
return 1
@ -78,8 +78,8 @@ namespace eval punk::winpath {
#(can exist on server shares and on NTFS - but standard apps can't access without dos device syntax)
proc is_dos_device_path {path} {
set strcopy_path [punk::objclone $path]
set strcopy_path [string map [list \\ /] $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway)
if {[string range $strcopy_path 0 3] in [list "//?/" "//./"]} {
set strcopy_path [string map {\\ /} $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway)
if {[string range $strcopy_path 0 3] in {//?/ //./}} {
return 1
} else {
return 0

2
src/modules/punkcheck-0.1.0.tm
Unescape View File

@ -1,5 +1,5 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'deck make' or src/make.tcl to update from <pkg>-buildversion.txt
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'dev 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.

110
src/modules/shellfilter-0.1.9.tm
Unescape View File

@ -10,9 +10,9 @@
#
namespace eval shellfilter::log {
tcl::namespace::eval shellfilter::log {
variable allow_adhoc_tags 1
variable open_logs [dict create]
variable open_logs [tcl::dict::create]
#'tag' is an identifier for the log source.
# each tag will use it's own thread to write to the configured log target
@ -20,11 +20,11 @@ namespace eval shellfilter::log {
upvar ::shellfilter::sources sourcelist
package require shellthread
if {![dict exists $settingsdict -tag]} {
dict set settingsdict -tag $tag
tcl::dict::set settingsdict -tag $tag
} else {
#review
if {$tag ne [dict get $settingsdict -tag]} {
error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[dict get $settingsdict -tag]' omit -tag, or supply same value"
if {$tag ne [tcl::dict::get $settingsdict -tag]} {
error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[tcl::dict::get $settingsdict -tag]' omit -tag, or supply same value"
}
}
if {$tag ni $sourcelist} {
@ -250,18 +250,18 @@ namespace eval shellfilter::chan {
variable o_is_junction
constructor {tf} {
set o_trecord $tf
set o_enc [dict get $tf -encoding]
set o_enc [tcl::dict::get $tf -encoding]
set o_lastxlines [list]
set o_postcountdown 0
set defaults [dict create -pre 1 -post 1]
set settingsdict [dict get $tf -settings]
set settings [dict merge $defaults $settingsdict]
set o_datavar [dict get $settings -varname]
set o_grepfor [dict get $settings -grep]
set o_prelines [dict get $settings -pre]
set o_postlines [dict get $settings -post]
if {[dict exists $tf -junction]} {
set o_is_junction [dict get $tf -junction]
set defaults [tcl::dict::create -pre 1 -post 1]
set settingsdict [tcl::dict::get $tf -settings]
set settings [tcl::dict::merge $defaults $settingsdict]
set o_datavar [tcl::dict::get $settings -varname]
set o_grepfor [tcl::dict::get $settings -grep]
set o_prelines [tcl::dict::get $settings -pre]
set o_postlines [tcl::dict::get $settings -post]
if {[tcl::dict::exists $tf -junction]} {
set o_is_junction [tcl::dict::get $tf -junction]
} else {
set o_is_junction 0
}
@ -278,7 +278,7 @@ namespace eval shellfilter::chan {
# return ?
#}
method write {transform_handle bytes} {
set logdata [encoding convertfrom $o_enc $bytes]
set logdata [tcl::encoding::convertfrom $o_enc $bytes]
set lastx $o_lastxlines
lappend o_lastxlines $logdata
@ -318,12 +318,12 @@ namespace eval shellfilter::chan {
variable o_is_junction
constructor {tf} {
set o_trecord $tf
set o_enc [dict get $tf -encoding]
set settingsdict [dict get $tf -settings]
set varname [dict get $settingsdict -varname]
set o_enc [tcl::dict::get $tf -encoding]
set settingsdict [tcl::dict::get $tf -settings]
set varname [tcl::dict::get $settingsdict -varname]
set o_datavars $varname
if {[dict exists $tf -junction]} {
set o_is_junction [dict get $tf -junction]
if {[tcl::dict::exists $tf -junction]} {
set o_is_junction [tcl::dict::get $tf -junction]
} else {
set o_is_junction 0
}
@ -348,7 +348,7 @@ namespace eval shellfilter::chan {
return ""
}
method write {ch bytes} {
set stringdata [encoding convertfrom $o_enc $bytes]
set stringdata [tcl::encoding::convertfrom $o_enc $bytes]
foreach v $o_datavars {
append $v $stringdata
}
@ -366,15 +366,15 @@ namespace eval shellfilter::chan {
variable o_is_junction
constructor {tf} {
set o_trecord $tf
set o_enc [dict get $tf -encoding]
set settingsdict [dict get $tf -settings]
set o_enc [tcl::dict::get $tf -encoding]
set settingsdict [tcl::dict::get $tf -settings]
if {![dict exists $settingsdict -tag]} {
error "tee_to_pipe constructor settingsdict missing -tag"
}
set o_localchan [dict get $settingsdict -pipechan]
set o_logsource [dict get $settingsdict -tag]
if {[dict exists $tf -junction]} {
set o_is_junction [dict get $tf -junction]
set o_localchan [tcl::dict::get $settingsdict -pipechan]
set o_logsource [tcl::dict::get $settingsdict -tag]
if {[tcl::dict::exists $tf -junction]} {
set o_is_junction [tcl::dict::get $tf -junction]
} else {
set o_is_junction 0
}
@ -397,7 +397,7 @@ namespace eval shellfilter::chan {
return ""
}
method read {transform_handle bytes} {
set logdata [encoding convertfrom $o_enc $bytes]
set logdata [tcl::encoding::convertfrom $o_enc $bytes]
#::shellfilter::log::write $o_logsource $logdata
puts -nonewline $o_localchan $logdata
return $bytes
@ -406,7 +406,7 @@ namespace eval shellfilter::chan {
return ""
}
method write {transform_handle bytes} {
set logdata [encoding convertfrom $o_enc $bytes]
set logdata [tcl::encoding::convertfrom $o_enc $bytes]
#::shellfilter::log::write $o_logsource $logdata
puts -nonewline $o_localchan $logdata
return $bytes
@ -425,15 +425,15 @@ namespace eval shellfilter::chan {
variable o_is_junction
constructor {tf} {
set o_trecord $tf
set o_enc [dict get $tf -encoding]
set settingsdict [dict get $tf -settings]
if {![dict exists $settingsdict -tag]} {
set o_enc [tcl::dict::get $tf -encoding]
set settingsdict [tcl::dict::get $tf -settings]
if {![tcl::dict::exists $settingsdict -tag]} {
error "tee_to_log constructor settingsdict missing -tag"
}
set o_logsource [dict get $settingsdict -tag]
set o_logsource [tcl::dict::get $settingsdict -tag]
set o_tid [::shellfilter::log::open $o_logsource $settingsdict]
if {[dict exists $tf -junction]} {
set o_is_junction [dict get $tf -junction]
if {[tcl::dict::exists $tf -junction]} {
set o_is_junction [tcl::dict::get $tf -junction]
} else {
set o_is_junction 0
}
@ -450,12 +450,12 @@ namespace eval shellfilter::chan {
# post any events
}
method read {ch bytes} {
set logdata [encoding convertfrom $o_enc $bytes]
set logdata [tcl::encoding::convertfrom $o_enc $bytes]
::shellfilter::log::write $o_logsource $logdata
return $bytes
}
method write {ch bytes} {
set logdata [encoding convertfrom $o_enc $bytes]
set logdata [tcl::encoding::convertfrom $o_enc $bytes]
::shellfilter::log::write $o_logsource $logdata
return $bytes
}
@ -620,10 +620,10 @@ namespace eval shellfilter::chan {
constructor {tf} {
package require punk::ansi
set o_trecord $tf
set o_enc [dict get $tf -encoding]
set settingsdict [dict get $tf -settings]
if {[dict exists $settingsdict -colour]} {
set o_colour [dict get $settingsdict -colour]
set o_enc [tcl::dict::get $tf -encoding]
set settingsdict [tcl::dict::get $tf -settings]
if {[tcl::dict::exists $settingsdict -colour]} {
set o_colour [tcl::dict::get $settingsdict -colour]
set o_do_colour [punk::ansi::a+ {*}$o_colour]
set o_do_normal [punk::ansi::a]
} else {
@ -631,8 +631,8 @@ namespace eval shellfilter::chan {
set o_do_colour ""
set o_do_normal ""
}
if {[dict exists $tf -junction]} {
set o_is_junction [dict get $tf -junction]
if {[tcl::dict::exists $tf -junction]} {
set o_is_junction [tcl::dict::get $tf -junction]
} else {
set o_is_junction 0
}
@ -652,18 +652,18 @@ namespace eval shellfilter::chan {
return ""
}
method write {transform_handle bytes} {
set instring [encoding convertfrom $o_enc $bytes]
set instring [tcl::encoding::convertfrom $o_enc $bytes]
set outstring "$o_do_colour$instring$o_do_normal"
#set outstring ">>>$instring"
return [encoding convertto $o_enc $outstring]
return [tcl::encoding::convertto $o_enc $outstring]
}
method drain {transform_handle} {
return ""
}
method read {transform_handle bytes} {
set instring [encoding convertfrom $o_enc $bytes]
set instring [tcl::encoding::convertfrom $o_enc $bytes]
set outstring "$o_do_colour$instring$o_do_normal"
return [encoding convertto $o_enc $outstring]
return [tcl::encoding::convertto $o_enc $outstring]
}
method meta_is_redirection {} {
return $o_is_junction
@ -749,7 +749,7 @@ namespace eval shellfilter::chan {
set instring "\r$instring"
}
set outstring [string map [list \r\n \n] $instring]
set outstring [string map {\r\n \n} $instring]
set lastchar [string range $outstring end end]
if {$lastchar eq "\r"} {
set o_last_char_was_cr 1
@ -810,9 +810,9 @@ namespace eval shellfilter::chan {
set instring "\r$instring"
}
set outstring [string map [list \r\n \uFFFF] $instring]
set outstring [string map [list \n \r\n] $outstring]
set outstring [string map [list \uFFFF \r\n] $outstring]
set outstring [string map {\r\n \uFFFF} $instring]
set outstring [string map {\n \r\n} $outstring]
set outstring [string map {\uFFFF \r\n} $outstring]
set lastchar [string range $outstring end end]
if {$lastchar eq "\r"} {
@ -2217,7 +2217,7 @@ namespace eval shellfilter {
#'clock micros' good enough id for shellcommand calls unless one day they can somehow be called concurrently or sequentially within a microsecond and within the same interp.
# a simple counter would probably work too
#consider other options if an alternative to the single vwait in this function is used.
set call_id [clock micros] ;
set call_id [tcl::clock::microseconds] ;
set ::shellfilter::shellcommandvars($call_id,exitcode) ""
set waitvar ::shellfilter::shellcommandvars($call_id,waitvar)
if {$debug} {
@ -2585,7 +2585,7 @@ namespace eval shellfilter {
if {[string length $teefile]} {
set logname "redir_[string map [list : _ ] $winfile]_[clock micros]"
set logname "redir_[string map {: _} $winfile]_[tcl::clock::microseconds]"
set tid [::shellfilter::log::open $logname {-syslog 127.0.0.1:514}]
if {$teefile eq "write"} {
::shellfilter::log::write $logname "opening '$winfile' for write"
@ -2598,7 +2598,7 @@ namespace eval shellfilter {
chan configure $fd -translation $outtranslation
chan configure $fd -encoding utf-8
set tempvar_bytetotal [namespace current]::totalbytes[clock micros]
set tempvar_bytetotal [namespace current]::totalbytes[tcl::clock::microseconds]
set $tempvar_bytetotal 0
chan event $rdout readable [list apply {{chan other wrerr outchan errchan read_proc_out_buffering waitfor outprefix call_id debug debugname writefile writefilefd copytempfile bytevar logtag} {
#review - if we write outprefix to normal stdout.. why not to redirected file?

8
src/modules/shellthread-1.6.1.tm
Unescape View File

@ -12,15 +12,15 @@ namespace eval shellthread {
proc iso8601 {{tsmicros ""}} {
if {$tsmicros eq ""} {
set tsmicros [clock micros]
set tsmicros [tcl::clock::microseconds]
} else {
set microsnow [clock micros]
if {[string length $tsmicros] != [string length $microsnow]} {
set microsnow [tcl::clock::microseconds]
if {[tcl::string::length $tsmicros] != [tcl::string::length $microsnow]} {
error "iso8601 requires 'clock micros' or empty string to create timestamp"
}
}
set seconds [expr {$tsmicros / 1000000}]
return [clock format $seconds -format "%Y-%m-%d_%H-%M-%S"]
return [tcl::clock::format $seconds -format "%Y-%m-%d_%H-%M-%S"]
}
}

2
src/modules/tcl9test-999999.0a1.0.tm
Unescape View File

@ -1,5 +1,5 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'deck make' or src/make.tcl to update from <pkg>-buildversion.txt
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'dev 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.

1550
src/modules/textblock-999999.0a1.0.tm
View File

File diff suppressed because it is too large Load Diff

2
src/modules/winlibreoffice-999999.0a1.0.tm
Unescape View File

@ -1,5 +1,5 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'deck make' or src/make.tcl to update from <pkg>-buildversion.txt
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'dev 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.

Write Preview
Loading…
Cancel
Save