29 changed files with 6589 additions and 412 deletions
@ -0,0 +1,218 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::cap 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta description pkg capability register |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::cap { |
||||
variable pkgcap [dict create] |
||||
variable caps [dict create] |
||||
proc register_package {pkg capabilitylist} { |
||||
variable pkgcap |
||||
variable caps |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
#for each capability |
||||
# - ensure 1st element is a single word |
||||
# - ensure that if 2nd element (capdict) is present - it is dict shaped |
||||
foreach c $capabilitylist { |
||||
lassign $c capname capdict |
||||
if {[llength $capname] !=1} { |
||||
error "register_package error. pkg: '$pkg' An entry in the capability list doesn't appear to have a single-word name. Problematic entry:'$c'" |
||||
} |
||||
if {[expr {[llength $capdict] %2 != 0}]} { |
||||
error "register_package error. pkg:'$pkg' The second element for capname:'$capname' doesn't appear to be a valid dict. Problematic entry: '$c'" |
||||
} |
||||
if {[dict exists $caps $capname]} { |
||||
set cap_pkgs [dict get $caps $capname] |
||||
} else { |
||||
set cap_pkgs [list] |
||||
} |
||||
if {$pkg ni $cap_pkgs} { |
||||
dict lappend caps $capname $pkg |
||||
} |
||||
} |
||||
dict set pkgcap $pkg $capabilitylist |
||||
} |
||||
proc promote_package {pkg} { |
||||
variable pkgcap |
||||
variable caps |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
if {![dict exists $pkgcap $pkg]} { |
||||
error "punk::cap::promote_package error pkg'$pkg' not registered. Use register_package \$pkg first" |
||||
} |
||||
if {[dict size $pkgcap] > 1} { |
||||
set pkginfo [dict get $pkgcap $pkg] |
||||
#remove and re-add at end of dict |
||||
dict unset pkgcap $pkg |
||||
dict set pkgcap $pkg $pkginfo |
||||
foreach {cap cap_pkgs} $caps { |
||||
if {$pkg in $cap_pkgs} { |
||||
set posn [lsearch $cap_pkgs $pkg] |
||||
if {$posn >=0} { |
||||
#rewrite package list with pkg at tail of list for this capability |
||||
set cap_pkgs [lreplace $cap_pkgs $posn $posn] |
||||
lappend cap_pkgs $pkg |
||||
dict set caps $cap $cap_pkgs |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
proc demote_package {pkg} { |
||||
variable pkgcap |
||||
variable caps |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
if {![dict exists $pkgcap $pkg]} { |
||||
error "punk::cap::promote_package error pkg'$pkg' not registered. Use register_package \$pkg first" |
||||
} |
||||
if {[dict size $pkgcap] > 1} { |
||||
set pkginfo [dict get $pkgcap $pkg] |
||||
#remove and re-add at start of dict |
||||
dict unset pkgcap $pkg |
||||
dict set pkgcap $pkg $pkginfo |
||||
set pkgcap [dict merge [dict create $pkg $pkginfo] $pkgcap] |
||||
foreach {cap cap_pkgs} $caps { |
||||
if {$pkg in $cap_pkgs} { |
||||
set posn [lsearch $cap_pkgs $pkg] |
||||
if {$posn >=0} { |
||||
#rewrite package list with pkg at head of list for this capability |
||||
set cap_pkgs [lreplace $cap_pkgs $posn $posn] |
||||
set cap_pkgs [list $pkg {*}$cap_pkgs] |
||||
dict set caps $cap $cap_pkgs |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
proc unregister_package {pkg} { |
||||
variable pkgcap |
||||
variable caps |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
if {[dict exists $pkgcap $pkg]} { |
||||
#remove corresponding entries in caps |
||||
set capabilitylist [dict get $pkgcap $pkg] |
||||
foreach c $capabilitylist { |
||||
lassign $c capname _capdict |
||||
set pkglist [dict get $caps $capname] |
||||
set posn [lsearch $pkglist $pkg] |
||||
if {$posn >= 0} { |
||||
set pkglist [lreplace $pkglist $posn $posn] |
||||
dict set caps $capname $pkglist |
||||
} |
||||
} |
||||
#delete the main registration record |
||||
dict unset pkgcap $pkg |
||||
} |
||||
} |
||||
proc registered_package {pkg} { |
||||
variable pkgcap |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
if {[dict exists $pkgcap $pkg]} { |
||||
return [dict get $pkgcap $pkg] |
||||
} else { |
||||
return |
||||
} |
||||
} |
||||
proc registered_packages {} { |
||||
variable pkgcap |
||||
return $pkgcap |
||||
} |
||||
|
||||
proc capabilities {{glob *}} { |
||||
variable caps |
||||
set keys [lsort [dict keys $caps $glob]] |
||||
set cap_list [list] |
||||
foreach k $keys { |
||||
lappend cap_list [list $k [dict get $caps $k]] |
||||
} |
||||
return $cap_list |
||||
} |
||||
|
||||
namespace eval templates { |
||||
#return a dict keyed on folder with source pkg as value |
||||
proc folders {} { |
||||
package require punk::cap |
||||
set caplist [punk::cap::capabilities templates] |
||||
# e.g {templates {punk::mix::templates ::somepkg}} |
||||
set templates_record [lindex $caplist 0] |
||||
set pkgs [lindex $templates_record 1] |
||||
|
||||
set folderdict [dict create] |
||||
foreach pkg $pkgs { |
||||
set caplist [punk::cap::registered_package $pkg] |
||||
set templates_entries [lsearch -all -inline -index 0 $caplist templates] ;#we generally expect only one - but if multiple exist - use them |
||||
foreach templates_info $templates_entries { |
||||
lassign $templates_info _templates templates_dict |
||||
if {[dict exists $templates_dict relpath]} { |
||||
set provide_statement [package ifneeded $pkg [package require $pkg]] |
||||
set tmfile [lindex $provide_statement end] |
||||
#set tmdir [file dirname [lindex $provide_statement end]] |
||||
set tpath [file normalize [file join $tmfile [dict get $templates_dict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder |
||||
#relpath relative to file is important for tm files that are zip/tar based containers |
||||
if {[file isdirectory $tpath]} { |
||||
dict set folderdict $tpath [list source $pkg sourcetype package] |
||||
} else { |
||||
puts stderr "punk::mix template_folders WARNING - unable to determine base folder for package '$pkg' which is registered with punk::mix as a provider of 'templates' capability" |
||||
} |
||||
} else { |
||||
puts stderr "punk::mix template_folders WARNING - registered pkg 'pkg' has capability 'templates' but no 'relpath' key - unable to use as source of templates" |
||||
} |
||||
} |
||||
} |
||||
return $folderdict |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::cap [namespace eval punk::cap { |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,3 @@
|
||||
0.1.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
@ -0,0 +1,996 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::char 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
package require mime |
||||
package require overtype |
||||
|
||||
|
||||
|
||||
#Note that ansi escapes can begin with \033\[ (\u001b\[) or the single character "Control Sequence Introducer" 0x9b |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::char { |
||||
namespace export * |
||||
variable invalid "???" ;# ideally this would be 0xFFFD - which should display as black diamond/rhombus with question mark. As at 2023 - this tends to display indistinguishably from other missing glyph boxes - so we use a longer sequence we can detect by length and to display obviously |
||||
variable invalid_display_char \u25ab; #todo - change to 0xFFFD once diamond glyph more common? |
||||
|
||||
#just the 7-bit ascii. use [page ascii] for the 8-bit |
||||
proc ascii {} {return { |
||||
00 NUL 01 SOH 02 STX 03 ETX 04 EOT 05 ENQ 06 ACK 07 BEL |
||||
08 BS 09 HT 0a LF 0b VT 0c FF 0d CR 0e SO 0f SI |
||||
10 DLE 11 DC1 12 DC2 13 DC3 14 DC4 15 NAK 16 SYN 17 ETB |
||||
18 CAN 19 EM 1a SUB 1b ESC 1c FS 1d GS 1e RS 1f US |
||||
20 SP 21 ! 22 " 23 # 24 $ 25 % 26 & 27 ' |
||||
28 ( 29 ) 2a * 2b + 2c , 2d - 2e . 2f / |
||||
30 0 31 1 32 2 33 3 34 4 35 5 36 6 37 7 |
||||
38 8 39 9 3a : 3b ; 3c < 3d = 3e > 3f ? |
||||
40 @ 41 A 42 B 43 C 44 D 45 E 46 F 47 G |
||||
48 H 49 I 4a J 4b K 4c L 4d M 4e N 4f O |
||||
50 P 51 Q 52 R 53 S 54 T 55 U 56 V 57 W |
||||
58 X 59 Y 5a Z 5b [ 5c \ 5d ] 5e ^ 5f _ |
||||
60 ` 61 a 62 b 63 c 64 d 65 e 66 f 67 g |
||||
68 h 69 i 6a j 6b k 6c l 6d m 6e n 6f o |
||||
70 p 71 q 72 r 73 s 74 t 75 u 76 v 77 w |
||||
78 x 79 y 7a z 7b { 7c | 7d } 7e ~ 7f DEL |
||||
}} |
||||
|
||||
#G0 character set |
||||
proc ascii2 {} { |
||||
set dict [asciidict2] |
||||
set out "" |
||||
set i 1 |
||||
append out " " |
||||
dict for {k v} $dict { |
||||
#single chars are wrapped with \033(0 and \033(B ie total length 7 |
||||
if {[string length $v] == 7} { |
||||
set v " $v " |
||||
} elseif {[string length $v] == 2} { |
||||
set v "$v " |
||||
} elseif {[string length $v] == 0} { |
||||
set v " " |
||||
} |
||||
append out "$k $v " |
||||
if {$i > 0 && $i % 8 == 0} { |
||||
set out [string range $out 0 end-2] |
||||
append out \n " " |
||||
} |
||||
incr i |
||||
} |
||||
set out [string trimright $out " "] |
||||
return $out |
||||
} |
||||
|
||||
|
||||
proc symbol {} { |
||||
tailcall page symbol |
||||
} |
||||
proc dingbats {} { |
||||
set out "" |
||||
append out [page dingbats] \n |
||||
set unicode_dict [charset_dict dingbats] |
||||
|
||||
append out " " |
||||
set i 1 |
||||
dict for {k charinfo} $unicode_dict { |
||||
set char [dict get $charinfo char] |
||||
if {[string length $char] == 0} { |
||||
set displayv " " |
||||
} elseif {[string length $char] == 1} { |
||||
set displayv " $char " |
||||
} else { |
||||
set displayv $char |
||||
} |
||||
append out "$k $displayv " |
||||
if {$i > 0 && $i % 8 == 0} { |
||||
set out [string range $out 0 end-2] |
||||
append out \n " " |
||||
} |
||||
incr i |
||||
} |
||||
return $out |
||||
} |
||||
proc page_names {{search *}} { |
||||
set all_names [list] |
||||
set d [page_names_dict $search] |
||||
dict for {k v} $d { |
||||
if {$k ni $all_names} { |
||||
lappend all_names $k |
||||
} |
||||
foreach m $v { |
||||
if {$m ni $all_names} { |
||||
lappend all_names $m |
||||
} |
||||
} |
||||
} |
||||
return [lsort $all_names] |
||||
} |
||||
proc page_names_help {{namesearch *}} { |
||||
set d [page_names_dict $namesearch] |
||||
|
||||
set out "" |
||||
dict for {k v} $d { |
||||
append out "$k $v" \n |
||||
} |
||||
return [linesort $out] |
||||
} |
||||
proc page_names_dict {{search *}} { |
||||
if {![regexp {[?*]} $search]} { |
||||
set search "*$search*" |
||||
} |
||||
set encnames [encoding names] |
||||
foreach enc $encnames { |
||||
dict set d $enc [list] |
||||
} |
||||
set mimenames [array get ::mime::reversemap] |
||||
dict for {mname encname} $mimenames { |
||||
if {$encname in $encnames} { |
||||
set enclist [dict get $d $encname] |
||||
if {$mname ni $enclist} { |
||||
dict lappend d $encname $mname |
||||
} |
||||
} |
||||
} |
||||
foreach enc [lsort $encnames] { |
||||
set mime_enc [mime::mapencoding $enc] |
||||
if {$mime_enc ne ""} { |
||||
set enclist [dict get $d $enc] |
||||
if {$mime_enc ni $enclist} { |
||||
dict lappend d $enc $mime_enc |
||||
} |
||||
} |
||||
} |
||||
set dresult [dict create] |
||||
if {$search ne "*"} { |
||||
dict for {k v} $d { |
||||
if {[string match -nocase $search $k] || ([lsearch -nocase $v $search]) >= 0} { |
||||
dict set dresult $k $v |
||||
} |
||||
} |
||||
} else { |
||||
set dresult $d |
||||
} |
||||
return $dresult |
||||
} |
||||
proc page8 {encname args} { |
||||
dict set args -cols 8 |
||||
tailcall page $encname {*}$args |
||||
} |
||||
proc page16 {encname args} { |
||||
dict set args -cols 16 |
||||
tailcall page $encname {*}$args |
||||
} |
||||
proc page {encname args} { |
||||
variable invalid |
||||
set encname [encname $encname] |
||||
set defaults [list\ |
||||
-range {0 256}\ |
||||
-cols 8\ |
||||
] |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- --- --- |
||||
set cols [dict get $opts -cols] |
||||
# -- --- --- --- --- --- --- --- --- |
||||
|
||||
set d_bytedisplay [basedict_display] |
||||
|
||||
#set d_ascii [pagedict_raw ascii] |
||||
set d_ascii [basedict] |
||||
set d_asciiposn [lreverse $d_ascii] ;#values should be unique except for "???". We are mainly interested in which ones have display-names e.g cr csi |
||||
#The results of this are best seen by comparing the ebcdic and ascii pages |
||||
|
||||
set d_page [pagedict_raw $encname] |
||||
|
||||
set out "" |
||||
set i 1 |
||||
append out " " |
||||
dict for {k rawchar} $d_page { |
||||
set num [expr {"0x$k"}] |
||||
#see if ascii equivalent exists and has a name |
||||
if {$rawchar eq $invalid} { |
||||
set displayv "$invalid" |
||||
} else { |
||||
set bytedisplay "" |
||||
if {[dict exists $d_asciiposn $rawchar]} { |
||||
set asciiposn [dict get $d_asciiposn $rawchar] |
||||
set bytedisplay [dict get $d_bytedisplay $asciiposn] |
||||
} |
||||
if {$bytedisplay eq $invalid} { |
||||
# |
||||
set displayv " $rawchar " |
||||
} else { |
||||
set displaylen [string length $bytedisplay] |
||||
if {$displaylen == 2} { |
||||
set displayv "$bytedisplay " |
||||
} elseif {$displaylen == 3} { |
||||
set displayv $bytedisplay |
||||
} else { |
||||
if {[string length $rawchar] == 0} { |
||||
set displayv " " |
||||
} else { |
||||
#presumed 1 |
||||
set displayv " $rawchar " |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
append out "$k $displayv " |
||||
if {$i > 0 && $i % $cols == 0} { |
||||
set out [string range $out 0 end-2] |
||||
append out \n " " |
||||
} |
||||
incr i |
||||
} |
||||
set out [string trimright $out " "] |
||||
return $out |
||||
} |
||||
|
||||
proc pagechar1 {page num} { |
||||
set encpage $page |
||||
if {$page ni [encoding names]} { |
||||
set mimenamesdict [page_names_dict] |
||||
dict for {k v} $mimenamesdict { |
||||
if {[lsearch -nocase $v $page] >= 0} { |
||||
set encpage $k |
||||
break |
||||
} |
||||
} |
||||
if {$encpage eq $page} { |
||||
#didn't find a mapping to something else.. |
||||
error "unknown encoding '$page'" |
||||
} |
||||
} |
||||
encoding convertfrom $encpage [format %c $num] |
||||
} |
||||
|
||||
proc pagechar {page num} { |
||||
set encpage $page |
||||
if {$page ni [encoding names]} { |
||||
set mimenamesdict [page_names_dict] |
||||
dict for {k v} $mimenamesdict { |
||||
if {[lsearch -nocase $v $page] >= 0} { |
||||
set encpage $k |
||||
break |
||||
} |
||||
} |
||||
if {$encpage eq $page} { |
||||
#didn't find a mapping to something else.. |
||||
error "unknown encoding '$page'" |
||||
} |
||||
} |
||||
set ch [format %c $num] |
||||
if {[decodable $ch $encpage]} { |
||||
set outchar [encoding convertfrom $encpage $ch] |
||||
} else { |
||||
#here we will use \0xFFFD instead of our replacement string ??? - as the name pagechar implies always returning a single character. REVIEW. |
||||
set outchar $::punk::char::invalid_display_char |
||||
} |
||||
return $outchar |
||||
} |
||||
|
||||
proc pagebyte {page num} { |
||||
set encpage $page |
||||
if {$page ni [encoding names]} { |
||||
set mimenamesdict [page_names_dict] |
||||
dict for {k v} $mimenamesdict { |
||||
if {[lsearch -nocase $v $page] >= 0} { |
||||
set encpage $k |
||||
break |
||||
} |
||||
} |
||||
if {$encpage eq $page} { |
||||
#didn't find a mapping to something else.. |
||||
error "unknown encoding '$page'" |
||||
} |
||||
} |
||||
set ch [format %c $num] |
||||
if {[decodable $ch $encpage]} { |
||||
#set outchar [encoding convertto $encpage [format %c $num]] |
||||
set outchar [format %c $num] |
||||
} else { |
||||
set outchar $::punk::char::invalid_display_char |
||||
} |
||||
return $outchar |
||||
} |
||||
|
||||
proc all_pages {} { |
||||
set out "" |
||||
set mimenamesdict [page_names_dict] |
||||
foreach encname [encoding names] { |
||||
if {[dict exists $mimenamesdict $encname]} { |
||||
set alt "([dict get $mimenamesdict $encname])" |
||||
} else { |
||||
set alt "" |
||||
} |
||||
append out "$encname $alt" \n |
||||
append out [page $encname] |
||||
} |
||||
return $out |
||||
} |
||||
|
||||
proc encname {encoding_name_or_alias} { |
||||
set encname $encoding_name_or_alias |
||||
if {[lsearch -nocase [page_names] $encname] < 0} { |
||||
error "Unknown encoding '$encname' - use 'punk::char::page_names' to see valid encoding names on this system" |
||||
} |
||||
if {$encname ni [encoding names]} { |
||||
set encname [mime::reversemapencoding $encname] |
||||
} |
||||
return $encname |
||||
} |
||||
|
||||
proc pagedict_raw {encname} { |
||||
variable invalid ;# ="???" |
||||
set encname [encname $encname] |
||||
set d [dict create] |
||||
for {set i 0} {$i < 256} {incr i} { |
||||
set k [format %02x $i] |
||||
#dict set d $k [encoding convertfrom $encname [format %c $i]] |
||||
set ch [format %c $i] ; |
||||
#jmn |
||||
if {[decodable $ch $encname]} { |
||||
#set encchar [encoding convertto $encname $ch] |
||||
#dict set d $k [encoding convertfrom $encchar] |
||||
dict set d $k [encoding convertfrom $encname $ch] |
||||
} else { |
||||
dict set d $k $invalid ;#use replacement so we can detect difference from actual "?" |
||||
} |
||||
} |
||||
return $d |
||||
} |
||||
proc asciidict {} { |
||||
variable invalid |
||||
set d [dict create] |
||||
set a128 [asciidict128] |
||||
for {set i 0} {$i < 256} {incr i} { |
||||
set k [format %02x $i] |
||||
if {$i <= 127} { |
||||
dict set d $k [dict get $a128 $k] |
||||
} else { |
||||
# |
||||
dict set d $k $invalid |
||||
} |
||||
|
||||
if {$i <=32} { |
||||
#no point emitting the lower control characters raw to screen - emit the short-names defined in the 'ascii' proc |
||||
dict set d $k [dict get $a128 $k] |
||||
} else { |
||||
if {$i == 0x9b} { |
||||
dict set d $k CSI ;#don't emit the ansi 'Control Sequence Introducer' - or it will be interpreted by the console and affect the layout. |
||||
} else { |
||||
dict set d $k [format %c $i] |
||||
} |
||||
} |
||||
} |
||||
return $d |
||||
} |
||||
|
||||
proc basedict_display {} { |
||||
set d [dict create] |
||||
set a128 [asciidict128] |
||||
for {set i 0} {$i < 256} {incr i} { |
||||
set k [format %02x $i] |
||||
if {$i <=32} { |
||||
#no point emitting the lower control characters raw to screen - emit the short-names defined in the 'ascii' proc |
||||
dict set d $k [dict get $a128 $k] |
||||
} else { |
||||
if {$i == 0x9b} { |
||||
dict set d $k CSI ;#don't emit the ansi 'Control Sequence Introducer' - or it will be interpreted by the console and affect the layout. |
||||
} else { |
||||
#dict set d $k [encoding convertfrom [encoding system] [format %c $i]] |
||||
#don't use encoding convertfrom - we want the value independent of the current encoding system. |
||||
dict set d $k [format %c $i] |
||||
} |
||||
} |
||||
} |
||||
return $d |
||||
} |
||||
proc basedict_encoding_system {} { |
||||
#result depends on 'encoding system' currently in effect |
||||
set d [dict create] |
||||
for {set i 0} {$i < 256} {incr i} { |
||||
set k [format %02x $i] |
||||
dict set d $k [encoding convertfrom [encoding system] [format %c $i]] |
||||
} |
||||
return $d |
||||
} |
||||
|
||||
proc basedict {} { |
||||
#this gives same result independent of current value of 'encoding system' |
||||
set d [dict create] |
||||
for {set i 0} {$i < 256} {incr i} { |
||||
set k [format %02x $i] |
||||
dict set d $k [format %c $i] |
||||
} |
||||
return $d |
||||
} |
||||
proc pagedict {pagename args} { |
||||
variable charsets |
||||
set encname [encname $pagename] |
||||
set defaults [list\ |
||||
-range {0 256}\ |
||||
-charset ""\ |
||||
] |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- --- --- --- |
||||
set range [dict get $opts -range] |
||||
set charset [dict get $opts -charset] |
||||
# -- --- --- --- --- --- --- --- --- --- |
||||
if {$charset ne ""} { |
||||
if {$charset ni [charset_names]} { |
||||
error "unknown charset '$charset' - use 'charset_names' to get list" |
||||
} |
||||
set setinfo [dict get $charsets $charset] |
||||
set ranges [dict get $setinfo ranges] |
||||
set charset_dict [dict create] |
||||
foreach r $ranges { |
||||
set start [dict get $r start] |
||||
set end [dict get $r end] |
||||
#set charset_dict [dict merge $charset_dict [char_range_dict $start $end]] |
||||
break |
||||
} |
||||
|
||||
} else { |
||||
set start [lindex $range 0] |
||||
set end [lindex $range 1] |
||||
} |
||||
|
||||
set d [dict create] |
||||
for {set i $start} {$i <= $end} {incr i} { |
||||
set k [format %02x $i] |
||||
dict set d $k [encoding convertfrom $encname [format %c $i]] |
||||
} |
||||
return $d |
||||
} |
||||
|
||||
#todo - benchmark peformance - improve punk pipeline |
||||
proc asciidict128 {} { |
||||
regexp -all -inline {\S+} [concat {*}[linelist [ascii] -line trimleft]] |
||||
} |
||||
proc _asciidict128 {} { |
||||
.= ascii |> .=>1 linelist -line trimleft |> .=* concat |> {regexp -all -inline {\S+} $data} |
||||
} |
||||
|
||||
proc asciidict2 {} { |
||||
set d [dict create] |
||||
dict for {k v} [basedict_display] { |
||||
if {[string length $v] == 1} { |
||||
set num [expr {"0x$k"}] |
||||
#dict set d $k "\033(0[subst \\u00$k]\033(B" |
||||
dict set d $k "\033(0[format %c $num]\033(B" |
||||
} else { |
||||
dict set d $k $v |
||||
} |
||||
} |
||||
return $d |
||||
} |
||||
|
||||
#-- --- --- --- --- --- --- --- |
||||
# encoding convertfrom & encoding convertto can be somewhat confusing to think about. (Need to think in reverse.) |
||||
# e.g encoding convertto dingbats <somethingpretty> will output something that doesn't look dingbatty on screen. |
||||
#-- --- --- --- --- --- --- --- |
||||
#must use Tcl instead of tcl (at least for 8.6) |
||||
if {![package vsatisfies [package present Tcl] 8.7]} { |
||||
proc encodable "s {enc [encoding system]}" { |
||||
set encname [encname $enc] |
||||
if {($encname eq "ascii")} { |
||||
#8.6 fails to round-trip convert 0x7f del character despite it being in the ascii range (review Why?? what else doesn't round-trip but should?) |
||||
#just strip it out of the string as we are only after a boolean answer and if s is only a single del char empty string will result in true |
||||
set s [string map [list [format %c 0x7f] ""] $s] |
||||
} |
||||
string eq $s [encoding convertfrom $encname [encoding convertto $encname $s]] |
||||
} |
||||
proc decodable "s {enc [encoding system]}" { |
||||
set encname [encname $enc] |
||||
#review |
||||
string eq $s [encoding convertto $encname [encoding convertfrom $encname $s]] |
||||
} |
||||
} else { |
||||
proc encodable "s {enc [encoding system]}" { |
||||
set encname [encname $enc] |
||||
string eq $s [encoding convertfrom $encname [encoding convertto $encname $s]] |
||||
} |
||||
proc decodable "s {enc [encoding system]}" { |
||||
set encname [encname $enc] |
||||
string eq $s [encoding convertto $encname [encoding convertfrom $encname $s]] |
||||
} |
||||
} |
||||
#-- --- --- --- --- --- --- --- |
||||
proc test_japanese {{encoding jis0208}} { |
||||
#A very basic test of 2char encodings such as jis0208 |
||||
set yatbun 日本 ;# encoding convertfrom jis0208 F|K\\ |
||||
lassign [split $yatbun] yat bun |
||||
puts "original yatbun ${yat} ${bun}" |
||||
set eyat [encoding convertto $encoding $yat] |
||||
set ebun [encoding convertto $encoding $bun] |
||||
puts "$encoding encoded: ${eyat} ${ebun}" |
||||
puts "reencoded: [encoding convertfrom $encoding $eyat] [encoding convertfrom $encoding $ebun]" |
||||
return $yatbun |
||||
} |
||||
|
||||
#G0 Sets Sequence G1 Sets Sequence Meaning |
||||
#ESC ( A ESC ) A United Kingdom Set |
||||
#ESC ( B ESC ) B ASCII Set |
||||
#ESC ( 0 ESC ) 0 Special Graphics |
||||
#ESC ( 1 ESC ) 1 Alternate Character ROM Standard Character Set |
||||
#ESC ( 2 ESC ) 2 Alternate Character ROM Special Graphic |
||||
|
||||
# -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
# Unicode character sets - some hardcoded - some loadable from data files |
||||
# -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
variable charinfo [dict create] |
||||
variable charsets [dict create] |
||||
|
||||
|
||||
# -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
# Aggregate character sets (ones that pick various ranges from underlying unicode ranges) |
||||
# -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
dict set charsets "WGL4" [list altname "Windows Glyph List 4" ranges [list\ |
||||
{start 0 end 127 name "basic latin"}\ |
||||
{start 128 end 255 name "latin-1 supplement"}\ |
||||
] description "Greek and Coptic"] |
||||
|
||||
|
||||
|
||||
|
||||
# -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
#The base page 0-256 8bit range - values don't have specific characters or descriptions - as they are codepage dependent |
||||
#we will fill this here for completeness - but with placeholders |
||||
# -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
dict set charsets "non-unicode" [list ranges [list {start 0 end 127 name ascii} {start 128 end 255 name 8bit-ascii}] description "8bit extended ascii range"] |
||||
for {set i 0} {$i < 256} {incr i} { |
||||
dict set charinfo $i [list desc "codepage-dependent" short "byte_[format %02x $i]"] |
||||
} |
||||
|
||||
# -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
# Unicode ranges |
||||
# -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
# -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
dict set charsets "greek" [list ranges [list {start 880 end 1023} {start 7936 end 8191}] description "Greek and Coptic"] |
||||
|
||||
|
||||
# -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
dict set charsets "latin_extended_additional" [list ranges [list {start 7680 end 7935 }] description "Latin Extended Additional"] |
||||
|
||||
# -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
dict set charsets "block_elements" [list ranges [list {start 9600 end 9631}] description "Block Elements"] |
||||
dict set charinfo 9600 [list desc "Upper Half Block" short "blocke_up_half"] |
||||
dict set charinfo 9601 [list desc "Lower One Eighth Block" short "blocke_lw_1_8th"] |
||||
dict set charinfo 9602 [list desc "Lower One Quarter Block" short "blocke_lw_1_qtr"] |
||||
|
||||
|
||||
# -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
dict set charsets "dingbats" [list ranges [list {start 9984 end 10175 }] description "Unicode Dingbats"] |
||||
dict set charinfo 9984 [list desc "Black Safety Scissors" short "dingbats_black_safety_scissors"] |
||||
#... |
||||
dict set charinfo 10175 [list desc "Double Curly Loop" short "dingbats_double_curly_loop"] |
||||
|
||||
# -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
# emoticons https://www.unicode.org/charts/PDF/U1F600.pdf |
||||
dict set charsets "emoticons" [list ranges [list {start 128512 end 128591}] description "Emoticons"] |
||||
dict set charinfo 128512 [list desc "Grinning Face" short "emoticon_grinface"] |
||||
dict set charinfo 128513 [list desc "Grinning Face with Smiling Eyes" short "emoticon_grinface_smile_eyes"] |
||||
dict set charinfo 128514 [list desc "Face with Tears of Joy" short "emoticon_face_tears_joy"] |
||||
|
||||
#todo |
||||
dict set charinfo 128590 [list desc "Person with Pouting Face" short "emoticon_person_pouting"] |
||||
|
||||
# -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
dict set charsets "box_drawing" [list ranges [list {start 9472 end 9599}] description "Box Drawing"] |
||||
dict set charinfo 9472 [list desc "Box Drawings Light Horizontal" short "boxd_lhz"] |
||||
dict set charinfo 9473 [list desc "Box Drawings Heavy Horizontal" short "boxd_hhz"] |
||||
dict set charinfo 9474 [list desc "Box Drawings Light Vertical" short "boxd_lv"] |
||||
dict set charinfo 9475 [list desc "Box Drawings Heavy Vertical" short "boxd_hv"] |
||||
dict set charinfo 9476 [list desc "Box Drawings Light Triple Dash Horizontal" short "boxd_ltdshhz"] |
||||
dict set charinfo 9477 [list desc "Box Drawings Heavy Triple Dash Horizontal" short "boxd_htdshhz"] |
||||
dict set charinfo 9478 [list desc "Box Drawings Light Triple Dash Vertical" short "boxd_ltdshv"] |
||||
dict set charinfo 9479 [list desc "Box Drawings Heavy Triple Dash Vertical" short "boxd_htdshv"] |
||||
dict set charinfo 9480 [list desc "Box Drawings Light Quadruple Dash Horizontal" short "boxd_lqdshhz"] |
||||
dict set charinfo 9481 [list desc "Box Drawings Heavy Quadruple Dash Horizontal" short "boxd_hqdshhz"] |
||||
dict set charinfo 9482 [list desc "Box Drawings Light Quadruple Dash Vertical" short "boxd_lqdshv"] |
||||
dict set charinfo 9483 [list desc "Box Drawings Heavy Quadruple Dash Vertical" short "boxd_hqdshv"] |
||||
dict set charinfo 9484 [list desc "Box Drawings Light Down and Right" short "boxd_ldr"] |
||||
dict set charinfo 9485 [list desc "Box Drawings Down Light and Right Heavy" short "boxd_dlrh"] |
||||
dict set charinfo 9486 [list desc "Box Drawings Down Heavy and Right Light" short "boxd_dhrl"] |
||||
dict set charinfo 9487 [list desc "Box Drawings Heavy Down and Right" short "boxd_hdr"] |
||||
dict set charinfo 9488 [list desc "Box Drawings Light Down and Left" short "boxd_ldl"] |
||||
dict set charinfo 9489 [list desc "Box Drawings Down Light and Left Heavy" short "boxd_dllh"] |
||||
dict set charinfo 9490 [list desc "Box Drawings Down Heavy and Left Light" short "boxd_dhll"] |
||||
dict set charinfo 9491 [list desc "Box Drawings Heavy Down and Left" short "boxd_hdl"] |
||||
dict set charinfo 9492 [list desc "Box Drawings Light Up and Right" short "boxd_lur"] |
||||
dict set charinfo 9493 [list desc "Box Drawings Up Light and Right Heavy" short "boxd_ulrh"] |
||||
dict set charinfo 9494 [list desc "Box Drawings Up Heavy and Right Light" short "boxd_uhrl"] |
||||
dict set charinfo 9495 [list desc "Box Drawings Heavy Up and Right" short "boxd_hur"] |
||||
dict set charinfo 9496 [list desc "Box Drawings Light Up and Left" short "boxd_lul"] |
||||
dict set charinfo 9497 [list desc "Box Drawings Up Light and Left Heavy" short "boxd_ullh"] |
||||
dict set charinfo 9498 [list desc "Box Drawings Up Heavy and Left Light" short "boxd_uhll"] |
||||
dict set charinfo 9499 [list desc "Box Drawings Heavy Up and Left" short "boxd_hul"] |
||||
dict set charinfo 9500 [list desc "Box Drawings Light Vertical and Right" short "boxd_lvr"] |
||||
dict set charinfo 9501 [list desc "Box Drawings Vertical Light and Right Heavy" short "boxd_vlrh"] |
||||
dict set charinfo 9502 [list desc "Box Drawings Up Heavy and Right Down Light" short "boxd_uhrdl"] |
||||
dict set charinfo 9503 [list desc "Box Drawings Down Heavy and Right Up Light" short "boxd_dhrul"] |
||||
dict set charinfo 9504 [list desc "Box Drawings Vertical Heavy and Right Light" short "boxd_vhrl"] |
||||
dict set charinfo 9505 [list desc "Box Drawings Down Light and Right Up Heavy" short "boxd_dlruh"] |
||||
dict set charinfo 9506 [list desc "Box Drawings Up Light and Right Down Heavy" short "boxd_ulrdh"] |
||||
dict set charinfo 9507 [list desc "Box Drawings Heavy Vertical and Right" short "boxd_hvr"] |
||||
dict set charinfo 9508 [list desc "Box Drawings Light Vertical and Left" short "boxd_lvl"] |
||||
dict set charinfo 9509 [list desc "Box Drawings Vertical Light and Left Heavy" short "boxd_vllh"] |
||||
dict set charinfo 9510 [list desc "Box Drawings Up Heavy and Let Down Light" short "boxd_uhldl"] |
||||
dict set charinfo 9511 [list desc "Box Drawings Down Heavy and Left Up Light" short "boxd_dhlul"] |
||||
dict set charinfo 9512 [list desc "Box Drawings Vertical Heavy and Left Light" short "boxd_vhll"] |
||||
dict set charinfo 9513 [list desc "Box Drawings Down Light and left Up Heavy" short "boxd_dlluh"] |
||||
dict set charinfo 9514 [list desc "Box Drawings Up Light and Left Down Heavy" short "boxd_ulldh"] |
||||
dict set charinfo 9515 [list desc "Box Drawings Heavy Vertical and Left" short "boxd_hvl"] |
||||
dict set charinfo 9516 [list desc "Box Drawings Light Down and Horizontal" short "boxd_ldhz"] |
||||
dict set charinfo 9517 [list desc "Box Drawings Left Heavy and Right Down Light" short "boxd_lhrdl"] |
||||
dict set charinfo 9518 [list desc "Box Drawings Right Heavy and Left Down Light" short "boxd_rhldl"] |
||||
dict set charinfo 9519 [list desc "Box Drawings Down Light and Horizontal Heavy" short "boxd_dlhzh"] |
||||
dict set charinfo 9520 [list desc "Box Drawings Down Heavy and Horizontal Light" short "boxd_dhhzl"] |
||||
dict set charinfo 9521 [list desc "Box Drawings Right Light and Left Down Heavy" short "boxd_rlldh"] |
||||
dict set charinfo 9522 [list desc "Box Drawings Left Light and Right Down Heavy" short "boxd_llrdh"] |
||||
dict set charinfo 9523 [list desc "Box Drawings Heavy Down and Horizontal" short "boxd_hdhz"] |
||||
dict set charinfo 9524 [list desc "Box Drawings Light Up and Horizontal" short "boxd_luhz"] |
||||
dict set charinfo 9525 [list desc "Box Drawings Left Heavy and Right Up Light" short "boxd_lhrul"] |
||||
dict set charinfo 9526 [list desc "Box Drawings Right Heavy and Left Up Light" short "boxd_rhlul"] |
||||
dict set charinfo 9527 [list desc "Box Drawings Up Light and Horizontal Heavy" short "boxd_ulhzh"] |
||||
dict set charinfo 9528 [list desc "Box Drawings Up Heavy and Horizontal Light" short "boxd_uhhzl"] |
||||
dict set charinfo 9529 [list desc "Box Drawings Right Light and Left Up Heavy" short "boxd_rlluh"] |
||||
dict set charinfo 9530 [list desc "Box Drawings Left Light and Right Up Heavy" short "boxd_llruh"] |
||||
dict set charinfo 9531 [list desc "Box Drawings Heavy Up and Horizontal" short "boxd_huhz"] |
||||
dict set charinfo 9532 [list desc "Box Drawings Light Vertical and Horizontal" short "boxd_lvhz"] |
||||
dict set charinfo 9533 [list desc "Box Drawings Left Heavy and Right Vertical Light" short "boxd_lhrvl"] |
||||
dict set charinfo 9534 [list desc "Box Drawings Right Heavy and Left Vertical Light" short "boxd_rhlvl"] |
||||
dict set charinfo 9535 [list desc "Box Drawings Vertical Light and Horizontal Heavy" short "boxd_vlhzh"] |
||||
dict set charinfo 9536 [list desc "Box Drawings Up Heavy and Down Horizontal Light" short "boxd_uhdhzl"] |
||||
dict set charinfo 9537 [list desc "Box Drawings Down Heavy and Up Horizontal Light" short "boxd_dhuhzl"] |
||||
dict set charinfo 9538 [list desc "Box Drawings Vertical Heavy and Horizontal Light" short "boxd_vhhzl"] |
||||
dict set charinfo 9539 [list desc "Box Drawings Left Up Heavy and Right Down Light" short "boxd_luhrdl"] |
||||
dict set charinfo 9540 [list desc "Box Drawings Right Up Heavy and Left Down Light" short "boxd_ruhldl"] |
||||
dict set charinfo 9541 [list desc "Box Drawings Left Down Heavy and Right Up Light" short "boxd_ldhrul"] |
||||
dict set charinfo 9542 [list desc "Box Drawings Right Down Heavy and Left Up Light" short "boxd_rdhlul"] |
||||
dict set charinfo 9543 [list desc "Box Drawings Down Light and Up Horizontal Heavy" short "boxd_dluhzh"] |
||||
dict set charinfo 9544 [list desc "Box Drawings Up Light and Down Horizontal Heavy" short "boxd_dldhzh"] |
||||
dict set charinfo 9545 [list desc "Box Drawings Right Light and Left Vertical Heavy" short "boxd_rllvh"] |
||||
dict set charinfo 9546 [list desc "Box Drawings Left Light and Right Vertical Heavy" short "boxd_llrvh"] |
||||
dict set charinfo 9547 [list desc "Box Drawings Heavy Vertical and Horizontal" short "boxd_hvhz"] |
||||
dict set charinfo 9548 [list desc "Box Drawings Light Double Dash Horizontal" short "boxd_lddshhz"] |
||||
dict set charinfo 9549 [list desc "Box Drawings Heavy Double Dash Horizontal" short "boxd_hddshhz"] |
||||
dict set charinfo 9550 [list desc "Box Drawings Light Double Dash Vertical" short "boxd_lddshv"] |
||||
dict set charinfo 9551 [list desc "Box Drawings Heavy Double Dash Vertical" short "boxd_hddshv"] |
||||
dict set charinfo 9552 [list desc "Box Drawings Double Horizontal" short "boxd_dhz"] |
||||
dict set charinfo 9553 [list desc "Box Drawings Double Vertical" short "boxd_dv"] |
||||
dict set charinfo 9554 [list desc "Box Drawings Down Single and Right Double" short "boxd_dsrd"] |
||||
dict set charinfo 9555 [list desc "Box Drawings Down Double and Right Single" short "boxd_ddrs"] |
||||
dict set charinfo 9556 [list desc "Box Drawings Double Down and Right" short "boxd_ddr"] |
||||
dict set charinfo 9557 [list desc "Box Drawings Down Single and Left Double" short "boxd_dsld"] |
||||
dict set charinfo 9558 [list desc "Box Drawings Down Double and Left Single" short "boxd_ddls"] |
||||
dict set charinfo 9559 [list desc "Box Drawings Double Down and Left" short "boxd_ddl"] |
||||
dict set charinfo 9560 [list desc "Box Drawings Up Single and Right Double" short "boxd_usrd"] |
||||
dict set charinfo 9561 [list desc "Box Drawings Up Double and Right Single" short "boxd_udrs"] |
||||
dict set charinfo 9562 [list desc "Box Drawings Double Up and Right" short "boxd_dur"] |
||||
dict set charinfo 9563 [list desc "Box Drawings Up Single and Left Double" short "boxd_usld"] |
||||
dict set charinfo 9564 [list desc "Box Drawings Up Double and Left Single" short "boxd_udls"] |
||||
dict set charinfo 9565 [list desc "Box Drawings Double Up and Left" short "boxd_dul"] |
||||
dict set charinfo 9566 [list desc "Box Drawings Vertical Single and Right Double" short "boxd_vsrd"] |
||||
dict set charinfo 9567 [list desc "Box Drawings Vertical Double and Right Single" short "boxd_vdrs"] |
||||
dict set charinfo 9568 [list desc "Box Drawings Double Vertical and Right" short "boxd_dvr"] |
||||
dict set charinfo 9569 [list desc "Box Drawings Vertical Single and Left Double" short "boxd_vsld"] |
||||
dict set charinfo 9570 [list desc "Box Drawings Vertical Double and Left Single" short "boxd_vdls"] |
||||
dict set charinfo 9571 [list desc "Box Drawings Double Vertical and Left" short "boxd_dvl"] |
||||
dict set charinfo 9572 [list desc "Box Drawings Down Single and Horizontal Double" short "boxd_dshzd"] |
||||
dict set charinfo 9573 [list desc "Box Drawings Down Double and Horizontal Single" short "boxd_ddhzs"] |
||||
dict set charinfo 9574 [list desc "Box Drawings Double Down and Horizontal" short "boxd_ddhz"] |
||||
dict set charinfo 9575 [list desc "Box Drawings Up Single and Horizontal Double" short "boxd_ushzd"] |
||||
dict set charinfo 9576 [list desc "Box Drawings Up Double and Horizontal Single" short "boxd_udhzs"] |
||||
dict set charinfo 9577 [list desc "Box Drawings Double Up and Horizontal" short "boxd_duhz"] |
||||
dict set charinfo 9578 [list desc "Box Drawings Vertical Single and Horizontal Double" short "boxd_vshzd"] |
||||
dict set charinfo 9579 [list desc "Box Drawings Vertical Double and Horizontal Single" short "boxd_vdhzs"] |
||||
dict set charinfo 9580 [list desc "Box Drawings Double Vertical and Horizontal" short "boxd_dvhz"] |
||||
dict set charinfo 9581 [list desc "Box Drawings Light Arc Down and Right" short "boxd_ladr"] |
||||
dict set charinfo 9582 [list desc "Box Drawings Light Arc Down and Left" short "boxd_ladl"] |
||||
dict set charinfo 9583 [list desc "Box Drawings Light Arc Up and Left" short "boxd_laul"] |
||||
dict set charinfo 9584 [list desc "Box Drawings Light Arc Up and Right" short "boxd_laur"] |
||||
dict set charinfo 9585 [list desc "Box Drawings Light Diagonal Upper Right To Lower Left" short "boxd_ldgurll"] |
||||
dict set charinfo 9586 [list desc "Box Drawings Light Diagonal Upper Left To Lower Right" short "boxd_ldgullr"] |
||||
dict set charinfo 9587 [list desc "Box Drawings Light Diagonal Cross" short "boxd_ldc"] |
||||
dict set charinfo 9588 [list desc "Box Drawings Light Left" short "boxd_ll"] |
||||
dict set charinfo 9589 [list desc "Box Drawings Light Up" short "boxd_lu"] |
||||
dict set charinfo 9590 [list desc "Box Drawings Light Right" short "boxd_lr"] |
||||
dict set charinfo 9591 [list desc "Box Drawings Light Down" short "boxd_ld"] |
||||
dict set charinfo 9592 [list desc "Box Drawings Heavy Left" short "boxd_hl"] |
||||
dict set charinfo 9593 [list desc "Box Drawings Heavy Up" short "boxd_hu"] |
||||
dict set charinfo 9594 [list desc "Box Drawings Heavy Right" short "boxd_hr"] |
||||
dict set charinfo 9595 [list desc "Box Drawings Heavy Down" short "boxd_hd"] |
||||
dict set charinfo 9596 [list desc "Box Drawings Light Left and Heavy Right" short "boxd_llhr"] |
||||
dict set charinfo 9597 [list desc "Box Drawings Light Up and Heavy Down" short "boxd_luhd"] |
||||
dict set charinfo 9598 [list desc "Box Drawings Heavy Left and Light Right" short "boxd_hllr"] |
||||
dict set charinfo 9599 [list desc "Box Drawings Heavy Up and Light Down" short "boxd_huld"] |
||||
|
||||
|
||||
dict set charsets "halfwidth_and_fullwidth_forms" [list ranges [list {start 65280 end 65519}] description "Halfwidth and Fullwidth Forms (variants)"] |
||||
dict set charsets "ascii_fullwidth" [list ranges [list {start 65281 end 65374}] description "Ascii 21 to 7E fullwidth" parentblock "halfwidth_and_fullwidth_forms"] |
||||
|
||||
dict set charsets "specials" [list ranges [list {start 65520 end 65535}] description "Specials"] |
||||
|
||||
#build dicts keyed on short |
||||
variable charshort |
||||
proc _build_charshort {} { |
||||
variable charshort |
||||
set charshort [dict create] |
||||
variable charinfo |
||||
dict for {k v} $charinfo { |
||||
set sh [dict get $v short] |
||||
if {[dict exists $charshort $sh]} { |
||||
puts stderr "_build_charshort WARNING character data load duplicate shortcode '$sh'" |
||||
} |
||||
dict set charshort $sh [format %c $k] |
||||
} |
||||
return [dict size $charshort] |
||||
} |
||||
_build_charshort |
||||
|
||||
proc load_nerdfonts {} { |
||||
variable charsets |
||||
variable charinfo |
||||
package require fileutil |
||||
set ver [package provide punk::char] |
||||
if {$ver ne ""} { |
||||
set ifneeded [package ifneeded punk::char [package provide punk::char]] |
||||
#puts stderr "punk::char ifneeded script: $ifneeded" |
||||
lassign [split $ifneeded ";"] _ sourceinfo |
||||
set basedir [file dirname [lindex $sourceinfo end]] |
||||
} else { |
||||
#review - will only work at package load time |
||||
set scr [info script] |
||||
if {$scr eq ""} { |
||||
error "load_nerdfonts unable to determine package folder" |
||||
} |
||||
set basedir [file dirname [info script]] |
||||
} |
||||
set pkg_data_dir [file join $basedir char] |
||||
set fname [file join $pkg_data_dir nerd-fonts-glyph-list.txt] |
||||
if {[file exists $fname]} { |
||||
#puts stderr "load_nerdfonts loading $fname" |
||||
set data [fileutil::cat -translation binary $fname] |
||||
set short_seen [list] |
||||
set current_set_range [dict create] |
||||
foreach ln [split $data \n] { |
||||
set ln [string trim $ln] |
||||
if {$ln eq ""} {continue} |
||||
set desc [lassign $ln hex set] |
||||
set hexnum 0x$hex |
||||
set dec [expr $hexnum] |
||||
set setname "nf_$set" ;#Ensure nerdfont set names are prefixed. |
||||
if {$setname ni [dict keys $charsets]} { |
||||
set newrange [list start $dec end $dec] |
||||
dict set current_set_range $setname $newrange |
||||
dict set charsets $setname [list ranges [list $newrange] description "nerd fonts $set"] |
||||
} else { |
||||
set existing_range [dict get $current_set_range $setname] |
||||
set existing_end [dict get $existing_range end] |
||||
if {$dec - $existing_end == 1} { |
||||
#part of current range |
||||
dict set current_set_range $setname end $dec |
||||
#overwrite last ranges element |
||||
set rangelist [lrange [dict get $charsets $setname ranges] 0 end-1] |
||||
lappend rangelist [dict get $current_set_range $setname] |
||||
dict set charsets $setname ranges $rangelist |
||||
} else { |
||||
#new range for set |
||||
dict set current_set_range $setname start $dec |
||||
dict set current_set_range $setname end $dec |
||||
set rangelist [dict get $charsets $setname ranges] |
||||
lappend rangelist [dict get $current_set_range $setname] |
||||
dict set charsets $setname ranges $rangelist |
||||
} |
||||
#dict set charsets $setname end $dec |
||||
} |
||||
if {$hex ni [dict keys $charinfo]} { |
||||
# -- --- |
||||
#review |
||||
set map [list beaufort bf gibbous gb crescent cr thunderstorm tstorm thermometer thermom] |
||||
lappend map {*}[list directory dir creativecommons ccom creative_commons ccom forwardslash fs] |
||||
lappend map {*}[list multimedia mm multiple multi outline outl language lang] |
||||
lappend map {*}[list odnoklassniki okru] |
||||
# -- --- |
||||
#consider other ways to unambiguously shorten names? |
||||
#normalize nf_fa & nf_fa 'o' element to 'outl' so outlines can be searched across sets more easily (o not necessarily at last position) |
||||
set normdesc [list] |
||||
foreach el $desc { |
||||
if {$el eq "o"} { |
||||
set el "outl" |
||||
} |
||||
lappend normdesc $el |
||||
} |
||||
set joined_desc [join $normdesc _] |
||||
#map after join so we can normalize some underscored elements e.g creativecommons & creative_commons |
||||
set mapped_desc [string map $map $joined_desc] |
||||
set s nf_${set}_$mapped_desc |
||||
|
||||
if {$s ni $short_seen} { |
||||
lappend short_seen $s |
||||
} else { |
||||
#duplicate in the data file (e.g 2023 weather night alt rain mix) |
||||
set s ${s}_$hex |
||||
} |
||||
dict set charinfo $dec [list desc "$desc" short $s] |
||||
} |
||||
} |
||||
_build_charshort |
||||
} else { |
||||
puts stderr "unable to find glyph file. Tried $fname" |
||||
} |
||||
} |
||||
|
||||
proc charshort {shortname} { |
||||
variable charshort |
||||
return [dict get $charshort $shortname] |
||||
} |
||||
|
||||
proc box_drawing {args} { |
||||
return [charset "box_drawing" {*}$args] |
||||
} |
||||
proc box_drawing_dict {} { |
||||
return [charset_dict "box_drawing"] |
||||
} |
||||
|
||||
proc char_range_dict {start end args} { |
||||
if {![string is integer -strict $start] || ![string is integer -strict $end]} { |
||||
error "char_range_dict error start and end must be integers" |
||||
} |
||||
set and_globs [list] |
||||
if {![llength $args]} { |
||||
set args [list *] |
||||
} |
||||
foreach glob $args { |
||||
if {![regexp {[*?]} $glob]} { |
||||
lappend and_globs "*$glob*" |
||||
} else { |
||||
lappend and_globs $glob |
||||
} |
||||
} |
||||
variable charinfo |
||||
set cdict [dict create] |
||||
for {set i $start} {$i <= $end} {incr i} { |
||||
set hx [format %04x $i] |
||||
set ch [format %c $i] |
||||
if {[dict exists $charinfo $i]} { |
||||
set d [dict get $charinfo $i desc] |
||||
set s [dict get $charinfo $i short] |
||||
} else { |
||||
set d "" |
||||
set s "" |
||||
} |
||||
set matchcount 0 |
||||
foreach glob $and_globs { |
||||
if {[string match -nocase $glob $s] || [string match -nocase $glob $d]} { |
||||
incr matchcount |
||||
} |
||||
} |
||||
if {$matchcount == [llength $and_globs]} { |
||||
dict set cdict $hx [list char $ch desc $d short $s dec $i] |
||||
} |
||||
} |
||||
return $cdict |
||||
} |
||||
proc char_range {start end args} { |
||||
if {![string is integer -strict $start] || ![string is integer -strict $end]} { |
||||
error "char_range error start and end must be integers" |
||||
} |
||||
set charset_dict [char_range_dict $start $end {*}$args] |
||||
set out "" |
||||
set col3 [string repeat " " 12] |
||||
dict for {k inf} $charset_dict { |
||||
set s [dict get $inf short] |
||||
set d [dict get $inf desc] |
||||
set s_col [overtype::left $col3 $s] |
||||
append out "$k [dict get $inf char] $s_col $d" \n |
||||
} |
||||
return $out |
||||
} |
||||
|
||||
proc charset_names {} { |
||||
variable charsets |
||||
return [dict keys $charsets] |
||||
} |
||||
proc charset_dict {name} { |
||||
variable charsets |
||||
if {$name ni [charset_names]} { |
||||
error "unknown charset '$name' - use 'charset_names' to get list" |
||||
} |
||||
set setinfo [dict get $charsets $name] |
||||
set ranges [dict get $setinfo ranges] |
||||
set charset_dict [dict create] |
||||
foreach r $ranges { |
||||
set start [dict get $r start] |
||||
set end [dict get $r end] |
||||
set charset_dict [dict merge $charset_dict [char_range_dict $start $end]] |
||||
} |
||||
return $charset_dict |
||||
} |
||||
proc charset {namesearch args} { |
||||
variable charsets |
||||
if {[regexp {[?*]} $namesearch]} { |
||||
#name glob search |
||||
} else { |
||||
if {$namesearch ni [charset_names]} { |
||||
error "unknown charset '$namesearch' - use 'charset_names' to get list" |
||||
} |
||||
} |
||||
|
||||
set out "" |
||||
set matched_names [dict keys $charsets $namesearch] |
||||
foreach name $matched_names { |
||||
set setinfo [dict get $charsets $name] |
||||
set ranges [dict get $setinfo ranges] |
||||
set charset_dict [dict create] |
||||
foreach r $ranges { |
||||
set start [dict get $r start] |
||||
set end [dict get $r end] |
||||
set charset_dict [dict merge $charset_dict [char_range_dict $start $end {*}$args]] |
||||
} |
||||
set col_items_short [list] |
||||
set col_items_desc [list] |
||||
dict for {k inf} $charset_dict { |
||||
lappend col_items_short [dict get $inf short] |
||||
lappend col_items_desc [dict get $inf desc] |
||||
} |
||||
if {[llength $col_items_short]} { |
||||
set widest3 [tcl::mathfunc::max {*}[lmap v $col_items_short {string length $v}]] |
||||
if {$widest3 == 0} { |
||||
set col3 " " |
||||
} else { |
||||
set col3 [string repeat " " $widest3] |
||||
} |
||||
dict for {k inf} $charset_dict { |
||||
set s [dict get $inf short] |
||||
set d [dict get $inf desc] |
||||
set s_col [overtype::left $col3 $s] |
||||
append out "$k [dict get $inf char] $s_col $d" \n |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $out |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::char [namespace eval punk::char { |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,3 @@
|
||||
0.1.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,168 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::console 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
package require zzzload |
||||
zzzload::pkg_require twapi |
||||
} |
||||
|
||||
#see https://learn.microsoft.com/en-us/windows/console/classic-vs-vt |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::console { |
||||
variable has_twapi 0 |
||||
|
||||
|
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
proc enableRaw {{channel stdin}} { |
||||
define_windows_procs |
||||
tailcall enableRaw $channel |
||||
} |
||||
proc disableRaw {{channel stdin}} { |
||||
define_windows_procs |
||||
tailcall disableRaw $channel |
||||
} |
||||
} else { |
||||
proc enableRaw {{channel stdin}} { |
||||
set sttycmd [auto_execok stty] |
||||
exec {*}$sttycmd raw -echo <@$channel |
||||
} |
||||
proc disableRaw {{channel stdin}} { |
||||
set sttycmd [auto_execok stty] |
||||
exec {*}$sttycmd raw echo <@$channel |
||||
} |
||||
} |
||||
|
||||
proc define_windows_procs {} { |
||||
set loadstate [zzzload::pkg_require twapi] |
||||
if {$loadstate ni [list loading failed]} { |
||||
package require twapi ;#should be fast once twapi dll loaded in zzzload thread |
||||
set ::punk::console::has_twapi 1 |
||||
proc enableRaw {{channel stdin}} { |
||||
#review - change to modify_console_input_mode |
||||
set console_handle [twapi::GetStdHandle -10] |
||||
set oldmode [twapi::GetConsoleMode $console_handle] |
||||
set newmode [expr {$oldmode & ~6}] ;# Turn off the echo and line-editing bits |
||||
twapi::SetConsoleMode $console_handle $newmode |
||||
} |
||||
proc disableRaw {{channel stdin}} { |
||||
set console_handle [twapi::GetStdHandle -10] |
||||
set oldmode [twapi::GetConsoleMode $console_handle] |
||||
set newmode [expr {$oldmode | 6}] ;# Turn on the echo and line-editing bits |
||||
twapi::SetConsoleMode $console_handle $newmode |
||||
} |
||||
|
||||
} else { |
||||
if {$loadstate eq "failed"} { |
||||
puts stderr "punk::console falling back to stty because twapi load failed" |
||||
proc enableRaw {{channel stdin}} { |
||||
set sttycmd [auto_execok stty] |
||||
exec {*}$sttycmd raw -echo <@$channel |
||||
} |
||||
proc disableRaw {{channel stdin}} { |
||||
set sttycmd [auto_execok stty] |
||||
exec {*}$sttycmd raw echo <@$channel |
||||
} |
||||
} |
||||
tailcall du_dirlisting_generic $folderpath {*}$args |
||||
} |
||||
|
||||
} |
||||
|
||||
proc ansi_response_handler {chan} { |
||||
set status [catch {read $chan 1} bytes] |
||||
if { $status != 0 } { |
||||
# Error on the channel |
||||
puts "error reading $chan: $bytes" |
||||
set ::punk::console::chunkdone 2 |
||||
} elseif {$bytes ne ""} { |
||||
# Successfully read the channel |
||||
#puts "got: [string length $bytes]" |
||||
append ::punk::console::chunk $bytes |
||||
if {$bytes eq "R"} { |
||||
set ::punk::console::chunkdone 4 |
||||
} else { |
||||
fileevent stdin readable [list ::punk::console::ansi_response_handler stdin] |
||||
} |
||||
} elseif { [eof $chan] } { |
||||
# End of file on the channel |
||||
#review |
||||
puts "ansi_response_handler end of file" |
||||
set ::punk::console::chunkdone 1 |
||||
} elseif { [fblocked $chan] } { |
||||
# Read blocked. Just return |
||||
} else { |
||||
# Something else |
||||
puts "ansi_response_handler can't happen" |
||||
set ::punk::console::chunkdone 3 |
||||
} |
||||
} |
||||
|
||||
proc get_cursor_position {} { |
||||
set ::punk::console::chunk "" |
||||
enableRaw |
||||
puts -nonewline stdout \033\[6n ;flush stdout |
||||
#e.g \033\[46;1R |
||||
#todo - reset |
||||
fconfigure stdin -blocking 0 |
||||
fileevent stdin readable [list ::punk::console::ansi_response_handler stdin] |
||||
set info "" |
||||
vwait ::punk::console::chunkdone |
||||
fileevent stdin readable {} |
||||
disableRaw |
||||
set info $::punk::console::chunk |
||||
#set punk::console::chunk "" |
||||
set data [string range $info 2 end-1] |
||||
return [split $data ";"] |
||||
} |
||||
proc test {} { |
||||
enableRaw |
||||
puts -nonewline stdout \033\[6n ;flush stdout |
||||
fconfigure stdin -blocking 0 |
||||
set info [read stdin 20] ;# |
||||
after 1 |
||||
if {[string first "R" $info] <=0} { |
||||
append info [read stdin 20] |
||||
} |
||||
disableRaw |
||||
set data [string range [string trim $info] 2 end-1] |
||||
return [split $data ";"] |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::console [namespace eval punk::console { |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,3 @@
|
||||
0.1.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
@ -1,10 +1,15 @@
|
||||
|
||||
package require punk::cap |
||||
package require punk::mix::templates ;#registers 'templates' capability with punk::cap |
||||
package require punk::mix::base |
||||
package require punk::mix::cli |
||||
|
||||
namespace eval punk::mix { |
||||
|
||||
} |
||||
|
||||
package provide punk::mix [namespace eval punk::mix { |
||||
variable version |
||||
set version 0.2 |
||||
|
||||
variable version |
||||
set version 0.2 |
||||
|
||||
}] |
||||
|
||||
@ -0,0 +1,49 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::templates 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
package require punk::cap |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::templates { |
||||
punk::cap::register_package punk::mix::templates [list\ |
||||
{templates {relpath ../templates}}\ |
||||
] |
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::templates [namespace eval punk::mix::templates { |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,3 @@
|
||||
0.1.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
@ -0,0 +1,632 @@
|
||||
# -*- 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.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
package require textutil |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#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" |
||||
} |
||||
|
||||
#interp alias {} ::overtype::stripcodes {} ::overtype::stripansi |
||||
proc overtype::stripcodes {text} { |
||||
tailcall overtype::stripansi $text |
||||
} |
||||
|
||||
proc overtype::stripansi {text} { |
||||
set inputlist [split $text ""] |
||||
set outputlist [list] |
||||
dict set escape_terminals 1 [list J K m n A B C D E F G s u] ;#review |
||||
dict set escape_terminals 2 [list \007] |
||||
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] |
||||
if {$in_escapesequence != 0} { |
||||
if {$u in [dict get $escape_terminals $in_escapesequence]} { |
||||
set in_escapesequence 0 |
||||
} |
||||
} else { |
||||
if {$u eq "\033" && $v eq "\["} { |
||||
set in_escapesequence 1 |
||||
} elseif {$u eq "\033" && $v eq "\]"} { |
||||
set in_escapesequence 2 |
||||
} else { |
||||
lappend outputlist $u |
||||
} |
||||
} |
||||
incr i |
||||
} |
||||
return [join $outputlist ""] |
||||
|
||||
} |
||||
|
||||
#maintenance warning - also in 'shellfilter' pkg |
||||
#strip ansi codes from text - basic! assumes we don't get data split in the middle of an ansi-code ie best used with line-buffering |
||||
proc overtype::stripansi2 {text} { |
||||
variable lasttext "" |
||||
if {[set posn [string first "\033" $text]] < 0} { |
||||
return $text |
||||
} |
||||
if {[set posn [string first "\033(" $text]] >= 0} { |
||||
#e.g "\033(0" - select VT100 graphics for character set G0 |
||||
#e.g "\033(X" - where X is any char other than 0 to reset |
||||
set text [string range $text 0 $posn-1][string range $text $posn+3 end] |
||||
} |
||||
if {[set posn [string first "\033)" $text]] >= 0} { |
||||
#e.g "\033)0" - select VT100 graphics for character set G1 |
||||
#e.g "\033)X" - where X is any char other than 0 to reset |
||||
set text [string range $text 0 $posn-1][string range $text $posn+3 end] |
||||
} |
||||
#strip title including inner text - the title is an instruction to the window - so the title-text doesn't form part of the line-data in the text block |
||||
if {[set posn [string first "\033\]" $text]] >= 0} { |
||||
set next2 [string range $text $posn+2 $posn+3] |
||||
if {$next2 in [list {0;} {1;} {2;}]} { |
||||
#0; set icon name and window title |
||||
#1; set icon name |
||||
#2; set window title |
||||
set tail [string range $text $posn end] |
||||
set endoffset [string first \007 $tail] |
||||
if {$endoffset > 3} { |
||||
set text [string range $text 0 $posn-1][string range $text $posn+$offset+1 end] |
||||
} else { |
||||
#unexpected.. we seem to be missing terminating BEL character |
||||
puts stderr "stripansi failure: missing terminator BEL on title" |
||||
} |
||||
} |
||||
} |
||||
if {[set posn [string first "\033\[" $text]] >= 0} { |
||||
set mnext [string first m [string range $text $posn end]] |
||||
if {$mnext >= 0} { |
||||
set mpos [expr {$posn + $mnext}] |
||||
set stripped1 [string range $text 0 $posn-1][string range $text $mpos+1 end] |
||||
#return [stripansi $stripped1] ;#recurse to get any others |
||||
tailcall ::overtype::stripansi $stripped1 |
||||
} else { |
||||
#partial or not actually a basic ansi code.. pass it all through |
||||
return $text |
||||
} |
||||
} |
||||
if {[set posn [string first "\033" $text]] >= 0} { |
||||
if {$lasttext eq $text} { |
||||
return $text |
||||
} |
||||
set lasttext $text |
||||
tailcall ::overtype::stripansi $text |
||||
} |
||||
return $text |
||||
} |
||||
proc overtype::strip_nonprinting {str} { |
||||
set map [list\ |
||||
\007 ""\ |
||||
[format %c 0] ""\ |
||||
[format %c 0x7f] ""\ |
||||
] |
||||
return [string map $map $str] |
||||
} |
||||
|
||||
#length of text for printing characters only |
||||
#review - unicode and other non-printing chars? |
||||
#review - is there an existing library or better method? print to a terminal and query cursor position? |
||||
#Note this length calculation is only suitable for lines being appended to other strings if the line is pre-processed to account for backspace and carriage returns first |
||||
#If the raw line is appended to another string without such processing - the backspaces & carriage returns can affect data prior to the start of the string. |
||||
proc overtype::printing_length {line} { |
||||
if {[string first \n $line] >= 0} { |
||||
error "line_print_length must not contain newline characters" |
||||
} |
||||
set line [stripansi $line] |
||||
set line [strip_nonprinting $line] ;#only strip nonprinting after stripansi - some like BEL are part of ansi |
||||
#backspace 0x08 only erases* printing characters anyway - so presumably order of processing doesn't matter |
||||
#(* more correctly - moves cursor back) |
||||
#backspace will not move beyond a preceding newline - but we have disallowed newlines for this function already |
||||
#leading backspaces will eat into any string (even prompt in non-standard tclsh shell) that is prepended to the line |
||||
# - but for the purposes of overtype we wouldn't want that - so we strip it here in the length calculation and should strip leading backspaces in the actual data concatenation operations too. |
||||
#curiously - a backspace sequence at the end of a string also doesn't reduce the printing width - so we can also strip from RHS |
||||
|
||||
#Note that backspace following a \t will only shorten the string by one (ie it doesn't move back the whole tab width like it does interactively in the terminal) |
||||
#for this reason - it would seem best to normalize the tabs to spaces prior to performing the backspace calculation - otherwise we won't account for the 'short' tabs it effectivley produces |
||||
#normalize tabs to an appropriate* width |
||||
#*todo - handle terminal/context where tabwidth != the default 8 spaces |
||||
set line [textutil::tabify::untabify2 $line] |
||||
|
||||
set bs [format %c 0x08] |
||||
#set line [string map [list "\r${bs}" "\r"] $line] ;#backsp following a \r will have no effect |
||||
set line [string trim $line $bs] |
||||
set n 0 |
||||
set chars [split $line ""] |
||||
#build an output |
||||
set idx 0 |
||||
set out [list] |
||||
foreach c $chars { |
||||
if {$c eq $bs} { |
||||
if {$idx > 0} { |
||||
incr idx -1 |
||||
} |
||||
} elseif {$c eq "\r"} { |
||||
set idx 0 |
||||
} else { |
||||
priv::printing_length_addchar $idx $c |
||||
incr idx |
||||
} |
||||
} |
||||
set line2 [join $out ""] |
||||
return [string length $line2] |
||||
} |
||||
namespace eval overtype::priv { |
||||
proc printing_length_addchar {i c} { |
||||
upvar out o |
||||
set nxt [llength $o] |
||||
if {$i < $nxt} { |
||||
lset o $i $c |
||||
} else { |
||||
lappend o $c |
||||
} |
||||
} |
||||
} |
||||
|
||||
#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} |
||||
} |
||||
foreach {underblock overblock} [lrange $args end-1 end] break |
||||
set defaults [dict create\ |
||||
-ellipsis 0\ |
||||
-ellipsistext $default_ellipsis_horizontal\ |
||||
-overflow 0\ |
||||
-transparent 0\ |
||||
] |
||||
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 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 {printing_length $v}]] |
||||
set overlines [split $overblock \n] |
||||
|
||||
set outputlines [list] |
||||
foreach undertext $underlines overtext $overlines { |
||||
set undertext_printlen [printing_length $undertext] |
||||
set overlen [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 -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 $undertext $overtext] |
||||
} |
||||
} |
||||
return [join $outputlines \n] |
||||
|
||||
} |
||||
|
||||
#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\ |
||||
] |
||||
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 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 {printing_length $v}]] |
||||
set overlines [split $overblock \n] |
||||
|
||||
set outputlines [list] |
||||
foreach undertext $underlines overtext $overlines { |
||||
set olen [printing_length $overtext] |
||||
set ulen [printing_length $undertext] |
||||
if {$ulen < $colwidth} { |
||||
set udiff [expr {$colwidth - $ulen}] |
||||
set undertext "$undertext[string repeat { } $udiff]" |
||||
} |
||||
#review |
||||
append overtext "\033\[0m" |
||||
|
||||
set diff [expr {$colwidth - $olen}] |
||||
if {$diff > 0} { |
||||
#background block is wider |
||||
set half [expr {round(int($diff / 2))}] |
||||
if {[string match right [dict get $opts -bias]]} { |
||||
if {[expr {2 * $half}] < $diff} { |
||||
incr half |
||||
} |
||||
} |
||||
|
||||
set rhs [expr {$diff - $half - 1}] |
||||
set lhs [expr {$half - 1}] |
||||
|
||||
set a [string range $undertext 0 $lhs] |
||||
set rhsoffset [expr {$rhs +1}] |
||||
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 |
||||
} else { |
||||
#overlay wider or equal |
||||
set rendered [renderline -transparent $opt_transparent -overflow [dict get $opts -overflow] $undertext $overtext] |
||||
if {$diff < 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 { |
||||
#widths match |
||||
} |
||||
lappend outputlines $rendered |
||||
#lappend outputlines [renderline -transparent $opt_transparent $undertext $overtext] |
||||
} |
||||
} |
||||
return [join $outputlines \n] |
||||
} |
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- |
||||
#todo - ansi |
||||
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\ |
||||
] |
||||
set newargs [dict merge $defaults $argsflags] |
||||
tailcall overtype::renderline {*}$newargs $under $over |
||||
} |
||||
|
||||
#renderline may not make sense as it is in the long run. 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. |
||||
# |
||||
proc overtype::renderline {args} { |
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-transparent [0|1|<regexp>]? ?-overflow [1|0]? undertext overtext} |
||||
} |
||||
foreach {under over} [lrange $args end-1 end] break |
||||
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\ |
||||
] |
||||
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_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]} |
||||
} |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- |
||||
|
||||
|
||||
if {[string first \t $under] >= 0} { |
||||
set under [textutil::tabify::untabify2 $under] |
||||
} |
||||
if {[string first \t $over] >= 0} { |
||||
set over [textutil::tabify::untabify2 $over] |
||||
} |
||||
|
||||
|
||||
set bs [format %c 0x08] |
||||
set escape_terminals [list J K m n A B C D E F G s u] ;#review - this definitely doesn't cover all |
||||
|
||||
|
||||
#todo - ansi split printables in the undertext - maintaining colorcodes etc |
||||
set out [split $under ""] |
||||
set under_printables [list] |
||||
set in_escapesequence 0 |
||||
#assumption - undertext already 'rendered' - ie no backspaces or carriagereturns or other cursor movement controls |
||||
#this is basically a form of stripansi... review! |
||||
foreach u [split $under ""] { |
||||
if {$in_escapesequence} { |
||||
if {$u in $escape_terminals} { |
||||
set in_escapesequence 0 |
||||
} |
||||
} else { |
||||
if {$u eq "\033"} { |
||||
set in_escapesequence 1 |
||||
} else { |
||||
lappend under_printables $u |
||||
} |
||||
} |
||||
} |
||||
set original_under_printlen [printing_length $under] |
||||
|
||||
set original_under_printlen2 [llength $under_printables] |
||||
if {$original_under_printlen != $original_under_printlen2} { |
||||
puts stderr "overtype::renderline WARNING - differing printable length calculations for under text: $under" |
||||
puts stderr "printing_length: $original_under_printlen" |
||||
puts stderr "llength under_printables: $original_under_printlen2" |
||||
} |
||||
#assert - same as llength $under_printables ? |
||||
|
||||
|
||||
|
||||
|
||||
set i 0 |
||||
set in_escapesequence 0 |
||||
#we still want to copy over escape sequences - but we need to keep track of printables |
||||
set i_printable 0 |
||||
foreach o [split $over ""] { |
||||
if {$in_escapesequence} { |
||||
if {$o in $escape_terminals} { |
||||
set in_escapesequence 0 |
||||
} |
||||
#pass through to output but not printables |
||||
priv::renderline_insertchar $i $o |
||||
incr i |
||||
} else { |
||||
if {$o eq "\033"} { |
||||
set in_escapesequence 1 |
||||
priv::renderline_insertchar $i $o |
||||
incr i |
||||
} elseif {$o eq "\r"} { |
||||
set i 0 |
||||
set i_printable 0 |
||||
} elseif {$o eq $bs} { |
||||
if {$i > 0} { |
||||
#review - we potentially need to backspace beyond ansi code! |
||||
incr i -1 |
||||
} |
||||
if {$i_printable > 0} { |
||||
incr i_printable -1 |
||||
} |
||||
} elseif {$do_transparency && [regexp $opt_transparent $o]} { |
||||
if {$i > [llength $out]-1} { |
||||
lappend out " " |
||||
} |
||||
incr i |
||||
if {$i_printable > [llength $under_printables]-1} { |
||||
lappend under_printables " " |
||||
} |
||||
incr i_printable |
||||
} else { |
||||
priv::renderline_addchar $i $o |
||||
priv::renderline_addprintable $i_printable $o |
||||
if {!$opt_overflow} { |
||||
if {$i_printable == $original_under_printlen} { |
||||
#we have reached our cutoff length - but there could be a closing ansi code or other control characters that would change the already-processed output. |
||||
#also - trailing ansi escapes should remain to affect subsequent lines - we really just want to suppress the printables from this point on and possibly trim some corresponding codes. |
||||
#(e.g color codes that are opened and closed around trimmed printables) |
||||
#todo - something!! |
||||
break |
||||
} |
||||
} |
||||
incr i |
||||
incr i_printable |
||||
} |
||||
} |
||||
} |
||||
return [join $out ""] |
||||
} |
||||
|
||||
namespace eval overtype::priv { |
||||
proc renderline_addchar {i c} { |
||||
upvar out o |
||||
set nxt [llength $o] |
||||
if {$i < $nxt} { |
||||
lset o $i $c |
||||
} else { |
||||
lappend o $c |
||||
} |
||||
} |
||||
proc renderline_insertchar {i c} { |
||||
upvar out o |
||||
set nxt [llength $o] |
||||
if {$i < $nxt} { |
||||
set o [linsert $o $i $c] |
||||
} else { |
||||
lappend o $c |
||||
} |
||||
} |
||||
proc renderline_addprintable {i c} { |
||||
upvar under_printables printables |
||||
set nxt [llength $printables] |
||||
if {$i < $nxt} { |
||||
lset printables $i $c |
||||
} else { |
||||
lappend printables $c |
||||
} |
||||
} |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- |
||||
|
||||
proc overtype::centre_prev {args} { |
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} |
||||
} |
||||
foreach {undertext overtext} [lrange $args end-1 end] break |
||||
|
||||
set opt(-bias) left |
||||
set opt(-overflow) 0 |
||||
array set opt [lrange $args 0 end-2] |
||||
|
||||
|
||||
set olen [printing_length $overtext] |
||||
set ulen [printing_length $undertext] |
||||
set diff [expr {$ulen - $olen}] |
||||
if {$diff > 0} { |
||||
set half [expr {round(int($diff / 2))}] |
||||
if {[string match right $opt(-bias)]} { |
||||
if {[expr {2 * $half}] < $diff} { |
||||
incr half |
||||
} |
||||
} |
||||
|
||||
set rhs [expr {$diff - $half - 1}] |
||||
set lhs [expr {$half - 1}] |
||||
|
||||
set a [string range $undertext 0 $lhs] |
||||
set b $overtext |
||||
set c [string range $undertext end-$rhs end] |
||||
return $a$b$c |
||||
} else { |
||||
if {$diff < 0} { |
||||
if {$opt(-overflow)} { |
||||
return $overtext |
||||
} else { |
||||
return [string range $overtext 0 [expr {$ulen - 1}]] |
||||
} |
||||
} else { |
||||
return $overtext |
||||
} |
||||
} |
||||
} |
||||
proc overtype::right {args} { |
||||
# @d !todo - implement overflow, length checks etc |
||||
|
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-overflow [1|0]? undertext overtext} |
||||
} |
||||
foreach {undertext overtext} [lrange $args end-1 end] break |
||||
|
||||
set opt(-overflow) 0 |
||||
array set opt [lrange $args 0 end-2] |
||||
|
||||
|
||||
set olen [printing_length $overtext] |
||||
set ulen [printing_length $undertext] |
||||
|
||||
if {$opt(-overflow)} { |
||||
return [string range $undertext 0 end-$olen]$overtext |
||||
} else { |
||||
if {$olen > $ulen} { |
||||
set diff [expr {$olen - $ulen}] |
||||
return [string range $undertext 0 end-$olen][string range $overtext 0 end-$diff] |
||||
} else { |
||||
return [string range $undertext 0 end-$olen]$overtext |
||||
} |
||||
} |
||||
} |
||||
|
||||
namespace eval overtype { |
||||
interp alias {} ::overtype::center {} ::overtype::centre |
||||
} |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide overtype [namespace eval overtype { |
||||
variable version |
||||
set version 1.5.0 |
||||
}] |
||||
return |
||||
Loading…
Reference in new issue