56 changed files with 17897 additions and 2979 deletions
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,195 @@
|
||||
#JMN - api should be kept in sync with package patternlib where possible |
||||
# |
||||
package provide oolib [namespace eval oolib { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
||||
namespace eval oolib { |
||||
oo::class create collection { |
||||
variable o_data ;#dict |
||||
variable o_alias |
||||
constructor {} { |
||||
set o_data [dict create] |
||||
} |
||||
method info {} { |
||||
return [dict info $o_data] |
||||
} |
||||
method count {} { |
||||
return [dict size $o_data] |
||||
} |
||||
method isEmpty {} { |
||||
expr {[dict size $o_data] == 0} |
||||
} |
||||
method names {{globOrIdx {}}} { |
||||
if {[llength $globOrIdx]} { |
||||
if {[string is integer -strict $globOrIdx]} { |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $idx} result]} { |
||||
error "[self object] no such index : '$idx'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} else { |
||||
#glob |
||||
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] |
||||
} |
||||
} else { |
||||
return [dict keys $o_data] |
||||
} |
||||
} |
||||
#like names but without globbing |
||||
method keys {} { |
||||
dict keys $o_data |
||||
} |
||||
method key {{posn 0}} { |
||||
if {$posn < 0} { |
||||
set posn "end-[expr {abs($posn + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $posn} result]} { |
||||
error "[self object] no such index : '$posn'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} |
||||
method hasKey {key} { |
||||
dict exists $o_data $key |
||||
} |
||||
method get {} { |
||||
return $o_data |
||||
} |
||||
method items {} { |
||||
return [dict values $o_data] |
||||
} |
||||
method item {key} { |
||||
if {[string is integer -strict $key]} { |
||||
if {$key > 0} { |
||||
set valposn [expr {(2*$key) +1}] |
||||
return [lindex $o_data $valposn] |
||||
} else { |
||||
set key "end-[expr {abs($key + 1)}]" |
||||
return [lindex [dict keys $o_data] $key] |
||||
} |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
return [dict get $o_data $key] |
||||
} |
||||
} |
||||
#inverse lookup |
||||
method itemKeys {value} { |
||||
set value_indices [lsearch -all [dict values $o_data] $value] |
||||
set keylist [list] |
||||
foreach i $value_indices { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
method search {value args} { |
||||
set matches [lsearch {*}$args [dict values $o_data] $value] |
||||
if {"-inline" in $args} { |
||||
return $matches |
||||
} else { |
||||
set keylist [list] |
||||
foreach i $matches { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
} |
||||
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? |
||||
method alias {newAlias existingKeyOrAlias} { |
||||
if {[string is integer -strict $newAlias]} { |
||||
error "[self object] collection key alias cannot be integer" |
||||
} |
||||
if {[string length $existingKeyOrAlias]} { |
||||
set o_alias($newAlias) $existingKeyOrAlias |
||||
} else { |
||||
unset o_alias($newAlias) |
||||
} |
||||
} |
||||
method aliases {{key ""}} { |
||||
if {[string length $key]} { |
||||
set result [list] |
||||
foreach {n v} [array get o_alias] { |
||||
if {$v eq $key} { |
||||
lappend result $n $v |
||||
} |
||||
} |
||||
return $result |
||||
} else { |
||||
return [array get o_alias] |
||||
} |
||||
} |
||||
#if the supplied index is an alias, return the underlying key; else return the index supplied. |
||||
method realKey {idx} { |
||||
if {[catch {set o_alias($idx)} key]} { |
||||
return $idx |
||||
} else { |
||||
return $key |
||||
} |
||||
} |
||||
method add {value key} { |
||||
if {[string is integer -strict $key]} { |
||||
error "[self object] collection key must not be an integer. Use another structure if integer keys required" |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
error "[self object] col_processors object error: key '$key' already exists in collection" |
||||
} |
||||
dict set o_data $key $value |
||||
return [expr {[dict size $o_data] - 1}] ;#return index of item |
||||
} |
||||
method remove {idx {endRange ""}} { |
||||
if {[string length $endRange]} { |
||||
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" |
||||
} |
||||
if {[string is integer -strict $idx]} { |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx+1)}]" |
||||
} |
||||
set key [lindex [dict keys $o_data] $idx] |
||||
set posn $idx |
||||
} else { |
||||
set key $idx |
||||
set posn [lsearch -exact [dict keys $o_data] $key] |
||||
if {$posn < 0} { |
||||
error "[self object] no such index: '$idx' in this collection" |
||||
} |
||||
} |
||||
dict unset o_data $key |
||||
return |
||||
} |
||||
method clear {} { |
||||
set o_data [dict create] |
||||
return |
||||
} |
||||
method reverse {} { |
||||
set dictnew [dict create] |
||||
foreach k [lreverse [dict keys $o_data]] { |
||||
dict set dictnew $k [dict get $o_data $k] |
||||
} |
||||
set o_data $dictnew |
||||
return |
||||
} |
||||
#review - cmd as list vs cmd as script? |
||||
method map {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list {*}$cmd $v]] |
||||
} |
||||
return $seed |
||||
} |
||||
method objectmap {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list $v {*}$cmd]] |
||||
} |
||||
return $seed |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
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,50 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# |
||||
# 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) %year% |
||||
# |
||||
# @@ Meta Begin |
||||
# Application %pkg% %version% |
||||
# Meta platform tcl |
||||
# Meta license %license% |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval %pkg% { |
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide %pkg% [namespace eval %pkg% { |
||||
variable version |
||||
set version %version% |
||||
}] |
||||
return |
||||
@ -1,428 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
## Overview |
||||
|
||||
# Heuristics to assemble a platform identifier from publicly available |
||||
# information. The identifier describes the platform of the currently |
||||
# running tcl shell. This is a mixture of the runtime environment and |
||||
# of build-time properties of the executable itself. |
||||
# |
||||
# Examples: |
||||
# <1> A tcl shell executing on a x86_64 processor, but having a |
||||
# wordsize of 4 was compiled for the x86 environment, i.e. 32 |
||||
# bit, and loaded packages have to match that, and not the |
||||
# actual cpu. |
||||
# |
||||
# <2> The hp/solaris 32/64 bit builds of the core cannot be |
||||
# distinguished by looking at tcl_platform. As packages have to |
||||
# match the 32/64 information we have to look in more places. In |
||||
# this case we inspect the executable itself (magic numbers, |
||||
# i.e. fileutil::magic::filetype). |
||||
# |
||||
# The basic information used comes out of the 'os' and 'machine' |
||||
# entries of the 'tcl_platform' array. A number of general and |
||||
# os/machine specific transformation are applied to get a canonical |
||||
# result. |
||||
# |
||||
# General |
||||
# Only the first element of 'os' is used - we don't care whether we |
||||
# are on "Windows NT" or "Windows XP" or whatever. |
||||
# |
||||
# Machine specific |
||||
# % amd64 -> x86_64 |
||||
# % arm* -> arm |
||||
# % sun4* -> sparc |
||||
# % ia32* -> ix86 |
||||
# % intel -> ix86 |
||||
# % i*86* -> ix86 |
||||
# % Power* -> powerpc |
||||
# % x86_64 + wordSize 4 => x86 code |
||||
# |
||||
# OS specific |
||||
# % AIX are always powerpc machines |
||||
# % HP-UX 9000/800 etc means parisc |
||||
# % linux has to take glibc version into account |
||||
# % sunos -> solaris, and keep version number |
||||
# |
||||
# NOTE: A platform like linux glibc 2.3, which can use glibc 2.2 stuff |
||||
# has to provide all possible allowed platform identifiers when |
||||
# searching search. Ditto a solaris 2.8 platform can use solaris 2.6 |
||||
# packages. Etc. This is handled by the other procedure, see below. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requirements |
||||
|
||||
namespace eval ::platform {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Implementation |
||||
|
||||
# -- platform::generic |
||||
# |
||||
# Assembles an identifier for the generic platform. It leaves out |
||||
# details like kernel version, libc version, etc. |
||||
|
||||
proc ::platform::generic {} { |
||||
global tcl_platform |
||||
|
||||
set plat [string tolower [lindex $tcl_platform(os) 0]] |
||||
set cpu $tcl_platform(machine) |
||||
|
||||
switch -glob -- $cpu { |
||||
sun4* { |
||||
set cpu sparc |
||||
} |
||||
intel - |
||||
ia32* - |
||||
i*86* { |
||||
set cpu ix86 |
||||
} |
||||
x86_64 { |
||||
if {$tcl_platform(wordSize) == 4} { |
||||
# See Example <1> at the top of this file. |
||||
set cpu ix86 |
||||
} |
||||
} |
||||
ppc - |
||||
"Power*" { |
||||
set cpu powerpc |
||||
} |
||||
"arm*" { |
||||
set cpu arm |
||||
} |
||||
ia64 { |
||||
if {$tcl_platform(wordSize) == 4} { |
||||
append cpu _32 |
||||
} |
||||
} |
||||
} |
||||
|
||||
switch -glob -- $plat { |
||||
windows { |
||||
if {$tcl_platform(platform) == "unix"} { |
||||
set plat cygwin |
||||
} else { |
||||
set plat win32 |
||||
} |
||||
if {$cpu eq "amd64"} { |
||||
# Do not check wordSize, win32-x64 is an IL32P64 platform. |
||||
set cpu x86_64 |
||||
} |
||||
} |
||||
sunos { |
||||
set plat solaris |
||||
if {[string match "ix86" $cpu]} { |
||||
if {$tcl_platform(wordSize) == 8} { |
||||
set cpu x86_64 |
||||
} |
||||
} elseif {![string match "ia64*" $cpu]} { |
||||
# sparc |
||||
if {$tcl_platform(wordSize) == 8} { |
||||
append cpu 64 |
||||
} |
||||
} |
||||
} |
||||
darwin { |
||||
set plat macosx |
||||
# Correctly identify the cpu when running as a 64bit |
||||
# process on a machine with a 32bit kernel |
||||
if {$cpu eq "ix86"} { |
||||
if {$tcl_platform(wordSize) == 8} { |
||||
set cpu x86_64 |
||||
} |
||||
} |
||||
} |
||||
aix { |
||||
set cpu powerpc |
||||
if {$tcl_platform(wordSize) == 8} { |
||||
append cpu 64 |
||||
} |
||||
} |
||||
hp-ux { |
||||
set plat hpux |
||||
if {![string match "ia64*" $cpu]} { |
||||
set cpu parisc |
||||
if {$tcl_platform(wordSize) == 8} { |
||||
append cpu 64 |
||||
} |
||||
} |
||||
} |
||||
osf1 { |
||||
set plat tru64 |
||||
} |
||||
default { |
||||
set plat [lindex [split $plat _-] 0] |
||||
} |
||||
} |
||||
|
||||
return "${plat}-${cpu}" |
||||
} |
||||
|
||||
# -- platform::identify |
||||
# |
||||
# Assembles an identifier for the exact platform, by extending the |
||||
# generic identifier. I.e. it adds in details like kernel version, |
||||
# libc version, etc., if they are relevant for the loading of |
||||
# packages on the platform. |
||||
|
||||
proc ::platform::identify {} { |
||||
global tcl_platform |
||||
|
||||
set id [generic] |
||||
regexp {^([^-]+)-([^-]+)$} $id -> plat cpu |
||||
|
||||
switch -- $plat { |
||||
solaris { |
||||
regsub {^5} $tcl_platform(osVersion) 2 text |
||||
append plat $text |
||||
return "${plat}-${cpu}" |
||||
} |
||||
macosx { |
||||
set major [lindex [split $tcl_platform(osVersion) .] 0] |
||||
if {$major > 19} { |
||||
set minor [lindex [split $tcl_platform(osVersion) .] 1] |
||||
incr major -9 |
||||
append plat $major.[expr {$minor - 1}] |
||||
} else { |
||||
incr major -4 |
||||
append plat 10.$major |
||||
return "${plat}-${cpu}" |
||||
} |
||||
return "${plat}-${cpu}" |
||||
} |
||||
linux { |
||||
# Look for the libc*.so and determine its version |
||||
# (libc5/6, libc6 further glibc 2.X) |
||||
|
||||
set v unknown |
||||
|
||||
# Determine in which directory to look. /lib, or /lib64. |
||||
# For that we use the tcl_platform(wordSize). |
||||
# |
||||
# We could use the 'cpu' info, per the equivalence below, |
||||
# that however would be restricted to intel. And this may |
||||
# be a arm, mips, etc. system. The wordsize is more |
||||
# fundamental. |
||||
# |
||||
# ix86 <=> (wordSize == 4) <=> 32 bit ==> /lib |
||||
# x86_64 <=> (wordSize == 8) <=> 64 bit ==> /lib64 |
||||
# |
||||
# Do not look into /lib64 even if present, if the cpu |
||||
# doesn't fit. |
||||
|
||||
# TODO: Determine the prefixes (i386, x86_64, ...) for |
||||
# other cpus. The path after the generic one is utterly |
||||
# specific to intel right now. Ok, on Ubuntu, possibly |
||||
# other Debian systems we may apparently be able to query |
||||
# the necessary CPU code. If we can't we simply use the |
||||
# hardwired fallback. |
||||
|
||||
switch -exact -- $tcl_platform(wordSize) { |
||||
4 { |
||||
lappend bases /lib |
||||
if {[catch { |
||||
exec dpkg-architecture -qDEB_HOST_MULTIARCH |
||||
} res]} { |
||||
lappend bases /lib/i386-linux-gnu |
||||
} else { |
||||
# dpkg-arch returns the full tripled, not just cpu. |
||||
lappend bases /lib/$res |
||||
} |
||||
} |
||||
8 { |
||||
lappend bases /lib64 |
||||
if {[catch { |
||||
exec dpkg-architecture -qDEB_HOST_MULTIARCH |
||||
} res]} { |
||||
lappend bases /lib/x86_64-linux-gnu |
||||
} else { |
||||
# dpkg-arch returns the full tripled, not just cpu. |
||||
lappend bases /lib/$res |
||||
} |
||||
} |
||||
default { |
||||
return -code error "Bad wordSize $tcl_platform(wordSize), expected 4 or 8" |
||||
} |
||||
} |
||||
|
||||
foreach base $bases { |
||||
if {[LibcVersion $base -> v]} break |
||||
} |
||||
|
||||
append plat -$v |
||||
return "${plat}-${cpu}" |
||||
} |
||||
} |
||||
|
||||
return $id |
||||
} |
||||
|
||||
proc ::platform::LibcVersion {base _->_ vv} { |
||||
upvar 1 $vv v |
||||
set libclist [lsort [glob -nocomplain -directory $base libc*]] |
||||
|
||||
if {![llength $libclist]} { return 0 } |
||||
|
||||
set libc [lindex $libclist 0] |
||||
|
||||
# Try executing the library first. This should suceed |
||||
# for a glibc library, and return the version |
||||
# information. |
||||
|
||||
if {![catch { |
||||
set vdata [lindex [split [exec $libc] \n] 0] |
||||
}]} { |
||||
regexp {version ([0-9]+(\.[0-9]+)*)} $vdata -> v |
||||
foreach {major minor} [split $v .] break |
||||
set v glibc${major}.${minor} |
||||
return 1 |
||||
} else { |
||||
# We had trouble executing the library. We are now |
||||
# inspecting its name to determine the version |
||||
# number. This code by Larry McVoy. |
||||
|
||||
if {[regexp -- {libc-([0-9]+)\.([0-9]+)} $libc -> major minor]} { |
||||
set v glibc${major}.${minor} |
||||
return 1 |
||||
} |
||||
} |
||||
return 0 |
||||
} |
||||
|
||||
# -- platform::patterns |
||||
# |
||||
# Given an exact platform identifier, i.e. _not_ the generic |
||||
# identifier it assembles a list of exact platform identifier |
||||
# describing platform which should be compatible with the |
||||
# input. |
||||
# |
||||
# I.e. packages for all platforms in the result list should be |
||||
# loadable on the specified platform. |
||||
|
||||
# << Should we add the generic identifier to the list as well ? In |
||||
# general it is not compatible I believe. So better not. In many |
||||
# cases the exact identifier is identical to the generic one |
||||
# anyway. |
||||
# >> |
||||
|
||||
proc ::platform::patterns {id} { |
||||
set res [list $id] |
||||
if {$id eq "tcl"} {return $res} |
||||
|
||||
switch -glob -- $id { |
||||
solaris*-* { |
||||
if {[regexp {solaris([^-]*)-(.*)} $id -> v cpu]} { |
||||
if {$v eq ""} {return $id} |
||||
foreach {major minor} [split $v .] break |
||||
incr minor -1 |
||||
for {set j $minor} {$j >= 6} {incr j -1} { |
||||
lappend res solaris${major}.${j}-${cpu} |
||||
} |
||||
} |
||||
} |
||||
linux*-* { |
||||
if {[regexp {linux-glibc([^-]*)-(.*)} $id -> v cpu]} { |
||||
foreach {major minor} [split $v .] break |
||||
incr minor -1 |
||||
for {set j $minor} {$j >= 0} {incr j -1} { |
||||
lappend res linux-glibc${major}.${j}-${cpu} |
||||
} |
||||
} |
||||
} |
||||
macosx-powerpc { |
||||
lappend res macosx-universal |
||||
} |
||||
macosx-x86_64 { |
||||
lappend res macosx-i386-x86_64 |
||||
} |
||||
macosx-ix86 { |
||||
lappend res macosx-universal macosx-i386-x86_64 |
||||
} |
||||
macosx*-* { |
||||
# 10.5+,11.0+ |
||||
if {[regexp {macosx([^-]*)-(.*)} $id -> v cpu]} { |
||||
|
||||
switch -exact -- $cpu { |
||||
ix86 { |
||||
lappend alt i386-x86_64 |
||||
lappend alt universal |
||||
} |
||||
x86_64 { |
||||
if {[lindex [split $::tcl_platform(osVersion) .] 0] < 19} { |
||||
set alt i386-x86_64 |
||||
} else { |
||||
set alt {} |
||||
} |
||||
} |
||||
arm { |
||||
lappend alt x86_64 |
||||
} |
||||
default { set alt {} } |
||||
} |
||||
|
||||
if {$v ne ""} { |
||||
foreach {major minor} [split $v .] break |
||||
|
||||
set res {} |
||||
if {$major eq 11} { |
||||
# Add 11.0 to 11.minor to patterns. |
||||
for {set j $minor} {$j >= 0} {incr j -1} { |
||||
lappend res macosx${major}.${j}-${cpu} |
||||
foreach a $alt { |
||||
lappend res macosx${major}.${j}-$a |
||||
} |
||||
} |
||||
set major 10 |
||||
set minor 15 |
||||
} |
||||
# Add 10.5 to 10.minor to patterns. |
||||
for {set j $minor} {$j >= 5} {incr j -1} { |
||||
if {$cpu ne "arm"} { |
||||
lappend res macosx${major}.${j}-${cpu} |
||||
} |
||||
foreach a $alt { |
||||
lappend res macosx${major}.${j}-$a |
||||
} |
||||
} |
||||
|
||||
# Add unversioned patterns for 10.3/10.4 builds. |
||||
lappend res macosx-${cpu} |
||||
foreach a $alt { |
||||
lappend res macosx-$a |
||||
} |
||||
} else { |
||||
# No version, just do unversioned patterns. |
||||
foreach a $alt { |
||||
lappend res macosx-$a |
||||
} |
||||
} |
||||
} else { |
||||
# no v, no cpu ... nothing |
||||
} |
||||
} |
||||
} |
||||
lappend res tcl ; # Pure tcl packages are always compatible. |
||||
return $res |
||||
} |
||||
|
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide platform 1.0.17 |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Demo application |
||||
|
||||
if {[info exists argv0] && ($argv0 eq [info script])} { |
||||
puts ==================================== |
||||
parray tcl_platform |
||||
puts ==================================== |
||||
puts Generic\ identification:\ [::platform::generic] |
||||
puts Exact\ identification:\ \ \ [::platform::identify] |
||||
puts ==================================== |
||||
puts Search\ patterns: |
||||
puts *\ [join [::platform::patterns [::platform::identify]] \n*\ ] |
||||
puts ==================================== |
||||
exit 0 |
||||
} |
||||
@ -1,241 +0,0 @@
|
||||
|
||||
# -*- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
## Overview |
||||
|
||||
# Higher-level commands which invoke the functionality of this package |
||||
# for an arbitrary tcl shell (tclsh, wish, ...). This is required by a |
||||
# repository as while the tcl shell executing packages uses the same |
||||
# platform in general as a repository application there can be |
||||
# differences in detail (i.e. 32/64 bit builds). |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requirements |
||||
|
||||
package require platform |
||||
namespace eval ::platform::shell {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Implementation |
||||
|
||||
# -- platform::shell::generic |
||||
|
||||
proc ::platform::shell::generic {shell} { |
||||
# Argument is the path to a tcl shell. |
||||
|
||||
CHECK $shell |
||||
LOCATE base out |
||||
|
||||
set code {} |
||||
# Forget any pre-existing platform package, it might be in |
||||
# conflict with this one. |
||||
lappend code {package forget platform} |
||||
# Inject our platform package |
||||
lappend code [list source $base] |
||||
# Query and print the architecture |
||||
lappend code {puts [platform::generic]} |
||||
# And done |
||||
lappend code {exit 0} |
||||
|
||||
set arch [RUN $shell [join $code \n]] |
||||
|
||||
if {$out} {file delete -force $base} |
||||
return $arch |
||||
} |
||||
|
||||
# -- platform::shell::identify |
||||
|
||||
proc ::platform::shell::identify {shell} { |
||||
# Argument is the path to a tcl shell. |
||||
|
||||
CHECK $shell |
||||
LOCATE base out |
||||
|
||||
set code {} |
||||
# Forget any pre-existing platform package, it might be in |
||||
# conflict with this one. |
||||
lappend code {package forget platform} |
||||
# Inject our platform package |
||||
lappend code [list source $base] |
||||
# Query and print the architecture |
||||
lappend code {puts [platform::identify]} |
||||
# And done |
||||
lappend code {exit 0} |
||||
|
||||
set arch [RUN $shell [join $code \n]] |
||||
|
||||
if {$out} {file delete -force $base} |
||||
return $arch |
||||
} |
||||
|
||||
# -- platform::shell::platform |
||||
|
||||
proc ::platform::shell::platform {shell} { |
||||
# Argument is the path to a tcl shell. |
||||
|
||||
CHECK $shell |
||||
|
||||
set code {} |
||||
lappend code {puts $tcl_platform(platform)} |
||||
lappend code {exit 0} |
||||
|
||||
return [RUN $shell [join $code \n]] |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Internal helper commands. |
||||
|
||||
proc ::platform::shell::CHECK {shell} { |
||||
if {![file exists $shell]} { |
||||
return -code error "Shell \"$shell\" does not exist" |
||||
} |
||||
if {![file executable $shell]} { |
||||
return -code error "Shell \"$shell\" is not executable (permissions)" |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc ::platform::shell::LOCATE {bv ov} { |
||||
upvar 1 $bv base $ov out |
||||
|
||||
# Locate the platform package for injection into the specified |
||||
# shell. We are using package management to find it, whereever it |
||||
# is, instead of using hardwired relative paths. This allows us to |
||||
# install the two packages as TMs without breaking the code |
||||
# here. If the found package is wrapped we copy the code somewhere |
||||
# where the spawned shell will be able to read it. |
||||
|
||||
# This code is brittle, it needs has to adapt to whatever changes |
||||
# are made to the TM code, i.e. the provide statement generated by |
||||
# tm.tcl |
||||
|
||||
set pl [package ifneeded platform [package require platform]] |
||||
set base [lindex $pl end] |
||||
|
||||
set out 0 |
||||
if {[lindex [file system $base]] ne "native"} { |
||||
set temp [TEMP] |
||||
file copy -force $base $temp |
||||
set base $temp |
||||
set out 1 |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc ::platform::shell::RUN {shell code} { |
||||
set c [TEMP] |
||||
set cc [open $c w] |
||||
puts $cc $code |
||||
close $cc |
||||
|
||||
set e [TEMP] |
||||
|
||||
set code [catch { |
||||
exec $shell $c 2> $e |
||||
} res] |
||||
|
||||
file delete $c |
||||
|
||||
if {$code} { |
||||
append res \n[read [set chan [open $e r]]][close $chan] |
||||
file delete $e |
||||
return -code error "Shell \"$shell\" is not executable ($res)" |
||||
} |
||||
|
||||
file delete $e |
||||
return $res |
||||
} |
||||
|
||||
proc ::platform::shell::TEMP {} { |
||||
set prefix platform |
||||
|
||||
# This code is copied out of Tcllib's fileutil package. |
||||
# (TempFile/tempfile) |
||||
|
||||
set tmpdir [DIR] |
||||
|
||||
set chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" |
||||
set nrand_chars 10 |
||||
set maxtries 10 |
||||
set access [list RDWR CREAT EXCL TRUNC] |
||||
set permission 0600 |
||||
set channel "" |
||||
set checked_dir_writable 0 |
||||
set mypid [pid] |
||||
for {set i 0} {$i < $maxtries} {incr i} { |
||||
set newname $prefix |
||||
for {set j 0} {$j < $nrand_chars} {incr j} { |
||||
append newname [string index $chars \ |
||||
[expr {int(rand()*62)}]] |
||||
} |
||||
set newname [file join $tmpdir $newname] |
||||
if {[file exists $newname]} { |
||||
after 1 |
||||
} else { |
||||
if {[catch {open $newname $access $permission} channel]} { |
||||
if {!$checked_dir_writable} { |
||||
set dirname [file dirname $newname] |
||||
if {![file writable $dirname]} { |
||||
return -code error "Directory $dirname is not writable" |
||||
} |
||||
set checked_dir_writable 1 |
||||
} |
||||
} else { |
||||
# Success |
||||
close $channel |
||||
return [file normalize $newname] |
||||
} |
||||
} |
||||
} |
||||
if {$channel ne ""} { |
||||
return -code error "Failed to open a temporary file: $channel" |
||||
} else { |
||||
return -code error "Failed to find an unused temporary file name" |
||||
} |
||||
} |
||||
|
||||
proc ::platform::shell::DIR {} { |
||||
# This code is copied out of Tcllib's fileutil package. |
||||
# (TempDir/tempdir) |
||||
|
||||
global tcl_platform env |
||||
|
||||
set attempdirs [list] |
||||
|
||||
foreach tmp {TMPDIR TEMP TMP} { |
||||
if { [info exists env($tmp)] } { |
||||
lappend attempdirs $env($tmp) |
||||
} |
||||
} |
||||
|
||||
switch $tcl_platform(platform) { |
||||
windows { |
||||
lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP" |
||||
} |
||||
macintosh { |
||||
set tmpdir $env(TRASH_FOLDER) ;# a better place? |
||||
} |
||||
default { |
||||
lappend attempdirs \ |
||||
[file join / tmp] \ |
||||
[file join / var tmp] \ |
||||
[file join / usr tmp] |
||||
} |
||||
} |
||||
|
||||
lappend attempdirs [pwd] |
||||
|
||||
foreach tmp $attempdirs { |
||||
if { [file isdirectory $tmp] && [file writable $tmp] } { |
||||
return [file normalize $tmp] |
||||
} |
||||
} |
||||
|
||||
# Fail if nothing worked. |
||||
return -code error "Unable to determine a proper directory for temporary files" |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide platform::shell 1.1.4 |
||||
@ -0,0 +1,181 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::doc 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::doc { |
||||
namespace export * |
||||
|
||||
proc _default {} { |
||||
puts "documentation subsystem" |
||||
puts "commands: doc.build" |
||||
puts " build documentation from src/doc to src/embedded using the kettle build tool" |
||||
} |
||||
|
||||
proc build {} { |
||||
puts "build docs" |
||||
set projectdir [punk::repo::find_project] |
||||
if {$projectdir eq ""} { |
||||
puts stderr "No current project dir - unable to build docs" |
||||
return |
||||
} |
||||
if {[file exists $projectdir/src/doc]} { |
||||
set original_wd [pwd] |
||||
cd $projectdir/src |
||||
#---------- |
||||
set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] |
||||
$installer set_source_target $projectdir/src/doc $projectdir/src/embedded |
||||
set event [$installer start_event {-install_step kettledoc}] |
||||
#use same virtual id "kettle_build_doc" as project.new - review best way to keep identifiers like this in sync. |
||||
$event targetset_init VIRTUAL kettle_build_doc ;#VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated |
||||
$event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source |
||||
#---------- |
||||
if {\ |
||||
[llength [dict get [$event targetset_source_changes] changed]]\ |
||||
} { |
||||
$event targetset_started |
||||
# -- --- --- --- --- --- |
||||
puts stdout "BUILDING DOCS at $projectdir/src/embedded from src/doc" |
||||
if {[catch { |
||||
|
||||
punk::mix::cli::lib::kettle_call lib doc |
||||
#Kettle doc |
||||
|
||||
} errM]} { |
||||
$event targetset_end FAILED -note "kettle_build_doc failed: $errM" |
||||
} else { |
||||
$event targetset_end OK |
||||
} |
||||
# -- --- --- --- --- --- |
||||
} else { |
||||
puts stderr "No change detected in src/doc" |
||||
$event targetset_end SKIPPED |
||||
} |
||||
$event end |
||||
$event destroy |
||||
$installer destroy |
||||
cd $original_wd |
||||
} else { |
||||
puts stderr "No doc folder found at $projectdir/src/doc" |
||||
} |
||||
} |
||||
proc status {} { |
||||
set projectdir [punk::repo::find_project] |
||||
if {$projectdir eq ""} { |
||||
puts stderr "No current project dir - unable to check doc status" |
||||
return |
||||
} |
||||
if {![file exists $projectdir/src/doc]} { |
||||
set result "No documentation source found. Expected .man files in doctools format at $projectdir/src/doc" |
||||
return $result |
||||
} |
||||
set original_wd [pwd] |
||||
cd $projectdir/src |
||||
puts stdout "Testing status of doctools source location $projectdir/src/doc ..." |
||||
flush stdout |
||||
#---------- |
||||
set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] |
||||
$installer set_source_target $projectdir/src/doc $projectdir/src/embedded |
||||
set event [$installer start_event {-install_step kettledoc}] |
||||
#use same virtual id "kettle_build_doc" as project.new - review best way to keep identifiers like this in sync. |
||||
$event targetset_init QUERY kettle_build_doc ;#usually VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated - but here we use QUERY to ensure no writes to .punkcheck |
||||
set last_completion [$event targetset_last_complete] |
||||
|
||||
if {[llength $last_completion]} { |
||||
#adding a source causes it to be checksummed |
||||
$event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source |
||||
#---------- |
||||
set changeinfo [$event targetset_source_changes] |
||||
if {\ |
||||
[llength [dict get $changeinfo changed]]\ |
||||
} { |
||||
puts stdout "changed" |
||||
puts stdout $changeinfo |
||||
} else { |
||||
puts stdout "No changes detected in $projectdir/src/doc tree" |
||||
} |
||||
} else { |
||||
#no previous completion-record for this target - must assume changed - no need to trigger checksumming |
||||
puts stdout "No existing record of doc build in .punkcheck. Assume it needs to be rebuilt." |
||||
} |
||||
|
||||
|
||||
$event destroy |
||||
$installer destroy |
||||
|
||||
cd $original_wd |
||||
} |
||||
proc validate {} { |
||||
set projectdir [punk::repo::find_project] |
||||
if {$projectdir eq ""} { |
||||
puts stderr "No current project dir - unable to check doc status" |
||||
return |
||||
} |
||||
if {![file exists $projectdir/src/doc]} { |
||||
set result "No documentation source found. Expected .man files in doctools format at $projectdir/src/doc" |
||||
return $result |
||||
} |
||||
set original_wd [pwd] |
||||
cd $projectdir/src |
||||
|
||||
punk::mix::cli::lib::kettle_call lib validate-doc |
||||
|
||||
cd $original_wd |
||||
} |
||||
|
||||
namespace eval collection { |
||||
variable pkg |
||||
set pkg punk::mix::commandset::doc |
||||
|
||||
namespace export * |
||||
namespace path [namespace parent] |
||||
|
||||
} |
||||
|
||||
namespace eval lib { |
||||
variable pkg |
||||
set pkg punk::mix::commandset::doc |
||||
|
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::doc [namespace eval punk::mix::commandset::doc { |
||||
variable pkg punk::mix::commandset::doc |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,3 @@
|
||||
0.1.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
@ -0,0 +1,6 @@
|
||||
## e.g |
||||
#set bootsupport_modules [list\ |
||||
# src/vendormodules cksum\ |
||||
# modules punkcheck\ |
||||
#] |
||||
|
||||
@ -0,0 +1,200 @@
|
||||
# cksum.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||
# |
||||
# Provides a Tcl only implementation of the unix cksum(1) command. This is |
||||
# similar to the sum(1) command but the algorithm is better defined and |
||||
# standardized across multiple platforms by POSIX 1003.2/D11.2 |
||||
# |
||||
# This command has been verified against the cksum command from the GNU |
||||
# textutils package version 2.0 |
||||
# |
||||
# ------------------------------------------------------------------------- |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# ------------------------------------------------------------------------- |
||||
|
||||
package require Tcl 8.5-; # tcl minimum version |
||||
|
||||
namespace eval ::crc { |
||||
namespace export cksum |
||||
|
||||
variable cksum_tbl [list 0x0 \ |
||||
0x04C11DB7 0x09823B6E 0x0D4326D9 0x130476DC 0x17C56B6B \ |
||||
0x1A864DB2 0x1E475005 0x2608EDB8 0x22C9F00F 0x2F8AD6D6 \ |
||||
0x2B4BCB61 0x350C9B64 0x31CD86D3 0x3C8EA00A 0x384FBDBD \ |
||||
0x4C11DB70 0x48D0C6C7 0x4593E01E 0x4152FDA9 0x5F15ADAC \ |
||||
0x5BD4B01B 0x569796C2 0x52568B75 0x6A1936C8 0x6ED82B7F \ |
||||
0x639B0DA6 0x675A1011 0x791D4014 0x7DDC5DA3 0x709F7B7A \ |
||||
0x745E66CD 0x9823B6E0 0x9CE2AB57 0x91A18D8E 0x95609039 \ |
||||
0x8B27C03C 0x8FE6DD8B 0x82A5FB52 0x8664E6E5 0xBE2B5B58 \ |
||||
0xBAEA46EF 0xB7A96036 0xB3687D81 0xAD2F2D84 0xA9EE3033 \ |
||||
0xA4AD16EA 0xA06C0B5D 0xD4326D90 0xD0F37027 0xDDB056FE \ |
||||
0xD9714B49 0xC7361B4C 0xC3F706FB 0xCEB42022 0xCA753D95 \ |
||||
0xF23A8028 0xF6FB9D9F 0xFBB8BB46 0xFF79A6F1 0xE13EF6F4 \ |
||||
0xE5FFEB43 0xE8BCCD9A 0xEC7DD02D 0x34867077 0x30476DC0 \ |
||||
0x3D044B19 0x39C556AE 0x278206AB 0x23431B1C 0x2E003DC5 \ |
||||
0x2AC12072 0x128E9DCF 0x164F8078 0x1B0CA6A1 0x1FCDBB16 \ |
||||
0x018AEB13 0x054BF6A4 0x0808D07D 0x0CC9CDCA 0x7897AB07 \ |
||||
0x7C56B6B0 0x71159069 0x75D48DDE 0x6B93DDDB 0x6F52C06C \ |
||||
0x6211E6B5 0x66D0FB02 0x5E9F46BF 0x5A5E5B08 0x571D7DD1 \ |
||||
0x53DC6066 0x4D9B3063 0x495A2DD4 0x44190B0D 0x40D816BA \ |
||||
0xACA5C697 0xA864DB20 0xA527FDF9 0xA1E6E04E 0xBFA1B04B \ |
||||
0xBB60ADFC 0xB6238B25 0xB2E29692 0x8AAD2B2F 0x8E6C3698 \ |
||||
0x832F1041 0x87EE0DF6 0x99A95DF3 0x9D684044 0x902B669D \ |
||||
0x94EA7B2A 0xE0B41DE7 0xE4750050 0xE9362689 0xEDF73B3E \ |
||||
0xF3B06B3B 0xF771768C 0xFA325055 0xFEF34DE2 0xC6BCF05F \ |
||||
0xC27DEDE8 0xCF3ECB31 0xCBFFD686 0xD5B88683 0xD1799B34 \ |
||||
0xDC3ABDED 0xD8FBA05A 0x690CE0EE 0x6DCDFD59 0x608EDB80 \ |
||||
0x644FC637 0x7A089632 0x7EC98B85 0x738AAD5C 0x774BB0EB \ |
||||
0x4F040D56 0x4BC510E1 0x46863638 0x42472B8F 0x5C007B8A \ |
||||
0x58C1663D 0x558240E4 0x51435D53 0x251D3B9E 0x21DC2629 \ |
||||
0x2C9F00F0 0x285E1D47 0x36194D42 0x32D850F5 0x3F9B762C \ |
||||
0x3B5A6B9B 0x0315D626 0x07D4CB91 0x0A97ED48 0x0E56F0FF \ |
||||
0x1011A0FA 0x14D0BD4D 0x19939B94 0x1D528623 0xF12F560E \ |
||||
0xF5EE4BB9 0xF8AD6D60 0xFC6C70D7 0xE22B20D2 0xE6EA3D65 \ |
||||
0xEBA91BBC 0xEF68060B 0xD727BBB6 0xD3E6A601 0xDEA580D8 \ |
||||
0xDA649D6F 0xC423CD6A 0xC0E2D0DD 0xCDA1F604 0xC960EBB3 \ |
||||
0xBD3E8D7E 0xB9FF90C9 0xB4BCB610 0xB07DABA7 0xAE3AFBA2 \ |
||||
0xAAFBE615 0xA7B8C0CC 0xA379DD7B 0x9B3660C6 0x9FF77D71 \ |
||||
0x92B45BA8 0x9675461F 0x8832161A 0x8CF30BAD 0x81B02D74 \ |
||||
0x857130C3 0x5D8A9099 0x594B8D2E 0x5408ABF7 0x50C9B640 \ |
||||
0x4E8EE645 0x4A4FFBF2 0x470CDD2B 0x43CDC09C 0x7B827D21 \ |
||||
0x7F436096 0x7200464F 0x76C15BF8 0x68860BFD 0x6C47164A \ |
||||
0x61043093 0x65C52D24 0x119B4BE9 0x155A565E 0x18197087 \ |
||||
0x1CD86D30 0x029F3D35 0x065E2082 0x0B1D065B 0x0FDC1BEC \ |
||||
0x3793A651 0x3352BBE6 0x3E119D3F 0x3AD08088 0x2497D08D \ |
||||
0x2056CD3A 0x2D15EBE3 0x29D4F654 0xC5A92679 0xC1683BCE \ |
||||
0xCC2B1D17 0xC8EA00A0 0xD6AD50A5 0xD26C4D12 0xDF2F6BCB \ |
||||
0xDBEE767C 0xE3A1CBC1 0xE760D676 0xEA23F0AF 0xEEE2ED18 \ |
||||
0xF0A5BD1D 0xF464A0AA 0xF9278673 0xFDE69BC4 0x89B8FD09 \ |
||||
0x8D79E0BE 0x803AC667 0x84FBDBD0 0x9ABC8BD5 0x9E7D9662 \ |
||||
0x933EB0BB 0x97FFAD0C 0xAFB010B1 0xAB710D06 0xA6322BDF \ |
||||
0xA2F33668 0xBCB4666D 0xB8757BDA 0xB5365D03 0xB1F740B4 ] |
||||
|
||||
variable uid |
||||
if {![info exists uid]} {set uid 0} |
||||
} |
||||
|
||||
# crc::CksumInit -- |
||||
# |
||||
# Create and initialize a cksum context. This is cleaned up when we |
||||
# call CksumFinal to obtain the result. |
||||
# |
||||
proc ::crc::CksumInit {} { |
||||
variable uid |
||||
set token [namespace current]::[incr uid] |
||||
upvar #0 $token state |
||||
array set state {t 0 l 0} |
||||
return $token |
||||
} |
||||
|
||||
proc ::crc::CksumUpdate {token data} { |
||||
variable cksum_tbl |
||||
upvar #0 $token state |
||||
set t $state(t) |
||||
binary scan $data c* r |
||||
foreach {n} $r { |
||||
set index [expr { (($t >> 24) ^ ($n & 0xFF)) & 0xFF }] |
||||
# Since the introduction of built-in bigInt support with Tcl |
||||
# 8.5, bit-shifting $t to the left no longer overflows, |
||||
# keeping it 32 bits long. The value grows bigger and bigger |
||||
# instead - a severe hit on performance. For this reason we |
||||
# do a bitwise AND against 0xFFFFFFFF at each step to keep the |
||||
# value within limits. |
||||
set t [expr {0xFFFFFFFF & (($t << 8) ^ [lindex $cksum_tbl $index])}] |
||||
incr state(l) |
||||
} |
||||
set state(t) $t |
||||
return |
||||
} |
||||
|
||||
proc ::crc::CksumFinal {token} { |
||||
variable cksum_tbl |
||||
upvar #0 $token state |
||||
set t $state(t) |
||||
for {set i $state(l)} {$i > 0} {set i [expr {$i>>8}]} { |
||||
set index [expr {(($t >> 24) ^ $i) & 0xFF}] |
||||
set t [expr {0xFFFFFFFF & (($t << 8) ^ [lindex $cksum_tbl $index])}] |
||||
} |
||||
unset state |
||||
return [expr {~$t & 0xFFFFFFFF}] |
||||
} |
||||
|
||||
# crc::Pop -- |
||||
# |
||||
# Pop the nth element off a list. Used in options processing. |
||||
# |
||||
proc ::crc::Pop {varname {nth 0}} { |
||||
upvar $varname args |
||||
set r [lindex $args $nth] |
||||
set args [lreplace $args $nth $nth] |
||||
return $r |
||||
} |
||||
|
||||
# Description: |
||||
# Provide a Tcl equivalent of the unix cksum(1) command. |
||||
# Options: |
||||
# -filename name - return a checksum for the specified file. |
||||
# -format string - return the checksum using this format string. |
||||
# -chunksize size - set the chunking read size |
||||
# |
||||
proc ::crc::cksum {args} { |
||||
array set opts [list -filename {} -channel {} -chunksize 4096 \ |
||||
-format %u -command {}] |
||||
while {[string match -* [set option [lindex $args 0]]]} { |
||||
switch -glob -- $option { |
||||
-file* { set opts(-filename) [Pop args 1] } |
||||
-chan* { set opts(-channel) [Pop args 1] } |
||||
-chunk* { set opts(-chunksize) [Pop args 1] } |
||||
-for* { set opts(-format) [Pop args 1] } |
||||
-command { set opts(-command) [Pop args 1] } |
||||
default { |
||||
if {[llength $args] == 1} { break } |
||||
if {[string compare $option "--"] == 0} { Pop args ; break } |
||||
set err [join [lsort [array names opts -*]] ", "] |
||||
return -code error "bad option \"option\": must be $err" |
||||
} |
||||
} |
||||
Pop args |
||||
} |
||||
|
||||
if {$opts(-filename) != {}} { |
||||
set opts(-channel) [open $opts(-filename) r] |
||||
fconfigure $opts(-channel) -translation binary |
||||
} |
||||
|
||||
if {$opts(-channel) == {}} { |
||||
|
||||
if {[llength $args] != 1} { |
||||
return -code error "wrong # args: should be\ |
||||
cksum ?-format string?\ |
||||
-channel chan | -filename file | string" |
||||
} |
||||
set tok [CksumInit] |
||||
CksumUpdate $tok [lindex $args 0] |
||||
set r [CksumFinal $tok] |
||||
|
||||
} else { |
||||
|
||||
set tok [CksumInit] |
||||
while {![eof $opts(-channel)]} { |
||||
CksumUpdate $tok [read $opts(-channel) $opts(-chunksize)] |
||||
} |
||||
set r [CksumFinal $tok] |
||||
|
||||
if {$opts(-filename) != {}} { |
||||
close $opts(-channel) |
||||
} |
||||
} |
||||
|
||||
return [format $opts(-format) $r] |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
package provide cksum 1.1.4 |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Local variables: |
||||
# mode: tcl |
||||
# indent-tabs-mode: nil |
||||
# End: |
||||
@ -0,0 +1,933 @@
|
||||
# cmdline.tcl -- |
||||
# |
||||
# This package provides a utility for parsing command line |
||||
# arguments that are processed by our various applications. |
||||
# It also includes a utility routine to determine the |
||||
# application name for use in command line errors. |
||||
# |
||||
# Copyright (c) 1998-2000 by Ajuba Solutions. |
||||
# Copyright (c) 2001-2015 by Andreas Kupries <andreas_kupries@users.sf.net>. |
||||
# Copyright (c) 2003 by David N. Welton <davidw@dedasys.com> |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
|
||||
package require Tcl 8.5- |
||||
package provide cmdline 1.5.2 |
||||
|
||||
namespace eval ::cmdline { |
||||
namespace export getArgv0 getopt getKnownOpt getfiles getoptions \ |
||||
getKnownOptions usage |
||||
} |
||||
|
||||
# ::cmdline::getopt -- |
||||
# |
||||
# The cmdline::getopt works in a fashion like the standard |
||||
# C based getopt function. Given an option string and a |
||||
# pointer to an array or args this command will process the |
||||
# first argument and return info on how to proceed. |
||||
# |
||||
# Arguments: |
||||
# argvVar Name of the argv list that you |
||||
# want to process. If options are found the |
||||
# arg list is modified and the processed arguments |
||||
# are removed from the start of the list. |
||||
# optstring A list of command options that the application |
||||
# will accept. If the option ends in ".arg" the |
||||
# getopt routine will use the next argument as |
||||
# an argument to the option. Otherwise the option |
||||
# is a boolean that is set to 1 if present. |
||||
# optVar The variable pointed to by optVar |
||||
# contains the option that was found (without the |
||||
# leading '-' and without the .arg extension). |
||||
# valVar Upon success, the variable pointed to by valVar |
||||
# contains the value for the specified option. |
||||
# This value comes from the command line for .arg |
||||
# options, otherwise the value is 1. |
||||
# If getopt fails, the valVar is filled with an |
||||
# error message. |
||||
# |
||||
# Results: |
||||
# The getopt function returns 1 if an option was found, 0 if no more |
||||
# options were found, and -1 if an error occurred. |
||||
|
||||
proc ::cmdline::getopt {argvVar optstring optVar valVar} { |
||||
upvar 1 $argvVar argsList |
||||
upvar 1 $optVar option |
||||
upvar 1 $valVar value |
||||
|
||||
set result [getKnownOpt argsList $optstring option value] |
||||
|
||||
if {$result < 0} { |
||||
# Collapse unknown-option error into any-other-error result. |
||||
set result -1 |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
# ::cmdline::getKnownOpt -- |
||||
# |
||||
# The cmdline::getKnownOpt works in a fashion like the standard |
||||
# C based getopt function. Given an option string and a |
||||
# pointer to an array or args this command will process the |
||||
# first argument and return info on how to proceed. |
||||
# |
||||
# Arguments: |
||||
# argvVar Name of the argv list that you |
||||
# want to process. If options are found the |
||||
# arg list is modified and the processed arguments |
||||
# are removed from the start of the list. Note that |
||||
# unknown options and the args that follow them are |
||||
# left in this list. |
||||
# optstring A list of command options that the application |
||||
# will accept. If the option ends in ".arg" the |
||||
# getopt routine will use the next argument as |
||||
# an argument to the option. Otherwise the option |
||||
# is a boolean that is set to 1 if present. |
||||
# optVar The variable pointed to by optVar |
||||
# contains the option that was found (without the |
||||
# leading '-' and without the .arg extension). |
||||
# valVar Upon success, the variable pointed to by valVar |
||||
# contains the value for the specified option. |
||||
# This value comes from the command line for .arg |
||||
# options, otherwise the value is 1. |
||||
# If getopt fails, the valVar is filled with an |
||||
# error message. |
||||
# |
||||
# Results: |
||||
# The getKnownOpt function returns 1 if an option was found, |
||||
# 0 if no more options were found, -1 if an unknown option was |
||||
# encountered, and -2 if any other error occurred. |
||||
|
||||
proc ::cmdline::getKnownOpt {argvVar optstring optVar valVar} { |
||||
upvar 1 $argvVar argsList |
||||
upvar 1 $optVar option |
||||
upvar 1 $valVar value |
||||
|
||||
# default settings for a normal return |
||||
set value "" |
||||
set option "" |
||||
set result 0 |
||||
|
||||
# check if we're past the end of the args list |
||||
if {[llength $argsList] != 0} { |
||||
|
||||
# if we got -- or an option that doesn't begin with -, return (skipping |
||||
# the --). otherwise process the option arg. |
||||
switch -glob -- [set arg [lindex $argsList 0]] { |
||||
"--" { |
||||
set argsList [lrange $argsList 1 end] |
||||
} |
||||
"--*" - |
||||
"-*" { |
||||
set option [string range $arg 1 end] |
||||
if {[string equal [string range $option 0 0] "-"]} { |
||||
set option [string range $arg 2 end] |
||||
} |
||||
|
||||
# support for format: [-]-option=value |
||||
set idx [string first "=" $option 1] |
||||
if {$idx != -1} { |
||||
set _val [string range $option [expr {$idx+1}] end] |
||||
set option [string range $option 0 [expr {$idx-1}]] |
||||
} |
||||
|
||||
if {[lsearch -exact $optstring $option] != -1} { |
||||
# Booleans are set to 1 when present |
||||
set value 1 |
||||
set result 1 |
||||
set argsList [lrange $argsList 1 end] |
||||
} elseif {[lsearch -exact $optstring "$option.arg"] != -1} { |
||||
set result 1 |
||||
set argsList [lrange $argsList 1 end] |
||||
|
||||
if {[info exists _val]} { |
||||
set value $_val |
||||
} elseif {[llength $argsList]} { |
||||
set value [lindex $argsList 0] |
||||
set argsList [lrange $argsList 1 end] |
||||
} else { |
||||
set value "Option \"$option\" requires an argument" |
||||
set result -2 |
||||
} |
||||
} else { |
||||
# Unknown option. |
||||
set value "Illegal option \"-$option\"" |
||||
set result -1 |
||||
} |
||||
} |
||||
default { |
||||
# Skip ahead |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
# ::cmdline::getoptions -- |
||||
# |
||||
# Process a set of command line options, filling in defaults |
||||
# for those not specified. This also generates an error message |
||||
# that lists the allowed flags if an incorrect flag is specified. |
||||
# |
||||
# Arguments: |
||||
# argvVar The name of the argument list, typically argv. |
||||
# We remove all known options and their args from it. |
||||
# In other words, after the call to this command the |
||||
# referenced variable contains only the non-options, |
||||
# and unknown options. |
||||
# optlist A list-of-lists where each element specifies an option |
||||
# in the form: |
||||
# (where flag takes no argument) |
||||
# flag comment |
||||
# |
||||
# (or where flag takes an argument) |
||||
# flag default comment |
||||
# |
||||
# If flag ends in ".arg" then the value is taken from the |
||||
# command line. Otherwise it is a boolean and appears in |
||||
# the result if present on the command line. If flag ends |
||||
# in ".secret", it will not be displayed in the usage. |
||||
# usage Text to include in the usage display. Defaults to |
||||
# "options:" |
||||
# |
||||
# Results |
||||
# Name value pairs suitable for using with array set. |
||||
# A modified `argvVar`. |
||||
|
||||
proc ::cmdline::getoptions {argvVar optlist {usage options:}} { |
||||
upvar 1 $argvVar argv |
||||
|
||||
set opts [GetOptionDefaults $optlist result] |
||||
|
||||
set argc [llength $argv] |
||||
while {[set err [getopt argv $opts opt arg]]} { |
||||
if {$err < 0} { |
||||
set result(?) "" |
||||
break |
||||
} |
||||
set result($opt) $arg |
||||
} |
||||
if {[info exist result(?)] || [info exists result(help)]} { |
||||
Error [usage $optlist $usage] USAGE |
||||
} |
||||
return [array get result] |
||||
} |
||||
|
||||
# ::cmdline::getKnownOptions -- |
||||
# |
||||
# Process a set of command line options, filling in defaults |
||||
# for those not specified. This ignores unknown flags, but generates |
||||
# an error message that lists the correct usage if a known option |
||||
# is used incorrectly. |
||||
# |
||||
# Arguments: |
||||
# argvVar The name of the argument list, typically argv. This |
||||
# We remove all known options and their args from it. |
||||
# In other words, after the call to this command the |
||||
# referenced variable contains only the non-options, |
||||
# and unknown options. |
||||
# optlist A list-of-lists where each element specifies an option |
||||
# in the form: |
||||
# flag default comment |
||||
# If flag ends in ".arg" then the value is taken from the |
||||
# command line. Otherwise it is a boolean and appears in |
||||
# the result if present on the command line. If flag ends |
||||
# in ".secret", it will not be displayed in the usage. |
||||
# usage Text to include in the usage display. Defaults to |
||||
# "options:" |
||||
# |
||||
# Results |
||||
# Name value pairs suitable for using with array set. |
||||
# A modified `argvVar`. |
||||
|
||||
proc ::cmdline::getKnownOptions {argvVar optlist {usage options:}} { |
||||
upvar 1 $argvVar argv |
||||
|
||||
set opts [GetOptionDefaults $optlist result] |
||||
|
||||
# As we encounter them, keep the unknown options and their |
||||
# arguments in this list. Before we return from this procedure, |
||||
# we'll prepend these args to the argList so that the application |
||||
# doesn't lose them. |
||||
|
||||
set unknownOptions [list] |
||||
|
||||
set argc [llength $argv] |
||||
while {[set err [getKnownOpt argv $opts opt arg]]} { |
||||
if {$err == -1} { |
||||
# Unknown option. |
||||
|
||||
# Skip over any non-option items that follow it. |
||||
# For now, add them to the list of unknownOptions. |
||||
lappend unknownOptions [lindex $argv 0] |
||||
set argv [lrange $argv 1 end] |
||||
while {([llength $argv] != 0) \ |
||||
&& ![string match "-*" [lindex $argv 0]]} { |
||||
lappend unknownOptions [lindex $argv 0] |
||||
set argv [lrange $argv 1 end] |
||||
} |
||||
} elseif {$err == -2} { |
||||
set result(?) "" |
||||
break |
||||
} else { |
||||
set result($opt) $arg |
||||
} |
||||
} |
||||
|
||||
# Before returning, prepend the any unknown args back onto the |
||||
# argList so that the application doesn't lose them. |
||||
set argv [concat $unknownOptions $argv] |
||||
|
||||
if {[info exist result(?)] || [info exists result(help)]} { |
||||
Error [usage $optlist $usage] USAGE |
||||
} |
||||
return [array get result] |
||||
} |
||||
|
||||
# ::cmdline::GetOptionDefaults -- |
||||
# |
||||
# This internal procedure processes the option list (that was passed to |
||||
# the getopt or getKnownOpt procedure). The defaultArray gets an index |
||||
# for each option in the option list, the value of which is the option's |
||||
# default value. |
||||
# |
||||
# Arguments: |
||||
# optlist A list-of-lists where each element specifies an option |
||||
# in the form: |
||||
# flag default comment |
||||
# If flag ends in ".arg" then the value is taken from the |
||||
# command line. Otherwise it is a boolean and appears in |
||||
# the result if present on the command line. If flag ends |
||||
# in ".secret", it will not be displayed in the usage. |
||||
# defaultArrayVar The name of the array in which to put argument defaults. |
||||
# |
||||
# Results |
||||
# Name value pairs suitable for using with array set. |
||||
|
||||
proc ::cmdline::GetOptionDefaults {optlist defaultArrayVar} { |
||||
upvar 1 $defaultArrayVar result |
||||
|
||||
set opts {? help} |
||||
foreach opt $optlist { |
||||
set name [lindex $opt 0] |
||||
if {[regsub -- {\.secret$} $name {} name] == 1} { |
||||
# Need to hide this from the usage display and getopt |
||||
} |
||||
lappend opts $name |
||||
if {[regsub -- {\.arg$} $name {} name] == 1} { |
||||
|
||||
# Set defaults for those that take values. |
||||
|
||||
set default [lindex $opt 1] |
||||
set result($name) $default |
||||
} else { |
||||
# The default for booleans is false |
||||
set result($name) 0 |
||||
} |
||||
} |
||||
return $opts |
||||
} |
||||
|
||||
# ::cmdline::usage -- |
||||
# |
||||
# Generate an error message that lists the allowed flags. |
||||
# |
||||
# Arguments: |
||||
# optlist As for cmdline::getoptions |
||||
# usage Text to include in the usage display. Defaults to |
||||
# "options:" |
||||
# |
||||
# Results |
||||
# A formatted usage message |
||||
|
||||
proc ::cmdline::usage {optlist {usage {options:}}} { |
||||
set str "[getArgv0] $usage\n" |
||||
set longest 20 |
||||
set lines {} |
||||
foreach opt [concat $optlist \ |
||||
{{- "Forcibly stop option processing"} {help "Print this message"} {? "Print this message"}}] { |
||||
set name "-[lindex $opt 0]" |
||||
if {[regsub -- {\.secret$} $name {} name] == 1} { |
||||
# Hidden option |
||||
continue |
||||
} |
||||
if {[regsub -- {\.arg$} $name {} name] == 1} { |
||||
append name " value" |
||||
set desc "[lindex $opt 2] <[lindex $opt 1]>" |
||||
} else { |
||||
set desc "[lindex $opt 1]" |
||||
} |
||||
set n [string length $name] |
||||
if {$n > $longest} { set longest $n } |
||||
# max not available before 8.5 - set longest [expr {max($longest, )}] |
||||
lappend lines $name $desc |
||||
} |
||||
foreach {name desc} $lines { |
||||
append str "[string trimright [format " %-*s %s" $longest $name $desc]]\n" |
||||
} |
||||
|
||||
return $str |
||||
} |
||||
|
||||
# ::cmdline::getfiles -- |
||||
# |
||||
# Given a list of file arguments from the command line, compute |
||||
# the set of valid files. On windows, file globbing is performed |
||||
# on each argument. On Unix, only file existence is tested. If |
||||
# a file argument produces no valid files, a warning is optionally |
||||
# generated. |
||||
# |
||||
# This code also uses the full path for each file. If not |
||||
# given it prepends [pwd] to the filename. This ensures that |
||||
# these files will never conflict with files in our zip file. |
||||
# |
||||
# Arguments: |
||||
# patterns The file patterns specified by the user. |
||||
# quiet If this flag is set, no warnings will be generated. |
||||
# |
||||
# Results: |
||||
# Returns the list of files that match the input patterns. |
||||
|
||||
proc ::cmdline::getfiles {patterns quiet} { |
||||
set result {} |
||||
if {$::tcl_platform(platform) == "windows"} { |
||||
foreach pattern $patterns { |
||||
set pat [file join $pattern] |
||||
set files [glob -nocomplain -- $pat] |
||||
if {$files == {}} { |
||||
if {! $quiet} { |
||||
puts stdout "warning: no files match \"$pattern\"" |
||||
} |
||||
} else { |
||||
foreach file $files { |
||||
lappend result $file |
||||
} |
||||
} |
||||
} |
||||
} else { |
||||
set result $patterns |
||||
} |
||||
set files {} |
||||
foreach file $result { |
||||
# Make file an absolute path so that we will never conflict |
||||
# with files that might be contained in our zip file. |
||||
set fullPath [file join [pwd] $file] |
||||
|
||||
if {[file isfile $fullPath]} { |
||||
lappend files $fullPath |
||||
} elseif {! $quiet} { |
||||
puts stdout "warning: no files match \"$file\"" |
||||
} |
||||
} |
||||
return $files |
||||
} |
||||
|
||||
# ::cmdline::getArgv0 -- |
||||
# |
||||
# This command returns the "sanitized" version of argv0. It will strip |
||||
# off the leading path and remove the ".bin" extensions that our apps |
||||
# use because they must be wrapped by a shell script. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# The application name that can be used in error messages. |
||||
|
||||
proc ::cmdline::getArgv0 {} { |
||||
global argv0 |
||||
|
||||
set name [file tail $argv0] |
||||
return [file rootname $name] |
||||
} |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
# Now the typed versions of the above commands. |
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
# typedCmdline.tcl -- |
||||
# |
||||
# This package provides a utility for parsing typed command |
||||
# line arguments that may be processed by various applications. |
||||
# |
||||
# Copyright (c) 2000 by Ross Palmer Mohn. |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: cmdline.tcl,v 1.28 2011/02/23 17:41:52 andreas_kupries Exp $ |
||||
|
||||
namespace eval ::cmdline { |
||||
namespace export typedGetopt typedGetoptions typedUsage |
||||
|
||||
# variable cmdline::charclasses -- |
||||
# |
||||
# Create regexp list of allowable character classes |
||||
# from "string is" error message. |
||||
# |
||||
# Results: |
||||
# String of character class names separated by "|" characters. |
||||
|
||||
variable charclasses |
||||
#checker exclude badKey |
||||
catch {string is . .} charclasses |
||||
variable dummy |
||||
regexp -- {must be (.+)$} $charclasses dummy charclasses |
||||
regsub -all -- {, (or )?} $charclasses {|} charclasses |
||||
unset dummy |
||||
} |
||||
|
||||
# ::cmdline::typedGetopt -- |
||||
# |
||||
# The cmdline::typedGetopt works in a fashion like the standard |
||||
# C based getopt function. Given an option string and a |
||||
# pointer to a list of args this command will process the |
||||
# first argument and return info on how to proceed. In addition, |
||||
# you may specify a type for the argument to each option. |
||||
# |
||||
# Arguments: |
||||
# argvVar Name of the argv list that you want to process. |
||||
# If options are found, the arg list is modified |
||||
# and the processed arguments are removed from the |
||||
# start of the list. |
||||
# |
||||
# optstring A list of command options that the application |
||||
# will accept. If the option ends in ".xxx", where |
||||
# xxx is any valid character class to the tcl |
||||
# command "string is", then typedGetopt routine will |
||||
# use the next argument as a typed argument to the |
||||
# option. The argument must match the specified |
||||
# character classes (e.g. integer, double, boolean, |
||||
# xdigit, etc.). Alternatively, you may specify |
||||
# ".arg" for an untyped argument. |
||||
# |
||||
# optVar Upon success, the variable pointed to by optVar |
||||
# contains the option that was found (without the |
||||
# leading '-' and without the .xxx extension). If |
||||
# typedGetopt fails the variable is set to the empty |
||||
# string. SOMETIMES! Different for each -value! |
||||
# |
||||
# argVar Upon success, the variable pointed to by argVar |
||||
# contains the argument for the specified option. |
||||
# If typedGetopt fails, the variable is filled with |
||||
# an error message. |
||||
# |
||||
# Argument type syntax: |
||||
# Option that takes no argument. |
||||
# foo |
||||
# |
||||
# Option that takes a typeless argument. |
||||
# foo.arg |
||||
# |
||||
# Option that takes a typed argument. Allowable types are all |
||||
# valid character classes to the tcl command "string is". |
||||
# Currently must be one of alnum, alpha, ascii, control, |
||||
# boolean, digit, double, false, graph, integer, lower, print, |
||||
# punct, space, true, upper, wordchar, or xdigit. |
||||
# foo.double |
||||
# |
||||
# Option that takes an argument from a list. |
||||
# foo.(bar|blat) |
||||
# |
||||
# Argument quantifier syntax: |
||||
# Option that takes an optional argument. |
||||
# foo.arg? |
||||
# |
||||
# Option that takes a list of arguments terminated by "--". |
||||
# foo.arg+ |
||||
# |
||||
# Option that takes an optional list of arguments terminated by "--". |
||||
# foo.arg* |
||||
# |
||||
# Argument quantifiers work on all argument types, so, for |
||||
# example, the following is a valid option specification. |
||||
# foo.(bar|blat|blah)? |
||||
# |
||||
# Argument syntax miscellany: |
||||
# Options may be specified on the command line using a unique, |
||||
# shortened version of the option name. Given that program foo |
||||
# has an option list of {bar.alpha blah.arg blat.double}, |
||||
# "foo -b fob" returns an error, but "foo -ba fob" |
||||
# successfully returns {bar fob} |
||||
# |
||||
# Results: |
||||
# The typedGetopt function returns one of the following: |
||||
# 1 a valid option was found |
||||
# 0 no more options found to process |
||||
# -1 invalid option |
||||
# -2 missing argument to a valid option |
||||
# -3 argument to a valid option does not match type |
||||
# |
||||
# Known Bugs: |
||||
# When using options which include special glob characters, |
||||
# you must use the exact option. Abbreviating it can cause |
||||
# an error in the "cmdline::prefixSearch" procedure. |
||||
|
||||
proc ::cmdline::typedGetopt {argvVar optstring optVar argVar} { |
||||
variable charclasses |
||||
|
||||
upvar $argvVar argsList |
||||
|
||||
upvar $optVar retvar |
||||
upvar $argVar optarg |
||||
|
||||
# default settings for a normal return |
||||
set optarg "" |
||||
set retvar "" |
||||
set retval 0 |
||||
|
||||
# check if we're past the end of the args list |
||||
if {[llength $argsList] != 0} { |
||||
|
||||
# if we got -- or an option that doesn't begin with -, return (skipping |
||||
# the --). otherwise process the option arg. |
||||
switch -glob -- [set arg [lindex $argsList 0]] { |
||||
"--" { |
||||
set argsList [lrange $argsList 1 end] |
||||
} |
||||
|
||||
"-*" { |
||||
# Create list of options without their argument extensions |
||||
|
||||
set optstr "" |
||||
foreach str $optstring { |
||||
lappend optstr [file rootname $str] |
||||
} |
||||
|
||||
set _opt [string range $arg 1 end] |
||||
|
||||
set i [prefixSearch $optstr [file rootname $_opt]] |
||||
if {$i != -1} { |
||||
set opt [lindex $optstring $i] |
||||
|
||||
set quantifier "none" |
||||
if {[regexp -- {\.[^.]+([?+*])$} $opt dummy quantifier]} { |
||||
set opt [string range $opt 0 end-1] |
||||
} |
||||
|
||||
if {[string first . $opt] == -1} { |
||||
set retval 1 |
||||
set retvar $opt |
||||
set argsList [lrange $argsList 1 end] |
||||
|
||||
} elseif {[regexp -- "\\.(arg|$charclasses)\$" $opt dummy charclass] |
||||
|| [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} { |
||||
if {[string equal arg $charclass]} { |
||||
set type arg |
||||
} elseif {[regexp -- "^($charclasses)\$" $charclass]} { |
||||
set type class |
||||
} else { |
||||
set type oneof |
||||
} |
||||
|
||||
set argsList [lrange $argsList 1 end] |
||||
set opt [file rootname $opt] |
||||
|
||||
while {1} { |
||||
if {[llength $argsList] == 0 |
||||
|| [string equal "--" [lindex $argsList 0]]} { |
||||
if {[string equal "--" [lindex $argsList 0]]} { |
||||
set argsList [lrange $argsList 1 end] |
||||
} |
||||
|
||||
set oneof "" |
||||
if {$type == "arg"} { |
||||
set charclass an |
||||
} elseif {$type == "oneof"} { |
||||
set oneof ", one of $charclass" |
||||
set charclass an |
||||
} |
||||
|
||||
if {$quantifier == "?"} { |
||||
set retval 1 |
||||
set retvar $opt |
||||
set optarg "" |
||||
} elseif {$quantifier == "+"} { |
||||
set retvar $opt |
||||
if {[llength $optarg] < 1} { |
||||
set retval -2 |
||||
set optarg "Option requires at least one $charclass argument$oneof -- $opt" |
||||
} else { |
||||
set retval 1 |
||||
} |
||||
} elseif {$quantifier == "*"} { |
||||
set retval 1 |
||||
set retvar $opt |
||||
} else { |
||||
set optarg "Option requires $charclass argument$oneof -- $opt" |
||||
set retvar $opt |
||||
set retval -2 |
||||
} |
||||
set quantifier "" |
||||
} elseif {($type == "arg") |
||||
|| (($type == "oneof") |
||||
&& [string first "|[lindex $argsList 0]|" "|$charclass|"] != -1) |
||||
|| (($type == "class") |
||||
&& [string is $charclass [lindex $argsList 0]])} { |
||||
set retval 1 |
||||
set retvar $opt |
||||
lappend optarg [lindex $argsList 0] |
||||
set argsList [lrange $argsList 1 end] |
||||
} else { |
||||
set oneof "" |
||||
if {$type == "arg"} { |
||||
set charclass an |
||||
} elseif {$type == "oneof"} { |
||||
set oneof ", one of $charclass" |
||||
set charclass an |
||||
} |
||||
set optarg "Option requires $charclass argument$oneof -- $opt" |
||||
set retvar $opt |
||||
set retval -3 |
||||
|
||||
if {$quantifier == "?"} { |
||||
set retval 1 |
||||
set optarg "" |
||||
} |
||||
set quantifier "" |
||||
} |
||||
if {![regexp -- {[+*]} $quantifier]} { |
||||
break; |
||||
} |
||||
} |
||||
} else { |
||||
Error \ |
||||
"Illegal option type specification: must be one of $charclasses" \ |
||||
BAD OPTION TYPE |
||||
} |
||||
} else { |
||||
set optarg "Illegal option -- $_opt" |
||||
set retvar $_opt |
||||
set retval -1 |
||||
} |
||||
} |
||||
default { |
||||
# Skip ahead |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $retval |
||||
} |
||||
|
||||
# ::cmdline::typedGetoptions -- |
||||
# |
||||
# Process a set of command line options, filling in defaults |
||||
# for those not specified. This also generates an error message |
||||
# that lists the allowed options if an incorrect option is |
||||
# specified. |
||||
# |
||||
# Arguments: |
||||
# argvVar The name of the argument list, typically argv |
||||
# optlist A list-of-lists where each element specifies an option |
||||
# in the form: |
||||
# |
||||
# option default comment |
||||
# |
||||
# Options formatting is as described for the optstring |
||||
# argument of typedGetopt. Default is for optionally |
||||
# specifying a default value. Comment is for optionally |
||||
# specifying a comment for the usage display. The |
||||
# options "--", "-help", and "-?" are automatically included |
||||
# in optlist. |
||||
# |
||||
# Argument syntax miscellany: |
||||
# Options formatting and syntax is as described in typedGetopt. |
||||
# There are two additional suffixes that may be applied when |
||||
# passing options to typedGetoptions. |
||||
# |
||||
# You may add ".multi" as a suffix to any option. For options |
||||
# that take an argument, this means that the option may be used |
||||
# more than once on the command line and that each additional |
||||
# argument will be appended to a list, which is then returned |
||||
# to the application. |
||||
# foo.double.multi |
||||
# |
||||
# If a non-argument option is specified as ".multi", it is |
||||
# toggled on and off for each time it is used on the command |
||||
# line. |
||||
# foo.multi |
||||
# |
||||
# If an option specification does not contain the ".multi" |
||||
# suffix, it is not an error to use an option more than once. |
||||
# In this case, the behavior for options with arguments is that |
||||
# the last argument is the one that will be returned. For |
||||
# options that do not take arguments, using them more than once |
||||
# has no additional effect. |
||||
# |
||||
# Options may also be hidden from the usage display by |
||||
# appending the suffix ".secret" to any option specification. |
||||
# Please note that the ".secret" suffix must be the last suffix, |
||||
# after any argument type specification and ".multi" suffix. |
||||
# foo.xdigit.multi.secret |
||||
# |
||||
# Results |
||||
# Name value pairs suitable for using with array set. |
||||
|
||||
proc ::cmdline::typedGetoptions {argvVar optlist {usage options:}} { |
||||
variable charclasses |
||||
|
||||
upvar 1 $argvVar argv |
||||
|
||||
set opts {? help} |
||||
foreach opt $optlist { |
||||
set name [lindex $opt 0] |
||||
if {[regsub -- {\.secret$} $name {} name] == 1} { |
||||
# Remove this extension before passing to typedGetopt. |
||||
} |
||||
if {[regsub -- {\.multi$} $name {} name] == 1} { |
||||
# Remove this extension before passing to typedGetopt. |
||||
|
||||
regsub -- {\..*$} $name {} temp |
||||
set multi($temp) 1 |
||||
} |
||||
lappend opts $name |
||||
if {[regsub -- "\\.(arg|$charclasses|\\(.+).?\$" $name {} name] == 1} { |
||||
# Set defaults for those that take values. |
||||
# Booleans are set just by being present, or not |
||||
|
||||
set dflt [lindex $opt 1] |
||||
if {$dflt != {}} { |
||||
set defaults($name) $dflt |
||||
} |
||||
} |
||||
} |
||||
set argc [llength $argv] |
||||
while {[set err [typedGetopt argv $opts opt arg]]} { |
||||
if {$err == 1} { |
||||
if {[info exists result($opt)] |
||||
&& [info exists multi($opt)]} { |
||||
# Toggle boolean options or append new arguments |
||||
|
||||
if {$arg == ""} { |
||||
unset result($opt) |
||||
} else { |
||||
set result($opt) "$result($opt) $arg" |
||||
} |
||||
} else { |
||||
set result($opt) "$arg" |
||||
} |
||||
} elseif {($err == -1) || ($err == -3)} { |
||||
Error [typedUsage $optlist $usage] USAGE |
||||
} elseif {$err == -2 && ![info exists defaults($opt)]} { |
||||
Error [typedUsage $optlist $usage] USAGE |
||||
} |
||||
} |
||||
if {[info exists result(?)] || [info exists result(help)]} { |
||||
Error [typedUsage $optlist $usage] USAGE |
||||
} |
||||
foreach {opt dflt} [array get defaults] { |
||||
if {![info exists result($opt)]} { |
||||
set result($opt) $dflt |
||||
} |
||||
} |
||||
return [array get result] |
||||
} |
||||
|
||||
# ::cmdline::typedUsage -- |
||||
# |
||||
# Generate an error message that lists the allowed flags, |
||||
# type of argument taken (if any), default value (if any), |
||||
# and an optional description. |
||||
# |
||||
# Arguments: |
||||
# optlist As for cmdline::typedGetoptions |
||||
# |
||||
# Results |
||||
# A formatted usage message |
||||
|
||||
proc ::cmdline::typedUsage {optlist {usage {options:}}} { |
||||
variable charclasses |
||||
|
||||
set str "[getArgv0] $usage\n" |
||||
set longest 20 |
||||
set lines {} |
||||
foreach opt [concat $optlist \ |
||||
{{help "Print this message"} {? "Print this message"}}] { |
||||
set name "-[lindex $opt 0]" |
||||
if {[regsub -- {\.secret$} $name {} name] == 1} { |
||||
# Hidden option |
||||
continue |
||||
} |
||||
|
||||
if {[regsub -- {\.multi$} $name {} name] == 1} { |
||||
# Display something about multiple options |
||||
} |
||||
|
||||
if {[regexp -- "\\.(arg|$charclasses)\$" $name dummy charclass] || |
||||
[regexp -- {\.\(([^)]+)\)} $opt dummy charclass] |
||||
} { |
||||
regsub -- "\\..+\$" $name {} name |
||||
append name " $charclass" |
||||
set desc [lindex $opt 2] |
||||
set default [lindex $opt 1] |
||||
if {$default != ""} { |
||||
append desc " <$default>" |
||||
} |
||||
} else { |
||||
set desc [lindex $opt 1] |
||||
} |
||||
lappend accum $name $desc |
||||
set n [string length $name] |
||||
if {$n > $longest} { set longest $n } |
||||
# max not available before 8.5 - set longest [expr {max($longest, [string length $name])}] |
||||
} |
||||
foreach {name desc} $accum { |
||||
append str "[string trimright [format " %-*s %s" $longest $name $desc]]\n" |
||||
} |
||||
return $str |
||||
} |
||||
|
||||
# ::cmdline::prefixSearch -- |
||||
# |
||||
# Search a Tcl list for a pattern; searches first for an exact match, |
||||
# and if that fails, for a unique prefix that matches the pattern |
||||
# (i.e, first "lsearch -exact", then "lsearch -glob $pattern*" |
||||
# |
||||
# Arguments: |
||||
# list list of words |
||||
# pattern word to search for |
||||
# |
||||
# Results: |
||||
# Index of found word is returned. If no exact match or |
||||
# unique short version is found then -1 is returned. |
||||
|
||||
proc ::cmdline::prefixSearch {list pattern} { |
||||
# Check for an exact match |
||||
|
||||
if {[set pos [::lsearch -exact $list $pattern]] > -1} { |
||||
return $pos |
||||
} |
||||
|
||||
# Check for a unique short version |
||||
|
||||
set slist [lsort $list] |
||||
if {[set pos [::lsearch -glob $slist $pattern*]] > -1} { |
||||
# What if there is nothing for the check variable? |
||||
|
||||
set check [lindex $slist [expr {$pos + 1}]] |
||||
if {[string first $pattern $check] != 0} { |
||||
return [::lsearch -exact $list [lindex $slist $pos]] |
||||
} |
||||
} |
||||
return -1 |
||||
} |
||||
# ::cmdline::Error -- |
||||
# |
||||
# Internal helper to throw errors with a proper error-code attached. |
||||
# |
||||
# Arguments: |
||||
# message text of the error message to throw. |
||||
# args additional parts of the error code to use, |
||||
# with CMDLINE as basic prefix added by this command. |
||||
# |
||||
# Results: |
||||
# An error is thrown, always. |
||||
|
||||
proc ::cmdline::Error {message args} { |
||||
return -code error -errorcode [linsert $args 0 CMDLINE] $message |
||||
} |
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,195 @@
|
||||
#JMN - api should be kept in sync with package patternlib where possible |
||||
# |
||||
package provide oolib [namespace eval oolib { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
||||
namespace eval oolib { |
||||
oo::class create collection { |
||||
variable o_data ;#dict |
||||
variable o_alias |
||||
constructor {} { |
||||
set o_data [dict create] |
||||
} |
||||
method info {} { |
||||
return [dict info $o_data] |
||||
} |
||||
method count {} { |
||||
return [dict size $o_data] |
||||
} |
||||
method isEmpty {} { |
||||
expr {[dict size $o_data] == 0} |
||||
} |
||||
method names {{globOrIdx {}}} { |
||||
if {[llength $globOrIdx]} { |
||||
if {[string is integer -strict $globOrIdx]} { |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $idx} result]} { |
||||
error "[self object] no such index : '$idx'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} else { |
||||
#glob |
||||
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] |
||||
} |
||||
} else { |
||||
return [dict keys $o_data] |
||||
} |
||||
} |
||||
#like names but without globbing |
||||
method keys {} { |
||||
dict keys $o_data |
||||
} |
||||
method key {{posn 0}} { |
||||
if {$posn < 0} { |
||||
set posn "end-[expr {abs($posn + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $posn} result]} { |
||||
error "[self object] no such index : '$posn'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} |
||||
method hasKey {key} { |
||||
dict exists $o_data $key |
||||
} |
||||
method get {} { |
||||
return $o_data |
||||
} |
||||
method items {} { |
||||
return [dict values $o_data] |
||||
} |
||||
method item {key} { |
||||
if {[string is integer -strict $key]} { |
||||
if {$key > 0} { |
||||
set valposn [expr {(2*$key) +1}] |
||||
return [lindex $o_data $valposn] |
||||
} else { |
||||
set key "end-[expr {abs($key + 1)}]" |
||||
return [lindex [dict keys $o_data] $key] |
||||
} |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
return [dict get $o_data $key] |
||||
} |
||||
} |
||||
#inverse lookup |
||||
method itemKeys {value} { |
||||
set value_indices [lsearch -all [dict values $o_data] $value] |
||||
set keylist [list] |
||||
foreach i $value_indices { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
method search {value args} { |
||||
set matches [lsearch {*}$args [dict values $o_data] $value] |
||||
if {"-inline" in $args} { |
||||
return $matches |
||||
} else { |
||||
set keylist [list] |
||||
foreach i $matches { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
} |
||||
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? |
||||
method alias {newAlias existingKeyOrAlias} { |
||||
if {[string is integer -strict $newAlias]} { |
||||
error "[self object] collection key alias cannot be integer" |
||||
} |
||||
if {[string length $existingKeyOrAlias]} { |
||||
set o_alias($newAlias) $existingKeyOrAlias |
||||
} else { |
||||
unset o_alias($newAlias) |
||||
} |
||||
} |
||||
method aliases {{key ""}} { |
||||
if {[string length $key]} { |
||||
set result [list] |
||||
foreach {n v} [array get o_alias] { |
||||
if {$v eq $key} { |
||||
lappend result $n $v |
||||
} |
||||
} |
||||
return $result |
||||
} else { |
||||
return [array get o_alias] |
||||
} |
||||
} |
||||
#if the supplied index is an alias, return the underlying key; else return the index supplied. |
||||
method realKey {idx} { |
||||
if {[catch {set o_alias($idx)} key]} { |
||||
return $idx |
||||
} else { |
||||
return $key |
||||
} |
||||
} |
||||
method add {value key} { |
||||
if {[string is integer -strict $key]} { |
||||
error "[self object] collection key must not be an integer. Use another structure if integer keys required" |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
error "[self object] col_processors object error: key '$key' already exists in collection" |
||||
} |
||||
dict set o_data $key $value |
||||
return [expr {[dict size $o_data] - 1}] ;#return index of item |
||||
} |
||||
method remove {idx {endRange ""}} { |
||||
if {[string length $endRange]} { |
||||
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" |
||||
} |
||||
if {[string is integer -strict $idx]} { |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx+1)}]" |
||||
} |
||||
set key [lindex [dict keys $o_data] $idx] |
||||
set posn $idx |
||||
} else { |
||||
set key $idx |
||||
set posn [lsearch -exact [dict keys $o_data] $key] |
||||
if {$posn < 0} { |
||||
error "[self object] no such index: '$idx' in this collection" |
||||
} |
||||
} |
||||
dict unset o_data $key |
||||
return |
||||
} |
||||
method clear {} { |
||||
set o_data [dict create] |
||||
return |
||||
} |
||||
method reverse {} { |
||||
set dictnew [dict create] |
||||
foreach k [lreverse [dict keys $o_data]] { |
||||
dict set dictnew $k [dict get $o_data $k] |
||||
} |
||||
set o_data $dictnew |
||||
return |
||||
} |
||||
#review - cmd as list vs cmd as script? |
||||
method map {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list {*}$cmd $v]] |
||||
} |
||||
return $seed |
||||
} |
||||
method objectmap {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list $v {*}$cmd]] |
||||
} |
||||
return $seed |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,15 @@
|
||||
|
||||
package require punk::cap |
||||
package require punk::mix::templates ;#registers 'templates' capability with punk::cap |
||||
package require punk::mix::base |
||||
package require punk::mix::cli |
||||
|
||||
namespace eval punk::mix { |
||||
|
||||
} |
||||
|
||||
package provide punk::mix [namespace eval punk::mix { |
||||
variable version |
||||
set version 0.2 |
||||
|
||||
}] |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,266 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::winpath 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::winpath { |
||||
namespace export winpath windir cdwin cdwindir illegalname_fix illegalname_test |
||||
|
||||
|
||||
|
||||
|
||||
#\\servername\share etc or \\?\UNC\servername\share etc. |
||||
proc is_unc_path {path} { |
||||
set strcopy_path [punk::objclone $path] |
||||
set strcopy_path [string map [list \\ /] $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway) |
||||
if {[string first "//" $strcopy_path] == 0} { |
||||
#check for "Dos device path" syntax |
||||
if {[string range $strcopy_path 0 3] in [list "//?/" "//./"]} { |
||||
#Note that //./ doesn't appear to be supported in Tcl as at 2023-08 - but //?/ works (except for //?/UNC/Server/share) |
||||
if {[string range $strcopy_path 4 6] eq "UNC"} { |
||||
return 1 |
||||
} else { |
||||
#some other Dos device path. Could be a drive which is mapped to a UNC path - but the path itself isn't a unc path |
||||
return 0 |
||||
} |
||||
} else { |
||||
#leading double slash and not dos device path syntax |
||||
return 1 |
||||
} |
||||
} |
||||
return 0 |
||||
} |
||||
|
||||
#ordinary \\Servername or \\servername\share or \\servername\share\path (or forward-slash equivalent) with no dos device syntax //?/ //./ etc. |
||||
proc is_unc_path_plain {path} { |
||||
if {[is_unc_path $path]} { |
||||
if {![is_dos_device_path $path]} { |
||||
return 1 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
|
||||
#int-rep path preserved - but 'file attributes', and therefor this operation, is expensive (on windows at least) |
||||
proc pwdshortname {{path {}}} { |
||||
if {$path eq ""} { |
||||
set path [pwd] |
||||
} else { |
||||
if {[file pathtype $path] eq "relative"} { |
||||
set path [file normalize $path] |
||||
} |
||||
} |
||||
return [dict get [file attributes $path] -shortname] |
||||
} |
||||
#dos device path syntax allows windows api to acces extended-length paths and filenames with illegal path characters such as trailing dots or whitespace |
||||
#(can exist on server shares and on NTFS - but standard apps can't access without dos device syntax) |
||||
proc is_dos_device_path {path} { |
||||
set strcopy_path [punk::objclone $path] |
||||
set strcopy_path [string map [list \\ /] $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway) |
||||
if {[string range $strcopy_path 0 3] in [list "//?/" "//./"]} { |
||||
return 1 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
proc strip_dos_device_prefix {path} { |
||||
#it's unlikely to be valid to strip only //?/ from a //?/UNC path so check for it here and diver to strip that. |
||||
#(review.. or raise error because a //?/UNC path isn't *strictly* a UNC path? ) |
||||
if {[is_unc_path $path]} { |
||||
return [strip_unc_path_prefix $path] |
||||
} |
||||
if {[is_dos_device_path $path]} { |
||||
return [string range $path 4 end] |
||||
} else { |
||||
return $path |
||||
} |
||||
} |
||||
proc strip_unc_path_prefix {path} { |
||||
if {[is_unc_path $path]} { |
||||
#//?/UNC/server/etc |
||||
set strcopy_path [punk::objclone $path] |
||||
set trimmedpath [string range $strcopy_path 7 end] |
||||
file pathtype $trimmedpath ;#shimmer it to path rep |
||||
return $trimmedpath |
||||
} elseif {is_unc_path_plain $path} { |
||||
#plain unc //server |
||||
set strcopy_path [punk::objclone $path] |
||||
set trimmedpath [string range $strcopy_path 2 end] |
||||
file pathtype $trimmedpath |
||||
return $trimmedpath |
||||
} else { |
||||
return $path |
||||
} |
||||
} |
||||
#we don't validate that path is actually illegal because we don't know the full range of such names. |
||||
#The caller can apply this to any path. |
||||
#don't test for platform here - needs to be callable from any platform for potential passing to windows (what usecase? 8.3 name is not always calculable independently) |
||||
#The utility of this is questionable. prepending a dos-device path won't make a filename with illegal characters readable by windows. |
||||
#It will need the 'shortname' at least for the illegal segment - if not the whole path |
||||
#Whilst the 8.3 name algorithm - including undocumented hash function has been reverse engineered |
||||
#- it depends on the content of the directory - as collisions cause a different name (e.g incremented number) |
||||
#- it also depends on the history of the folder |
||||
#- you can't take the current dir contents and a particular *existing* longname and determine the shortname algorithmically... |
||||
#- the shortname may have been generated during a different directory state. |
||||
#- It is then stored on disk (where?) - so access to reading the existing shortname is required. |
||||
#- An implementation of the 8.3 algorithm would only be potentially useful in determining the name that will result from adding a new file |
||||
# and would be subject to potential collisions if there are race-conditions in file creation |
||||
#- Using an 8.3 algorithm externally would be dangerous in that it could appear to work a lot of the time - but return a different file entirely sometimes. |
||||
#- Conclusion is that the 8.3 name must be retrieved rathern than calclated |
||||
proc illegalname_fix {path} { |
||||
#don't add extra dos device path syntax protection-prefix if already done |
||||
if {[is_unc_path $path]} { |
||||
error "illegalname_fix called on UNC path $path - unable to process" |
||||
} |
||||
if {[is_dos_device_path $path]} { |
||||
#we may have appended |
||||
return $path |
||||
} |
||||
|
||||
|
||||
|
||||
#\\servername\share theoretically maps to: \\?\UNC\servername\share in protected form. https://learn.microsoft.com/en-us/dotnet/standard/io/file-path-formats |
||||
#NOTE: 2023-08 on windows 10 at least \\?\UNC\Server\share doesn't work - ie we can't use illegalname_fix on UNC paths such as \\Server\share |
||||
#(but mapped drive to same path will work) |
||||
#Note that test-path cmdlet in powershell is also flaky with regards to \\?\UNC\Server paths. |
||||
#It seems prudent for now to disallow \\?\ protection for UNC paths such as \\server\etc |
||||
if {[is_unc_path $path]} { |
||||
set err "" |
||||
append err "illegalname_fix doesn't currently support UNC paths (non dos device leading double slash or //?/UNC/...)" |
||||
append err \n " - because //?/UNC/Servername/share is not supported in Tcl (and only minimally even in powershell) as at 2023. (on windows use mapped drive instead)" |
||||
error $err |
||||
} |
||||
|
||||
set strcopy_path [punk::objclone $path] |
||||
|
||||
|
||||
#Note: path could still have leading double slash if it is a Dos device path: e.g. //?/c:/etc |
||||
if {[file pathtype $path] eq "absolute"} { |
||||
if {$path eq "~"} { |
||||
# non-normalized ~ is classified as absolute |
||||
# tilde special meaning is a bit of a nuisance.. but as it's the entire path in this case.. presumably it should be kept that way |
||||
# leave for caller to interpret it - but it's not an illegal name whether it's interpreted with special meaning or not |
||||
# unlikely this fix will be called on a plain tilde anyway |
||||
return $path |
||||
} else { |
||||
set fullpath $path |
||||
} |
||||
} else { |
||||
#set fullpath [file normalize $path] ;#very slow on windows |
||||
#set fullpath [pwd]/$path ;#will keep ./ in middle of path - not valid for dos-device paths |
||||
if {[string range $strcopy_path 0 1] eq "./"} { |
||||
set strcopy_path [string range $strcopy_path 2 end] |
||||
} |
||||
set fullpath [file join [pwd] $strcopy_path] |
||||
} |
||||
#For file I/O, the "\\?\" prefix to a path string tells the Windows APIs to disable all string parsing |
||||
# and to send the string that follows it straight to the file system. |
||||
set protect "\\\\?\\" ;# value is: \\?\ prefix |
||||
set protect2 "//?/" ;#file normalize may do this - it still works |
||||
#don't use "//./" - not currently supported in Tcl - seems to work in powershell though. |
||||
|
||||
|
||||
#choose //?/ as normalized version - since likely 'file normalize' will do it anyway, and experimentall, the windows API accepts both REVIEW |
||||
set result ${protect2}$fullpath |
||||
file pathtype $result ;#make it return a path rep |
||||
return $result |
||||
} |
||||
|
||||
#don't test for platform here - needs to be callable from any platform for potential passing to windows |
||||
#we can create files with windows illegal names by using //?/ dos device path syntax - but we need to detect when that is required. |
||||
# |
||||
# path int-rep preserving |
||||
proc illegalname_test {path} { |
||||
#https://learn.microsoft.com/en-us/windows/win32/fileio/naming-a-file |
||||
#according to the above: Use any character in the current code page for a name, including Unicode characters and characters in the extended character set (128–255), except for the following: |
||||
set reserved [list < > : \" / \\ | ? *] |
||||
|
||||
|
||||
#we need to exclude things like path/.. path/. |
||||
foreach seg [file split $path] { |
||||
if {$seg in [list . ..]} { |
||||
#review - what if there is a folder or file that actually has a name such as . or .. ? |
||||
#unlikely in normal use - but could done deliberately for bad reasons? |
||||
#We are unable to check for it here anyway - as this command is intended for checking the path string - not the actual path on a filesystem. |
||||
# |
||||
#/./ /../ segments don't require protection - keep checking. |
||||
continue |
||||
} |
||||
|
||||
#only check for actual space as other whitespace seems to work without being stripped |
||||
#trailing tab and trailing \n or \r seem to be creatable in windows with Tcl - map to some glyph |
||||
if {[string index $seg end] in [list " " "."]} { |
||||
#windows API doesn't handle trailing dots or spaces (silently strips) - even though such files can be created on NTFS systems (or seen via samba etc) |
||||
return 1 |
||||
} |
||||
} |
||||
#glob chars '* ?' are probably illegal.. but although x*y.txt and x?y.txt don't display properly (* ? replaced with some other glyph) |
||||
#- they seem to be readable from cmd and tclsh as is. |
||||
# pipe symbol also has glyph substitution and behaves the same e.g a|b.txt |
||||
#(at least with encoding system utf-8) |
||||
|
||||
#todo - determine what else constitutes an illegal name according to windows APIs and requires protection with dos device syntax |
||||
return 0 |
||||
} |
||||
|
||||
proc test_ntfs_tunneling {f1 f2 args} { |
||||
file mkdir $f1 |
||||
puts stderr "waiting 15secs..." |
||||
after 5000 {puts -nonewline stderr .} |
||||
after 5000 {puts -nonewline stderr .} |
||||
after 5000 {puts -nonewline stderr .} |
||||
after 500 {puts stderr \n} |
||||
file mkdir $f2 |
||||
puts stdout "$f1 [file stat $f1]" |
||||
puts stdout "$f2 [file stat $f2]" |
||||
file delete $f1 |
||||
puts stdout "renaming $f2 to $f1" |
||||
file rename $f2 $f1 |
||||
puts stdout "$f1 [file stat $f1]" |
||||
|
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::winpath [namespace eval punk::winpath { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,189 @@
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# sets.tcl -- |
||||
# |
||||
# Definitions for the processing of sets. |
||||
# |
||||
# Copyright (c) 2004-2008 by Andreas Kupries. |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: sets.tcl,v 1.17 2008/03/09 04:24:37 andreas_kupries Exp $ |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
# @mdgen EXCLUDE: sets_c.tcl |
||||
|
||||
package require Tcl 8.5- |
||||
|
||||
namespace eval ::struct::set {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Management of set implementations. |
||||
|
||||
# ::struct::set::LoadAccelerator -- |
||||
# |
||||
# Loads a named implementation, if possible. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to load. |
||||
# |
||||
# Results: |
||||
# A boolean flag. True if the implementation |
||||
# was successfully loaded; and False otherwise. |
||||
|
||||
proc ::struct::set::LoadAccelerator {key} { |
||||
variable accel |
||||
set r 0 |
||||
switch -exact -- $key { |
||||
critcl { |
||||
# Critcl implementation of set requires Tcl 8.4. |
||||
if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} |
||||
if {[catch {package require tcllibc}]} {return 0} |
||||
set r [llength [info commands ::struct::set_critcl]] |
||||
} |
||||
tcl { |
||||
variable selfdir |
||||
source [file join $selfdir sets_tcl.tcl] |
||||
set r 1 |
||||
} |
||||
default { |
||||
return -code error "invalid accelerator/impl. package $key:\ |
||||
must be one of [join [KnownImplementations] {, }]" |
||||
} |
||||
} |
||||
set accel($key) $r |
||||
return $r |
||||
} |
||||
|
||||
# ::struct::set::SwitchTo -- |
||||
# |
||||
# Activates a loaded named implementation. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to activate. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
proc ::struct::set::SwitchTo {key} { |
||||
variable accel |
||||
variable loaded |
||||
|
||||
if {[string equal $key $loaded]} { |
||||
# No change, nothing to do. |
||||
return |
||||
} elseif {![string equal $key ""]} { |
||||
# Validate the target implementation of the switch. |
||||
|
||||
if {![info exists accel($key)]} { |
||||
return -code error "Unable to activate unknown implementation \"$key\"" |
||||
} elseif {![info exists accel($key)] || !$accel($key)} { |
||||
return -code error "Unable to activate missing implementation \"$key\"" |
||||
} |
||||
} |
||||
|
||||
# Deactivate the previous implementation, if there was any. |
||||
|
||||
if {![string equal $loaded ""]} { |
||||
rename ::struct::set ::struct::set_$loaded |
||||
} |
||||
|
||||
# Activate the new implementation, if there is any. |
||||
|
||||
if {![string equal $key ""]} { |
||||
rename ::struct::set_$key ::struct::set |
||||
} |
||||
|
||||
# Remember the active implementation, for deactivation by future |
||||
# switches. |
||||
|
||||
set loaded $key |
||||
return |
||||
} |
||||
|
||||
proc ::struct::set::Loaded {} { |
||||
variable loaded |
||||
return $loaded |
||||
} |
||||
|
||||
# ::struct::set::Implementations -- |
||||
# |
||||
# Determines which implementations are |
||||
# present, i.e. loaded. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. |
||||
|
||||
proc ::struct::set::Implementations {} { |
||||
variable accel |
||||
set res {} |
||||
foreach n [array names accel] { |
||||
if {!$accel($n)} continue |
||||
lappend res $n |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
# ::struct::set::KnownImplementations -- |
||||
# |
||||
# Determines which implementations are known |
||||
# as possible implementations. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. In the order |
||||
# of preference, most prefered first. |
||||
|
||||
proc ::struct::set::KnownImplementations {} { |
||||
return {critcl tcl} |
||||
} |
||||
|
||||
proc ::struct::set::Names {} { |
||||
return { |
||||
critcl {tcllibc based} |
||||
tcl {pure Tcl} |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization: Data structures. |
||||
|
||||
namespace eval ::struct::set { |
||||
variable selfdir [file dirname [info script]] |
||||
variable accel |
||||
array set accel {tcl 0 critcl 0} |
||||
variable loaded {} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization: Choose an implementation, |
||||
## most prefered first. Loads only one of the |
||||
## possible implementations. And activates it. |
||||
|
||||
namespace eval ::struct::set { |
||||
variable e |
||||
foreach e [KnownImplementations] { |
||||
if {[LoadAccelerator $e]} { |
||||
SwitchTo $e |
||||
break |
||||
} |
||||
} |
||||
unset e |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::struct { |
||||
# Export the constructor command. |
||||
namespace export set |
||||
} |
||||
|
||||
package provide struct::set 2.2.3 |
||||
@ -0,0 +1,189 @@
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# sets.tcl -- |
||||
# |
||||
# Definitions for the processing of sets. |
||||
# |
||||
# Copyright (c) 2004-2008 by Andreas Kupries. |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: sets.tcl,v 1.17 2008/03/09 04:24:37 andreas_kupries Exp $ |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
# @mdgen EXCLUDE: sets_c.tcl |
||||
|
||||
package require Tcl 8.5- |
||||
|
||||
namespace eval ::struct::set {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Management of set implementations. |
||||
|
||||
# ::struct::set::LoadAccelerator -- |
||||
# |
||||
# Loads a named implementation, if possible. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to load. |
||||
# |
||||
# Results: |
||||
# A boolean flag. True if the implementation |
||||
# was successfully loaded; and False otherwise. |
||||
|
||||
proc ::struct::set::LoadAccelerator {key} { |
||||
variable accel |
||||
set r 0 |
||||
switch -exact -- $key { |
||||
critcl { |
||||
# Critcl implementation of set requires Tcl 8.4. |
||||
if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} |
||||
if {[catch {package require tcllibc}]} {return 0} |
||||
set r [llength [info commands ::struct::set_critcl]] |
||||
} |
||||
tcl { |
||||
variable selfdir |
||||
source [file join $selfdir sets_tcl.tcl] |
||||
set r 1 |
||||
} |
||||
default { |
||||
return -code error "invalid accelerator/impl. package $key:\ |
||||
must be one of [join [KnownImplementations] {, }]" |
||||
} |
||||
} |
||||
set accel($key) $r |
||||
return $r |
||||
} |
||||
|
||||
# ::struct::set::SwitchTo -- |
||||
# |
||||
# Activates a loaded named implementation. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to activate. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
proc ::struct::set::SwitchTo {key} { |
||||
variable accel |
||||
variable loaded |
||||
|
||||
if {[string equal $key $loaded]} { |
||||
# No change, nothing to do. |
||||
return |
||||
} elseif {![string equal $key ""]} { |
||||
# Validate the target implementation of the switch. |
||||
|
||||
if {![info exists accel($key)]} { |
||||
return -code error "Unable to activate unknown implementation \"$key\"" |
||||
} elseif {![info exists accel($key)] || !$accel($key)} { |
||||
return -code error "Unable to activate missing implementation \"$key\"" |
||||
} |
||||
} |
||||
|
||||
# Deactivate the previous implementation, if there was any. |
||||
|
||||
if {![string equal $loaded ""]} { |
||||
rename ::struct::set ::struct::set_$loaded |
||||
} |
||||
|
||||
# Activate the new implementation, if there is any. |
||||
|
||||
if {![string equal $key ""]} { |
||||
rename ::struct::set_$key ::struct::set |
||||
} |
||||
|
||||
# Remember the active implementation, for deactivation by future |
||||
# switches. |
||||
|
||||
set loaded $key |
||||
return |
||||
} |
||||
|
||||
proc ::struct::set::Loaded {} { |
||||
variable loaded |
||||
return $loaded |
||||
} |
||||
|
||||
# ::struct::set::Implementations -- |
||||
# |
||||
# Determines which implementations are |
||||
# present, i.e. loaded. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. |
||||
|
||||
proc ::struct::set::Implementations {} { |
||||
variable accel |
||||
set res {} |
||||
foreach n [array names accel] { |
||||
if {!$accel($n)} continue |
||||
lappend res $n |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
# ::struct::set::KnownImplementations -- |
||||
# |
||||
# Determines which implementations are known |
||||
# as possible implementations. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. In the order |
||||
# of preference, most prefered first. |
||||
|
||||
proc ::struct::set::KnownImplementations {} { |
||||
return {critcl tcl} |
||||
} |
||||
|
||||
proc ::struct::set::Names {} { |
||||
return { |
||||
critcl {tcllibc based} |
||||
tcl {pure Tcl} |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization: Data structures. |
||||
|
||||
namespace eval ::struct::set { |
||||
variable selfdir [file dirname [info script]] |
||||
variable accel |
||||
array set accel {tcl 0 critcl 0} |
||||
variable loaded {} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization: Choose an implementation, |
||||
## most prefered first. Loads only one of the |
||||
## possible implementations. And activates it. |
||||
|
||||
namespace eval ::struct::set { |
||||
variable e |
||||
foreach e [KnownImplementations] { |
||||
if {[LoadAccelerator $e]} { |
||||
SwitchTo $e |
||||
break |
||||
} |
||||
} |
||||
unset e |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::struct { |
||||
# Export the constructor command. |
||||
namespace export set |
||||
} |
||||
|
||||
package provide struct::set 2.2.3 |
||||
@ -0,0 +1,93 @@
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# sets_tcl.tcl -- |
||||
# |
||||
# Definitions for the processing of sets. C implementation. |
||||
# |
||||
# Copyright (c) 2007 by Andreas Kupries. |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: sets_c.tcl,v 1.3 2008/03/25 07:15:34 andreas_kupries Exp $ |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
package require critcl |
||||
# @sak notprovided struct_setc |
||||
package provide struct_setc 2.1.1 |
||||
package require Tcl 8.5- |
||||
|
||||
namespace eval ::struct { |
||||
# Supporting code for the main command. |
||||
|
||||
catch { |
||||
#critcl::cheaders -g |
||||
#critcl::debug memory symbols |
||||
} |
||||
|
||||
critcl::cheaders sets/*.h |
||||
critcl::csources sets/*.c |
||||
|
||||
critcl::ccode { |
||||
/* -*- c -*- */ |
||||
|
||||
#include <m.h> |
||||
} |
||||
|
||||
# Main command, set creation. |
||||
|
||||
critcl::ccommand set_critcl {dummy interp objc objv} { |
||||
/* Syntax - dispatcher to the sub commands. |
||||
*/ |
||||
|
||||
static CONST char* methods [] = { |
||||
"add", "contains", "difference", "empty", |
||||
"equal","exclude", "include", "intersect", |
||||
"intersect3", "size", "subsetof", "subtract", |
||||
"symdiff", "union", |
||||
NULL |
||||
}; |
||||
enum methods { |
||||
S_add, S_contains, S_difference, S_empty, |
||||
S_equal,S_exclude, S_include, S_intersect, |
||||
S_intersect3, S_size, S_subsetof, S_subtract, |
||||
S_symdiff, S_union |
||||
}; |
||||
|
||||
int m; |
||||
|
||||
if (objc < 2) { |
||||
Tcl_WrongNumArgs (interp, objc, objv, "cmd ?arg ...?"); |
||||
return TCL_ERROR; |
||||
} else if (Tcl_GetIndexFromObj (interp, objv [1], methods, "option", |
||||
0, &m) != TCL_OK) { |
||||
return TCL_ERROR; |
||||
} |
||||
|
||||
/* Dispatch to methods. They check the #args in detail before performing |
||||
* the requested functionality |
||||
*/ |
||||
|
||||
switch (m) { |
||||
case S_add: return sm_ADD (NULL, interp, objc, objv); |
||||
case S_contains: return sm_CONTAINS (NULL, interp, objc, objv); |
||||
case S_difference: return sm_DIFFERENCE (NULL, interp, objc, objv); |
||||
case S_empty: return sm_EMPTY (NULL, interp, objc, objv); |
||||
case S_equal: return sm_EQUAL (NULL, interp, objc, objv); |
||||
case S_exclude: return sm_EXCLUDE (NULL, interp, objc, objv); |
||||
case S_include: return sm_INCLUDE (NULL, interp, objc, objv); |
||||
case S_intersect: return sm_INTERSECT (NULL, interp, objc, objv); |
||||
case S_intersect3: return sm_INTERSECT3 (NULL, interp, objc, objv); |
||||
case S_size: return sm_SIZE (NULL, interp, objc, objv); |
||||
case S_subsetof: return sm_SUBSETOF (NULL, interp, objc, objv); |
||||
case S_subtract: return sm_SUBTRACT (NULL, interp, objc, objv); |
||||
case S_symdiff: return sm_SYMDIFF (NULL, interp, objc, objv); |
||||
case S_union: return sm_UNION (NULL, interp, objc, objv); |
||||
} |
||||
/* Not coming to this place */ |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
@ -0,0 +1,452 @@
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# sets_tcl.tcl -- |
||||
# |
||||
# Definitions for the processing of sets. |
||||
# |
||||
# Copyright (c) 2004-2008 by Andreas Kupries. |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: sets_tcl.tcl,v 1.4 2008/03/09 04:38:47 andreas_kupries Exp $ |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
package require Tcl 8.5- |
||||
|
||||
namespace eval ::struct::set { |
||||
# Only export one command, the one used to instantiate a new tree |
||||
namespace export set_tcl |
||||
} |
||||
|
||||
########################## |
||||
# Public functions |
||||
|
||||
# ::struct::set::set -- |
||||
# |
||||
# Command that access all set commands. |
||||
# |
||||
# Arguments: |
||||
# cmd Name of the subcommand to dispatch to. |
||||
# args Arguments for the subcommand. |
||||
# |
||||
# Results: |
||||
# Whatever the result of the subcommand is. |
||||
|
||||
proc ::struct::set::set_tcl {cmd args} { |
||||
# Do minimal args checks here |
||||
if { [llength [info level 0]] == 1 } { |
||||
return -code error "wrong # args: should be \"$cmd ?arg arg ...?\"" |
||||
} |
||||
::set sub S_$cmd |
||||
if { [llength [info commands ::struct::set::$sub]] == 0 } { |
||||
::set optlist [info commands ::struct::set::S_*] |
||||
::set xlist {} |
||||
foreach p $optlist { |
||||
lappend xlist [string range $p 17 end] |
||||
} |
||||
return -code error \ |
||||
"bad option \"$cmd\": must be [linsert [join [lsort $xlist] ", "] "end-1" "or"]" |
||||
} |
||||
return [uplevel 1 [linsert $args 0 ::struct::set::$sub]] |
||||
} |
||||
|
||||
########################## |
||||
# Implementations of the functionality. |
||||
# |
||||
|
||||
# ::struct::set::S_empty -- |
||||
# |
||||
# Determines emptiness of the set |
||||
# |
||||
# Parameters: |
||||
# set -- The set to check for emptiness. |
||||
# |
||||
# Results: |
||||
# A boolean value. True indicates that the set is empty. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
# |
||||
# Notes: |
||||
|
||||
proc ::struct::set::S_empty {set} { |
||||
return [expr {[llength $set] == 0}] |
||||
} |
||||
|
||||
# ::struct::set::S_size -- |
||||
# |
||||
# Computes the cardinality of the set. |
||||
# |
||||
# Parameters: |
||||
# set -- The set to inspect. |
||||
# |
||||
# Results: |
||||
# An integer greater than or equal to zero. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_size {set} { |
||||
return [llength [Cleanup $set]] |
||||
} |
||||
|
||||
# ::struct::set::S_contains -- |
||||
# |
||||
# Determines if the item is in the set. |
||||
# |
||||
# Parameters: |
||||
# set -- The set to inspect. |
||||
# item -- The element to look for. |
||||
# |
||||
# Results: |
||||
# A boolean value. True indicates that the element is present. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_contains {set item} { |
||||
return [expr {[lsearch -exact $set $item] >= 0}] |
||||
} |
||||
|
||||
# ::struct::set::S_union -- |
||||
# |
||||
# Computes the union of the arguments. |
||||
# |
||||
# Parameters: |
||||
# args -- List of sets to unify. |
||||
# |
||||
# Results: |
||||
# The union of the arguments. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_union {args} { |
||||
switch -exact -- [llength $args] { |
||||
0 {return {}} |
||||
1 {return [lindex $args 0]} |
||||
} |
||||
foreach setX $args { |
||||
foreach x $setX {::set ($x) {}} |
||||
} |
||||
return [array names {}] |
||||
} |
||||
|
||||
|
||||
# ::struct::set::S_intersect -- |
||||
# |
||||
# Computes the intersection of the arguments. |
||||
# |
||||
# Parameters: |
||||
# args -- List of sets to intersect. |
||||
# |
||||
# Results: |
||||
# The intersection of the arguments |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_intersect {args} { |
||||
switch -exact -- [llength $args] { |
||||
0 {return {}} |
||||
1 {return [lindex $args 0]} |
||||
} |
||||
::set res [lindex $args 0] |
||||
foreach set [lrange $args 1 end] { |
||||
if {[llength $res] && [llength $set]} { |
||||
::set res [Intersect $res $set] |
||||
} else { |
||||
# Squash 'res'. Otherwise we get the wrong result if res |
||||
# is not empty, but 'set' is. |
||||
::set res {} |
||||
break |
||||
} |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
proc ::struct::set::Intersect {A B} { |
||||
if {[llength $A] == 0} {return {}} |
||||
if {[llength $B] == 0} {return {}} |
||||
|
||||
# This is slower than local vars, but more robust |
||||
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 |
||||
} |
||||
|
||||
# ::struct::set::S_difference -- |
||||
# |
||||
# Compute difference of two sets. |
||||
# |
||||
# Parameters: |
||||
# A, B -- Sets to compute the difference for. |
||||
# |
||||
# Results: |
||||
# A - B |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_difference {A B} { |
||||
if {[llength $A] == 0} {return {}} |
||||
if {[llength $B] == 0} {return $A} |
||||
|
||||
array set tmp {} |
||||
foreach x $A {::set tmp($x) .} |
||||
foreach x $B {catch {unset tmp($x)}} |
||||
return [array names tmp] |
||||
} |
||||
|
||||
if {0} { |
||||
# Tcllib SF Bug 1002143. We cannot use the implementation below. |
||||
# It will treat set elements containing '(' and ')' as array |
||||
# elements, and this screws up the storage of elements as the name |
||||
# of local vars something fierce. No way around this. Disabling |
||||
# this code and always using the other implementation (s.a.) is |
||||
# the only possible fix. |
||||
|
||||
if {[package vcompare [package provide Tcl] 8.4] < 0} { |
||||
# Tcl 8.[23]. Use explicit array to perform the operation. |
||||
} else { |
||||
# Tcl 8.4+, has 'unset -nocomplain' |
||||
|
||||
proc ::struct::set::S_difference {A B} { |
||||
if {[llength $A] == 0} {return {}} |
||||
if {[llength $B] == 0} {return $A} |
||||
|
||||
# Get the variable B out of the way, avoid collisions |
||||
# prepare for "pure list optimization" |
||||
::set ::struct::set::tmp [lreplace $B -1 -1 unset -nocomplain] |
||||
unset B |
||||
|
||||
# unset A early: no local variables left |
||||
foreach [lindex [list $A [unset A]] 0] {.} {break} |
||||
|
||||
eval $::struct::set::tmp |
||||
return [info locals] |
||||
} |
||||
} |
||||
} |
||||
|
||||
# ::struct::set::S_symdiff -- |
||||
# |
||||
# Compute symmetric difference of two sets. |
||||
# |
||||
# Parameters: |
||||
# A, B -- The sets to compute the s.difference for. |
||||
# |
||||
# Results: |
||||
# The symmetric difference of the two input sets. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_symdiff {A B} { |
||||
# symdiff == (A-B) + (B-A) == (A+B)-(A*B) |
||||
if {[llength $A] == 0} {return $B} |
||||
if {[llength $B] == 0} {return $A} |
||||
return [S_union \ |
||||
[S_difference $A $B] \ |
||||
[S_difference $B $A]] |
||||
} |
||||
|
||||
# ::struct::set::S_intersect3 -- |
||||
# |
||||
# Return intersection and differences for two sets. |
||||
# |
||||
# Parameters: |
||||
# A, B -- The sets to inspect. |
||||
# |
||||
# Results: |
||||
# List containing A*B, A-B, and B-A |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_intersect3 {A B} { |
||||
return [list \ |
||||
[S_intersect $A $B] \ |
||||
[S_difference $A $B] \ |
||||
[S_difference $B $A]] |
||||
} |
||||
|
||||
# ::struct::set::S_equal -- |
||||
# |
||||
# Compares two sets for equality. |
||||
# |
||||
# Parameters: |
||||
# a First set to compare. |
||||
# b Second set to compare. |
||||
# |
||||
# Results: |
||||
# A boolean. True if the lists are equal. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_equal {A B} { |
||||
::set A [Cleanup $A] |
||||
::set B [Cleanup $B] |
||||
|
||||
# Equal if of same cardinality and difference is empty. |
||||
|
||||
if {[::llength $A] != [::llength $B]} {return 0} |
||||
return [expr {[llength [S_difference $A $B]] == 0}] |
||||
} |
||||
|
||||
|
||||
proc ::struct::set::Cleanup {A} { |
||||
# unset A to avoid collisions |
||||
if {[llength $A] < 2} {return $A} |
||||
# We cannot use variables to avoid an explicit array. The set |
||||
# elements may look like namespace vars (i.e. contain ::), and |
||||
# such elements break that, cannot be proc-local variables. |
||||
array set S {} |
||||
foreach item $A {set S($item) .} |
||||
return [array names S] |
||||
} |
||||
|
||||
# ::struct::set::S_include -- |
||||
# |
||||
# Add an element to a set. |
||||
# |
||||
# Parameters: |
||||
# Avar -- Reference to the set variable to extend. |
||||
# element -- The item to add to the set. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# The set in the variable referenced by Avar is extended |
||||
# by the element (if the element was not already present). |
||||
|
||||
proc ::struct::set::S_include {Avar element} { |
||||
# Avar = Avar + {element} |
||||
upvar 1 $Avar A |
||||
if {![info exists A] || ![S_contains $A $element]} { |
||||
lappend A $element |
||||
} |
||||
return |
||||
} |
||||
|
||||
# ::struct::set::S_exclude -- |
||||
# |
||||
# Remove an element from a set. |
||||
# |
||||
# Parameters: |
||||
# Avar -- Reference to the set variable to shrink. |
||||
# element -- The item to remove from the set. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# The set in the variable referenced by Avar is shrunk, |
||||
# the element remove (if the element was actually present). |
||||
|
||||
proc ::struct::set::S_exclude {Avar element} { |
||||
# Avar = Avar - {element} |
||||
upvar 1 $Avar A |
||||
if {![info exists A]} {return -code error "can't read \"$Avar\": no such variable"} |
||||
while {[::set pos [lsearch -exact $A $element]] >= 0} { |
||||
::set A [lreplace [K $A [::set A {}]] $pos $pos] |
||||
} |
||||
return |
||||
} |
||||
|
||||
# ::struct::set::S_add -- |
||||
# |
||||
# Add a set to a set. Similar to 'union', but the first argument |
||||
# is a variable. |
||||
# |
||||
# Parameters: |
||||
# Avar -- Reference to the set variable to extend. |
||||
# B -- The set to add to the set in Avar. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# The set in the variable referenced by Avar is extended |
||||
# by all the elements in B. |
||||
|
||||
proc ::struct::set::S_add {Avar B} { |
||||
# Avar = Avar + B |
||||
upvar 1 $Avar A |
||||
if {![info exists A]} {set A {}} |
||||
::set A [S_union [K $A [::set A {}]] $B] |
||||
return |
||||
} |
||||
|
||||
# ::struct::set::S_subtract -- |
||||
# |
||||
# Remove a set from a set. Similar to 'difference', but the first argument |
||||
# is a variable. |
||||
# |
||||
# Parameters: |
||||
# Avar -- Reference to the set variable to shrink. |
||||
# B -- The set to remove from the set in Avar. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# The set in the variable referenced by Avar is shrunk, |
||||
# all elements of B are removed. |
||||
|
||||
proc ::struct::set::S_subtract {Avar B} { |
||||
# Avar = Avar - B |
||||
upvar 1 $Avar A |
||||
if {![info exists A]} {return -code error "can't read \"$Avar\": no such variable"} |
||||
::set A [S_difference [K $A [::set A {}]] $B] |
||||
return |
||||
} |
||||
|
||||
# ::struct::set::S_subsetof -- |
||||
# |
||||
# A predicate checking if the first set is a subset |
||||
# or equal to the second set. |
||||
# |
||||
# Parameters: |
||||
# A -- The possible subset. |
||||
# B -- The set to compare to. |
||||
# |
||||
# Results: |
||||
# A boolean value, true if A is subset of or equal to B |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_subsetof {A B} { |
||||
# A subset|== B <=> (A == A*B) |
||||
return [S_equal $A [S_intersect $A $B]] |
||||
} |
||||
|
||||
# ::struct::set::K -- |
||||
# Performance helper command. |
||||
|
||||
proc ::struct::set::K {x y} {::set x} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::struct { |
||||
# Put 'set::set' into the general structure namespace |
||||
# for pickup by the main management. |
||||
|
||||
namespace import -force set::set_tcl |
||||
} |
||||
@ -0,0 +1,24 @@
|
||||
This is primarily for tcl .tm modules required for your bootstrapping/make/build process. |
||||
It could include other files necessary for this process. |
||||
|
||||
The .tm modules here may be required for your build script if it intended the installation operator uses an existing tclsh or other shell as opposed to a tclkit you may have for distribution which is more likely to include necessary libraries. |
||||
|
||||
The modules here are loaded by your initialisation scripts and so can be a snapshot of different versions than those in your project src. |
||||
The modules can be your own, or 3rd party such as individual items from tcllib. |
||||
|
||||
You can copy modules from a running punk shell to this location using the pmix command. |
||||
|
||||
e.g |
||||
>pmix visible_lib_copy_to_modulefolder some::module::lib bootsupport |
||||
|
||||
The pmix command will help you pick the latest version, and will create any necessary file structure matching the namespace of the package. |
||||
|
||||
e.g the result might be a file such as |
||||
<projectname>/src/bootsupport/some/module/lib-0.1.tm |
||||
|
||||
The originating library may not yet be in .tm form. |
||||
You can copy a pkgIndex.tcl based library that is composed of a single .tcl file the same way using the above process and it will automatically name and file it appropriately but you need to check that the library doesn't require/load additional files - and that it is Tcl script only. |
||||
|
||||
Always verify that the library is copyable in this manner and test in a shell with tcl::tm::path pointed to ./bootsupport that it works. |
||||
|
||||
|
||||
@ -1,6 +1,10 @@
|
||||
#single line per runtime executable. Name of runtime followed by list of .vfs folders with path relative to src folder. |
||||
#if runtime has no entry - it will only match a .vfs folder with a matching filename e.g runtime1.exe runtime1.vfs |
||||
tclkit86bi.exe punk86.vfs |
||||
tclkit87a5bawt.exe punk86.vfs |
||||
#tclkit86bi.exe vfs_windows/punk86win.vfs |
||||
|
||||
#single line per runtime executable. Name of runtime followed by list of .vfs folders with path relative to src folder. |
||||
#if runtime has no entry - it will only match a .vfs folder with a matching filename e.g runtime1.exe runtime1.vfs |
||||
#Use a runtime with a name of dash (-) to build a .kit file from the .vfs folder using no runtime |
||||
#e.g |
||||
#- myproject.vfs |
||||
#- punk86.vfs |
||||
tclkit86bi.exe punk86.vfs |
||||
#tclkit87a5bawt.exe punk86.vfs |
||||
#tclkit86bi.exe vfs_windows/punk86win.vfs |
||||
|
||||
|
||||
Loading…
Reference in new issue