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::base |
||||||
package require punk::mix::cli |
package require punk::mix::cli |
||||||
|
|
||||||
|
namespace eval punk::mix { |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
package provide punk::mix [namespace eval punk::mix { |
package provide punk::mix [namespace eval punk::mix { |
||||||
variable version |
variable version |
||||||
set version 0.2 |
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