2 changed files with 629 additions and 0 deletions
@ -0,0 +1,628 @@ |
|||||||
|
# -*- 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 0.1.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 {[dict get $sdict datatype_name] in {character binarytext} && [binary scan [string range $saucerecord 105 105] cu v]} { |
||||||
|
dict set sdict tflags $v |
||||||
|
if {$v & 1} { |
||||||
|
dict set sdict ansiflags_ice 1 |
||||||
|
} else { |
||||||
|
dict set sdict ansiflags_ice 0 |
||||||
|
} |
||||||
|
set bits [format %08b $v] |
||||||
|
set ls [string range $bits 5 6] |
||||||
|
switch -- $ls { |
||||||
|
"00" { |
||||||
|
dict set sdict ansiflags_letterspacing unspecified |
||||||
|
} |
||||||
|
"01" { |
||||||
|
dict set sdict ansiflags_letterspacing 8 |
||||||
|
} |
||||||
|
"10" { |
||||||
|
dict set sdict ansiflags_letterspacing 9 |
||||||
|
} |
||||||
|
"11" { |
||||||
|
dict set sdict ansiflags_letterspacing invalid |
||||||
|
} |
||||||
|
} |
||||||
|
set ar [string range $bits 3 4] |
||||||
|
switch -- $ar { |
||||||
|
"00" { |
||||||
|
dict set sdict ansiflags_aspectratio unspecified |
||||||
|
} |
||||||
|
"01" { |
||||||
|
dict set sdict ansiflags_aspectratio tallpixels |
||||||
|
} |
||||||
|
"10" { |
||||||
|
dict set sdict ansiflags_aspectratio squarepixels |
||||||
|
} |
||||||
|
"11" { |
||||||
|
dict set sdict ansiflags_aspectratio invalid |
||||||
|
} |
||||||
|
} |
||||||
|
} 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 is supposed to represent half the characterwidth (only widths with multiples of 2 can be specified) |
||||||
|
#HOWEVER - in the wild we may see width/height specified in tinfo1/tinfo2 with some other value in filetype (eg 1) |
||||||
|
#If both tinfo1 and tinfo2 are non zero - we will use them, even though it's not in spec. |
||||||
|
set t1 [dict get $sdict tinfo1] |
||||||
|
if {$t1 eq ""} { |
||||||
|
set t1 0 |
||||||
|
} |
||||||
|
set t2 [dict get $sdict tinfo2] |
||||||
|
if {$t2 eq ""} { |
||||||
|
set t2 0 |
||||||
|
} |
||||||
|
if {$t1 != 0 && $t2 != 0} { |
||||||
|
#not to spec - but we will assume these have values for a reason.. |
||||||
|
puts stderr "punk::ansi::sauce::to_dict using tinfo1/tinfo2 data for columns/rows (non-compliant SAUCE data)" |
||||||
|
dict set sdict columns [expr {2 * $t1}] |
||||||
|
dict set sdict rows $t2 |
||||||
|
} else { |
||||||
|
#proper mechanism to specify columns for binarytext is the datatype field. |
||||||
|
|
||||||
|
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 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
Loading…
Reference in new issue