229 changed files with 28904 additions and 150743 deletions
File diff suppressed because it is too large
Load Diff
@ -1,673 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2024 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application modpod 0.1.4 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin modpod_module_modpod 0 0.1.4] |
||||
#[copyright "2024"] |
||||
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||
#[require modpod] |
||||
#[keywords module] |
||||
#[description] |
||||
#[para] - |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of modpod |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by modpod |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
package require struct::set ;#review |
||||
package require punk::lib |
||||
package require punk::args |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6-}] |
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
|
||||
#changes |
||||
#0.1.4 - when mounting with vfs::zip (because zipfs not available) - mount relative to executable folder instead of module dir |
||||
# (given just a module name it's easier to find exepath than look at package ifneeded script to get module path) |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Base namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval modpod { |
||||
namespace export {[a-z]*}; # Convention: export all lowercase |
||||
|
||||
variable connected |
||||
if {![info exists connected(to)]} { |
||||
set connected(to) list |
||||
} |
||||
variable modpodscript |
||||
set modpodscript [info script] |
||||
if {[string tolower [file extension $modpodscript]] eq ".tcl"} { |
||||
set connected(self) [file dirname $modpodscript] |
||||
} else { |
||||
#expecting a .tm |
||||
set connected(self) $modpodscript |
||||
} |
||||
variable loadables [info sharedlibextension] |
||||
variable sourceables {.tcl .tk} ;# .tm ? |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace modpod}] |
||||
#[para] Core API functions for modpod |
||||
#[list_begin definitions] |
||||
|
||||
|
||||
|
||||
#old tar connect mechanism - review - not needed? |
||||
proc connect {args} { |
||||
puts stderr "modpod::connect--->>$args" |
||||
set argd [punk::args::parse $args withdef { |
||||
@id -id ::modpod::connect |
||||
-type -default "" |
||||
@values -min 1 -max 1 |
||||
path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)" |
||||
}] |
||||
catch { |
||||
punk::lib::showdict $argd ;#heavy dependencies |
||||
} |
||||
set opt_path [dict get $argd values path] |
||||
variable connected |
||||
set original_connectpath $opt_path |
||||
set modpodpath [modpod::system::normalize $opt_path] ;# |
||||
|
||||
if {$modpodpath in $connected(to)} { |
||||
return [dict create ok ALREADY_CONNECTED] |
||||
} |
||||
lappend connected(to) $modpodpath |
||||
|
||||
set connected(connectpath,$opt_path) $original_connectpath |
||||
set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info script]]}] |
||||
|
||||
set connected(location,$modpodpath) [file dirname $modpodpath] |
||||
set connected(startdata,$modpodpath) -1 |
||||
set connected(type,$modpodpath) [dict get $argd opts -type] |
||||
set connected(fh,$modpodpath) "" |
||||
|
||||
if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { |
||||
set connected(type,$modpodpath) "unwrapped" |
||||
lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
||||
set this_pkg_tm_folder [file dirname [file dirname $modpodpath]] |
||||
|
||||
} else { |
||||
#connect to .tm but may still be unwrapped version available |
||||
lassign [::split [file rootname [file tail $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
||||
set this_pkg_tm_folder [file dirname $modpodpath] |
||||
if {$connected(type,$modpodpath) ne "unwrapped"} { |
||||
#Not directly connected to unwrapped version - but may still be redirected there |
||||
set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)] |
||||
if {[file exists $unwrappedFolder]} { |
||||
#folder with exact version-match must exist for redirect to 'unwrapped' |
||||
set con(type,$modpodpath) "modpod-redirecting" |
||||
} |
||||
} |
||||
|
||||
} |
||||
set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm" |
||||
set connected(tmfile,$modpodpath) |
||||
set tail_segments [list] |
||||
set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]] |
||||
set lcase_modulepaths [string tolower [tcl::tm::list]] |
||||
foreach lc_mpath $lcase_modulepaths { |
||||
set mpath_segments [file split $lc_mpath] |
||||
if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
||||
set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end] |
||||
break |
||||
} |
||||
} |
||||
if {[llength $tail_segments]} { |
||||
set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require |
||||
} else { |
||||
set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)] |
||||
} |
||||
|
||||
switch -exact -- $connected(type,$modpodpath) { |
||||
"modpod-redirecting" { |
||||
#redirect to the unwrapped version |
||||
set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl] |
||||
|
||||
} |
||||
"unwrapped" { |
||||
if {[info commands ::thread::id] ne ""} { |
||||
set from [pid],[thread::id] |
||||
} else { |
||||
set from [pid] |
||||
} |
||||
#::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath" |
||||
return [list ok ""] |
||||
} |
||||
default { |
||||
#autodetect .tm - zip/tar ? |
||||
#todo - use vfs ? |
||||
|
||||
#connect to tarball - start at 1st header |
||||
set connected(startdata,$modpodpath) 0 |
||||
set fh [open $modpodpath r] |
||||
set connected(fh,$modpodpath) $fh |
||||
fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {} |
||||
|
||||
if {$connected(startdata,$modpodpath) >= 0} { |
||||
#verify we have a valid tar header |
||||
if {![catch {::modpod::system::tar::readHeader [read $fh 512]}]} { |
||||
seek $fh $connected(startdata,$modpodpath) start |
||||
return [list ok $fh] |
||||
} else { |
||||
#error "cannot verify tar header" |
||||
#try zipfs |
||||
if {[info commands tcl::zipfs::mount] ne ""} { |
||||
|
||||
} |
||||
} |
||||
} |
||||
lpop connected(to) end |
||||
set connected(startdata,$modpodpath) -1 |
||||
unset connected(fh,$modpodpath) |
||||
catch {close $fh} |
||||
return [dict create err {Does not appear to be a valid modpod}] |
||||
} |
||||
} |
||||
} |
||||
proc disconnect {{modpod ""}} { |
||||
variable connected |
||||
if {![llength $connected(to)]} { |
||||
return 0 |
||||
} |
||||
if {$modpod eq ""} { |
||||
puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]" |
||||
set modpod [lindex $connected(to) end] |
||||
} |
||||
|
||||
if {[set posn [lsearch $connected(to) $modpod]] == -1} { |
||||
puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod" |
||||
return 0 |
||||
} |
||||
if {[string length $connected(fh,$modpod)]} { |
||||
close $connected(fh,$modpod) |
||||
} |
||||
array unset connected *,$modpod |
||||
set connected(to) [lreplace $connected(to) $posn $posn] |
||||
return 1 |
||||
} |
||||
proc get {args} { |
||||
set argd [punk::args::parse $args withdef { |
||||
@id -id ::modpod::get |
||||
-from -default "" -help "path to pod" |
||||
@values -min 1 -max 1 |
||||
filename |
||||
}] |
||||
set frompod [dict get $argd opts -from] |
||||
set filename [dict get $argd values filename] |
||||
|
||||
variable connected |
||||
#//review |
||||
set modpod [::modpod::system::connect_if_not $frompod] |
||||
set fh $connected(fh,$modpod) |
||||
if {$connected(type,$modpod) eq "unwrapped"} { |
||||
#for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder |
||||
if {[string range $filename 0 0 eq "/"]} { |
||||
#absolute path (?) |
||||
set path [file join $connected(location,$modpod) .. [string trim $filename /]] |
||||
} else { |
||||
#relative path - use #modpod-xxx as base |
||||
set path [file join $connected(location,$modpod) $filename] |
||||
} |
||||
set fd [open $path r] |
||||
#utf-8? |
||||
#fconfigure $fd -encoding iso8859-1 -translation binary |
||||
return [list ok [lindex [list [read $fd] [close $fd]] 0]] |
||||
} else { |
||||
#read from vfs |
||||
puts stderr "get $filename from wrapped pod '$frompod' not implemented" |
||||
} |
||||
} |
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace modpod ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval modpod::lib { |
||||
namespace export {[a-z]*}; # Convention: export all lowercase |
||||
namespace path [namespace parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace modpod::lib}] |
||||
#[para] Secondary functions that are part of the API |
||||
#[list_begin definitions] |
||||
|
||||
#proc utility1 {p1 args} { |
||||
# #*** !doctools |
||||
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||
# #[para]Description of utility1 |
||||
# return 1 |
||||
#} |
||||
|
||||
proc is_valid_tm_version {versionpart} { |
||||
#Needs to be suitable for use with Tcl's 'package vcompare' |
||||
if {![catch [list package vcompare $versionparts $versionparts]]} { |
||||
return 1 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
|
||||
#zipfile is a pure zip at this point - ie no script/exe header |
||||
proc make_zip_modpod {args} { |
||||
set argd [punk::args::parse $args withdef { |
||||
@id -id ::modpod::lib::make_zip_modpod |
||||
-offsettype -default "archive" -choices {archive file} -help\ |
||||
"Whether zip offsets are relative to start of file or start of zip-data within the file. |
||||
'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip, |
||||
but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip) |
||||
info-zip's 'zip -A' can sometimes convert archive-relative to file-relative. |
||||
-offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'" |
||||
@values -min 2 -max 2 |
||||
zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" |
||||
outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" |
||||
}] |
||||
set zipfile [dict get $argd values zipfile] |
||||
set outfile [dict get $argd values outfile] |
||||
set opt_offsettype [dict get $argd opts -offsettype] |
||||
|
||||
|
||||
set mount_stub [string map [list %offsettype% $opt_offsettype] { |
||||
#zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. |
||||
#Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. |
||||
#generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% <zipfile> <tmfile> |
||||
if {[catch {file normalize [info script]} modfile]} { |
||||
error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" |
||||
} |
||||
if {$modfile eq "" || ![file exists $modfile]} { |
||||
error "modpod zip stub error. Unable to determine module path" |
||||
} |
||||
set moddir [file dirname $modfile] |
||||
set exedir [file dirname [file normalize [info nameofexecutable]]] |
||||
set mod_and_ver [file rootname [file tail $modfile]] |
||||
lassign [split $mod_and_ver -] moduletail version |
||||
|
||||
#determine module namespace so we can mount appropriately |
||||
proc intersect {A B} { |
||||
if {[llength $A] == 0} {return {}} |
||||
if {[llength $B] == 0} {return {}} |
||||
if {[llength $B] > [llength $A]} { |
||||
set res $A |
||||
set A $B |
||||
set B $res |
||||
} |
||||
set res {} |
||||
foreach x $A {set ($x) {}} |
||||
foreach x $B { |
||||
if {[info exists ($x)]} { |
||||
lappend res $x |
||||
} |
||||
} |
||||
return $res |
||||
} |
||||
set lcase_tmfile_segments [string tolower [file split $moddir]] |
||||
set lcase_modulepaths [string tolower [tcl::tm::list]] |
||||
foreach lc_mpath $lcase_modulepaths { |
||||
set mpath_segments [file split $lc_mpath] |
||||
if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
||||
set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use properly cased tail |
||||
break |
||||
} |
||||
} |
||||
if {[llength $tail_segments]} { |
||||
set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require |
||||
set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver |
||||
} else { |
||||
set fullpackage $moduletail |
||||
set mount_at #modpod/#mounted-modpod-$mod_and_ver |
||||
} |
||||
|
||||
if {[info commands tcl::zipfs::mount] ne ""} { |
||||
#argument order changed to be consistent with vfs::zip::Mount etc |
||||
#early versions: zipfs::Mount mountpoint zipname |
||||
#since 2023-09: zipfs::Mount zipname mountpoint |
||||
#don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance) |
||||
#This is presumably related to // being interpreted as a network path |
||||
set mountpoints [dict keys [tcl::zipfs::mount]] |
||||
if {"//zipfs:/$mount_at" ni $mountpoints} { |
||||
#despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it |
||||
if {[catch { |
||||
#tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) |
||||
#puts "tcl::zipfs::mount $modfile $mount_at" |
||||
tcl::zipfs::mount $modfile $mount_at |
||||
} errM]} { |
||||
#try old api |
||||
if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { |
||||
puts stderr "modpod stub>>> tcl::zipfs::mount <file> <mountpoint> failed.\nbut old api: tcl::zipfs::mount <mountpoint> <file> succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" |
||||
puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" |
||||
} |
||||
} |
||||
if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
||||
puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]" |
||||
#tcl::zipfs::unmount //zipfs:/$mount_at |
||||
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" |
||||
} |
||||
} |
||||
# #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form |
||||
source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm |
||||
} else { |
||||
#fallback to slower vfs::zip |
||||
#NB. We don't create the intermediate dirs - but the mount still works |
||||
|
||||
if {![file exists $exedir/$mount_at]} { |
||||
if {[catch {package require vfs::zip} errM]} { |
||||
set msg "Unable to load vfs::zip package to mount module $mod_and_ver (and zipfs not available either)" |
||||
append msg \n "If neither zipfs or vfs::zip are available - the module can still be loaded by manually unzipping the file $modfile in place." |
||||
append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" |
||||
error $msg |
||||
} else { |
||||
set fd [vfs::zip::Mount $modfile $exedir/$mount_at] |
||||
if {![file exists $exedir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
||||
vfs::zip::Unmount $fd $exedir/$mount_at |
||||
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" |
||||
} |
||||
} |
||||
} |
||||
source $exedir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm |
||||
} |
||||
#zipped data follows |
||||
}] |
||||
#todo - test if supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? |
||||
append mount_stub \x1A |
||||
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub $opt_offsettype |
||||
|
||||
} |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace modpod::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
namespace eval modpod::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace modpod::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
#deflate,store only supported |
||||
|
||||
#zipfile here is plain zip - no script/exe prefix part. |
||||
proc make_mountable_zip {zipfile outfile mount_stub {offsettype "archive"}} { |
||||
set inzip [open $zipfile r] |
||||
fconfigure $inzip -encoding iso8859-1 -translation binary |
||||
set out [open $outfile w+] |
||||
fconfigure $out -encoding iso8859-1 -translation binary |
||||
puts -nonewline $out $mount_stub |
||||
set stuboffset [tell $out] |
||||
lappend report "stub size: $stuboffset" |
||||
fcopy $inzip $out |
||||
close $inzip |
||||
|
||||
set size [tell $out] |
||||
lappend report "modpod::system::make_mountable_zip" |
||||
lappend report "tmfile : [file tail $outfile]" |
||||
lappend report "output size : $size" |
||||
lappend report "offsettype : $offsettype" |
||||
|
||||
if {$offsettype eq "file"} { |
||||
#make zip offsets relative to start of whole file including prepended script. |
||||
#same offset structure as Tcl's older 'zipfs mkimg' as at 2024-10 |
||||
#2025 - zipfs mkimg fixed to use 'archive' offset. |
||||
#not editable by 7z,nanazip,peazip |
||||
|
||||
#we aren't adding any new files/folders so we can edit the offsets in place |
||||
|
||||
#Now seek in $out to find the end of directory signature: |
||||
#The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text |
||||
if {$size < 65559} { |
||||
set tailsearch_start 0 |
||||
} else { |
||||
set tailsearch_start [expr {$size - 65559}] |
||||
} |
||||
seek $out $tailsearch_start |
||||
set data [read $out] |
||||
#EOCD - End of Central Directory record |
||||
#PK\5\6 |
||||
set start_of_end [string last "\x50\x4b\x05\x06" $data] |
||||
#set start_of_end [expr {$start_of_end + $seek}] |
||||
#incr start_of_end $seek |
||||
set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] |
||||
|
||||
lappend report "kitfile-relative START-OF-EOCD: $filerelative_eocd_posn" |
||||
|
||||
seek $out $filerelative_eocd_posn |
||||
set end_of_ctrl_dir [read $out] |
||||
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||
|
||||
lappend report "End of central directory: [array get eocd]" |
||||
seek $out [expr {$filerelative_eocd_posn+16}] |
||||
|
||||
#adjust offset of start of central directory by the length of our sfx stub |
||||
puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $stuboffset}]] |
||||
flush $out |
||||
|
||||
seek $out $filerelative_eocd_posn |
||||
set end_of_ctrl_dir [read $out] |
||||
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||
|
||||
# 0x06054b50 - end of central dir signature |
||||
puts stderr "$end_of_ctrl_dir" |
||||
puts stderr "comment_len: $eocd(comment_len)" |
||||
puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" |
||||
lappend report "New dir offset: $eocd(diroffset)" |
||||
lappend report "Adjusting $eocd(totalnum) zip file items." |
||||
catch { |
||||
punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies |
||||
} |
||||
|
||||
seek $out $eocd(diroffset) |
||||
for {set i 0} {$i <$eocd(totalnum)} {incr i} { |
||||
set current_file [tell $out] |
||||
set fileheader [read $out 46] |
||||
puts -------------- |
||||
puts [ansistring VIEW -lf 1 $fileheader] |
||||
puts -------------- |
||||
#binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||
# x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||
|
||||
binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||
set ::last_header $fileheader |
||||
|
||||
puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" |
||||
puts "ver: $x(version)" |
||||
puts "method: $x(method)" |
||||
|
||||
#PK\1\2 |
||||
#33639248 dec = 0x02014b50 - central directory file header signature |
||||
if { $x(sig) != 33639248 } { |
||||
error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" |
||||
} |
||||
|
||||
foreach size $x(lengths) var {filename extrafield comment} { |
||||
if { $size > 0 } { |
||||
set x($var) [read $out $size] |
||||
} else { |
||||
set x($var) "" |
||||
} |
||||
} |
||||
set next_file [tell $out] |
||||
lappend report "file $i: $x(offset) $x(sizes) $x(filename)" |
||||
|
||||
seek $out [expr {$current_file+42}] |
||||
puts -nonewline $out [binary format i [expr {$x(offset)+$stuboffset}]] |
||||
|
||||
#verify: |
||||
flush $out |
||||
seek $out $current_file |
||||
set fileheader [read $out 46] |
||||
lappend report "old $x(offset) + $stuboffset" |
||||
binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||
lappend report "new $x(offset)" |
||||
|
||||
seek $out $next_file |
||||
} |
||||
} |
||||
|
||||
close $out |
||||
#pdict/showdict reuire punk & textlib - ie lots of dependencies |
||||
#don't fall over just because of that |
||||
catch { |
||||
punk::lib::showdict -roottype list -chan stderr $report |
||||
} |
||||
#puts [join $report \n] |
||||
return |
||||
} |
||||
|
||||
proc connect_if_not {{podpath ""}} { |
||||
upvar ::modpod::connected connected |
||||
set podpath [::modpod::system::normalize $podpath] |
||||
set docon 0 |
||||
if {![llength $connected(to)]} { |
||||
if {![string length $podpath]} { |
||||
error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified" |
||||
} else { |
||||
set docon 1 |
||||
} |
||||
} else { |
||||
if {![string length $podpath]} { |
||||
set podpath [lindex $connected(to) end] |
||||
puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]" |
||||
} else { |
||||
if {$podpath ni $connected(to)} { |
||||
set docon 1 |
||||
} |
||||
} |
||||
} |
||||
if {$docon} { |
||||
if {[lindex [modpod::connect $podpath]] 0] ne "ok"} { |
||||
error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod" |
||||
} else { |
||||
return $podpath |
||||
} |
||||
} |
||||
#we were already connected |
||||
return $podpath |
||||
} |
||||
|
||||
proc myversion {} { |
||||
upvar ::modpod::connected connected |
||||
set script [info script] |
||||
if {![string length $script]} { |
||||
error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod" |
||||
} |
||||
set fname [file tail [file rootname [file normalize $script]]] |
||||
set scriptdir [file dirname $script] |
||||
|
||||
if {![string match "#modpod-*" $fname]} { |
||||
lassign [lrange [split $fname -] end-1 end] _pkgname version |
||||
} else { |
||||
lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version |
||||
if {![string length $version]} { |
||||
#try again on the name of the containing folder |
||||
lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version |
||||
#todo - proper walk up the directory tree |
||||
if {![string length $version]} { |
||||
#try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod) |
||||
lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version |
||||
} |
||||
} |
||||
} |
||||
|
||||
#tarjar::Log debug "'myversion' determined version for [info script]: $version" |
||||
return $version |
||||
} |
||||
|
||||
proc myname {} { |
||||
upvar ::modpod::connected connected |
||||
set script [info script] |
||||
if {![string length $script]} { |
||||
error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod" |
||||
} |
||||
return $connected(fullpackage,$script) |
||||
} |
||||
proc myfullname {} { |
||||
upvar ::modpod::connected connected |
||||
set script [info script] |
||||
#set script [::tarjar::normalize $script] |
||||
set script [file normalize $script] |
||||
if {![string length $script]} { |
||||
error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar" |
||||
} |
||||
return $::tarjar::connected(fullpackage,$script) |
||||
} |
||||
proc normalize {path} { |
||||
#newer versions of Tcl don't do tilde sub |
||||
|
||||
#Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths) |
||||
# we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function. |
||||
set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes.. |
||||
set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after |
||||
set path [file normalize $path] |
||||
#set path [string tolower $path] ;#must do this after file normalize |
||||
return [string map [list $matilda ~] $path] ;#get our tildes back. |
||||
} |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide modpod [namespace eval modpod { |
||||
variable pkg modpod |
||||
variable version |
||||
set version 0.1.4 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,37 +0,0 @@
|
||||
|
||||
package require punk::cap |
||||
|
||||
|
||||
tcl::namespace::eval punk::mix { |
||||
proc init {} { |
||||
package require punk::cap::handlers::templates ;#handler for templates cap |
||||
punk::cap::register_capabilityname punk.templates ::punk::cap::handlers::templates ;#time taken should generally be sub 200us |
||||
|
||||
#todo: use tcllib pluginmgr to load all modules that provide 'punk.templates' |
||||
#review - tcllib pluginmgr 0.5 @2025 has some bugs - esp regarding .tm modules vs packages |
||||
#We may also need to better control the order of module and library paths in the safe interps pluginmgr uses. |
||||
#todo - develop punk::pluginmgr to fix these issues (bug reports already submitted re tcllib, but the path issues may need customisation) |
||||
|
||||
package require punk::mix::templates ;#registers as provider pkg for 'punk.templates' capability with punk::cap |
||||
set t [time { |
||||
if {[catch {punk::mix::templates::provider register *} errM]} { |
||||
puts stderr "punk::mix failure during punk::mix::templates::provider register *" |
||||
puts stderr $errM |
||||
puts stderr "-----" |
||||
puts stderr $::errorInfo |
||||
} |
||||
}] |
||||
puts stderr "->punk::mix::templates::provider register * t=$t" |
||||
} |
||||
init |
||||
|
||||
} |
||||
|
||||
package require punk::mix::base |
||||
package require punk::mix::cli |
||||
|
||||
package provide punk::mix [tcl::namespace::eval punk::mix { |
||||
variable version |
||||
set version 0.2 |
||||
|
||||
}] |
||||
@ -1,276 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2024 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::repl::codethread 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin shellspy_module_punk::repl::codethread 0 0.1.0] |
||||
#[copyright "2024"] |
||||
#[titledesc {Module repl codethread}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {codethread for repl - root interpreter}] [comment {-- Description at end of page heading --}] |
||||
#[require punk::repl::codethread] |
||||
#[keywords module repl] |
||||
#[description] |
||||
#[para] This is part of the infrastructure required for the punk::repl to operate |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of punk::repl::codethread |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by punk::repl::codethread |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
package require punk::config |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# oo::class namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#tcl::namespace::eval punk::repl::codethread::class { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::repl::codethread::class}] |
||||
#[para] class definitions |
||||
#if {[info commands [tcl::namespace::current]::interface_sample1] eq ""} { |
||||
#*** !doctools |
||||
#[list_begin enumerated] |
||||
|
||||
# oo::class create interface_sample1 { |
||||
# #*** !doctools |
||||
# #[enum] CLASS [class interface_sample1] |
||||
# #[list_begin definitions] |
||||
|
||||
# method test {arg1} { |
||||
# #*** !doctools |
||||
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||
# #[para] test method |
||||
# puts "test: $arg1" |
||||
# } |
||||
|
||||
# #*** !doctools |
||||
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||
# } |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end class enumeration ---}] |
||||
#} |
||||
#} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Base namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::repl::codethread { |
||||
tcl::namespace::export * |
||||
variable replthread |
||||
variable replthread_cond |
||||
variable running 0 |
||||
|
||||
variable output_stdout "" |
||||
variable output_stderr "" |
||||
|
||||
#variable xyz |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace punk::repl::codethread}] |
||||
#[para] Core API functions for punk::repl::codethread |
||||
#[list_begin definitions] |
||||
|
||||
|
||||
|
||||
#proc sample1 {p1 n args} { |
||||
# #*** !doctools |
||||
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||
# #[para]Description of sample1 |
||||
# #[para] Arguments: |
||||
# # [list_begin arguments] |
||||
# # [arg_def tring p1] A description of string argument p1. |
||||
# # [arg_def integer n] A description of integer argument n. |
||||
# # [list_end] |
||||
# return "ok" |
||||
#} |
||||
|
||||
variable run_command_cache |
||||
|
||||
proc is_running {} { |
||||
variable running |
||||
return $running |
||||
} |
||||
proc runscript {script} { |
||||
|
||||
#puts stderr "->runscript" |
||||
variable replthread_cond |
||||
#variable output_stdout |
||||
#set output_stdout "" |
||||
#variable output_stderr |
||||
#set output_stderr "" |
||||
#expecting to be called from a thread::send in parent repl - ie in the toplevel interp so that the sub-interp "code" is available |
||||
#if a thread::send is done from the commandline in a codethread - Tcl will |
||||
if {"code" ni [interp children] || ![info exists replthread_cond]} { |
||||
#in case someone tries calling from codethread directly - don't do anything or change any state |
||||
#(direct caller could create an interp named code at the level "" -> "code" -"code" and add a replthread_cond value to avoid this check - but it probably won't do anything useful) |
||||
#if called directly - the context will be within the first 'code' interp. |
||||
#inappropriate caller could add superfluous entries to shellfilter stack if function errors out |
||||
#inappropriate caller could affect tsv vars (if their interp allows that anyway) |
||||
puts stderr "runscript is meant to be called from the parent repl thread via a thread::send to the codethread" |
||||
return |
||||
} |
||||
interp eval code [list set ::punk::repl::codethread::output_stdout ""] |
||||
interp eval code [list set ::punk::repl::codethread::output_stderr ""] |
||||
|
||||
set outstack [list] |
||||
set errstack [list] |
||||
upvar ::punk::config::running running_config |
||||
if {[string length [dict get $running_config color_stdout_repl]] && [interp eval code punk::console::colour]} { |
||||
lappend outstack [interp eval code [list shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout_repl]]]] |
||||
} |
||||
lappend outstack [interp eval code [list shellfilter::stack::add stdout tee_to_var -settings {-varname ::punk::repl::codethread::output_stdout}]] |
||||
|
||||
if {[string length [dict get $running_config color_stderr_repl]] && [interp eval code punk::console::colour]} { |
||||
lappend errstack [interp eval code [list shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr_repl]]]] |
||||
# #lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour cyan]] |
||||
} |
||||
lappend errstack [interp eval code [list shellfilter::stack::add stderr tee_to_var -settings {-varname ::punk::repl::codethread::output_stderr}]] |
||||
|
||||
#an experiment |
||||
#set errhandle [shellfilter::stack::item_tophandle stderr] |
||||
#interp transfer "" $errhandle code |
||||
|
||||
set status [catch { |
||||
#shennanigans to keep compiled script around after call. |
||||
#otherwise when $script goes out of scope - internal rep of vars set in script changes. |
||||
#The shimmering may be no big deal(?) - but debug/analysis using tcl::unsupported::representation becomes impossible. |
||||
interp eval code [list ::punk::lib::set_clone ::codeinterp::clonescript $script] ;#like objclone |
||||
interp eval code { |
||||
lappend ::codeinterp::run_command_cache $::codeinterp::clonescript |
||||
if {[llength $::codeinterp::run_command_cache] > 2000} { |
||||
set ::codeinterp::run_command_cache [lrange $::codeinterp::run_command_cache 1750 end][unset ::codeinterp::run_command_cache] |
||||
} |
||||
tcl::namespace::inscope $::punk::ns::ns_current $::codeinterp::clonescript |
||||
} |
||||
} result] |
||||
|
||||
|
||||
flush stdout |
||||
flush stderr |
||||
|
||||
#interp transfer code $errhandle "" |
||||
#flush $errhandle |
||||
set lastoutchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stdout]] end] |
||||
set lasterrchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stderr]] end] |
||||
#puts stderr "-->[ansistring VIEW -lf 1 $lastoutchar$lasterrchar]" |
||||
|
||||
set tid [thread::id] |
||||
tsv::set codethread_$tid info [list lastoutchar $lastoutchar lasterrchar $lasterrchar] |
||||
tsv::set codethread_$tid status $status |
||||
tsv::set codethread_$tid result $result |
||||
tsv::set codethread_$tid errorcode $::errorCode |
||||
|
||||
|
||||
#only remove from shellfilter::stack the items we added to stack in this function |
||||
foreach s [lreverse $outstack] { |
||||
interp eval code [list shellfilter::stack::remove stdout $s] |
||||
} |
||||
foreach s [lreverse $errstack] { |
||||
interp eval code [list shellfilter::stack::remove stderr $s] |
||||
} |
||||
thread::cond notify $replthread_cond |
||||
} |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::repl::codethread ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::repl::codethread::lib { |
||||
tcl::namespace::export * |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::repl::codethread::lib}] |
||||
#[para] Secondary functions that are part of the API |
||||
#[list_begin definitions] |
||||
|
||||
#proc utility1 {p1 args} { |
||||
# #*** !doctools |
||||
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||
# #[para]Description of utility1 |
||||
# return 1 |
||||
#} |
||||
|
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::repl::codethread::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
tcl::namespace::eval punk::repl::codethread::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::repl::codethread::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
|
||||
|
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::repl::codethread [tcl::namespace::eval punk::repl::codethread { |
||||
variable pkg punk::repl::codethread |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
@ -1,836 +0,0 @@
|
||||
# -*- 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: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2024 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::winlnk 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license MIT |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin punkshell_module_punk::winlnk 0 0.1.0] |
||||
#[copyright "2024"] |
||||
#[titledesc {windows shortcut .lnk library}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {punk::winlnk}] [comment {-- Description at end of page heading --}] |
||||
#[require punk::winlnk] |
||||
#[keywords module shortcut lnk parse windows crossplatform] |
||||
#[description] |
||||
#[para] Tools for reading windows shortcuts (.lnk files) on any platform |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of punk::winlnk |
||||
#[subsection Concepts] |
||||
#[para] Windows shortcuts are a binary format file with a .lnk extension |
||||
#[para] Shell Link (.LNK) Binary File Format is documented in [lb]MS_SHLLINK[rb].pdf published by Microsoft. |
||||
#[para] Revision 8.0 published 2024-04-23 |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by punk::winlnk |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
|
||||
#TODO - logger |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Base namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::winlnk { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
#variable xyz |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace punk::winlnk}] |
||||
#[para] Core API functions for punk::winlnk |
||||
#[list_begin definitions] |
||||
|
||||
|
||||
variable magic_HeaderSize "0000004C" ;#HeaderSize MUST equal this |
||||
variable magic_LinkCLSID "00021401-0000-0000-C000-000000000046" ;#LinkCLSID MUST equal this |
||||
|
||||
proc Get_contents {path {bytes all}} { |
||||
if {![file exists $path] || [file type $path] ne "file"} { |
||||
error "punk::winlnk::get_contents cannot find a filesystem object of type 'file' at location: $path" |
||||
} |
||||
set fd [open $path r] |
||||
chan configure $fd -translation binary -encoding iso8859-1 |
||||
if {$bytes eq "all"} { |
||||
set data [read $fd] |
||||
} else { |
||||
set data [read $fd $bytes] |
||||
} |
||||
close $fd |
||||
return $data |
||||
} |
||||
proc Contents_check_header {contents} { |
||||
variable magic_HeaderSize |
||||
variable magic_LinkCLSID |
||||
expr {[Header_Get_HeaderSize $contents] eq $magic_HeaderSize && [Header_Get_LinkCLSID $contents] eq $magic_LinkCLSID} |
||||
} |
||||
|
||||
#LinkFlags - 4 bytes - specifies information about the shell link and the presence of optional portions of the structure. |
||||
proc Show_LinkFlags {contents} { |
||||
set 4bytes [string range $contents 20 23] |
||||
set r [binary scan $4bytes i val] ;# i for little endian 32-bit signed int |
||||
puts "val: $val" |
||||
set declist [scan [string reverse $4bytes] %c%c%c%c] |
||||
set fmt [string repeat %08b 4] |
||||
puts "LinkFlags:[format $fmt {*}$declist]" |
||||
|
||||
set r [binary scan $4bytes b32 val] |
||||
puts "bscan-le: $val" |
||||
set r [binary scan [string reverse $4bytes] b32 val] |
||||
puts "bscan-2 : $val" |
||||
} |
||||
variable LinkFlags |
||||
set LinkFlags [dict create\ |
||||
hasLinkTargetIDList 1\ |
||||
HasLinkInfo 2\ |
||||
HasName 4\ |
||||
HasRelativePath 8\ |
||||
HasWorkingDir 16\ |
||||
HasArguments 32\ |
||||
HasIconLocation 64\ |
||||
IsUnicode 128\ |
||||
ForceNoLinkInfo 256\ |
||||
HasExpString 512\ |
||||
RunInSeparateProcess 1024\ |
||||
Unused1 2048\ |
||||
HasDarwinID 4096\ |
||||
RunAsUser 8192\ |
||||
HasExpIcon 16394\ |
||||
NoPidlAlias 32768\ |
||||
Unused2 65536\ |
||||
RunWithShimLayer 131072\ |
||||
ForceNoLinkTrack 262144\ |
||||
EnableTargetMetadata 524288\ |
||||
DisableLinkPathTracking 1048576\ |
||||
DisableKnownFolderTracking 2097152\ |
||||
DisableKnownFolderAlias 4194304\ |
||||
AllowLinkToLink 8388608\ |
||||
UnaliasOnSave 16777216\ |
||||
PreferEnvironmentPath 33554432\ |
||||
KeepLocalIDListForUNCTarget 67108864\ |
||||
] |
||||
variable LinkFlagLetters [list A B C D E F G H I J K L M N O P Q R S T U V W X Y Z AA] |
||||
proc Header_Has_LinkFlag {contents flagname} { |
||||
variable LinkFlags |
||||
variable LinkFlagLetters |
||||
if {[string length $flagname] <= 2} { |
||||
set idx [lsearch $LinkFlagLetters $flagname] |
||||
if {$idx < 0} { |
||||
error "punk::winlnk::Header_Has_LinkFlag error - flagname $flagname not known" |
||||
} |
||||
set binflag [expr {2**$idx}] |
||||
set allflags [Header_Get_LinkFlags $contents] |
||||
return [expr {$allflags & $binflag}] |
||||
} |
||||
if {[dict exists $LinkFlags $flagname]} { |
||||
set binflag [dict get $LinkFlags $flagname] |
||||
set allflags [Header_Get_LinkFlags $contents] |
||||
return [expr {$allflags & $binflag}] |
||||
} else { |
||||
error "punk::winlnk::Header_Has_LinkFlag error - flagname $flagname not known" |
||||
} |
||||
} |
||||
|
||||
#MS-SHLLINK.pdf documents the .lnk file format in detail, but here is a brief overview of the structure of a .lnk file: |
||||
#protocol revision 10.0 (November 2025) https://winprotocoldocs-bhdugrdyduf5h2e4.b02.azurefd.net/MS-SHLLINK/%5bMS-SHLLINK%5d.pdf |
||||
|
||||
|
||||
#SHELL_LINK_HEADER structure is 76 bytes long and starts at the beginning of the file |
||||
#offset hex:0x00 dec:0 4 bytes |
||||
#Header size (HeaderSize) (must be 0x0000004C for .lnk files) |
||||
proc Header_Get_HeaderSize {contents} { |
||||
set 4bytes [split [string range $contents 0 3] ""] |
||||
set hex4 "" |
||||
foreach b [lreverse $4bytes] { |
||||
set dec [scan $b %c] ;# 0-255 decimal |
||||
set HH [format %2.2llX $dec] |
||||
append hex4 $HH |
||||
} |
||||
return $hex4 |
||||
} |
||||
|
||||
|
||||
#offset hex:0x04 dec:4 16 bytes |
||||
#LinkCLSID (must be 00021401-0000-0000-C000-000000000046 for .lnk files) |
||||
proc Header_Get_LinkCLSID {contents} { |
||||
set 16bytes [string range $contents 4 19] |
||||
#CLSID hex textual representation is split as 4-2-2-2-6 bytes(hex pairs) |
||||
#e.g We expect 00021401-0000-0000-C000-000000000046 for .lnk files |
||||
#for endianness - it is little endian all the way but the split is 4-2-2-1-1-1-1-1-1-1-1 REVIEW |
||||
#(so it can appear as mixed endianness if you don't know the splits) |
||||
#https://devblogs.microsoft.com/oldnewthing/20220928-00/?p=107221 |
||||
#This is based on COM textual representation of GUIDS |
||||
#Apparently a CLSID is a GUID that identifies a COM object |
||||
set clsid "" |
||||
set s1 [tcl::string::range $16bytes 0 3] |
||||
set declist [scan [string reverse $s1] %c%c%c%c] |
||||
set fmt "%02X%02X%02X%02X" |
||||
append clsid [format $fmt {*}$declist] |
||||
|
||||
append clsid - |
||||
set s2 [tcl::string::range $16bytes 4 5] |
||||
set declist [scan [string reverse $s2] %c%c] |
||||
set fmt "%02X%02X" |
||||
append clsid [format $fmt {*}$declist] |
||||
|
||||
append clsid - |
||||
set s3 [tcl::string::range $16bytes 6 7] |
||||
set declist [scan [string reverse $s3] %c%c] |
||||
append clsid [format $fmt {*}$declist] |
||||
|
||||
append clsid - |
||||
#now treat bytes individually - so no endianness conversion |
||||
set declist [scan [tcl::string::range $16bytes 8 9] %c%c] |
||||
append clsid [format $fmt {*}$declist] |
||||
|
||||
append clsid - |
||||
set scan [string repeat %c 6] |
||||
set fmt [string repeat %02X 6] |
||||
set declist [scan [tcl::string::range $16bytes 10 15] $scan] |
||||
append clsid [format $fmt {*}$declist] |
||||
|
||||
return $clsid |
||||
} |
||||
|
||||
|
||||
#offset hex:0x14 dec:20 4 bytes |
||||
#Link flags (LinkFlags) - bit field specifying information about the shell link and the presence of optional portions of the structure. |
||||
#HasLinkTargetIDList bit 0 (0x00000001) - if set, a LinkTargetIDList structure is present immediately following the header |
||||
#HasLinkInfo bit 1 (0x00000002) - if set, a LinkInfo structure is present immediately following the header (or the LinkTargetIDList if that is present) |
||||
#HasName bit 2 (0x00000004) - if set, a null-terminated string containing the name of the link is present immediately following the header (or the LinkTargetIDList and LinkInfo if they are present) |
||||
#HasRelativePath bit 3 (0x00000008) - if set, a null-terminated string containing the relative path of the link target is present immediately following the header (or the LinkTargetIDList, LinkInfo and Name if they are present) |
||||
#HasWorkingDir bit 4 (0x00000010) - if set, a null-terminated string containing the working directory of the link target is present immediately following the header (or the LinkTargetIDList, LinkInfo, Name and Relative Path if they are present) |
||||
#HasArguments bit 5 (0x00000020) - if set, a null-terminated string containing the command line arguments for the link target is present immediately following the header (or the LinkTargetIDList, LinkInfo, Name, Relative Path and Working Dir if they are present) |
||||
#HasIconLocation bit 6 (0x00000040) - if set, a null-terminated string containing the location of the icon for the link is present immediately following the header (or the LinkTargetIDList, LinkInfo, Name, Relative Path, Working Dir and Arguments if they are present) |
||||
#IsUnicode bit 7 (0x00000080) - if set, the strings in the link are stored in Unicode (UTF-16LE) format; if not set, the strings are stored in ANSI format (usually the system's default code page) |
||||
#ForceNoLinkInfo bit 8 (0x00000100) - if set, the LinkInfo structure is not stored in the file even if the HasLinkInfo bit is set; this can be used to force the link to be resolved using only the information in the header and the optional strings, without using the LinkInfo structure |
||||
#HasExpString bit 9 (0x00000200) - if set, a null-terminated string containing an "environment variable" style string is present immediately following the header (or the LinkTargetIDList, LinkInfo, Name, Relative Path, Working Dir, Arguments and Icon Location if they are present); this string can contain environment variable references (e.g. %USERPROFILE%) that can be expanded to obtain the actual path of the link target |
||||
#RunInSeparateProcess bit 10 (0x00000400) - if set, the link target should be run in a separate process; if not set, the link target may be run in the same process as the caller |
||||
#Unused1 bit 11 (0x00000800) - reserved for future use; should be set to 0 |
||||
#HasDarwinID bit 12 (0x00001000) - if set, a null-terminated string containing a "Darwin ID" is present immediately following the header (or the LinkTargetIDList, LinkInfo, Name, Relative Path, Working Dir, Arguments, Icon Location and ExpString if they are present); this string can be used to identify the link target in a way that is independent of the file system (e.g. for links to Control Panel items or special folders) |
||||
#RunAsUser bit 13 (0x00002000) - if set, the link target should be run with the permissions of the user specified in the HasDarwinID string; if not set, the link target should be run with the permissions of the caller |
||||
#HasExpIcon bit 14 (0x00004000) - if set, a null-terminated string containing an "environment variable" style string for the icon location is present immediately following the header (or the LinkTargetIDList, LinkInfo, Name, Relative Path, Working Dir, Arguments, Icon Location, ExpString and DarwinID if they are present); this string can contain environment variable references that can be expanded to obtain the actual path of the icon for the link |
||||
#NoPidlAlias bit 15 (0x00008000) - if set, the link target should not be resolved using the PIDL alias mechanism; this can be used to prevent the link from being resolved to a different target if the original target is moved or renamed |
||||
#Unused2 bit 16 (0x00010000) - reserved for future use; should be set to 0 |
||||
#RunWithShimLayer bit 17 (0x00020000) - if set, the link target should be run with the application compatibility shim layer; if not set, the link target should be run without the shim layer |
||||
#ForceNoLinkTrack bit 18 (0x00040000) - if set, the link target should not be tracked by the shell's link tracking mechanism; this can be used to prevent the link from being automatically updated if the target is moved or renamed |
||||
#EnableTargetMetadata bit 19 (0x00080000) - if set, the link target should have metadata enabled; this can be used to allow the link to store additional information about the target (e.g. for links to files, the link can store the file's attributes, creation time, access time and modification time) |
||||
#DisableLinkPathTracking bit 20 (0x00100000) - if set, the link target should not be tracked by the shell's link path tracking mechanism; this can be used to prevent the link from being automatically updated if the target is moved or renamed based on its path |
||||
#DisableKnownFolderTracking bit 21 (0x00200000) - if set, the link target should not be tracked by the shell's known folder tracking mechanism; this can be used to prevent the link from being automatically updated if the target is moved or renamed based on its known folder ID |
||||
#DisableKnownFolderAlias bit 22 (0x00400000) - if set, the link target should not be aliased to a known folder; this can be used to prevent the link from being resolved to a different target if the original target is moved or renamed based on its known folder ID |
||||
#AllowLinkToLink bit 23 (0x00800000) - if set, the link target can be another link; if not set, the link target should not be another link (i.e. it should be a file or directory); this can be used to prevent the link from being resolved to a different target if the original target is moved or renamed based on the fact that it is a link |
||||
#UnaliasOnSave bit 24 (0x01000000) - if set, the link should be unaliased when it is saved; this can be used to prevent the link from being resolved to a different target if the original target is moved or renamed based on the fact that it is a link |
||||
#PreferEnvironmentPath bit 25 (0x02000000) - if set, the link should prefer to resolve the target using environment variable references; this can be used to allow the link to be resolved correctly even if the target is moved or renamed, as long as the environment variable references still point to the correct location |
||||
#KeepLocalIDListForUNCTarget bit 26 (0x04000000) - if set, the link should keep the local ID list for UNC targets; this can be used to allow the link to be resolved correctly even if the target is moved or renamed, as long as the local ID list still points to the correct location |
||||
# - the presence of these flags indicates the presence of optional structures in the .lnk file and also provides information about how to interpret the data in the file |
||||
proc Header_Get_LinkFlags {contents} { |
||||
set 4bytes [string range $contents 20 23] |
||||
set r [binary scan $4bytes i val] ;# i for little endian 32-bit signed int |
||||
return $val |
||||
} |
||||
|
||||
#offset hex:0x18 dec:24 4 bytes |
||||
#File attributes (FileAttributes) - bit field specifying the file attributes of the link target (if the EnableTargetMetadata flag is set in the LinkFlags field); this field is a bitwise combination of the following values: |
||||
proc Header_Get_FileAttributes {contents} { |
||||
if {![Header_Has_LinkFlag $contents "EnableTargetMetadata"]} { |
||||
return {} |
||||
} |
||||
set 4bytes [string range $contents 24 27] |
||||
set r [binary scan $4bytes i val] ;# i for little endian 32-bit signed int |
||||
set attrlist {} |
||||
if {$val & 0x00000001} {lappend attrlist "READONLY"} |
||||
if {$val & 0x00000002} {lappend attrlist "HIDDEN"} |
||||
if {$val & 0x00000004} {lappend attrlist "SYSTEM"} |
||||
if {$val & 0x00000010} {lappend attrlist "DIRECTORY"} |
||||
if {$val & 0x00000020} {lappend attrlist "ARCHIVE"} |
||||
if {$val & 0x00000040} {lappend attrlist "DEVICE"} |
||||
if {$val & 0x00000080} {lappend attrlist "NORMAL"} |
||||
if {$val & 0x00000100} {lappend attrlist "TEMPORARY"} |
||||
if {$val & 0x00000200} {lappend attrlist "SPARSE_FILE"} |
||||
if {$val & 0x00000400} {lappend attrlist "REPARSE_POINT"} |
||||
if {$val & 0x00000800} {lappend attrlist "COMPRESSED"} |
||||
if {$val & 0x00001000} {lappend attrlist "OFFLINE"} |
||||
if {$val & 0x00002000} {lappend attrlist "NOT_CONTENT_INDEXED"} |
||||
if {$val & 0x00004000} {lappend attrlist "ENCRYPTED"} |
||||
return $attrlist |
||||
} |
||||
proc Header_Get_FileAttributes_Raw {contents} { |
||||
if {![Header_Has_LinkFlag $contents "EnableTargetMetadata"]} { |
||||
return 0 |
||||
} |
||||
set 4bytes [string range $contents 24 27] |
||||
set r [binary scan $4bytes i val] ;# i for little endian 32-bit signed int |
||||
return $val |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
#offset hex:0x1C dec:28 8 bytes |
||||
#creation date and time (CreationTime) (FILETIME structure - 64-bit value representing the number of 100-nanosecond intervals since January 1, 1601 (UTC)) |
||||
proc Header_Get_CreationTime {contents} { |
||||
set 8bytes [string range $contents 28 35] |
||||
set r [binary scan $8bytes w val] ;# w for little endian 64-bit signed int |
||||
#convert FILETIME to human readable format - this is a bit complex because FILETIME is in 100-nanosecond intervals since January 1, 1601 (UTC) |
||||
#we can convert it to seconds and then to a human readable format |
||||
set seconds [expr {$val / 10000000.0}] |
||||
set epoch_seconds [expr {round($seconds) - 11644473600}] ;# number of seconds between January 1, 1601 and January 1, 1970 |
||||
set human_time [clock format $epoch_seconds -format "%Y-%m-%d %H:%M:%S" -gmt true] |
||||
return $human_time |
||||
} |
||||
proc Header_Get_CreationTime_Raw {contents} { |
||||
set 8bytes [string range $contents 28 35] |
||||
set r [binary scan $8bytes w val] ;# w for little endian 64-bit signed int |
||||
return $val |
||||
} |
||||
|
||||
#offset 36 8 bytes |
||||
#last access date and time (AccessTime) (FILETIME structure - 64-bit value representing the number of 100-nanosecond intervals since January 1, 1601 (UTC)) |
||||
proc Header_Get_AccessTime {contents} { |
||||
set 8bytes [string range $contents 36 43] |
||||
set r [binary scan $8bytes w val] ;# w for little endian 64-bit signed int |
||||
#convert FILETIME to human readable format - this is a bit complex because FILETIME is in 100-nanosecond intervals since January 1, 1601 (UTC) |
||||
#we can convert it to seconds and then to a human readable format |
||||
set seconds [expr {$val / 10000000.0}] |
||||
set epoch_seconds [expr {round($seconds) - 11644473600}] ;# number of seconds between January 1, 1601 and January 1, 1970 |
||||
set human_time [clock format $epoch_seconds -format "%Y-%m-%d %H:%M:%S" -gmt true] |
||||
return $human_time |
||||
} |
||||
proc Header_Get_AccessTime_Raw {contents} { |
||||
set 8bytes [string range $contents 36 43] |
||||
set r [binary scan $8bytes w val] ;# w for little endian 64-bit signed int |
||||
return $val |
||||
} |
||||
|
||||
#offset hex:0x2C dec:44 8 bytes |
||||
#last modification date and time (WriteTime) (FILETIME structure - 64-bit value representing the number of 100-nanosecond intervals since January 1, 1601 (UTC)) |
||||
proc Header_Get_WriteTime {contents} { |
||||
set 8bytes [string range $contents 44 51] |
||||
set r [binary scan $8bytes w val] ;# w for little endian 64-bit signed int |
||||
#convert FILETIME to human readable format - this is a bit complex because FILETIME is in 100-nanosecond intervals since January 1, 1601 (UTC) |
||||
#we can convert it to seconds and then to a human readable format |
||||
set seconds [expr {$val / 10000000.0}] |
||||
set epoch_seconds [expr {round($seconds) - 11644473600}] ;# number of seconds between January 1, 1601 and January 1, 1970 |
||||
set human_time [clock format $epoch_seconds -format "%Y-%m-%d %H:%M:%S" -gmt true] |
||||
return $human_time |
||||
} |
||||
proc Header_Get_WriteTime_Raw {contents} { |
||||
set 8bytes [string range $contents 44 51] |
||||
set r [binary scan $8bytes w val] ;# w for little endian 64-bit signed int |
||||
return $val |
||||
} |
||||
|
||||
#offset hex:0x34 dec:52 Bytes:4 - unsigned int |
||||
#file size in bytes (of target - low 32 bits if >4GB) |
||||
proc Header_Get_FileSize {contents} { |
||||
set 4bytes [string range $contents 52 55] |
||||
set r [binary scan $4bytes i val] |
||||
return $val |
||||
} |
||||
|
||||
#offset hex:0x38 dec:56 Bytes:4 - signed integer |
||||
#icon index value |
||||
proc Header_Get_IconIndex {contents} { |
||||
set 4bytes [string range $contents 56 59] |
||||
set r [binary scan $4bytes i val] |
||||
return $val |
||||
} |
||||
|
||||
#offset hex:0x3C dec:60 Bytes:4 - unsigned integer |
||||
#SW_SHOWNORMAL 0x00000001 |
||||
#SW_SHOWMAXIMIZED 0x00000001 |
||||
#SW_SHOWMINNOACTIVE 0x00000007 |
||||
# - all other values MUST be treated as SW_SHOWNORMAL |
||||
proc Header_Get_ShowCommand {contents} { |
||||
set 4bytes [string range $contents 60 63] |
||||
set r [binary scan $4bytes i val] |
||||
return $val |
||||
} |
||||
|
||||
#offset hex:0x40 dec:64 Bytes:2 |
||||
#Hot key |
||||
proc Header_Get_HotKey {contents} { |
||||
# Existing code that extracts the raw 16‑bit hotkey value: |
||||
set raw [Header_Get_HotKey_Raw $contents] |
||||
# The low byte holds the virtual‑key, high byte holds modifier flags |
||||
set vk [expr {$raw & 0xFF}] |
||||
set mods [expr {($raw >> 8) & 0xFF}] |
||||
set name [_vk_to_name $vk] |
||||
set modStr [_modifiers_to_string $mods] |
||||
if {$modStr eq ""} { |
||||
return $name |
||||
} else { |
||||
return "${modStr}+${name}" |
||||
} |
||||
} |
||||
proc Header_Get_HotKey_Raw {contents} { |
||||
set 2bytes [string range $contents 64 65] |
||||
set r [binary scan $2bytes s val] ;#short |
||||
return $val |
||||
} |
||||
proc _modifiers_to_string {mods} { |
||||
set parts {} |
||||
if {$mods & 0x01} {lappend parts "Shift"} |
||||
if {$mods & 0x02} {lappend parts "Ctrl"} |
||||
if {$mods & 0x04} {lappend parts "Alt"} |
||||
if {$mods & 0x08} {lappend parts "Win"} ;# optional |
||||
return [join $parts "+"] |
||||
} |
||||
proc _vk_to_name {vk} { |
||||
# Minimal map – extend as needed |
||||
array set vkMap { |
||||
0x00 "No key assigned" |
||||
0x08 Backspace 0x09 Tab 0x0D Return |
||||
0x10 Shift 0x11 Control 0x12 Alt |
||||
0x20 Space 0x21 PageUp 0x22 PageDown |
||||
0x23 End 0x24 Home 0x25 Left |
||||
0x26 Up 0x27 Right 0x28 Down |
||||
0x2D Insert 0x2E Delete |
||||
0x70 F1 0x71 F2 0x72 F3 |
||||
0x73 F4 0x74 F5 0x75 F6 |
||||
0x76 F7 0x77 F8 0x78 F9 |
||||
0x79 F10 0x7A F11 0x7B F12 |
||||
0x7c F13 0x7d F14 0x7e F15 |
||||
0x7f F16 0x80 F17 0x81 F18 |
||||
0x82 F19 0x83 F20 0x84 F21 |
||||
0x85 F22 0x86 F23 0x87 F24 |
||||
0x90 "NUM LOCK" 0x91 "SCROLL LOCK" |
||||
} |
||||
if {[info exists vkMap($vk)]} { |
||||
return $vkMap($vk) |
||||
} else { |
||||
if {$vk >= 0x30 && $vk <= 0x39} { |
||||
return [format "%c" $vk] ;# 0-9 |
||||
} elseif {$vk >= 0x41 && $vk <= 0x5A} { |
||||
return [format "%c" $vk] ;# A-Z |
||||
} |
||||
# fallback: hex representation |
||||
return [format "0x%02X" $vk] |
||||
} |
||||
} |
||||
|
||||
#offset hex:0x42 dec:66 Bytes:2 - reserved1 |
||||
proc Header_Get_Reserved1 {contents} { |
||||
set 2bytes [string range $contents 66 67] |
||||
set r [binary scan $2bytes s val] ;#short |
||||
return $val |
||||
} |
||||
|
||||
#offset hex:0x44 dec:68 Bytes:4 - reserved2 |
||||
proc Header_Get_Reserved2 {contents} { |
||||
set 4bytes [string range $contents 68 71] |
||||
set r [binary scan $4bytes i val] ;# i for little endian 32-bit signed int |
||||
return $val |
||||
} |
||||
|
||||
#offset hex:0x48 dec:72 Bytes:4 - reserved3 |
||||
proc Header_Get_Reserved3 {contents} { |
||||
set 4bytes [string range $contents 72 75] |
||||
set r [binary scan $4bytes i val] ;# i for little endian 32-bit signed int |
||||
return $val |
||||
} |
||||
|
||||
#end of 76 byte header |
||||
|
||||
proc Get_LinkTargetIDList_size {contents} { |
||||
if {[Header_Has_LinkFlag $contents "A"]} { |
||||
set 2bytes [string range $contents 76 77] |
||||
set r [binary scan $2bytes s val] ;#short |
||||
#logger |
||||
#puts stderr "LinkTargetIDList_size: $val" |
||||
return $val |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
proc Get_LinkInfo_content {contents} { |
||||
set idlist_size [Get_LinkTargetIDList_size $contents] |
||||
if {$idlist_size == 0} { |
||||
set offset 0 |
||||
} else { |
||||
set offset [expr {2 + $idlist_size}] ;#LinkTargetIdList IDListSize field + value |
||||
} |
||||
set linkinfo_start [expr {76 + $offset}] |
||||
if {[Header_Has_LinkFlag $contents "B"]} { |
||||
#puts stderr "linkinfo_start: $linkinfo_start" |
||||
set 4bytes [string range $contents $linkinfo_start $linkinfo_start+3] |
||||
binary scan $4bytes i val ;#size *including* these 4 bytes |
||||
set linkinfo_content [string range $contents $linkinfo_start [expr {$linkinfo_start + $val -1}]] |
||||
return [dict create linkinfo_start $linkinfo_start size $val next_start [expr {$linkinfo_start + $val}] content $linkinfo_content] |
||||
} else { |
||||
return [dict create linkinfo_start $linkinfo_start size 0 next_start $linkinfo_start content ""] |
||||
} |
||||
} |
||||
|
||||
proc LinkInfo_get_fields {linkinfocontent} { |
||||
set 4bytes [string range $linkinfocontent 0 3] |
||||
binary scan $4bytes i val ;#size *including* these 4 bytes |
||||
set bytes_linkinfoheadersize [string range $linkinfocontent 4 7] |
||||
set bytes_linkinfoflags [string range $linkinfocontent 8 11] |
||||
set r [binary scan $4bytes i flags] ;# i for little endian 32-bit signed int |
||||
#puts "linkinfoflags: $flags" |
||||
|
||||
set localbasepath "" |
||||
set commonpathsuffix "" |
||||
|
||||
#REVIEW - flags problem? |
||||
if {$flags & 1} { |
||||
#VolumeIDAndLocalBasePath |
||||
#logger |
||||
#puts stderr "VolumeIDAndLocalBasePath" |
||||
} |
||||
if {$flags & 2} { |
||||
#logger |
||||
#puts stderr "CommonNetworkRelativeLinkAndPathSuffix" |
||||
} |
||||
set bytes_volumeid_offset [string range $linkinfocontent 12 15] |
||||
set bytes_localbasepath_offset [string range $linkinfocontent 16 19] ;# a |
||||
set bytes_commonnetworkrelativelinkoffset [string range $linkinfocontent 20 23] |
||||
set bytes_commonpathsuffix_offset [string range $linkinfocontent 24 27] ;# a |
||||
|
||||
binary scan $bytes_localbasepath_offset i bp_offset |
||||
if {$bp_offset > 0} { |
||||
set tail [string range $linkinfocontent $bp_offset end] |
||||
set stringterminator 0 |
||||
set i 0 |
||||
set localbasepath "" |
||||
#TODO |
||||
while {!$stringterminator & $i < 100} { |
||||
set c [string index $tail $i] |
||||
if {$c eq "\x00"} { |
||||
set stringterminator 1 |
||||
} else { |
||||
append localbasepath $c |
||||
} |
||||
incr i |
||||
} |
||||
} |
||||
binary scan $bytes_commonpathsuffix_offset i cps_offset |
||||
if {$cps_offset > 0} { |
||||
set tail [string range $linkinfocontent $cps_offset end] |
||||
set stringterminator 0 |
||||
set i 0 |
||||
set commonpathsuffix "" |
||||
#TODO |
||||
while {!$stringterminator && $i < 100} { |
||||
set c [string index $tail $i] |
||||
if {$c eq "\x00"} { |
||||
set stringterminator 1 |
||||
} else { |
||||
append commonpathsuffix $c |
||||
} |
||||
incr i |
||||
} |
||||
} |
||||
|
||||
|
||||
return [dict create localbasepath $localbasepath commonpathsuffix $commonpathsuffix] |
||||
} |
||||
|
||||
proc contents_get_info {contents} { |
||||
|
||||
#todo - return something like the perl lnk-parse-1.0.pl script? |
||||
|
||||
#Link File: C:/repo/jn/tclmodules/tomlish/src/modules/test/#modpod-tomlish-0.1.0/suites/all/arrays_1.toml#roundtrip+roundtrip_files+arrays_1.toml.fauxlink.lnk |
||||
#Link Flags: HAS SHELLIDLIST | POINTS TO FILE/DIR | NO DESCRIPTION | HAS RELATIVE PATH STRING | HAS WORKING DIRECTORY | NO CMD LINE ARGS | NO CUSTOM ICON | |
||||
#File Attributes: ARCHIVE |
||||
#Create Time: Sun Jul 14 2024 10:41:34 |
||||
#Last Accessed time: Sat Sept 21 2024 02:46:10 |
||||
#Last Modified Time: Tue Sept 10 2024 17:16:07 |
||||
#Target Length: 479 |
||||
#Icon Index: 0 |
||||
#ShowWnd: 1 SW_NORMAL |
||||
#HotKey: 0 |
||||
#(App Path:) Remaining Path: repo\jn\tclmodules\tomlish\src\modules\test\#modpod-tomlish-0.1.0\suites\roundtrip\roundtrip_files\arrays_1.toml |
||||
#Relative Path: ..\roundtrip\roundtrip_files\arrays_1.toml |
||||
#Working Dir: C:\repo\jn\tclmodules\tomlish\src\modules\test\#modpod-tomlish-0.1.0\suites\roundtrip\roundtrip_files |
||||
|
||||
variable LinkFlags |
||||
set flags_enabled [list] |
||||
dict for {k v} $LinkFlags { |
||||
if {[Header_Has_LinkFlag $contents $k] > 0} { |
||||
lappend flags_enabled $k |
||||
} |
||||
} |
||||
|
||||
set showcommand_val [Header_Get_ShowCommand $contents] |
||||
switch -- $showcommand_val { |
||||
1 { |
||||
set showwnd [list 1 SW_SHOWNORMAL] |
||||
} |
||||
3 { |
||||
set showwnd [list 3 SW_SHOWMAXIMIZED] |
||||
} |
||||
7 { |
||||
set showwnd [list 7 SW_SHOWMINNOACTIVE] |
||||
} |
||||
default { |
||||
set showwnd [list $showcommand_val SW_SHOWNORMAL-effective] |
||||
} |
||||
} |
||||
|
||||
set linkinfo_content_dict [Get_LinkInfo_content $contents] |
||||
set localbase_path "" |
||||
set suffix_path "" |
||||
set linkinfocontent [dict get $linkinfo_content_dict content] |
||||
set link_target "" |
||||
if {$linkinfocontent ne ""} { |
||||
set linkfields [LinkInfo_get_fields $linkinfocontent] |
||||
set localbase_path [dict get $linkfields localbasepath] |
||||
set suffix_path [dict get $linkfields commonpathsuffix] |
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
set link_target [file join $localbase_path $suffix_path] |
||||
} else { |
||||
set suffix_path [string trimleft [string map {\\ /} $suffix_path] /] |
||||
if {[regexp {([a-zA-Z]):\\(.*)} $localbase_path _match drive_letter tail]} { |
||||
set localbase_path [string map {\\ /} $localbase_path] |
||||
set tail [string trimleft [string map {\\ /} $tail] /] |
||||
set link_target "" |
||||
#shortcut basepath is a windows path with drive letter - try to resolve it on unix by looking for a corresponding mount from fstab or a point under /mnt |
||||
set mountinfo [exec mount] |
||||
foreach line [split $mountinfo "\n"] { |
||||
#review - a more specific mount target might exist that includes the drive letter as part of the mount point name and is a longer prefix of the localbase_path |
||||
#- we should probably look for the longest prefix match rather than just the drive letter |
||||
if {[regexp -nocase -- [string cat ^$drive_letter {:\\\s+on\s+(\S+)}] $line _match mount_point]} { |
||||
set link_target [file join $mount_point $tail $suffix_path] |
||||
break |
||||
} |
||||
} |
||||
if {$link_target eq ""} { |
||||
#review - under what circumstances could this happen? If the drive letter doesn't match any mount points, then /mnt/drive_letter should generally already have been found above above |
||||
# - However, it may be possible for /mnt/drive_Letter to still exist even if it's not reflected in the output of mount or the output of mount is in an unexpected format. |
||||
|
||||
#nothing in mount result matches the drive letter - try looking for a mount point under /mnt with the drive letter as the name |
||||
if {[file exists /mnt/$drive_letter]} { |
||||
set link_target [file join /mnt/$drive_letter $tail $suffix_path] |
||||
} else { |
||||
if {$drive_letter eq [string tolower $drive_letter]]} { |
||||
set op_drive_letter [string toupper $drive_letter] |
||||
} else { |
||||
set op_drive_letter [string tolower $drive_letter] |
||||
} |
||||
if {[file exists /mnt/$op_drive_letter]} { |
||||
set link_target [file join /mnt/$op_drive_letter $tail $suffix_path] |
||||
} else { |
||||
#leave as is except for backslashes converted to forward |
||||
#- probably won't resolve correctly unless the unix system has a folder named drive_letter: in the current folder with a copy of the original filestructure. |
||||
set link_target [file join $localbase_path $suffix_path] |
||||
} |
||||
} |
||||
} else { |
||||
#shortcut basepath is a windows path with drive letter and we found a matching mount point - link_target is set to the resolved path |
||||
} |
||||
} else { |
||||
#shortcut basepath doesn't match expected windows path format - just join it with the suffix and hope for the best |
||||
#could be something like a network path or it could be something else entirely |
||||
set link_target [file join $localbase_path $suffix_path] |
||||
} |
||||
} |
||||
} |
||||
|
||||
set result [dict create\ |
||||
link_target $link_target\ |
||||
link_flags $flags_enabled\ |
||||
file_attributes [Header_Get_FileAttributes $contents]\ |
||||
creation_time [Header_Get_CreationTime $contents]\ |
||||
access_time [Header_Get_AccessTime $contents]\ |
||||
write_time [Header_Get_WriteTime $contents]\ |
||||
target_length [Header_Get_FileSize $contents]\ |
||||
icon_index "<unimplemented>"\ |
||||
showwnd "$showwnd"\ |
||||
hotkey [Header_Get_HotKey $contents]\ |
||||
relative_path "?"\ |
||||
] |
||||
} |
||||
|
||||
proc file_check_header {path} { |
||||
#*** !doctools |
||||
#[call [fun file_check_header] [arg path] ] |
||||
#[para]Return 0|1 |
||||
#[para]Determines if the .lnk file specified in path has a valid header for a windows shortcut |
||||
set c [Get_contents $path 20] |
||||
return [Contents_check_header $c] |
||||
} |
||||
namespace eval argdoc { |
||||
variable PUNKARGS |
||||
lappend PUNKARGS [list { |
||||
@id -id ::punk::winlnk::resolve |
||||
@cmd -name punk::winlnk::resolve\ |
||||
-summary\ |
||||
"Return information about a .lnk file (windows shortcut)"\ |
||||
-help\ |
||||
"Return a dict of info obtained by parsing the binary data in a windows .lnk file. |
||||
If the .lnk header check fails, then the .lnk file probably isn't really a shortcut |
||||
file and the dictionary will contain an 'error' key." |
||||
@values -min 1 -max 1 |
||||
path -type string -help "Path to the .lnk file to resolve" |
||||
}] |
||||
} |
||||
proc resolve {path} { |
||||
#*** !doctools |
||||
#[call [fun resolve] [arg path] ] |
||||
#[para] Return a dict of info obtained by parsing the binary data in a windows .lnk file |
||||
#[para] If the .lnk header check fails, then the .lnk file probably isn't really a shortcut file and the dictionary will contain an 'error' key |
||||
set c [Get_contents $path] |
||||
if {[Contents_check_header $c]} { |
||||
return [contents_get_info $c] |
||||
} else { |
||||
return [dict create error "lnk_header_check_failed"] |
||||
} |
||||
} |
||||
namespace eval argdoc { |
||||
variable PUNKARGS |
||||
lappend PUNKARGS [list { |
||||
@id -id ::punk::winlnk::file_show_info |
||||
@cmd -name punk::winlnk::file_show_info\ |
||||
-summary\ |
||||
"Show information about a .lnk file (windows shortcut)"\ |
||||
-help\ |
||||
"Print to stdout the information obtained by parsing the binary data in a windows .lnk file, in a human readable format. |
||||
If the .lnk header check fails, then the .lnk file probably isn't really a shortcut file and an error message will be printed." |
||||
@values -min 1 -max 1 |
||||
path -type string -help "Path to the .lnk file to resolve" |
||||
}] |
||||
} |
||||
proc file_show_info {path} { |
||||
package require punk::lib |
||||
punk::lib::showdict [resolve $path] * |
||||
} |
||||
namespace eval argdoc { |
||||
variable PUNKARGS |
||||
lappend PUNKARGS [list { |
||||
@id -id ::punk::winlnk::target |
||||
@cmd -name punk::winlnk::target\ |
||||
-summary\ |
||||
"Return the target path of a .lnk file (windows shortcut)"\ |
||||
-help\ |
||||
"Return the target path of the .lnk file specified in path. |
||||
This is a convenience function that extracts the target path from the .lnk file and returns it directly, |
||||
without all the additional information that resolve provides. If the .lnk header check fails, then |
||||
the .lnk file probably isn't really a shortcut file and an error message will be returned." |
||||
@values -min 1 -max 1 |
||||
path -type string -help "Path to the .lnk file to resolve" |
||||
}] |
||||
} |
||||
proc target {path} { |
||||
#*** !doctools |
||||
#[call [fun target] [arg path] ] |
||||
#[para]Return the target path of the .lnk file specified in path |
||||
set info [resolve $path] |
||||
if {[dict exists $info error]} { |
||||
error [dict get $info error] |
||||
} else { |
||||
return [dict get $info link_target] |
||||
} |
||||
} |
||||
|
||||
#proc sample1 {p1 n args} { |
||||
# #*** !doctools |
||||
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||
# #[para]Description of sample1 |
||||
# #[para] Arguments: |
||||
# # [list_begin arguments] |
||||
# # [arg_def tring p1] A description of string argument p1. |
||||
# # [arg_def integer n] A description of integer argument n. |
||||
# # [list_end] |
||||
# return "ok" |
||||
#} |
||||
|
||||
|
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::winlnk ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::winlnk::lib { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::winlnk::lib}] |
||||
#[para] Secondary functions that are part of the API |
||||
#[list_begin definitions] |
||||
|
||||
#proc utility1 {p1 args} { |
||||
# #*** !doctools |
||||
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||
# #[para]Description of utility1 |
||||
# return 1 |
||||
#} |
||||
|
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::winlnk::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
#tcl::namespace::eval punk::winlnk::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::winlnk::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
|
||||
|
||||
#} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
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::winlnk |
||||
} |
||||
## Ready |
||||
package provide punk::winlnk [tcl::namespace::eval punk::winlnk { |
||||
variable pkg punk::winlnk |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
@ -1,829 +0,0 @@
|
||||
#package require logger |
||||
|
||||
|
||||
package require Thread |
||||
|
||||
namespace eval shellthread { |
||||
|
||||
proc iso8601 {{tsmicros ""}} { |
||||
if {$tsmicros eq ""} { |
||||
set tsmicros [tcl::clock::microseconds] |
||||
} else { |
||||
set microsnow [tcl::clock::microseconds] |
||||
if {[tcl::string::length $tsmicros] != [tcl::string::length $microsnow]} { |
||||
error "iso8601 requires 'clock micros' or empty string to create timestamp" |
||||
} |
||||
} |
||||
set seconds [expr {$tsmicros / 1000000}] |
||||
return [tcl::clock::format $seconds -format "%Y-%m-%d_%H-%M-%S"] |
||||
} |
||||
} |
||||
|
||||
namespace eval shellthread::worker { |
||||
variable settings |
||||
variable sysloghost_port |
||||
variable sock |
||||
variable logfile "" |
||||
variable fd |
||||
variable client_ids [list] |
||||
variable ts_start_micros |
||||
variable errorlist [list] |
||||
variable inpipe "" |
||||
|
||||
proc bgerror {args} { |
||||
variable errorlist |
||||
lappend errorlist $args |
||||
} |
||||
proc send_errors_now {tidcli} { |
||||
variable errorlist |
||||
thread::send -async $tidcli [list shellthread::manager::report_worker_errors [list worker_tid [thread::id] errors $errorlist]] |
||||
} |
||||
proc add_client_tid {tidcli} { |
||||
variable client_ids |
||||
if {$tidcli ni $client_ids} { |
||||
lappend client_ids $tidcli |
||||
} |
||||
} |
||||
proc init {tidclient start_m settingsdict} { |
||||
variable sysloghost_port |
||||
variable logfile |
||||
variable settings |
||||
interp bgerror {} shellthread::worker::bgerror |
||||
#package require overtype ;#overtype uses tcllib textutil, punk::char etc - currently too heavyweight in terms of loading time for use in threads. |
||||
variable client_ids |
||||
variable ts_start_micros |
||||
lappend client_ids $tidclient |
||||
set ts_start_micros $start_m |
||||
|
||||
set defaults [list -raw 0 -file "" -syslog "" -direction out] |
||||
set settings [dict merge $defaults $settingsdict] |
||||
|
||||
set syslog [dict get $settings -syslog] |
||||
if {[string length $syslog]} { |
||||
lassign [split $syslog :] s_host s_port |
||||
set sysloghost_port [list $s_host $s_port] |
||||
if {[catch {package require udp} errm]} { |
||||
#disable rather than bomb and interfere with any -file being written |
||||
#review - log/notify? |
||||
set sysloghost_port "" |
||||
} |
||||
} else { |
||||
set sysloghost_port "" |
||||
} |
||||
|
||||
set logfile [dict get $settings -file] |
||||
} |
||||
|
||||
proc start_pipe_read {source readchan args} { |
||||
#assume 1 inpipe for now |
||||
variable inpipe |
||||
variable sysloghost_port |
||||
variable logfile |
||||
|
||||
set defaults [dict create -buffering \uFFFF ] |
||||
set opts [dict merge $defaults $args] |
||||
if {[dict exists $opts -readbuffering]} { |
||||
set readbuffering [dict get $opts -readbuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
#get buffering setting from the channel as it was set prior to thread::transfer |
||||
set readbuffering [chan configure $readchan -buffering] |
||||
} else { |
||||
set readbuffering [dict get $opts -buffering] |
||||
chan configure $readchan -buffering $readbuffering |
||||
} |
||||
} |
||||
if {[dict exists $opts -writebuffering]} { |
||||
set writebuffering [dict get $opts -writebuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
set writebuffering line |
||||
#set writebuffering [chan configure $writechan -buffering] |
||||
} else { |
||||
set writebuffering [dict get $opts -buffering] |
||||
#can configure $writechan -buffering $writebuffering |
||||
} |
||||
} |
||||
|
||||
chan configure $readchan -translation lf |
||||
|
||||
if {$readchan ni [chan names]} { |
||||
error "shellthread::worker::start_pipe_read - inpipe not configured. Use shellthread::manager::set_pipe_read_from_client to thread::transfer the pipe end" |
||||
} |
||||
set inpipe $readchan |
||||
chan configure $readchan -blocking 0 |
||||
set waitvar ::shellthread::worker::wait($inpipe,[clock micros]) |
||||
|
||||
#tcl::chan::fifo2 based pipe seems slower to establish events upon than Memchan |
||||
chan event $readchan readable [list ::shellthread::worker::pipe_read $readchan $source $waitvar $readbuffering $writebuffering] |
||||
vwait $waitvar |
||||
} |
||||
proc pipe_read {chan source waitfor readbuffering writebuffering} { |
||||
if {$readbuffering eq "line"} { |
||||
set chunksize [chan gets $chan chunk] |
||||
if {$chunksize >= 0} { |
||||
if {![chan eof $chan]} { |
||||
::shellthread::worker::log pipe 0 - $source - info $chunk\n $writebuffering |
||||
} else { |
||||
::shellthread::worker::log pipe 0 - $source - info $chunk $writebuffering |
||||
} |
||||
} |
||||
} else { |
||||
set chunk [chan read $chan] |
||||
::shellthread::worker::log pipe 0 - $source - info $chunk $writebuffering |
||||
} |
||||
if {[chan eof $chan]} { |
||||
chan event $chan readable {} |
||||
set $waitfor "pipe" |
||||
chan close $chan |
||||
} |
||||
} |
||||
|
||||
proc start_pipe_write {source writechan args} { |
||||
variable outpipe |
||||
set defaults [dict create -buffering \uFFFF ] |
||||
set opts [dict merge $defaults $args] |
||||
|
||||
#todo! |
||||
set readchan stdin |
||||
|
||||
if {[dict exists $opts -readbuffering]} { |
||||
set readbuffering [dict get $opts -readbuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
set readbuffering [chan configure $readchan -buffering] |
||||
} else { |
||||
set readbuffering [dict get $opts -buffering] |
||||
chan configure $readchan -buffering $readbuffering |
||||
} |
||||
} |
||||
if {[dict exists $opts -writebuffering]} { |
||||
set writebuffering [dict get $opts -writebuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
#nothing explicitly set - take from transferred channel |
||||
set writebuffering [chan configure $writechan -buffering] |
||||
} else { |
||||
set writebuffering [dict get $opts -buffering] |
||||
can configure $writechan -buffering $writebuffering |
||||
} |
||||
} |
||||
|
||||
if {$writechan ni [chan names]} { |
||||
error "shellthread::worker::start_pipe_write - outpipe not configured. Use shellthread::manager::set_pipe_write_to_client to thread::transfer the pipe end" |
||||
} |
||||
set outpipe $writechan |
||||
chan configure $readchan -blocking 0 |
||||
chan configure $writechan -blocking 0 |
||||
set waitvar ::shellthread::worker::wait($outpipe,[clock micros]) |
||||
|
||||
chan event $readchan readable [list apply {{chan writechan source waitfor readbuffering} { |
||||
if {$readbuffering eq "line"} { |
||||
set chunksize [chan gets $chan chunk] |
||||
if {$chunksize >= 0} { |
||||
if {![chan eof $chan]} { |
||||
puts $writechan $chunk |
||||
} else { |
||||
puts -nonewline $writechan $chunk |
||||
} |
||||
} |
||||
} else { |
||||
set chunk [chan read $chan] |
||||
puts -nonewline $writechan $chunk |
||||
} |
||||
if {[chan eof $chan]} { |
||||
chan event $chan readable {} |
||||
set $waitfor "pipe" |
||||
chan close $writechan |
||||
if {$chan ne "stdin"} { |
||||
chan close $chan |
||||
} |
||||
} |
||||
}} $readchan $writechan $source $waitvar $readbuffering] |
||||
|
||||
vwait $waitvar |
||||
} |
||||
|
||||
|
||||
proc _initsock {} { |
||||
variable sysloghost_port |
||||
variable sock |
||||
if {[string length $sysloghost_port]} { |
||||
if {[catch {chan configure $sock} state]} { |
||||
set sock [udp_open] |
||||
chan configure $sock -buffering none -translation binary |
||||
chan configure $sock -remote $sysloghost_port |
||||
} |
||||
} |
||||
} |
||||
proc _reconnect {} { |
||||
variable sock |
||||
catch {close $sock} |
||||
_initsock |
||||
return [chan configure $sock] |
||||
} |
||||
|
||||
proc send_info {client_tid ts_sent source msg} { |
||||
set ts_received [clock micros] |
||||
set lag_micros [expr {$ts_received - $ts_sent}] |
||||
set lag [expr {$lag_micros / 1000000.0}] ;#lag as x.xxxxxx seconds |
||||
log $client_tid $ts_sent $lag $source - info $msg line 1 |
||||
} |
||||
proc log {client_tid ts_sent lag source service level msg writebuffering {islog 0}} { |
||||
variable sock |
||||
variable fd |
||||
variable sysloghost_port |
||||
variable logfile |
||||
variable settings |
||||
|
||||
set logchunk $msg |
||||
|
||||
if {![dict get $settings -raw]} { |
||||
set tail_crlf 0 |
||||
set tail_lf 0 |
||||
set tail_cr 0 |
||||
#for cooked - always remove the trailing newline before splitting.. |
||||
# |
||||
#note that if we got our data from reading a non-line-buffered binary channel - then this naive line splitting will not split neatly for mixed line-endings. |
||||
# |
||||
#Possibly not critical as cooked is for logging and we are still preserving all \r and \n chars - but review and consider implementing a better split |
||||
#but add it back exactly as it was afterwards |
||||
#we can always split on \n - and any adjacent \r will be preserved in the rejoin |
||||
set lastchar [string range $logchunk end end] |
||||
if {[string range $logchunk end-1 end] eq "\r\n"} { |
||||
set tail_crlf 1 |
||||
set logchunk [string range $logchunk 0 end-2] |
||||
} else { |
||||
if {$lastchar eq "\n"} { |
||||
set tail_lf 1 |
||||
set logchunk [string range $logchunk 0 end-1] |
||||
} elseif {$lastchar eq "\r"} { |
||||
#\r line-endings are obsolete..and unlikely... and ugly as they can hide characters on the console. but we'll pass through anyway. |
||||
set tail_cr 1 |
||||
set logchunk [string range $logchunk 0 end-1] |
||||
} else { |
||||
#possibly a single line with no linefeed.. or has linefeeds only in the middle |
||||
} |
||||
} |
||||
|
||||
if {$ts_sent != 0} { |
||||
set micros [lindex [split [expr {$ts_sent / 1000000.0}] .] end] |
||||
set time_info [::shellthread::iso8601 $ts_sent].$micros |
||||
#set time_info "${time_info}+$lag" |
||||
set lagfp "+[format %f $lag]" |
||||
} else { |
||||
#from pipe - no ts_sent/lag info available |
||||
set time_info "" |
||||
set lagfp "" |
||||
} |
||||
|
||||
set idtail [string range $client_tid end-8 end] ;#enough for display purposes id - mostly zeros anyway |
||||
|
||||
|
||||
#set col0 [string repeat " " 9] |
||||
#set col1 [string repeat " " 27] |
||||
#set col2 [string repeat " " 11] |
||||
#set col3 [string repeat " " 22] |
||||
##do not columnize the final data column or append to tail - or we could muck up the crlf integrity |
||||
#lassign [list [overtype::left $col0 $idtail] [overtype::left $col1 $time_info] [overtype::left $col2 $lagfp] [overtype::left $col3 $source]] c0 c1 c2 c3 |
||||
|
||||
set w0 9 |
||||
set w1 27 |
||||
set w2 11 |
||||
set w3 22 ;#review - this can truncate source name without indication tail is missing |
||||
#do not columnize the final data column or append to tail - or we could muck up the crlf integrity |
||||
lassign [list \ |
||||
[format %-${w0}s $idtail]\ |
||||
[format %-${w1}s $time_info]\ |
||||
[format %-${w2}s $lagfp]\ |
||||
[format %-${w3}s $source]\ |
||||
] c0 c1 c2 c3 |
||||
set c2_blank [string repeat " " $w2] |
||||
|
||||
|
||||
#split on \n no matter the actual line-ending in use |
||||
#shouldn't matter as long as we don't add anything at the end of the line other than the raw data |
||||
#ie - don't quote or add spaces |
||||
set lines [split $logchunk \n] |
||||
|
||||
set i 1 |
||||
set outlines [list] |
||||
foreach ln $lines { |
||||
if {$i == 1} { |
||||
lappend outlines "$c0 $c1 $c2 $c3 $ln" |
||||
} else { |
||||
lappend outlines "$c0 $c1 $c2_blank $c3 $ln" |
||||
} |
||||
incr i |
||||
} |
||||
if {$tail_lf} { |
||||
set logchunk "[join $outlines \n]\n" |
||||
} elseif {$tail_crlf} { |
||||
set logchunk "[join $outlines \r\n]\r\n" |
||||
} elseif {$tail_cr} { |
||||
set logchunk "[join $outlines \r]\r" |
||||
} else { |
||||
#no trailing linefeed |
||||
set logchunk [join $outlines \n] |
||||
|
||||
} |
||||
|
||||
#set logchunk "[overtype::left $col0 $idtail] [overtype::left $col1 $time_info] [overtype::left $col2 "+$lagfp"] [overtype::left $col3 $source] $msg" |
||||
} |
||||
|
||||
if {[string length $sysloghost_port]} { |
||||
_initsock |
||||
catch {puts -nonewline $sock $logchunk} |
||||
} |
||||
#todo - sockets etc? |
||||
if {[string length $logfile]} { |
||||
#todo - setting to maintain open filehandle and reduce io. |
||||
# possible settings for buffersize - and maybe logrotation, although this could be left to client |
||||
#for now - default to safe option of open/close each write despite the overhead. |
||||
set fd [open $logfile a] |
||||
chan configure $fd -translation auto -buffering $writebuffering |
||||
#whether line buffered or not - by now our logchunk includes newlines |
||||
puts -nonewline $fd $logchunk |
||||
close $fd |
||||
} |
||||
} |
||||
|
||||
# - withdraw just this client |
||||
proc finish {tidclient} { |
||||
variable client_ids |
||||
if {($tidclient in $clientids) && ([llength $clientids] == 1)} { |
||||
terminate $tidclient |
||||
} else { |
||||
set posn [lsearch $client_ids $tidclient] |
||||
set client_ids [lreplace $clientids $posn $posn] |
||||
} |
||||
} |
||||
|
||||
#allow any client to terminate |
||||
proc terminate {tidclient} { |
||||
variable sock |
||||
variable fd |
||||
variable client_ids |
||||
if {$tidclient in $client_ids} { |
||||
catch {close $sock} |
||||
catch {close $fd} |
||||
set client_ids [list] |
||||
#review use of thread::release -wait |
||||
#docs indicate deprecated for regular use, and that we should use thread::join |
||||
#however.. how can we set a timeout on a thread::join ? |
||||
#by telling the thread to release itself - we can wait on the thread::send variable |
||||
# This needs review - because it's unclear that -wait even works on self |
||||
# (what does it mean to wait for the target thread to exit if the target is self??) |
||||
thread::release -wait |
||||
return [thread::id] |
||||
} else { |
||||
return "" |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
namespace eval shellthread::manager { |
||||
variable workers [dict create] |
||||
variable worker_errors [list] |
||||
variable timeouts |
||||
|
||||
variable free_threads [list] |
||||
#variable log_threads |
||||
|
||||
proc dict_getdef {dictValue args} { |
||||
if {[llength $args] < 2} { |
||||
error {wrong # args: should be "dict_getdef dictValue ?key ...? key default"} |
||||
} |
||||
set keys [lrange $args 0 end-1] |
||||
if {[tcl::dict::exists $dictValue {*}$keys]} { |
||||
return [tcl::dict::get $dictValue {*}$keys] |
||||
} else { |
||||
return [lindex $args end] |
||||
} |
||||
} |
||||
#new datastructure regarding workers and sourcetags required. |
||||
#one worker can service multiple sourcetags - but each sourcetag may be used by multiple threads too. |
||||
#generally each thread will use a specific sourcetag - but we may have pools doing similar things which log to same destination. |
||||
# |
||||
#As a convention we may use a sourcetag for the thread which started the worker that isn't actually used for logging - but as a common target for joins |
||||
#If the thread which started the thread calls leave_worker with that 'primary' sourcetag it means others won't be able to use that target - which seems reasonable. |
||||
#If another thread want's to maintain joinability beyond the span provided by the starting client, |
||||
#it can join with both the primary tag and a tag it will actually use for logging. |
||||
#A thread can join the logger with any existingtag - not just the 'primary' |
||||
#(which is arbitrary anyway. It will usually be the first in the list - but may be unsubscribed by clients and disappear) |
||||
proc join_worker {existingtag sourcetaglist} { |
||||
set client_tid [thread::id] |
||||
#todo - allow a source to piggyback on existing worker by referencing one of the sourcetags already using the worker |
||||
} |
||||
|
||||
proc new_pipe_worker {sourcetaglist {settingsdict {}}} { |
||||
if {[dict exists $settingsdict -workertype]} { |
||||
if {[string tolower [dict get $settingsdict -workertype]] ne "pipe"} { |
||||
error "new_pipe_worker error: -workertype ne 'pipe'. Set to 'pipe' or leave empty" |
||||
} |
||||
} |
||||
dict set settingsdict -workertype pipe |
||||
new_worker $sourcetaglist $settingsdict |
||||
} |
||||
|
||||
#it is up to caller to use a unique sourcetag (e.g by prefixing with own thread::id etc) |
||||
# This allows multiple threads to more easily write to the same named sourcetag if necessary |
||||
# todo - change sourcetag for a list of tags which will be handled by the same thread. e.g for multiple threads logging to same file |
||||
# |
||||
# todo - some protection mechanism for case where target is a file to stop creation of multiple worker threads writing to same file. |
||||
# Even if we use open fd,close fd wrapped around writes.. it is probably undesirable to have multiple threads with same target |
||||
# On the other hand socket targets such as UDP can happily be written to by multiple threads. |
||||
# For now the mechanism is that a call to new_worker (rename to open_worker?) will join the same thread if a sourcetag matches. |
||||
# but, as sourcetags can get removed(unsubbed via leave_worker) this doesn't guarantee two threads with same -file settings won't fight. |
||||
# Also.. the settingsdict is ignored when joining with a tag that exists.. this is problematic.. e.g logrotation where previous file still being written by existing worker |
||||
# todo - rename 'sourcetag' concept to 'targettag' ?? the concept is a mixture of both.. it is somewhat analagous to a syslog 'facility' |
||||
# probably new_worker should disallow auto-joining and we allow different workers to handle same tags simultaneously to support overlap during logrotation etc. |
||||
proc new_worker {sourcetaglist {settingsdict {}}} { |
||||
variable workers |
||||
set ts_start [clock micros] |
||||
set tidclient [thread::id] |
||||
set sourcetag [lindex $sourcetaglist 0] ;#todo - use all |
||||
|
||||
set defaults [dict create\ |
||||
-workertype message\ |
||||
] |
||||
set settingsdict [dict merge $defaults $settingsdict] |
||||
|
||||
set workertype [string tolower [dict get $settingsdict -workertype]] |
||||
set known_workertypes [list pipe message] |
||||
if {$workertype ni $known_workertypes} { |
||||
error "new_worker - unknown -workertype $workertype. Expected one of '$known_workertypes'" |
||||
} |
||||
|
||||
if {[dict exists $workers $sourcetag]} { |
||||
set winfo [dict get $workers $sourcetag] |
||||
if {[dict get $winfo tid] ne "noop" && [thread::exists [dict get $winfo tid]]} { |
||||
#add our client-info to existing worker thread |
||||
dict lappend winfo list_client_tids $tidclient |
||||
dict set workers $sourcetag $winfo ;#writeback |
||||
return [dict get $winfo tid] |
||||
} |
||||
} |
||||
|
||||
#noop fake worker for empty syslog and empty file |
||||
if {$workertype eq "message"} { |
||||
if {[dict_getdef $settingsdict -syslog ""] eq "" && [dict_getdef $settingsdict -file ""] eq ""} { |
||||
set winfo [dict create tid noop list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list] workertype "message"] |
||||
dict set workers $sourcetag $winfo |
||||
return noop |
||||
} |
||||
} |
||||
|
||||
#check if there is an existing unsubscribed thread first |
||||
#don't use free_threads for pipe workertype for now.. |
||||
variable free_threads |
||||
if {$workertype ne "pipe"} { |
||||
if {[llength $free_threads]} { |
||||
#todo - re-use from tail - as most likely to have been doing similar work?? review |
||||
|
||||
set free_threads [lassign $free_threads tidworker] |
||||
#todo - keep track of real ts_start of free threads... kill when too old |
||||
set winfo [dict create tid $tidworker list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list] workertype [dict get $settingsdict -workertype]] |
||||
#puts stderr "shellfilter::new_worker Re-using free worker thread: $tidworker with tag $sourcetag" |
||||
dict set workers $sourcetag $winfo |
||||
return $tidworker |
||||
} |
||||
} |
||||
|
||||
|
||||
#set ts_start [::shellthread::iso8601] |
||||
set tidworker [thread::create -preserved] |
||||
set init_script [string map [list %ts_start% $ts_start %mp% [tcl::tm::list] %ap% $::auto_path %tidcli% $tidclient %sd% $settingsdict] { |
||||
#set tclbase [file dirname [file dirname [info nameofexecutable]]] |
||||
#set tcllib $tclbase/lib |
||||
#if {$tcllib ni $::auto_path} { |
||||
# lappend ::auto_path $tcllib |
||||
#} |
||||
|
||||
set ::settingsinfo [dict create %sd%] |
||||
#if the executable running things is something like a tclkit, |
||||
# then it's likely we will need to use the caller's auto_path and tcl::tm::list to find things |
||||
#The caller can tune the thread's package search by providing a settingsdict |
||||
#tcl::tm::add * must add in reverse order to get reulting list in same order as original |
||||
if {![dict exists $::settingsinfo tcl_tm_list]} { |
||||
#JMN2 |
||||
::tcl::tm::add {*}[lreverse [list %mp%]] |
||||
} else { |
||||
tcl::tm::remove {*}[tcl::tm::list] |
||||
::tcl::tm::add {*}[lreverse [dict get $::settingsinfo tcl_tm_list]] |
||||
} |
||||
if {![dict exists $::settingsinfo auto_path]} { |
||||
set ::auto_path [list %ap%] |
||||
} else { |
||||
set ::auto_path [dict get $::settingsinfo auto_path] |
||||
} |
||||
|
||||
package require punk::packagepreference |
||||
punk::packagepreference::install |
||||
|
||||
package require Thread |
||||
package require shellthread |
||||
if {![catch {::shellthread::worker::init %tidcli% %ts_start% $::settingsinfo} errmsg]} { |
||||
unset ::settingsinfo |
||||
set ::shellthread_init "ok" |
||||
} else { |
||||
unset ::settingsinfo |
||||
set ::shellthread_init "err $errmsg" |
||||
} |
||||
}] |
||||
|
||||
thread::send -async $tidworker $init_script |
||||
#thread::send $tidworker $init_script |
||||
set winfo [dict create tid $tidworker list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list]] |
||||
dict set workers $sourcetag $winfo |
||||
return $tidworker |
||||
} |
||||
|
||||
proc set_pipe_read_from_client {tag_pipename worker_tid rchan args} { |
||||
variable workers |
||||
if {![dict exists $workers $tag_pipename]} { |
||||
error "workerthread::manager::set_pipe_read_from_client source/pipename $tag_pipename not found" |
||||
} |
||||
set match_worker_tid [dict get $workers $tag_pipename tid] |
||||
if {$worker_tid ne $match_worker_tid} { |
||||
error "workerthread::manager::set_pipe_read_from_client source/pipename $tag_pipename workert_tid mismatch '$worker_tid' vs existing:'$match_worker_tid'" |
||||
} |
||||
#buffering set during channel creation will be preserved on thread::transfer |
||||
thread::transfer $worker_tid $rchan |
||||
#start_pipe_read will vwait - so we have to send async |
||||
thread::send -async $worker_tid [list ::shellthread::worker::start_pipe_read $tag_pipename $rchan] |
||||
#client may start writing immediately - but presumably it will buffer in fifo2 |
||||
} |
||||
|
||||
proc set_pipe_write_to_client {tag_pipename worker_tid wchan args} { |
||||
variable workers |
||||
if {![dict exists $workers $tag_pipename]} { |
||||
error "workerthread::manager::set_pipe_write_to_client pipename $tag_pipename not found" |
||||
} |
||||
set match_worker_tid [dict get $workers $tag_pipename tid] |
||||
if {$worker_tid ne $match_worker_tid} { |
||||
error "workerthread::manager::set_pipe_write_to_client pipename $tag_pipename workert_tid mismatch '$worker_tid' vs existing:'$match_worker_tid'" |
||||
} |
||||
#buffering set during channel creation will be preserved on thread::transfer |
||||
thread::transfer $worker_tid $wchan |
||||
thread::send -async $worker_tid [list ::shellthread::worker::start_pipe_write $tag_pipename $wchan] |
||||
} |
||||
|
||||
proc write_log {source msg args} { |
||||
variable workers |
||||
set ts_micros_sent [clock micros] |
||||
set defaults [list -async 1 -level info] |
||||
set opts [dict merge $defaults $args] |
||||
|
||||
if {[dict exists $workers $source]} { |
||||
set tidworker [dict get $workers $source tid] |
||||
if {$tidworker eq "noop"} { |
||||
return |
||||
} |
||||
if {![thread::exists $tidworker]} { |
||||
# -syslog -file ? |
||||
set tidworker [new_worker $source] |
||||
} |
||||
} else { |
||||
#auto create with no requirement to call new_worker.. warn? |
||||
# -syslog -file ? |
||||
error "write_log no log opened for source: $source" |
||||
set tidworker [new_worker $source] |
||||
} |
||||
set client_tid [thread::id] |
||||
if {[dict get $opts -async]} { |
||||
thread::send -async $tidworker [list ::shellthread::worker::send_info $client_tid $ts_micros_sent $source $msg] |
||||
} else { |
||||
thread::send $tidworker [list ::shellthread::worker::send_info $client_tid $ts_micros_sent $source $msg] |
||||
} |
||||
} |
||||
proc report_worker_errors {errdict} { |
||||
variable workers |
||||
set reporting_tid [dict get $errdict worker_tid] |
||||
dict for {src srcinfo} $workers { |
||||
if {[dict get $srcinfo tid] eq $reporting_tid} { |
||||
dict set srcinfo errors [dict get $errdict errors] |
||||
dict set workers $src $srcinfo ;#writeback updated |
||||
break |
||||
} |
||||
} |
||||
} |
||||
|
||||
#aka leave_worker |
||||
#Note that the tags may be on separate workertids, or some tags may share workertids |
||||
proc unsubscribe {sourcetaglist} { |
||||
variable workers |
||||
#workers structure example: |
||||
#[list sourcetag1 [list tid <tidworker> list_client_tids <clients>] ts_start <ts_start> ts_end_list {}] |
||||
variable free_threads |
||||
set mytid [thread::id] ;#caller of shellthread::manager::xxx is the client thread |
||||
|
||||
set subscriberless_tags [list] |
||||
foreach source $sourcetaglist { |
||||
if {[dict exists $workers $source]} { |
||||
set list_client_tids [dict get $workers $source list_client_tids] |
||||
if {[set posn [lsearch $list_client_tids $mytid]] >= 0} { |
||||
set list_client_tids [lreplace $list_client_tids $posn $posn] |
||||
dict set workers $source list_client_tids $list_client_tids |
||||
} |
||||
if {![llength $list_client_tids]} { |
||||
lappend subscriberless_tags $source |
||||
} |
||||
} |
||||
} |
||||
|
||||
#we've removed our own tid from all the tags - possibly across multiplew workertids, and possibly leaving some workertids with no subscribers for a particular tag - or no subscribers at all. |
||||
|
||||
set subscriberless_workers [list] |
||||
set shuttingdown_workers [list] |
||||
foreach deadtag $subscriberless_tags { |
||||
set workertid [dict get $workers $deadtag tid] |
||||
set worker_tags [get_worker_tagstate $workertid] |
||||
set subscriber_count 0 |
||||
set kill_count 0 ;#number of ts_end_list entries - even one indicates thread is doomed |
||||
foreach taginfo $worker_tags { |
||||
incr subscriber_count [llength [dict get $taginfo list_client_tids]] |
||||
incr kill_count [llength [dict get $taginfo ts_end_list]] |
||||
} |
||||
if {$subscriber_count == 0} { |
||||
lappend subscriberless_workers $workertid |
||||
} |
||||
if {$kill_count > 0} { |
||||
lappend shuttingdown_workers $workertid |
||||
} |
||||
} |
||||
|
||||
#if worker isn't shutting down - add it to free_threads list |
||||
foreach workertid $subscriberless_workers { |
||||
if {$workertid ni $shuttingdown_workers} { |
||||
if {$workertid ni $free_threads && $workertid ne "noop"} { |
||||
lappend free_threads $workertid |
||||
} |
||||
} |
||||
} |
||||
|
||||
#todo |
||||
#unsub this client_tid from the sourcetags in the sourcetaglist. if no more client_tids exist for sourcetag, remove sourcetag, |
||||
#if no more sourcetags - add worker to free_threads |
||||
} |
||||
proc get_worker_tagstate {workertid} { |
||||
variable workers |
||||
set taginfo_list [list] |
||||
dict for {source sourceinfo} $workers { |
||||
if {[dict get $sourceinfo tid] eq $workertid} { |
||||
lappend taginfo_list $sourceinfo |
||||
} |
||||
} |
||||
return $taginfo_list |
||||
} |
||||
|
||||
#finalisation |
||||
proc shutdown_free_threads {{timeout 2500}} { |
||||
variable free_threads |
||||
if {![llength $free_threads]} { |
||||
return |
||||
} |
||||
upvar ::shellthread::manager::timeouts timeoutarr |
||||
if {[info exists timeoutarr(shutdown_free_threads)]} { |
||||
#already called |
||||
return false |
||||
} |
||||
#set timeoutarr(shutdown_free_threads) waiting |
||||
#after $timeout [list set timeoutarr(shutdown_free_threads) timed-out] |
||||
set ::shellthread::waitfor waiting |
||||
#after $timeout [list set ::shellthread::waitfor] |
||||
#2025-07 timed-out untested review |
||||
set cancelid [after $timeout [list set ::shellthread::waitfor timed-out]] |
||||
|
||||
set waiting_for [list] |
||||
set ended [list] |
||||
set timedout 0 |
||||
foreach tid $free_threads { |
||||
if {[thread::exists $tid]} { |
||||
lappend waiting_for $tid |
||||
#thread::send -async $tid [list shellthread::worker::terminate [thread::id]] timeoutarr(shutdown_free_threads) |
||||
thread::send -async $tid [list shellthread::worker::terminate [thread::id]] ::shellthread::waitfor |
||||
} |
||||
} |
||||
if {[llength $waiting_for]} { |
||||
for {set i 0} {$i < [llength $waiting_for]} {incr i} { |
||||
vwait ::shellthread::waitfor |
||||
if {$::shellthread::waitfor eq "timed-out"} { |
||||
set timedout 1 |
||||
break |
||||
} else { |
||||
after cancel $cancelid |
||||
lappend ended $::shellthread::waitfor |
||||
} |
||||
} |
||||
} |
||||
set free_threads [list] |
||||
return [dict create existed $waiting_for ended $ended timedout $timedout] |
||||
} |
||||
|
||||
#TODO - important. |
||||
#REVIEW! |
||||
#since moving to the unsubscribe mechansm - close_worker $source isn't being called |
||||
# - we need to set a limit to the number of free threads and shut down excess when detected during unsubscription |
||||
#instruction to shut-down the thread that has this source. |
||||
#instruction to shut-down the thread that has this source. |
||||
proc close_worker {source {timeout 2500}} { |
||||
variable workers |
||||
variable worker_errors |
||||
variable free_threads |
||||
upvar ::shellthread::manager::timeouts timeoutarr |
||||
set ts_now [clock micros] |
||||
#puts stderr "close_worker $source" |
||||
if {[dict exists $workers $source]} { |
||||
set tidworker [dict get $workers $source tid] |
||||
if {$tidworker in $freethreads} { |
||||
#make sure a thread that is being closed is removed from the free_threads list |
||||
set posn [lsearch $freethreads $tidworker] |
||||
set freethreads [lreplace $freethreads $posn $posn] |
||||
} |
||||
set mytid [thread::id] |
||||
set client_tids [dict get $workers $source list_client_tids] |
||||
if {[set posn [lsearch $client_tids $mytid]] >= 0} { |
||||
set client_tids [lreplace $client_tids $posn $posn] |
||||
#remove self from list of clients |
||||
dict set workers $source list_client_tids $client_tids |
||||
} |
||||
set ts_end_list [dict get $workers $source ts_end_list] ;#ts_end_list is just a list of timestamps of closing calls for this source - only one is needed to close, but they may all come in a flurry. |
||||
if {[llength $ts_end_list]} { |
||||
set last_end_ts [lindex $ts_end_list end] |
||||
if {(($tsnow - $last_end_ts) / 1000) >= $timeout} { |
||||
lappend ts_end_list $ts_now |
||||
dict set workers $source ts_end_list $ts_end_list |
||||
} else { |
||||
#existing close in progress.. assume it will work |
||||
return |
||||
} |
||||
} |
||||
|
||||
if {[thread::exists $tidworker]} { |
||||
#puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source still running.. terminating" |
||||
|
||||
#review - timeoutarr is local var (?) |
||||
set timeoutarr($source) 0 |
||||
after $timeout [list set timeoutarr($source) 2] |
||||
|
||||
thread::send -async $tidworker [list shellthread::worker::send_errors_now [thread::id]] |
||||
thread::send -async $tidworker [list shellthread::worker::terminate [thread::id]] timeoutarr($source) |
||||
|
||||
#thread::send -async $tidworker [string map [list %tidclient% [thread::id]] { |
||||
# shellthread::worker::terminate %tidclient% |
||||
#}] timeoutarr($source) |
||||
|
||||
vwait timeoutarr($source) |
||||
#puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source DONE1" |
||||
|
||||
thread::release $tidworker |
||||
#puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source DONE2" |
||||
if {[dict exists $workers $source errors]} { |
||||
set errlist [dict get $workers $source errors] |
||||
if {[llength $errlist]} { |
||||
lappend worker_errors [list $source [dict get $workers $source]] |
||||
} |
||||
} |
||||
dict unset workers $source |
||||
} else { |
||||
#thread may have been closed by call to close_worker with another source with same worker |
||||
#clear workers record for this source |
||||
#REVIEW - race condition for re-creation of source with new workerid? |
||||
#check that record is subscriberless to avoid this |
||||
if {[llength [dict get $workers $source list_client_tids]] == 0} { |
||||
dict unset workers $source |
||||
} |
||||
} |
||||
} |
||||
#puts stdout "close_worker $source - end" |
||||
} |
||||
|
||||
#worker errors only available for a source after close_worker called on that source |
||||
#It is possible for there to be multiple entries for a source because new_worker can be called multiple times with same sourcetag, |
||||
proc get_and_clear_errors {source} { |
||||
variable worker_errors |
||||
set source_errors [lsearch -all -inline -index 0 $worker_errors $source] |
||||
set worker_errors [lsearch -all -inline -index 0 -not $worker_errors $source] |
||||
return $source_errors |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
package provide shellthread [namespace eval shellthread { |
||||
variable version |
||||
set version 1.6.1 |
||||
}] |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,144 @@
|
||||
# -*- 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) 2026 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::args::moduledoc::iocp 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
package require Tcl 8.6- |
||||
|
||||
|
||||
|
||||
tcl::namespace::eval punk::args::moduledoc::iocp { |
||||
variable PUNKARGS |
||||
|
||||
namespace eval argdoc { |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
variable PUNKARGS |
||||
variable PUNKARGS_aliases |
||||
|
||||
lappend PUNKARGS_aliases {::iocp::inet::socket ::socket} |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)punk::args::moduledoc::iocp" |
||||
@package -name "punk::args::moduledoc::iocp" -help\ |
||||
"punk::args documentation for magicsplat iocp package" |
||||
}] |
||||
|
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
# == === === === === === === === === === === === === === === |
||||
# Sample 'about' function with punk::args documentation |
||||
# == === === === === === === === === === === === === === === |
||||
tcl::namespace::eval punk::args::moduledoc::iocp { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
|
||||
namespace eval argdoc { |
||||
#namespace for custom argument documentation |
||||
proc package_name {} { |
||||
return punk::args::moduledoc::iocp |
||||
} |
||||
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::args::moduledoc::iocp |
||||
} \n] |
||||
} |
||||
proc get_topic_License {} { |
||||
return "BSD" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return "$::punk::args::moduledoc::iocp::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 |
||||
} |
||||
# ------------------------------------------------------------- |
||||
} |
||||
|
||||
# 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::args::moduledoc::iocp::about" |
||||
dict set overrides @cmd -name "punk::args::moduledoc::iocp::about" |
||||
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||
About punk::args::moduledoc::iocp |
||||
}] \n] |
||||
dict set overrides topic -choices [list {*}[punk::args::moduledoc::iocp::argdoc::about_topics] *] |
||||
dict set overrides topic -choicerestricted 1 |
||||
dict set overrides topic -default [punk::args::moduledoc::iocp::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::args::moduledoc::iocp::about] |
||||
lassign [dict values $argd] _leaders opts values _received |
||||
punk::args::package::standard_about -package_about_namespace ::punk::args::moduledoc::iocp::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::args::moduledoc::iocp ::punk::args::moduledoc::iocp::argdoc |
||||
} |
||||
# ----------------------------------------------------------------------------- |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::args::moduledoc::iocp [tcl::namespace::eval punk::args::moduledoc::iocp { |
||||
variable pkg punk::args::moduledoc::iocp |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
return |
||||
|
||||
@ -0,0 +1,3 @@
|
||||
2.0.2 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
@ -1,3 +1,3 @@
|
||||
0.2.1 |
||||
0.2.2 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
Binary file not shown.
Binary file not shown.
@ -0,0 +1,2 @@
|
||||
package ifneeded Memchan 2.3 \ |
||||
[list load [file join $dir Memchan23.dll]] |
||||
@ -1,41 +1,42 @@
|
||||
#todo - change to include_modules.toml |
||||
#aim is to be programatically editable whilst retaining comments |
||||
|
||||
set local_modules [list\ |
||||
c:/repo/jn/tclmodules/fauxlink/modules fauxlink\ |
||||
c:/repo/jn/tclmodules/gridplus/modules gridplus\ |
||||
c:/repo/jn/tclmodules/modpod/modules modpod\ |
||||
c:/repo/jn/tclmodules/packageTest/modules packagetest\ |
||||
c:/repo/jn/tclmodules/tablelist/modules tablelist\ |
||||
c:/repo/jn/tclmodules/tablelist/modules tablelist_tile\ |
||||
c:/repo/jn/tclmodules/tomlish/modules tomlish\ |
||||
c:/repo/jn/tclmodules/tomlish/modules test::tomlish\ |
||||
c:/repo/jn/tclmodules/dictn/modules dictn\ |
||||
c:/repo/jn/tclmodules/dollarcent/modules dollarcent\ |
||||
c:/repo/jn/tclmodules/pattern/modules pattern\ |
||||
c:/repo/jn/tclmodules/pattern/modules pattern2\ |
||||
c:/repo/jn/tclmodules/pattern/modules patterncmd\ |
||||
c:/repo/jn/tclmodules/pattern/modules patternlib\ |
||||
c:/repo/jn/tclmodules/pattern/modules patterncipher\ |
||||
c:/repo/jn/tclmodules/pattern/modules metaface\ |
||||
c:/repo/jn/tclmodules/pattern/modules patternpredator1\ |
||||
c:/repo/jn/tclmodules/pattern/modules patternpredator2\ |
||||
c:/repo/jn/tclmodules/pattern/modules patterndispatcher\ |
||||
c:/repo/jn/tclmodules/pattern/modules treeobj\ |
||||
c:/repo/jn/tclmodules/pattern/modules pattern::ms\ |
||||
c:/repo/jn/tclmodules/pattern/modules pattern::IPatternBuilder\ |
||||
c:/repo/jn/tclmodules/pattern/modules pattern::IPatternInterface\ |
||||
c:/repo/jn/tclmodules/pattern/modules pattern::IPatternSystem\ |
||||
c:/repo/jn/tclmodules/pattern/modules test::pattern\ |
||||
c:/repo/jn/tclmodules/voo/modules voo\ |
||||
c:/repo/jn/tarjar/modules tarjar\ |
||||
] |
||||
set local_modules [list {*}{ |
||||
c:/repo/jn/tclmodules/fauxlink/modules fauxlink |
||||
c:/repo/jn/tclmodules/gridplus/modules gridplus |
||||
c:/repo/jn/tclmodules/modpod/modules modpod |
||||
c:/repo/jn/tclmodules/packageTest/modules packagetest |
||||
c:/repo/jn/tclmodules/tablelist/modules tablelist |
||||
c:/repo/jn/tclmodules/tablelist/modules tablelist_tile |
||||
c:/repo/jn/tclmodules/tomlish/modules tomlish |
||||
c:/repo/jn/tclmodules/tomlish/modules test::tomlish |
||||
c:/repo/jn/tclmodules/dictn/modules dictn |
||||
c:/repo/jn/tclmodules/dollarcent/modules dollarcent |
||||
c:/repo/jn/tclmodules/pattern/modules pattern |
||||
c:/repo/jn/tclmodules/pattern/modules pattern2 |
||||
c:/repo/jn/tclmodules/pattern/modules patterncmd |
||||
c:/repo/jn/tclmodules/pattern/modules patternlib |
||||
c:/repo/jn/tclmodules/pattern/modules patterncipher |
||||
c:/repo/jn/tclmodules/pattern/modules metaface |
||||
c:/repo/jn/tclmodules/pattern/modules patternpredator1 |
||||
c:/repo/jn/tclmodules/pattern/modules patternpredator2 |
||||
c:/repo/jn/tclmodules/pattern/modules patterndispatcher |
||||
c:/repo/jn/tclmodules/pattern/modules treeobj |
||||
c:/repo/jn/tclmodules/pattern/modules pattern::ms |
||||
c:/repo/jn/tclmodules/pattern/modules pattern::IPatternBuilder |
||||
c:/repo/jn/tclmodules/pattern/modules pattern::IPatternInterface |
||||
c:/repo/jn/tclmodules/pattern/modules pattern::IPatternSystem |
||||
c:/repo/jn/tclmodules/pattern/modules test::pattern |
||||
c:/repo/jn/tclmodules/voo/modules voo |
||||
c:/repo/jn/tarjar/modules tarjar |
||||
c:/repo/jn/tclmodules/sqids-tcl/modules sqids |
||||
}] |
||||
|
||||
#moved overtype into punkshell project |
||||
# c:/repo/jn/tclmodules/overtype/modules overtype |
||||
|
||||
set fossil_modules [dict create\ |
||||
] |
||||
set fossil_modules [dict create {*}{ |
||||
}] |
||||
|
||||
set git_modules [dict create\ |
||||
] |
||||
set git_modules [dict create {*}{ |
||||
}] |
||||
@ -0,0 +1,931 @@
|
||||
#Do not update version of this file. Update sqids-buildversion.txt and run make.tcl to update the version in this file and copy to modules folder. |
||||
package require Tcl 8.6- |
||||
|
||||
#MIT license |
||||
#Julian Noble 2026 |
||||
|
||||
#example: |
||||
# % package require sqids |
||||
# % set s1 [sqids::idscope new] |
||||
# ::oo::Obj275 |
||||
# % $s1 encode {1 2 3} |
||||
# 86Rf07 |
||||
# % $s1 decode 86Rf07 |
||||
# 1 2 3 |
||||
|
||||
|
||||
namespace eval sqids { |
||||
oo::class create idscope { |
||||
variable o_alphabet |
||||
variable o_alphabet_configured |
||||
variable o_alpha_re |
||||
variable o_minlength |
||||
variable o_blocklist |
||||
variable o_maxsafeinteger |
||||
#note that methods beginning with uppercase letters are private. |
||||
constructor {args} { |
||||
set defaults [dict create {*}{ |
||||
-alphabet "" |
||||
-minlength "" |
||||
-blocklist "" |
||||
-maxsafeinteger "" |
||||
}] |
||||
if {[llength $args] %2 !=0} { |
||||
error "sqids::idscope constructor: Require option value pairs. Known options:[dict keys $defaults]." |
||||
} |
||||
set useropts [dict create] |
||||
set explicit_empty_blocklist 0 ;#as opposed to default due to being unspecified. |
||||
dict for {k v} $args { |
||||
set fullmatch [tcl::prefix::match -error "" {-alphabet -minlength -blocklist -maxsafeinteger} $k] |
||||
switch -exact -- $fullmatch { |
||||
-alphabet - -minlength - -maxsafeinteger { |
||||
dict set useropts $fullmatch $v |
||||
} |
||||
-blocklist { |
||||
if {[llength $v] == 0} { |
||||
set explicit_empty_blocklist 1 |
||||
} |
||||
dict set useropts -blocklist $v |
||||
} |
||||
default { |
||||
error "sqids::idscope constructor: unknown option '$k'. Known options:[dict keys $defaults]." |
||||
} |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $useropts] |
||||
|
||||
set opt_alphabet [dict get $opts -alphabet] |
||||
if {$opt_alphabet eq ""} { |
||||
set o_alphabet $::sqids::data::default_alphabet |
||||
} else { |
||||
if {[string length $opt_alphabet] < 3} { |
||||
error "sqids::idscope constructor: -alphabet length must be at least 3." |
||||
} |
||||
#review - deny multibyte |
||||
if {[regexp {[^\u00-\u7F]} $opt_alphabet]} { |
||||
error "sqids::idscope constructor: -alphabet must not contain multibyte characters." |
||||
} |
||||
if {[regexp {(.).*\1} $opt_alphabet]} { |
||||
error "sqids::idscope constructor: -alphabet must contain unique characters." |
||||
} |
||||
set o_alphabet $opt_alphabet |
||||
} |
||||
set o_alphabet_configured $o_alphabet ;#for use in public method alphabet, which returns the configured alphabet in the order it was configured, not the shuffled order used for encoding. |
||||
set alphamatch [string map [list . \\. \[ \\\[ \] \\\] \{ \\\{ \} \\\}] $o_alphabet] ;#review |
||||
set o_alpha_re "^\[$alphamatch\]+\$" ;#independent of shuffled order. |
||||
|
||||
set o_alphabet [my shuffle $o_alphabet[set o_alphabet {}]] |
||||
|
||||
set opt_minlength [dict get $opts -minlength] |
||||
if {$opt_minlength eq ""} { |
||||
set o_minlength $::sqids::data::default_minlength |
||||
} else { |
||||
set maxval 255 |
||||
if {![string is integer -strict $opt_minlength] || $opt_minlength < 0 || $opt_minlength > $maxval} { |
||||
error "sqids constructor: -minlength must be an integer from 0 to $maxval inclusive." |
||||
} |
||||
set o_minlength $opt_minlength |
||||
} |
||||
set opt_blocklist [dict get $opts -blocklist] |
||||
if {!$explicit_empty_blocklist && $opt_blocklist eq ""} { |
||||
set o_blocklist $::sqids::data::default_blocklist |
||||
#default blocklist is already in lowercase. |
||||
} else { |
||||
set o_blocklist $opt_blocklist |
||||
set o_blocklist [string tolower $o_blocklist] |
||||
} |
||||
#Considered pruning blocklist entries that are 3 chars or less, |
||||
#or that contain characters not in the alphabet, as they will never match any id and just add overhead |
||||
#to the is_blocked method. |
||||
#This however adds some object instantiation overhead. |
||||
#counterpoint - caller should provide an appropriate blocklist for the supplied alphabet. |
||||
|
||||
set opt_maxsafeinteger [dict get $opts -maxsafeinteger] |
||||
if {$opt_maxsafeinteger eq ""} { |
||||
set o_maxsafeinteger $::sqids::data::MAX_SAFE_INTEGER |
||||
} else { |
||||
#accept arbitrarily large values as long as they're valid bignum integers. |
||||
if {[package vsatisfies [info tclversion] 8.7-]} { |
||||
if {![string is integer -strict $opt_maxsafeinteger] || $opt_maxsafeinteger < 0} { |
||||
error "sqids constructor: -maxsafeinteger must be a non-negative integer." |
||||
} |
||||
} else { |
||||
if {![string is entier -strict $opt_maxsafeinteger] || $opt_maxsafeinteger < 0} { |
||||
error "sqids constructor: -maxsafeinteger must be a non-negative integer." |
||||
} |
||||
} |
||||
set o_maxsafeinteger $opt_maxsafeinteger |
||||
} |
||||
|
||||
} |
||||
method config {{option {}}} { |
||||
#introspection method. |
||||
#return a dict of the configured options if no option specified, otherwise return the value of the specified option. |
||||
|
||||
#no facility is provided to change options after construction as a new idscope object should be used for different configurations (different scope of sqid ids). |
||||
#note that -alphabet refers to the configured alphabet in the order it was configured, not the shuffled order used for encoding. |
||||
if {$option eq ""} { |
||||
# |
||||
return [dict create {*}{ |
||||
} -blocklist $o_blocklist {*}{ |
||||
} -maxsafeinteger $o_maxsafeinteger {*}{ |
||||
} -minlength $o_minlength {*}{ |
||||
} -alphabet $o_alphabet_configured {*}{ |
||||
} |
||||
] |
||||
} |
||||
set fullmatch [tcl::prefix::match -error "" {-alphabet -minlength -blocklist -maxsafeinteger} $option] |
||||
switch -exact -- $fullmatch { |
||||
-alphabet {return $o_alphabet_configured} |
||||
-minlength {return $o_minlength} |
||||
-blocklist {return $o_blocklist} |
||||
-maxsafeinteger {return $o_maxsafeinteger} |
||||
default { |
||||
error "sqids::idscope config: unknown option '$option'. Known options:-alphabet -minlength -blocklist -maxsafeinteger." |
||||
} |
||||
} |
||||
} |
||||
#review tcl8.7 behaves like tcl 9 |
||||
#tcl 8.7 wasn't ever officially released (and won't be) - but it was available for a while and may exist in the wild. |
||||
if {[package vsatisfies [info tclversion] 8.7-]} { |
||||
#'string is integer' for tcl versions 8.7 and above supports bignums, which can be arbitrarily large. |
||||
method encode {numlist} { |
||||
if {[llength $numlist] == 0} {return} |
||||
#cannot encode negative numbers, or non-integers. |
||||
foreach num $numlist { |
||||
if {![string is integer -strict $num] || $num < 0 || $num > $o_maxsafeinteger} { |
||||
error "sqids encode: can only encode integers from 0 to $o_maxsafeinteger. Invalid value: '$num'" |
||||
} |
||||
} |
||||
return [my EncodeNumbers $numlist] |
||||
} |
||||
} else { |
||||
#In tcl 8.6, 'string is integer' is limited to 2**32-1, use the now deprecated 'string is entier'. |
||||
#Otherwise - integer operations still support bignums. |
||||
#(versions below 8.6 not supported by this modules) |
||||
method encode {numlist} { |
||||
if {[llength $numlist] == 0} {return} |
||||
#cannot encode negative numbers, or non-integers. |
||||
foreach num $numlist { |
||||
if {![string is entier -strict $num] || $num < 0 || $num > $o_maxsafeinteger} { |
||||
error "sqids encode: can only encode integers from 0 to $o_maxsafeinteger. Invalid value: '$num'" |
||||
} |
||||
} |
||||
return [my EncodeNumbers $numlist] |
||||
} |
||||
} |
||||
method EncodeNumbers {numlist {increment 0}} { |
||||
#assert number of letters in o_alphabet and number of letters in local alpha are the same and don't effectively change during this function. |
||||
#('set alpha {}' in calls to my shuffle is an optimization to avoid shared string and copy-on-write overhead. As alpha is set to the result, it doesn't violate the previous assertion.) |
||||
set alpha_len [string length $o_alphabet] |
||||
|
||||
if {$increment > $alpha_len} { |
||||
error "sqids EncodeNumbers: Reached max attempts to re-generate the ID" |
||||
} |
||||
|
||||
set offset [llength $numlist] |
||||
set i -1 |
||||
foreach v $numlist { |
||||
incr i |
||||
set x [scan [string index $o_alphabet [expr {$v % $alpha_len}]] %c] |
||||
set offset [expr {$offset + $x + $i}] |
||||
} |
||||
set offset [expr {$offset % $alpha_len}] |
||||
set offset [expr {($offset + $increment) % $alpha_len}] |
||||
set alpha [string range $o_alphabet $offset end][string range $o_alphabet 0 $offset-1] |
||||
set prefix [string index $alpha 0] |
||||
set alpha [string reverse $alpha] |
||||
set id $prefix |
||||
set i -1 |
||||
foreach num $numlist { |
||||
incr i |
||||
append id [my ToId $num [string range $alpha 1 end]] |
||||
if {$i < [llength $numlist]-1} { |
||||
append id [string index $alpha 0] |
||||
set alpha [my shuffle $alpha[set alpha {}]] |
||||
} |
||||
} |
||||
if {$o_minlength > [string length $id]} { |
||||
append id [string index $alpha 0] |
||||
while {$o_minlength - [string length $id] > 0} { |
||||
set alpha [my shuffle $alpha[set alpha {}]] |
||||
set numchars [expr {min($o_minlength - [string length $id],$alpha_len)}] |
||||
append id [string range $alpha 0 $numchars-1] |
||||
} |
||||
} |
||||
if {[my is_blocked $id]} { |
||||
set id [my EncodeNumbers $numlist [expr {$increment+1}]] |
||||
} |
||||
return $id |
||||
} |
||||
method is_blocked {id} { |
||||
#deliberately public method. |
||||
if {![llength $o_blocklist]} { |
||||
return 0 |
||||
} |
||||
#o_blocklist is stored in lowercase, so compare against lowercase id. |
||||
set idtest [string tolower $id] |
||||
set idlen [string length $idtest] |
||||
if {$idlen < 3} { |
||||
#sqids rule: short ids less than 3 chars will not be blocked. |
||||
#(this is from the FAQ - but spec (code in isblocked) seems to contradict - saying <= 3 must match exactly) |
||||
#however - most implementations filter out blocklist entries shorter than 3 at construction time. |
||||
#- so effectively the FAQ seems right but the reference code implements it in a very roundabout and unintuitive way. |
||||
#REVIEW. Why are there no tests regarding such short ids? |
||||
return 0 |
||||
} |
||||
if {$idlen == 3} { |
||||
if {$idtest in $o_blocklist} { |
||||
return 1 |
||||
} |
||||
} else { |
||||
foreach blocked $o_blocklist { |
||||
if {[string length $blocked] <= 3} { |
||||
#sqids rule: blocklist entries of 3 chars will only be blocked if they match the entire id exactly, |
||||
#so skip them in this loop as we've already checked for exact matches of the whole id when idlen == 3. |
||||
#note blocklist entries of 0 1 or 2 chars will never match any id - but in this implementation we leave |
||||
#it to the caller to provide a sensible blocklist. Nevertheless if we encounter them we will just skip them here. |
||||
continue |
||||
} |
||||
set posn [string first $blocked $idtest] |
||||
if {$posn == -1} { |
||||
continue |
||||
} |
||||
if {$posn == 0} { |
||||
#whether leetspeak or not, blocklist entries that match at the beginning of the id will be blocked. |
||||
return 1 |
||||
} |
||||
if {[regexp {[0-9]} $blocked]} { |
||||
#sqids rule: blocklist entries with digits (leetspeak) will only be blocked if the match is at the beginning or end of the id. |
||||
#we've already checked the beginning, so check the end now. |
||||
set endpos [expr {$idlen - [string length $blocked]}] |
||||
if {$posn == $endpos} { |
||||
return 1 |
||||
} |
||||
} else { |
||||
#sqids rule: blocklist entries without digits will be blocked if they match anywhere in the id. |
||||
return 1 |
||||
} |
||||
} |
||||
} |
||||
return 0 |
||||
} |
||||
method ToId {num alpha} { |
||||
set id "" |
||||
set alpha_len [string length $alpha] |
||||
while 1 { |
||||
set id [string index $alpha [expr {$num % $alpha_len}]]$id |
||||
set num [expr {$num / $alpha_len}] |
||||
if {$num == 0} break |
||||
} |
||||
return $id |
||||
} |
||||
method ToNumber {id alpha} { |
||||
set number 0 |
||||
set alpha_len [string length $alpha] |
||||
for {set i 0} {$i < [string length $id]} {incr i} { |
||||
set posn [string first [string index $id $i] $alpha] |
||||
set number [expr {($number * $alpha_len) + $posn}] |
||||
} |
||||
return $number |
||||
} |
||||
method shuffle {alpha} { |
||||
#public method. Primarily for internal use but can be used externally to examine the shuffled alphabet being used for encoding. |
||||
#e.g myscopeobject shuffle [myscopeobject config -alphabet] would show the shuffled alphabet being used for encoding. |
||||
#consistent shuffle (always produce the same result for same input) |
||||
set alpha_len [string length $alpha] |
||||
if {$alpha_len < 2} { |
||||
return $alpha |
||||
} |
||||
set chars [split $alpha ""] |
||||
|
||||
for {set i 0; set j [expr {$alpha_len-1}]} {$j > 0} {incr i; incr j -1} { |
||||
set iv [scan [lindex $chars $i] %c] |
||||
set jv [scan [lindex $chars $j] %c] |
||||
set r [expr {($i * $j + $iv + $jv) % $alpha_len}] |
||||
set item2 [lindex $chars $r] |
||||
lset chars $r [lindex $chars $i] |
||||
lset chars $i $item2 |
||||
} |
||||
return [join $chars ""] |
||||
} |
||||
method decode {id} { |
||||
if {$id eq ""} {return} |
||||
set result [list] |
||||
|
||||
if {![regexp $o_alpha_re $id]} { |
||||
puts stderr "sqids decode: ID contains characters not in the alphabet. re: $o_alpha_re id: $id" |
||||
return [list] |
||||
} |
||||
set prefix [string index $id 0] |
||||
set offset [string first $prefix $o_alphabet] |
||||
set alpha [string range $o_alphabet $offset end][string range $o_alphabet 0 $offset-1] |
||||
set alpha [string reverse $alpha] |
||||
set id [string range $id 1 end] |
||||
while {[string length $id] > 0} { |
||||
set separator [string index $alpha 0] |
||||
#split on first occurrence of separator only. |
||||
set sep_posn [string first $separator $id] |
||||
if {$sep_posn == -1} { |
||||
set parts [list $id] |
||||
} else { |
||||
set parts [list [string range $id 0 $sep_posn-1] [string range $id $sep_posn+1 end]] |
||||
} |
||||
#assert parts has 1 or 2 elements |
||||
|
||||
if {[lindex $parts 0] eq ""} { |
||||
#separator was at start of the id - done. |
||||
return $result |
||||
} |
||||
lappend result [my ToNumber [lindex $parts 0] [string range $alpha 1 end]] |
||||
if {[llength $parts] == 2} { |
||||
set alpha [my shuffle $alpha[set alpha {}]] |
||||
set id [lindex $parts 1] |
||||
} else { |
||||
set id "" |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
} |
||||
} |
||||
namespace eval sqids::data { |
||||
variable default_alphabet {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789} |
||||
|
||||
variable default_minlength 0 |
||||
|
||||
#arbitrary 1 googol limit (approx 2**332). We could go much higher e.g [string repeat 9 1000] |
||||
#Tcl bignums are limited by available memory and max string length (e.g approx 2**30 bytes?) |
||||
#- but speed of encoding and decoding will degrade as the number increases. |
||||
#Can be overridden by providing a -maxsafeinteger option to the idscope constructor. |
||||
variable MAX_SAFE_INTEGER [expr {"1[string repeat 0 100]"}] |
||||
|
||||
variable default_blocklist { |
||||
0rgasm |
||||
1d10t |
||||
1d1ot |
||||
1di0t |
||||
1diot |
||||
1eccacu10 |
||||
1eccacu1o |
||||
1eccacul0 |
||||
1eccaculo |
||||
1mbec11e |
||||
1mbec1le |
||||
1mbeci1e |
||||
1mbecile |
||||
a11upat0 |
||||
a11upato |
||||
a1lupat0 |
||||
a1lupato |
||||
aand |
||||
ah01e |
||||
ah0le |
||||
aho1e |
||||
ahole |
||||
al1upat0 |
||||
al1upato |
||||
allupat0 |
||||
allupato |
||||
ana1 |
||||
ana1e |
||||
anal |
||||
anale |
||||
anus |
||||
arrapat0 |
||||
arrapato |
||||
arsch |
||||
arse |
||||
ass |
||||
b00b |
||||
b00be |
||||
b01ata |
||||
b0ceta |
||||
b0iata |
||||
b0ob |
||||
b0obe |
||||
b0sta |
||||
b1tch |
||||
b1te |
||||
b1tte |
||||
ba1atkar |
||||
balatkar |
||||
bastard0 |
||||
bastardo |
||||
batt0na |
||||
battona |
||||
bitch |
||||
bite |
||||
bitte |
||||
bo0b |
||||
bo0be |
||||
bo1ata |
||||
boceta |
||||
boiata |
||||
boob |
||||
boobe |
||||
bosta |
||||
bran1age |
||||
bran1er |
||||
bran1ette |
||||
bran1eur |
||||
bran1euse |
||||
branlage |
||||
branler |
||||
branlette |
||||
branleur |
||||
branleuse |
||||
c0ck |
||||
c0g110ne |
||||
c0g11one |
||||
c0g1i0ne |
||||
c0g1ione |
||||
c0gl10ne |
||||
c0gl1one |
||||
c0gli0ne |
||||
c0glione |
||||
c0na |
||||
c0nnard |
||||
c0nnasse |
||||
c0nne |
||||
c0u111es |
||||
c0u11les |
||||
c0u1l1es |
||||
c0u1lles |
||||
c0ui11es |
||||
c0ui1les |
||||
c0uil1es |
||||
c0uilles |
||||
c11t |
||||
c11t0 |
||||
c11to |
||||
c1it |
||||
c1it0 |
||||
c1ito |
||||
cabr0n |
||||
cabra0 |
||||
cabrao |
||||
cabron |
||||
caca |
||||
cacca |
||||
cacete |
||||
cagante |
||||
cagar |
||||
cagare |
||||
cagna |
||||
cara1h0 |
||||
cara1ho |
||||
caracu10 |
||||
caracu1o |
||||
caracul0 |
||||
caraculo |
||||
caralh0 |
||||
caralho |
||||
cazz0 |
||||
cazz1mma |
||||
cazzata |
||||
cazzimma |
||||
cazzo |
||||
ch00t1a |
||||
ch00t1ya |
||||
ch00tia |
||||
ch00tiya |
||||
ch0d |
||||
ch0ot1a |
||||
ch0ot1ya |
||||
ch0otia |
||||
ch0otiya |
||||
ch1asse |
||||
ch1avata |
||||
ch1er |
||||
ch1ng0 |
||||
ch1ngadaz0s |
||||
ch1ngadazos |
||||
ch1ngader1ta |
||||
ch1ngaderita |
||||
ch1ngar |
||||
ch1ngo |
||||
ch1ngues |
||||
ch1nk |
||||
chatte |
||||
chiasse |
||||
chiavata |
||||
chier |
||||
ching0 |
||||
chingadaz0s |
||||
chingadazos |
||||
chingader1ta |
||||
chingaderita |
||||
chingar |
||||
chingo |
||||
chingues |
||||
chink |
||||
cho0t1a |
||||
cho0t1ya |
||||
cho0tia |
||||
cho0tiya |
||||
chod |
||||
choot1a |
||||
choot1ya |
||||
chootia |
||||
chootiya |
||||
cl1t |
||||
cl1t0 |
||||
cl1to |
||||
clit |
||||
clit0 |
||||
clito |
||||
cock |
||||
cog110ne |
||||
cog11one |
||||
cog1i0ne |
||||
cog1ione |
||||
cogl10ne |
||||
cogl1one |
||||
cogli0ne |
||||
coglione |
||||
cona |
||||
connard |
||||
connasse |
||||
conne |
||||
cou111es |
||||
cou11les |
||||
cou1l1es |
||||
cou1lles |
||||
coui11es |
||||
coui1les |
||||
couil1es |
||||
couilles |
||||
cracker |
||||
crap |
||||
cu10 |
||||
cu1att0ne |
||||
cu1attone |
||||
cu1er0 |
||||
cu1ero |
||||
cu1o |
||||
cul0 |
||||
culatt0ne |
||||
culattone |
||||
culer0 |
||||
culero |
||||
culo |
||||
cum |
||||
cunt |
||||
d11d0 |
||||
d11do |
||||
d1ck |
||||
d1ld0 |
||||
d1ldo |
||||
damn |
||||
de1ch |
||||
deich |
||||
depp |
||||
di1d0 |
||||
di1do |
||||
dick |
||||
dild0 |
||||
dildo |
||||
dyke |
||||
encu1e |
||||
encule |
||||
enema |
||||
enf01re |
||||
enf0ire |
||||
enfo1re |
||||
enfoire |
||||
estup1d0 |
||||
estup1do |
||||
estupid0 |
||||
estupido |
||||
etr0n |
||||
etron |
||||
f0da |
||||
f0der |
||||
f0ttere |
||||
f0tters1 |
||||
f0ttersi |
||||
f0tze |
||||
f0utre |
||||
f1ca |
||||
f1cker |
||||
f1ga |
||||
fag |
||||
fica |
||||
ficker |
||||
figa |
||||
foda |
||||
foder |
||||
fottere |
||||
fotters1 |
||||
fottersi |
||||
fotze |
||||
foutre |
||||
fr0c10 |
||||
fr0c1o |
||||
fr0ci0 |
||||
fr0cio |
||||
fr0sc10 |
||||
fr0sc1o |
||||
fr0sci0 |
||||
fr0scio |
||||
froc10 |
||||
froc1o |
||||
froci0 |
||||
frocio |
||||
frosc10 |
||||
frosc1o |
||||
frosci0 |
||||
froscio |
||||
fuck |
||||
g00 |
||||
g0o |
||||
g0u1ne |
||||
g0uine |
||||
gandu |
||||
go0 |
||||
goo |
||||
gou1ne |
||||
gouine |
||||
gr0gnasse |
||||
grognasse |
||||
haram1 |
||||
harami |
||||
haramzade |
||||
hund1n |
||||
hundin |
||||
id10t |
||||
id1ot |
||||
idi0t |
||||
idiot |
||||
imbec11e |
||||
imbec1le |
||||
imbeci1e |
||||
imbecile |
||||
j1zz |
||||
jerk |
||||
jizz |
||||
k1ke |
||||
kam1ne |
||||
kamine |
||||
kike |
||||
leccacu10 |
||||
leccacu1o |
||||
leccacul0 |
||||
leccaculo |
||||
m1erda |
||||
m1gn0tta |
||||
m1gnotta |
||||
m1nch1a |
||||
m1nchia |
||||
m1st |
||||
mam0n |
||||
mamahuev0 |
||||
mamahuevo |
||||
mamon |
||||
masturbat10n |
||||
masturbat1on |
||||
masturbate |
||||
masturbati0n |
||||
masturbation |
||||
merd0s0 |
||||
merd0so |
||||
merda |
||||
merde |
||||
merdos0 |
||||
merdoso |
||||
mierda |
||||
mign0tta |
||||
mignotta |
||||
minch1a |
||||
minchia |
||||
mist |
||||
musch1 |
||||
muschi |
||||
n1gger |
||||
neger |
||||
negr0 |
||||
negre |
||||
negro |
||||
nerch1a |
||||
nerchia |
||||
nigger |
||||
orgasm |
||||
p00p |
||||
p011a |
||||
p01la |
||||
p0l1a |
||||
p0lla |
||||
p0mp1n0 |
||||
p0mp1no |
||||
p0mpin0 |
||||
p0mpino |
||||
p0op |
||||
p0rca |
||||
p0rn |
||||
p0rra |
||||
p0uff1asse |
||||
p0uffiasse |
||||
p1p1 |
||||
p1pi |
||||
p1r1a |
||||
p1rla |
||||
p1sc10 |
||||
p1sc1o |
||||
p1sci0 |
||||
p1scio |
||||
p1sser |
||||
pa11e |
||||
pa1le |
||||
pal1e |
||||
palle |
||||
pane1e1r0 |
||||
pane1e1ro |
||||
pane1eir0 |
||||
pane1eiro |
||||
panele1r0 |
||||
panele1ro |
||||
paneleir0 |
||||
paneleiro |
||||
patakha |
||||
pec0r1na |
||||
pec0rina |
||||
pecor1na |
||||
pecorina |
||||
pen1s |
||||
pendej0 |
||||
pendejo |
||||
penis |
||||
pip1 |
||||
pipi |
||||
pir1a |
||||
pirla |
||||
pisc10 |
||||
pisc1o |
||||
pisci0 |
||||
piscio |
||||
pisser |
||||
po0p |
||||
po11a |
||||
po1la |
||||
pol1a |
||||
polla |
||||
pomp1n0 |
||||
pomp1no |
||||
pompin0 |
||||
pompino |
||||
poop |
||||
porca |
||||
porn |
||||
porra |
||||
pouff1asse |
||||
pouffiasse |
||||
pr1ck |
||||
prick |
||||
pussy |
||||
put1za |
||||
puta |
||||
puta1n |
||||
putain |
||||
pute |
||||
putiza |
||||
puttana |
||||
queca |
||||
r0mp1ba11e |
||||
r0mp1ba1le |
||||
r0mp1bal1e |
||||
r0mp1balle |
||||
r0mpiba11e |
||||
r0mpiba1le |
||||
r0mpibal1e |
||||
r0mpiballe |
||||
rand1 |
||||
randi |
||||
rape |
||||
recch10ne |
||||
recch1one |
||||
recchi0ne |
||||
recchione |
||||
retard |
||||
romp1ba11e |
||||
romp1ba1le |
||||
romp1bal1e |
||||
romp1balle |
||||
rompiba11e |
||||
rompiba1le |
||||
rompibal1e |
||||
rompiballe |
||||
ruff1an0 |
||||
ruff1ano |
||||
ruffian0 |
||||
ruffiano |
||||
s1ut |
||||
sa10pe |
||||
sa1aud |
||||
sa1ope |
||||
sacanagem |
||||
sal0pe |
||||
salaud |
||||
salope |
||||
saugnapf |
||||
sb0rr0ne |
||||
sb0rra |
||||
sb0rrone |
||||
sbattere |
||||
sbatters1 |
||||
sbattersi |
||||
sborr0ne |
||||
sborra |
||||
sborrone |
||||
sc0pare |
||||
sc0pata |
||||
sch1ampe |
||||
sche1se |
||||
sche1sse |
||||
scheise |
||||
scheisse |
||||
schlampe |
||||
schwachs1nn1g |
||||
schwachs1nnig |
||||
schwachsinn1g |
||||
schwachsinnig |
||||
schwanz |
||||
scopare |
||||
scopata |
||||
sexy |
||||
sh1t |
||||
shit |
||||
slut |
||||
sp0mp1nare |
||||
sp0mpinare |
||||
spomp1nare |
||||
spompinare |
||||
str0nz0 |
||||
str0nza |
||||
str0nzo |
||||
stronz0 |
||||
stronza |
||||
stronzo |
||||
stup1d |
||||
stupid |
||||
succh1am1 |
||||
succh1ami |
||||
succhiam1 |
||||
succhiami |
||||
sucker |
||||
t0pa |
||||
tapette |
||||
test1c1e |
||||
test1cle |
||||
testic1e |
||||
testicle |
||||
tette |
||||
topa |
||||
tr01a |
||||
tr0ia |
||||
tr0mbare |
||||
tr1ng1er |
||||
tr1ngler |
||||
tring1er |
||||
tringler |
||||
tro1a |
||||
troia |
||||
trombare |
||||
turd |
||||
twat |
||||
vaffancu10 |
||||
vaffancu1o |
||||
vaffancul0 |
||||
vaffanculo |
||||
vag1na |
||||
vagina |
||||
verdammt |
||||
verga |
||||
w1chsen |
||||
wank |
||||
wichsen |
||||
x0ch0ta |
||||
x0chota |
||||
xana |
||||
xoch0ta |
||||
xochota |
||||
z0cc01a |
||||
z0cc0la |
||||
z0cco1a |
||||
z0ccola |
||||
z1z1 |
||||
z1zi |
||||
ziz1 |
||||
zizi |
||||
zocc01a |
||||
zocc0la |
||||
zocco1a |
||||
zoccola |
||||
} |
||||
} |
||||
|
||||
package provide sqids [namespace eval sqids { |
||||
variable version |
||||
set version 0.3.1 |
||||
}] |
||||
|
||||
Binary file not shown.
Binary file not shown.
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in new issue