33 changed files with 1649 additions and 309 deletions
@ -0,0 +1,573 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.4.tm |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2025 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::ansi::sauce 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license MIT |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
package require Tcl 8.6- |
||||
|
||||
|
||||
|
||||
tcl::namespace::eval punk::ansi::sauce { |
||||
variable PUNKARGS |
||||
namespace eval argdoc { |
||||
variable PUNKARGS |
||||
#non-colour SGR codes |
||||
set I "\x1b\[3m" ;# [a+ italic] |
||||
set NI "\x1b\[23m" ;# [a+ noitalic] |
||||
set B "\x1b\[1m" ;# [a+ bold] |
||||
set N "\x1b\[22m" ;# [a+ normal] |
||||
set T "\x1b\[1\;4m" ;# [a+ bold underline] |
||||
set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline] |
||||
} |
||||
|
||||
proc from_file {fname} { |
||||
if {[file size $fname] < 128} { |
||||
return |
||||
} |
||||
set fd [open $fname r] |
||||
chan conf $fd -translation binary |
||||
chan seek $fd -128 end |
||||
set srec [read $fd] |
||||
set srec_len 128 ;#This is the normal length of a SAUCE record - we may need to set it shorter if truncation detected |
||||
if {[catch {set sdict [to_dict $srec]}]} { |
||||
#review - have seen truncated SAUCE records < 128 bytes |
||||
#we could search for SAUCE00 in the tail and see what records can be parsed? |
||||
#specifically publicdomain roysac images sometimes only 99 Bytes of sauce - suspect remaining were null \x0 padded and trimmed |
||||
set sauceposn [string first SAUCE00 $srec] |
||||
if {$sauceposn <= 0} { |
||||
close $fd |
||||
return |
||||
} |
||||
#emit something to give user an indication something isn't right |
||||
puts stderr "punk::ansi::sauce::from_file WARNING SAUCE record seems to be truncated - padding rhs with nulls and trying again.." |
||||
#SAUCE00 is not at the beginning |
||||
#pad the tail with nulls and try again |
||||
set srec [string range $srec $sauceposn end] |
||||
set srec_len [string length $srec] |
||||
set srec ${srec}[string repeat \x0 [expr {128 - [string length $srec]}]] |
||||
if {[catch {set sdict [to_dict $srec]}]} { |
||||
close $fd |
||||
return |
||||
} |
||||
dict set sdict warning "SAUCE truncation to $srec_len bytes detected" |
||||
} |
||||
if {[dict exists $sdict comments] && [dict get $sdict comments] > 0} { |
||||
set clines [dict get $sdict comments] |
||||
#Use srec_len instead of 128 - in case we had truncated source record which we padded and were able to parse |
||||
set offset [expr {-1 *($srec_len + ($clines * 64) + 5)}] |
||||
chan seek $fd $offset end |
||||
set tag [chan read $fd 5] |
||||
if {$tag eq "COMNT"} { |
||||
#'character' data - shouldn't be null terminated c-style string - but can be |
||||
set commentlines [list] |
||||
for {set c 0} {$c < $clines} {incr c} { |
||||
set rawline [chan read $fd 64] |
||||
if {![catch {binary scan $rawline C* str} errM]} { |
||||
set ln [format %-64s $str] |
||||
} else { |
||||
set ln [string repeat " " 64] |
||||
} |
||||
if {![catch {encoding convertfrom cp437 $ln} line]} { |
||||
lappend commentlines $line |
||||
} else { |
||||
catch { |
||||
package require punk::ansi |
||||
puts stderr "punk::ansi::sauce::from_file failed to decode (from cp437) comment line:[punk::ansi::ansistring VIEW $ln]" |
||||
} |
||||
lappend commentlines [string repeat " " 64] |
||||
} |
||||
} |
||||
dict set sdict commentlines $commentlines |
||||
} |
||||
} |
||||
close $fd |
||||
return $sdict |
||||
} |
||||
|
||||
set datatypes [dict create] |
||||
dict set datatypes 0 none |
||||
dict set datatypes 1 character |
||||
dict set datatypes 2 bitmap |
||||
dict set datatypes 3 vector |
||||
dict set datatypes 4 audio |
||||
dict set datatypes 5 binarytext |
||||
dict set datatypes 6 xbin |
||||
dict set datatypes 7 archive |
||||
dict set datatypes 8 executable |
||||
|
||||
set filetypes [dict create] |
||||
|
||||
#Character |
||||
dict set filetypes 1 0 [list name "ASCII" description "Plain ASCII text file with no formatting codes or color codes."] |
||||
dict set filetypes 1 1 [list name "ANSi" description "A file with ANSi coloring codes and cursor positioning."] |
||||
dict set filetypes 1 2 [list name "ANSiMation" description "Like an ANSi file, but it relies on a fixed screensize."] |
||||
dict set filetypes 1 3 [list name "RIP script" description "Remote Imaging Protocol Graphics."] |
||||
dict set filetypes 1 4 [list name "PCBoard" description "A file with PCBoard color codes and macros, and ANSi codes."] |
||||
dict set filetypes 1 5 [list name "Avatar" description "A file with Avatar color codes, and ANSi codes."] |
||||
dict set filetypes 1 6 [list name "HTML" description "HyperText Markup Language."] |
||||
dict set filetypes 1 7 [list name "Source" description "Source code for some programming language.\nThe file extension should determine the programming language."] |
||||
dict set filetypes 1 8 [list name "TundraDraw" description "A TundraDraw file.\nLike ANSi, but with a custom palette."] |
||||
|
||||
#Bitmap |
||||
dict set filetypes 2 0 [list name "GIF" description "CompuServe Graphics Interchange Format"] |
||||
dict set filetypes 2 1 [list name "PCX" description "ZSoft Paintbrush PCX"] |
||||
dict set filetypes 2 2 [list name "LBM/IFF" description "DeluxePaint LBM/IFF"] |
||||
dict set filetypes 2 3 [list name "TGA" description "Targa Truecolor"] |
||||
dict set filetypes 2 4 [list name "FLI" description "Autodesk FLI animation"] |
||||
dict set filetypes 2 5 [list name "FLC" description "Autodesk FLC animation"] |
||||
dict set filetypes 2 6 [list name "BMP" description "Windows or OS/2 Bitmap"] |
||||
dict set filetypes 2 7 [list name "GL" description "Grasp GL Animation"] |
||||
dict set filetypes 2 8 [list name "DL" description "DL Animation"] |
||||
dict set filetypes 2 9 [list name "WPG" description "Wordperfect Bitmap"] |
||||
dict set filetypes 2 10 [list name "PNG" description "Portable Network Graphics"] |
||||
dict set filetypes 2 11 [list name "JPG/JPeg" description "JPeg image (any subformat)"] |
||||
dict set filetypes 2 12 [list name "MPG" description "MPeg video (any subformat)"] |
||||
dict set filetypes 2 12 [list name "AVI" description "Audio Video Interleave (any subformat)"] |
||||
|
||||
#vector |
||||
dict set filetypes 3 0 [list name "DXF" description "CAD Drawing eXchange Format"] |
||||
dict set filetypes 3 1 [list name "DWG" description "AutoCAD Drawing File"] |
||||
dict set filetypes 3 2 [list name "WPG" description "WordPerfect or DrawPerfect vector graphics"] |
||||
dict set filetypes 3 3 [list name "3DS" description "3D Studio"] |
||||
|
||||
#Audio |
||||
dict set filetypes 4 0 [list name "MOD" description "4, 6 or 8 channel MOD (Noise Tracker)"] |
||||
dict set filetypes 4 1 [list name "669" description "Renaissance 8 channel 669"] |
||||
dict set filetypes 4 2 [list name "STM" description "Future Crew 4 channel ScreamTracker"] |
||||
dict set filetypes 4 3 [list name "S3M" description "Future Crew variable channel ScreamTracker 3"] |
||||
dict set filetypes 4 4 [list name "MTM" description "Renaissance variable channel MultiTracker"] |
||||
dict set filetypes 4 5 [list name "FAR" description "Farandole composer"] |
||||
dict set filetypes 4 6 [list name "ULT" description "UltraTracker"] |
||||
dict set filetypes 4 7 [list name "AMF" description "DMP/DSMI Advanced Module Format"] |
||||
dict set filetypes 4 8 [list name "DMF" description "Delusion Digital Music Format (XTracker)"] |
||||
dict set filetypes 4 9 [list name "OKT" description "Oktalyser"] |
||||
dict set filetypes 4 10 [list name "ROL" description "AdLib ROL file (FM audio)"] |
||||
dict set filetypes 4 11 [list name "CMF" description "Creative Music File (FM Audio)"] |
||||
dict set filetypes 4 12 [list name "MID" description "MIDI (Musical Instrument Digital Interface)"] |
||||
dict set filetypes 4 13 [list name "SADT" description "SAdT composer (FM Audio)"] |
||||
dict set filetypes 4 14 [list name "VOC" description "Creative Voice File"] |
||||
dict set filetypes 4 15 [list name "WAV" description "Waveform Audio File Format"] |
||||
dict set filetypes 4 16 [list name "SMP8" description "Raw, single channel 8 bit sample"] |
||||
dict set filetypes 4 17 [list name "SMP8S" description "Raw, stereo 8 bit sample"] |
||||
dict set filetypes 4 18 [list name "SMP16" description "Raw, single channel 16 bit sample"] |
||||
dict set filetypes 4 19 [list name "SMP16S" description "Raw, stereo 16 bit sample"] |
||||
dict set filetypes 4 20 [list name "PATCH8" description "8 Bit patch file"] |
||||
dict set filetypes 4 21 [list name "PATCH16" description "16 Bit patch file"] |
||||
dict set filetypes 4 22 [list name "XM" description "FastTracker \]\[ module"] |
||||
dict set filetypes 4 23 [list name "HSC" description "HSC Tracker (FM Audio)"] |
||||
dict set filetypes 4 24 [list name "IT" description "Impulse Tracker"] |
||||
|
||||
#Archive |
||||
dict set filetypes 7 0 [list name "ZIP" description "PKWare Zip"] |
||||
dict set filetypes 7 1 [list name "ARJ" description "Archive Robert K. Jung"] |
||||
dict set filetypes 7 2 [list name "LZH" description "Haruyasu Yoshizaki (Yoshi)"] |
||||
dict set filetypes 7 3 [list name "ARC" description "S.E.A"] |
||||
dict set filetypes 7 4 [list name "TAR" description "Unix TAR"] |
||||
dict set filetypes 7 5 [list name "ZOO" description "ZOO"] |
||||
dict set filetypes 7 6 [list name "RAR" description "RAR"] |
||||
dict set filetypes 7 7 [list name "UC2" description "UC2"] |
||||
dict set filetypes 7 8 [list name "PAK" description "PAK"] |
||||
dict set filetypes 7 9 [list name "SQZ" description "SQZ"] |
||||
|
||||
|
||||
#review |
||||
#map sauce encodings to those that exist by default in Tcl 'encoding names' |
||||
set encodings [dict create] |
||||
dict set encodings 437 cp437 |
||||
dict set encodings 720 cp1256 ;#Arabic |
||||
dict set encodings 737 cp737 |
||||
dict set encodings 775 cp775 |
||||
dict set encodings 819 iso8859-1 ;#Latin-1 Supplemental - review |
||||
dict set encodings 850 cp850 |
||||
dict set encodings 852 cp852 |
||||
dict set encodings 855 cp855 |
||||
dict set encodings 857 cp857 |
||||
#dict set encodings 858 "" ;#??? |
||||
dict set encodings 860 cp860 ;#Porguguese |
||||
dict set encodings 861 cp861 ;#Icelandic |
||||
dict set encodings 862 cp862 ;#Hebrew |
||||
dict set encodings 863 cp863 ;#French Canada |
||||
dict set encodings 864 cp864 |
||||
dict set encodings 865 cp865 |
||||
dict set encodings 866 cp866 ;#Cyrillic |
||||
dict set encodings 869 cp869 |
||||
#dict set encodings 872 "" ;#Cyrillic - cp855? macCyrillic? |
||||
#dict set encodings KAM "" ;#cp867,cp895 ? |
||||
#dict set encodings MAZ "" ;#cp667 cp790 ? |
||||
dict set encodings MIK cp866 ;#Cyrillic |
||||
|
||||
|
||||
|
||||
|
||||
#todo - fontName - which can also specify e.g code page 437 |
||||
## Font name [1] Font size Resolution [2] Aspect ratio [3] Vertical stretch [6] Description |
||||
## Display [4] Pixel [5] |
||||
|
||||
set fontnames [dict create] |
||||
|
||||
## IBM VGA 9×16 [7] 720×400 4:3 20:27 (1:1.35) 35% Standard hardware font on VGA cards for 80×25 text mode (code page 437) |
||||
dict set fontnames "IBM VGA" [list fontsize "9x16" resolution "720x400" aspect_ratio_display "4:3" aspect_ratio_pixel "20:27 (1:1.35)" vertical_stretch "35%" description "Standard hardware font on VGA cards for 80×25 text mode (code page 437)"] |
||||
## IBM VGA ### [8] 9×16 [7] 720×400 4:3 20:27 (1:1.35) 35% Software installed code page font for VGA 80×25 text mode |
||||
# - where ### is placeholder for 437,720,737 etc |
||||
|
||||
## IBM VGA50 ### [8] 9×8 [7] 720×400 4:3 20:27 (1:1.35) 35% Software installed code page font for VGA condensed 80×50 text mode |
||||
## IBM VGA25G ### [8] 8×19 640×480 4:3 1:1 0% Custom font for emulating 80×25 in VGA graphics mode 12 (640×480 16 color). |
||||
|
||||
## 8×16 640×400 4:3 6:5 (1:1.2) 20% Modified stats when using an 8 pixel wide version of "IBM VGA" or code page variant. |
||||
## IBM VGA50 9×8 [7] 720×400 4:3 20:27 (1:1.35) 35% Standard hardware font on VGA cards for condensed 80×50 text mode (code page 437) |
||||
## 8×8 640×400 4:3 5:6 (1:1.2) 20% Modified stats when using an 8 pixel wide version of "IBM VGA50" or code page variant. |
||||
## IBM VGA25G 8×19 640×480 4:3 1:1 0% Custom font for emulating 80×25 in VGA graphics mode 12 (640×480 16 color) (code page 437). |
||||
## IBM EGA 8×14 640×350 4:3 35:48 (1:1.3714) 37.14% Standard hardware font on EGA cards for 80×25 text mode (code page 437) |
||||
## IBM EGA43 8×8 640×350 4:3 35:48 (1:1.3714) 37.14% Standard hardware font on EGA cards for condensed 80×43 text mode (code page 437) |
||||
## IBM EGA ### [8] 8×14 640×350 4:3 35:48 (1:1.3714) 37.14% Software installed code page font for EGA 80×25 text mode |
||||
## IBM EGA43 ### [8] 8×8 640×350 4:3 35:48 (1:1.3714) 37.14% Software installed code page font for EGA condensed 80×43 text mode |
||||
## Amiga Topaz 1 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Original Amiga Topaz Kickstart 1.x font. (A500, A1000, A2000) |
||||
## Amiga Topaz 1+ 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Modified Amiga Topaz Kickstart 1.x font. (A500, A1000, A2000) |
||||
## Amiga Topaz 2 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Original Amiga Topaz Kickstart 2.x font (A600, A1200, A4000) |
||||
## Amiga Topaz 2+ 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Modified Amiga Topaz Kickstart 2.x font (A600, A1200, A4000) |
||||
## Amiga P0T-NOoDLE 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Original P0T-NOoDLE font. |
||||
## Amiga MicroKnight 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Original MicroKnight font. |
||||
## Amiga MicroKnight+ 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Modified MicroKnight font. |
||||
## Amiga mOsOul 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Original mOsOul font. |
||||
## C64 PETSCII unshifted 8×8 [10] 320×200 4:3 5:6 (1:1.2) 20% Original Commodore PETSCII font (PET, VIC-20, C64, CBM-II, Plus/4, C16, C116 and C128) in the unshifted mode. Unshifted mode (graphics) only has uppercase letters and additional graphic characters. This is the normal boot font. |
||||
## C64 PETSCII shifted 8×8 [10] 320×200 4:3 5:6 (1:1.2) 20% Original PETSCII font in shifted mode. Shifted mode (text) has both uppercase and lowercase letters. This mode is actuated by pressing Shift+Commodore key. |
||||
## Atari ATASCII 8×8 [11] 320×192 4:3 4:5 (1:1.25) 25% Original ATASCII font (Atari 400, 800, XL, XE) |
||||
|
||||
|
||||
#expect a 128 Byte sauce record |
||||
#Some sauce records may have been padded with null bytes - and been truncated by some process |
||||
|
||||
proc to_dict {saucerecord} { |
||||
variable datatypes |
||||
variable filetypes |
||||
variable encodings |
||||
if {[string length $saucerecord] != 128} { |
||||
error "punk::ansi::sauce::to_dict: Unable to interpret data as a SAUCE record - length != 128" |
||||
} |
||||
if {![string match "SAUCE*" $saucerecord]} { |
||||
error "punk::ansi::sauce::to_dict: Unable to interpret data as a SAUCE record - does not begin with 'SAUCE'" |
||||
} |
||||
#tcl binary scan: cu - unsigned 8-bit, su - unsigned 16-bit, iu - unsigned 32bit, |
||||
set sdict [dict create] |
||||
dict set sdict version [string range $saucerecord 5 6] ;#2bytes |
||||
|
||||
#sauce spec says 'character' type is a string encoded according to code page 437 (IBM PC / OEM ASCII) |
||||
# - in the wild - string may be terminated with null and have following garbage |
||||
# - 'binary scan $rawchars C* str' to get null-terminated string and pad rhs with spaces to cater for this possibility |
||||
|
||||
#dict set sdict title [string range $saucerecord 7 41] ;#35 bytes 'character' |
||||
set rawtitle [string range $saucerecord 7 41] ;#35 bytes 'character' |
||||
if {![catch {binary scan $rawtitle C* str} errM]} { |
||||
dict set sdict title [format %-35s $str] |
||||
} else { |
||||
dict set sdict title [string repeat " " 35] |
||||
} |
||||
|
||||
#dict set sdict author [string range $saucerecord 42 61] ;#20 bytes 'character' |
||||
set rawauthor [string range $saucerecord 42 61] ;#20 bytes 'character' |
||||
if {![catch {binary scan $rawauthor C* str} errM]} { |
||||
dict set sdict author [format %-20s $str] |
||||
} else { |
||||
dict set sdict author [string repeat " " 20] |
||||
} |
||||
|
||||
#dict set sdict group [string range $saucerecord 62 81] ;#20 bytes 'character' |
||||
set rawgroup [string range $saucerecord 62 81] ;#20 bytes 'character' |
||||
if {![catch {binary scan $rawgroup C* str} errM]} { |
||||
dict set sdict group [format %-20s $str] |
||||
} else { |
||||
dict set sdict group [string repeat " " 20] |
||||
} |
||||
|
||||
|
||||
|
||||
#dict set sdict date [string range $saucerecord 82 89] ;#8 bytes 'character' |
||||
set rawdata [string range $saucerecord 82 89] ;#8 bytes 'character' |
||||
if {![catch {binary scan $rawdate C* str} errM]} { |
||||
dict set sdict date [format %-8s $str] |
||||
} else { |
||||
dict set sdict date [string repeat " " 8] |
||||
} |
||||
|
||||
if {[binary scan [string range $saucerecord 90 93] iu v]} { |
||||
#4 bytes - unsigned littlendian |
||||
dict set sdict filesize $v |
||||
} else { |
||||
dict set sdict filesize "" |
||||
} |
||||
if {[binary scan [string range $saucerecord 94 94] cu v]} { |
||||
#1 byte - unsigned |
||||
dict set sdict datatype $v |
||||
if {[dict exists $datatypes [dict get $sdict datatype]]} { |
||||
dict set sdict datatype_name [dict get $datatypes [dict get $sdict datatype]] |
||||
} else { |
||||
dict set sdict datatype_name unrecognised |
||||
} |
||||
} else { |
||||
dict set sdict datatype "" |
||||
dict set sdict datatype_name failed ;#unrecognised?? |
||||
} |
||||
if {[binary scan [string range $saucerecord 95 95] cu v]} { |
||||
#1 byte - unsigned |
||||
dict set sdict filetype $v |
||||
if {[dict exists $filetypes [dict get $sdict datatype] $v]} { |
||||
dict set sdict filetype_name [dict get $filetypes [dict get $sdict datatype] $v name] |
||||
} else { |
||||
dict set sdict filetype_name "" |
||||
} |
||||
} else { |
||||
dict set sdict filetype "" |
||||
dict set sdict filetype_name "" |
||||
} |
||||
if {[binary scan [string range $saucerecord 96 97] su v]} { |
||||
dict set sdict tinfo1 $v |
||||
} else { |
||||
dict set sdict tinfo1 "" |
||||
} |
||||
|
||||
if {[binary scan [string range $saucerecord 98 99] su v]} { |
||||
dict set sdict tinfo2 $v |
||||
} else { |
||||
dict set sdict tinfo2 "" |
||||
} |
||||
|
||||
|
||||
if {[binary scan [string range $saucerecord 100 101] su v]} { |
||||
dict set sdict tinfo3 $v |
||||
} else { |
||||
dict set sdict tinfo3 "" |
||||
} |
||||
if {[binary scan [string range $saucerecord 102 103] su v]} { |
||||
dict set sdict tinfo4 $v |
||||
} else { |
||||
dict set sdict tinfo4 "" |
||||
} |
||||
if {[binary scan [string range $saucerecord 104 104] cu v]} { |
||||
#1 byte - unsigned |
||||
dict set sdict comments $v |
||||
} else { |
||||
dict set sdict comments 0 |
||||
} |
||||
if {[binary scan [string range $saucerecord 105 105] cu v]} { |
||||
dict set sdict tflags $v |
||||
} else { |
||||
dict set sdict tflags "" |
||||
} |
||||
set rawzstring [string range $saucerecord 106 127] |
||||
#Null terminated string use C to terminate at first null |
||||
if {[binary scan $rawzstring C* str]} { |
||||
dict set sdict tinfos $str |
||||
} else { |
||||
dict set sdict tinfos "" |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
switch -- [string tolower [dict get $sdict filetype_name]] { |
||||
ansi - ascii - pcboard - avatar { |
||||
dict set sdict columns [dict get $sdict tinfo1] |
||||
dict set sdict rows [dict get $sdict tinfo2] |
||||
dict set sdict fontname [dict get $sdict tinfos] |
||||
} |
||||
ansimation { |
||||
dict set sdict columns [dict get $sdict tinfo1] |
||||
#review - fixed screen height? |
||||
dict set sdict rows [dict get $sdict tinfo2] |
||||
dict set sdict fontname [dict get $sdict tinfos] |
||||
} |
||||
} |
||||
switch -- [dict get $sdict datatype] { |
||||
5 { |
||||
#binarytext |
||||
#filetype represents half the characterwidth (only widths with multiples of 2 can be specified) |
||||
set cols [expr {2*[dict get $sdict filetype]}] |
||||
dict set sdict columns $cols |
||||
#rows must be calculated from file size |
||||
#rows = (filesize - sauceinfosize)/ filetype * 2 * 2 |
||||
#(time additional 2 due to character/attribute pairs) |
||||
|
||||
#todo - calc filesize from total size of file - EOF - comment - sauce rather than rely on stored filesize? |
||||
dict set sdict rows [expr {[dict get $sdict filesize]/($cols * 2)}] |
||||
|
||||
} |
||||
6 { |
||||
#xbin - only filtype is 0 |
||||
#https://web.archive.org/web/20120204063040/http://www.acid.org/info/xbin/x_spec.htm |
||||
dict set sdict columns [dict get $sdict tinfo1] |
||||
dict set sdict rows [dict get $sdict tinfo2] |
||||
dict set sdict fontname [dict get $sdict tinfos] |
||||
} |
||||
} |
||||
if {[dict exists $sdict fontname]} { |
||||
set fname [dict get $sdict fontname] |
||||
#IBM VGA and IBM EGA variants are all cp437 - unless a 3 letter code specifying otherwise follows |
||||
switch -- [string range $fname 0 6] { |
||||
"IBM EGA" - "IBM VGA" { |
||||
lassign $fname _ibm _ code |
||||
set cp "" |
||||
if {$code eq ""} { |
||||
set cp "cp437" |
||||
} else { |
||||
if {[dict exists $encodings $code]} { |
||||
set cp [dict get $encodings $code] |
||||
} |
||||
} |
||||
if {$cp ne ""} { |
||||
dict set sdict codepage $cp |
||||
} |
||||
} |
||||
} |
||||
} |
||||
return $sdict |
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::ansi::sauce::lib { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
#tcl::namespace::eval punk::ansi::sauce::system { |
||||
#} |
||||
|
||||
|
||||
# == === === === === === === === === === === === === === === |
||||
# Sample 'about' function with punk::args documentation |
||||
# == === === === === === === === === === === === === === === |
||||
tcl::namespace::eval punk::ansi::sauce { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
variable PUNKARGS |
||||
variable PUNKARGS_aliases |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)punk::ansi::sauce" |
||||
@package -name "punk::ansi::sauce" -help\ |
||||
"Basic support for SAUCE format |
||||
Standard Architecture for Universal Comment Extensions |
||||
https://www.acid.org/info/sauce/sauce.htm " |
||||
}] |
||||
|
||||
namespace eval argdoc { |
||||
#namespace for custom argument documentation |
||||
proc package_name {} { |
||||
return punk::ansi::sauce |
||||
} |
||||
proc about_topics {} { |
||||
#info commands results are returned in an arbitrary order (like array keys) |
||||
set topic_funs [info commands [namespace current]::get_topic_*] |
||||
set about_topics [list] |
||||
foreach f $topic_funs { |
||||
set tail [namespace tail $f] |
||||
lappend about_topics [string range $tail [string length get_topic_] end] |
||||
} |
||||
#Adjust this function or 'default_topics' if a different order is required |
||||
return [lsort $about_topics] |
||||
} |
||||
proc default_topics {} {return [list Description *]} |
||||
|
||||
# ------------------------------------------------------------- |
||||
# get_topic_ functions add more to auto-include in about topics |
||||
# ------------------------------------------------------------- |
||||
proc get_topic_Description {} { |
||||
punk::args::lib::tstr [string trim { |
||||
package punk::ansi::sauce |
||||
ANSI SAUCE block processor |
||||
} \n] |
||||
} |
||||
proc get_topic_License {} { |
||||
return "MIT" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return "$::punk::ansi::sauce::version" |
||||
} |
||||
proc get_topic_Contributors {} { |
||||
set authors {{"Julian Noble" <julian@precisium.com.au>}} |
||||
set contributors "" |
||||
foreach a $authors { |
||||
append contributors $a \n |
||||
} |
||||
if {[string index $contributors end] eq "\n"} { |
||||
set contributors [string range $contributors 0 end-1] |
||||
} |
||||
return $contributors |
||||
} |
||||
proc get_topic_custom-topic {} { |
||||
punk::args::lib::tstr -return string { |
||||
A custom |
||||
topic |
||||
etc |
||||
} |
||||
} |
||||
# ------------------------------------------------------------- |
||||
} |
||||
|
||||
# we re-use the argument definition from punk::args::standard_about and override some items |
||||
set overrides [dict create] |
||||
dict set overrides @id -id "::punk::ansi::sauce::about" |
||||
dict set overrides @cmd -name "punk::ansi::sauce::about" |
||||
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||
About punk::ansi::sauce |
||||
}] \n] |
||||
dict set overrides topic -choices [list {*}[punk::ansi::sauce::argdoc::about_topics] *] |
||||
dict set overrides topic -choicerestricted 1 |
||||
dict set overrides topic -default [punk::ansi::sauce::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict |
||||
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||
lappend PUNKARGS [list $newdef] |
||||
proc about {args} { |
||||
package require punk::args |
||||
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on |
||||
set argd [punk::args::parse $args withid ::punk::ansi::sauce::about] |
||||
lassign [dict values $argd] _leaders opts values _received |
||||
punk::args::package::standard_about -package_about_namespace ::punk::ansi::sauce::argdoc {*}$opts {*}[dict get $values topic] |
||||
} |
||||
} |
||||
# end of sample 'about' function |
||||
# == === === === === === === === === === === === === === === |
||||
|
||||
|
||||
# ----------------------------------------------------------------------------- |
||||
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
||||
# ----------------------------------------------------------------------------- |
||||
# variable PUNKARGS |
||||
# variable PUNKARGS_aliases |
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::punk::ansi::sauce |
||||
} |
||||
# ----------------------------------------------------------------------------- |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::ansi::sauce [tcl::namespace::eval punk::ansi::sauce { |
||||
variable pkg punk::ansi::sauce |
||||
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,302 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.4.tm |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2025 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::nav::ns 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license MIT |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
package require Tcl 8.6- |
||||
|
||||
|
||||
|
||||
tcl::namespace::eval punk::nav::ns { |
||||
variable PUNKARGS |
||||
variable ns_current |
||||
#allow presetting |
||||
if {![info exists ::punk::nav::ns::ns_current]} { |
||||
set ns_current :: |
||||
} |
||||
namespace path {::punk::ns} |
||||
|
||||
proc ns/ {v {ns_or_glob ""} args} { |
||||
variable ns_current ;#change active ns of repl by setting ns_current |
||||
|
||||
set ns_caller [uplevel 1 {::tcl::namespace::current}] |
||||
#puts stderr "ns_cur:$ns_current ns_call:$ns_caller" |
||||
|
||||
|
||||
set types [list all] |
||||
set nspathcommands 0 |
||||
if {$v eq "/"} { |
||||
set types [list children] |
||||
} |
||||
if {$v eq "///"} { |
||||
set nspathcommands 1 |
||||
} |
||||
|
||||
set ns_or_glob [string map {:::: ::} $ns_or_glob] |
||||
|
||||
#todo - cooperate with repl? |
||||
set out "" |
||||
if {$ns_or_glob eq ""} { |
||||
set is_absolute 1 |
||||
set ns_queried $ns_current |
||||
set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $ns_current *]] |
||||
} else { |
||||
set is_absolute [string match ::* $ns_or_glob] |
||||
set has_globchars [regexp {[*?]} $ns_or_glob] ;#basic globs only? |
||||
if {$is_absolute} { |
||||
if {!$has_globchars} { |
||||
if {![nsexists $ns_or_glob]} { |
||||
error "cannot change to namespace $ns_or_glob" |
||||
} |
||||
set ns_current $ns_or_glob |
||||
set ns_queried $ns_current |
||||
tailcall ns/ $v "" |
||||
} else { |
||||
set ns_queried $ns_or_glob |
||||
set out [nslist -types $types -nspathcommands $nspathcommands $ns_or_glob] |
||||
} |
||||
} else { |
||||
if {!$has_globchars} { |
||||
set nsnext [nsjoin $ns_current $ns_or_glob] |
||||
if {![nsexists $nsnext]} { |
||||
error "cannot change to namespace $ns_or_glob" |
||||
} |
||||
set ns_current $nsnext |
||||
set ns_queried $nsnext |
||||
set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $nsnext *]] |
||||
} else { |
||||
set ns_queried [nsjoin $ns_current $ns_or_glob] |
||||
set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $ns_current $ns_or_glob]] |
||||
} |
||||
} |
||||
} |
||||
set ns_display "\n$ns_queried" |
||||
if {$ns_current eq $ns_queried} { |
||||
if {$ns_current in [info commands $ns_current] } { |
||||
if {![catch [list tcl::namespace::ensemble configure $ns_current] ensemble_info]} { |
||||
if {[llength $ensemble_info] > 0} { |
||||
#this namespace happens to match ensemble command. |
||||
#todo - keep cache of encountered ensembles from commands.. and examine namespace in the configure info. |
||||
set ns_display "\n[a+ yellow bold]$ns_current (ensemble)[a+]" |
||||
} |
||||
} |
||||
} |
||||
} |
||||
append out $ns_display |
||||
return $out |
||||
} |
||||
|
||||
#create possibly nested namespace structure - but only if not already existant |
||||
proc n/new {args} { |
||||
variable ns_current |
||||
if {![llength $args]} { |
||||
error "usage: :/new <ns> \[<ns> ...\]" |
||||
} |
||||
set a1 [lindex $args 0] |
||||
set is_absolute [string match ::* $a1] |
||||
if {$is_absolute} { |
||||
set nspath [nsjoinall {*}$args] |
||||
} else { |
||||
if {[string match :* $a1]} { |
||||
puts stderr "n/new WARNING namespace with leading colon '$a1' is likely to have unexpected results" |
||||
} |
||||
set nspath [nsjoinall $ns_current {*}$args] |
||||
} |
||||
|
||||
set ns_exists [nseval [nsprefix $nspath] [list ::tcl::namespace::exists [nstail $nspath] ]] |
||||
|
||||
if {$ns_exists} { |
||||
error "Namespace $nspath already exists" |
||||
} |
||||
#tcl::namespace::eval [nsprefix $nspath] [list tcl::namespace::eval [nstail $nspath] {}] |
||||
nseval [nsprefix $nspath] [list ::tcl::namespace::eval [nstail $nspath] {}] |
||||
n/ $nspath |
||||
} |
||||
|
||||
#nn/ ::/ nsup/ - back up one namespace level |
||||
proc nsup/ {v args} { |
||||
variable ns_current |
||||
if {$ns_current eq "::"} { |
||||
puts stderr "Already at global namespace '::'" |
||||
} else { |
||||
set out "" |
||||
set nsq [nsprefix $ns_current] |
||||
if {$v eq "/"} { |
||||
set out [get_nslist -match [nsjoin $nsq *] -types [list children]] |
||||
} else { |
||||
set out [get_nslist -match [nsjoin $nsq *] -types [list all]] |
||||
} |
||||
#set out [nslist [nsjoin $nsq *]] |
||||
set ns_current $nsq |
||||
append out "\n$ns_current" |
||||
return $out |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
#extra slash implies more verbosity (ie display commands instead of just nschildren) |
||||
interp alias {} n/ {} punk::nav::ns::ns/ / |
||||
interp alias {} n// {} punk::nav::ns::ns/ // |
||||
interp alias {} n/// {} punk::nav::ns::ns/ /// |
||||
interp alias {} n/new {} punk::nav::ns::n/new |
||||
interp alias {} nn/ {} punk::nav::ns::nsup/ / |
||||
interp alias {} nn// {} punk::nav::ns::nsup/ // |
||||
if 0 { |
||||
#we can't have ::/ without just plain / which is confusing. |
||||
interp alias {} :/ {} punk::nav::ns::ns/ / |
||||
interp alias {} :// {} punk::nav::ns::ns/ // |
||||
interp alias {} :/new {} punk::nav::ns::n/new |
||||
interp alias {} ::/ {} punk::nav::ns::nsup/ / |
||||
interp alias {} ::// {} punk::nav::ns::nsup/ // |
||||
} |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::nav::ns::lib { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
#tcl::namespace::eval punk::nav::ns::system { |
||||
#} |
||||
|
||||
|
||||
# == === === === === === === === === === === === === === === |
||||
# Sample 'about' function with punk::args documentation |
||||
# == === === === === === === === === === === === === === === |
||||
tcl::namespace::eval punk::nav::ns { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
variable PUNKARGS |
||||
variable PUNKARGS_aliases |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)punk::nav::ns" |
||||
@package -name "punk::nav::ns" -help\ |
||||
"Package |
||||
Description" |
||||
}] |
||||
|
||||
namespace eval argdoc { |
||||
#namespace for custom argument documentation |
||||
proc package_name {} { |
||||
return punk::nav::ns |
||||
} |
||||
proc about_topics {} { |
||||
#info commands results are returned in an arbitrary order (like array keys) |
||||
set topic_funs [info commands [namespace current]::get_topic_*] |
||||
set about_topics [list] |
||||
foreach f $topic_funs { |
||||
set tail [namespace tail $f] |
||||
lappend about_topics [string range $tail [string length get_topic_] end] |
||||
} |
||||
#Adjust this function or 'default_topics' if a different order is required |
||||
return [lsort $about_topics] |
||||
} |
||||
proc default_topics {} {return [list Description *]} |
||||
|
||||
# ------------------------------------------------------------- |
||||
# get_topic_ functions add more to auto-include in about topics |
||||
# ------------------------------------------------------------- |
||||
proc get_topic_Description {} { |
||||
punk::args::lib::tstr [string trim { |
||||
package punk::nav::ns |
||||
description to come.. |
||||
} \n] |
||||
} |
||||
proc get_topic_License {} { |
||||
return "MIT" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return "$::punk::nav::ns::version" |
||||
} |
||||
proc get_topic_Contributors {} { |
||||
set authors {<unspecified>} |
||||
set contributors "" |
||||
foreach a $authors { |
||||
append contributors $a \n |
||||
} |
||||
if {[string index $contributors end] eq "\n"} { |
||||
set contributors [string range $contributors 0 end-1] |
||||
} |
||||
return $contributors |
||||
} |
||||
proc get_topic_custom-topic {} { |
||||
punk::args::lib::tstr -return string { |
||||
A custom |
||||
topic |
||||
etc |
||||
} |
||||
} |
||||
# ------------------------------------------------------------- |
||||
} |
||||
|
||||
# we re-use the argument definition from punk::args::standard_about and override some items |
||||
set overrides [dict create] |
||||
dict set overrides @id -id "::punk::nav::ns::about" |
||||
dict set overrides @cmd -name "punk::nav::ns::about" |
||||
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||
About punk::nav::ns |
||||
}] \n] |
||||
dict set overrides topic -choices [list {*}[punk::nav::ns::argdoc::about_topics] *] |
||||
dict set overrides topic -choicerestricted 1 |
||||
dict set overrides topic -default [punk::nav::ns::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict |
||||
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||
lappend PUNKARGS [list $newdef] |
||||
proc about {args} { |
||||
package require punk::args |
||||
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on |
||||
set argd [punk::args::parse $args withid ::punk::nav::ns::about] |
||||
lassign [dict values $argd] _leaders opts values _received |
||||
punk::args::package::standard_about -package_about_namespace ::punk::nav::ns::argdoc {*}$opts {*}[dict get $values topic] |
||||
} |
||||
} |
||||
# end of sample 'about' function |
||||
# == === === === === === === === === === === === === === === |
||||
|
||||
|
||||
# ----------------------------------------------------------------------------- |
||||
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
||||
# ----------------------------------------------------------------------------- |
||||
# variable PUNKARGS |
||||
# variable PUNKARGS_aliases |
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::punk::nav::ns |
||||
} |
||||
# ----------------------------------------------------------------------------- |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::nav::ns [tcl::namespace::eval punk::nav::ns { |
||||
variable pkg punk::nav::ns |
||||
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. |
||||
Binary file not shown.
Binary file not shown.
Binary file not shown.
Loading…
Reference in new issue