35 changed files with 1166 additions and 9719 deletions
@ -1,195 +0,0 @@ |
|||||||
#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
Binary file not shown.
@ -1,87 +0,0 @@ |
|||||||
|
|
||||||
|
|
||||||
namespace eval punk::mix { |
|
||||||
package require punk::lib |
|
||||||
|
|
||||||
|
|
||||||
package require punk::mix_custom |
|
||||||
proc runcli {args} { |
|
||||||
if {![llength $args]} { |
|
||||||
tailcall punk::mix::clicommands help |
|
||||||
} else { |
|
||||||
tailcall punk::mix::clicommands {*}$args |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
namespace eval punk::mix::clicommands { |
|
||||||
namespace export help new |
|
||||||
namespace ensemble create |
|
||||||
namespace ensemble configure [namespace current] -unknown punk::mix::clicommands::_unknown |
|
||||||
|
|
||||||
proc set_alias {cmdname} { |
|
||||||
uplevel #0 [list interp alias {} $cmdname {} punk::mix::runcli] |
|
||||||
} |
|
||||||
proc _unknown {ns args} { |
|
||||||
puts stderr "arglen:[llength $args]" |
|
||||||
puts stdout "_unknown '$ns' '$args'" |
|
||||||
|
|
||||||
list punk::mix::clicommands::help {*}$args |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
proc new {name} { |
|
||||||
set curdir [pwd] |
|
||||||
if {[file exists $curdir/$name]} { |
|
||||||
error "Unable to create new project at $curdir/$name - file/folder already exists" |
|
||||||
} |
|
||||||
set base $curdir/$name |
|
||||||
file mkdir $base |
|
||||||
file mkdir $base/src |
|
||||||
file mkdir $base/modules |
|
||||||
|
|
||||||
|
|
||||||
} |
|
||||||
|
|
||||||
} |
|
||||||
punk::ensemble::extend punk::mix::clicommands punk::mix_custom |
|
||||||
|
|
||||||
|
|
||||||
namespace eval punk::mix::clicommands { |
|
||||||
proc help {args} { |
|
||||||
#' **%ensemblecommand% help** *args* |
|
||||||
#' |
|
||||||
#' Help for ensemble commands in the command line interface |
|
||||||
#' |
|
||||||
#' |
|
||||||
#' Arguments: |
|
||||||
#' |
|
||||||
#' * args - first word of args is the helptopic requested - usually a command name |
|
||||||
#' - calling help with no arguments will list available commands |
|
||||||
#' |
|
||||||
#' Returns: help text (text) |
|
||||||
#' |
|
||||||
#' Examples: |
|
||||||
#' |
|
||||||
#' ``` |
|
||||||
#' %ensemblecommand% help <commandname> |
|
||||||
#' ``` |
|
||||||
#' |
|
||||||
#' |
|
||||||
|
|
||||||
|
|
||||||
set commands [namespace export] |
|
||||||
set helpstr "" |
|
||||||
append helpstr "commands:\n" |
|
||||||
foreach cmd $commands { |
|
||||||
append helpstr " $cmd" |
|
||||||
} |
|
||||||
return $helpstr |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
package provide punk::mix [namespace eval punk::mix { |
|
||||||
variable version |
|
||||||
set version 0.1 |
|
||||||
|
|
||||||
}] |
|
||||||
Binary file not shown.
Binary file not shown.
@ -1,702 +0,0 @@ |
|||||||
# -*- tcl -*- |
|
||||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
|
||||||
# |
|
||||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
|
||||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
# (C) 2024 |
|
||||||
# |
|
||||||
# @@ Meta Begin |
|
||||||
# Application modpod 0.1.2 |
|
||||||
# Meta platform tcl |
|
||||||
# Meta license <unspecified> |
|
||||||
# @@ Meta End |
|
||||||
|
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
# doctools header |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
#*** !doctools |
|
||||||
#[manpage_begin modpod_module_modpod 0 0.1.2] |
|
||||||
#[copyright "2024"] |
|
||||||
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
|
||||||
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
|
||||||
#[require modpod] |
|
||||||
#[keywords module] |
|
||||||
#[description] |
|
||||||
#[para] - |
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[section Overview] |
|
||||||
#[para] overview of modpod |
|
||||||
#[subsection Concepts] |
|
||||||
#[para] - |
|
||||||
|
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
## Requirements |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[subsection dependencies] |
|
||||||
#[para] packages used by modpod |
|
||||||
#[list_begin itemized] |
|
||||||
|
|
||||||
package require Tcl 8.6- |
|
||||||
package require struct::set ;#review |
|
||||||
package require punk::lib |
|
||||||
package require punk::args |
|
||||||
#*** !doctools |
|
||||||
#[item] [package {Tcl 8.6-}] |
|
||||||
|
|
||||||
# #package require frobz |
|
||||||
# #*** !doctools |
|
||||||
# #[item] [package {frobz}] |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[list_end] |
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[section API] |
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
# oo::class namespace |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
namespace eval modpod::class { |
|
||||||
#*** !doctools |
|
||||||
#[subsection {Namespace modpod::class}] |
|
||||||
#[para] class definitions |
|
||||||
if {[info commands [namespace current]::interface_sample1] eq ""} { |
|
||||||
#*** !doctools |
|
||||||
#[list_begin enumerated] |
|
||||||
|
|
||||||
# oo::class create interface_sample1 { |
|
||||||
# #*** !doctools |
|
||||||
# #[enum] CLASS [class interface_sample1] |
|
||||||
# #[list_begin definitions] |
|
||||||
|
|
||||||
# method test {arg1} { |
|
||||||
# #*** !doctools |
|
||||||
# #[call class::interface_sample1 [method test] [arg arg1]] |
|
||||||
# #[para] test method |
|
||||||
# puts "test: $arg1" |
|
||||||
# } |
|
||||||
|
|
||||||
# #*** !doctools |
|
||||||
# #[list_end] [comment {-- end definitions interface_sample1}] |
|
||||||
# } |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[list_end] [comment {--- end class enumeration ---}] |
|
||||||
} |
|
||||||
} |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
# Base namespace |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
namespace eval modpod { |
|
||||||
namespace export {[a-z]*}; # Convention: export all lowercase |
|
||||||
|
|
||||||
variable connected |
|
||||||
if {![info exists connected(to)]} { |
|
||||||
set connected(to) list |
|
||||||
} |
|
||||||
variable modpodscript |
|
||||||
set modpodscript [info script] |
|
||||||
if {[string tolower [file extension $modpodscript]] eq ".tcl"} { |
|
||||||
set connected(self) [file dirname $modpodscript] |
|
||||||
} else { |
|
||||||
#expecting a .tm |
|
||||||
set connected(self) $modpodscript |
|
||||||
} |
|
||||||
variable loadables [info sharedlibextension] |
|
||||||
variable sourceables {.tcl .tk} ;# .tm ? |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[subsection {Namespace modpod}] |
|
||||||
#[para] Core API functions for modpod |
|
||||||
#[list_begin definitions] |
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
#proc sample1 {p1 args} { |
|
||||||
# #*** !doctools |
|
||||||
# #[call [fun sample1] [arg p1] [opt {?option value...?}]] |
|
||||||
# #[para]Description of sample1 |
|
||||||
# return "ok" |
|
||||||
#} |
|
||||||
|
|
||||||
#old tar connect mechanism - review - not needed? |
|
||||||
proc connect {args} { |
|
||||||
puts stderr "modpod::connect--->>$args" |
|
||||||
set argd [punk::args::get_dict { |
|
||||||
@id -id ::modpod::connect |
|
||||||
-type -default "" |
|
||||||
@values -min 1 -max 1 |
|
||||||
path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)" |
|
||||||
} $args] |
|
||||||
catch { |
|
||||||
punk::lib::showdict $argd ;#heavy dependencies |
|
||||||
} |
|
||||||
set opt_path [dict get $argd values path] |
|
||||||
variable connected |
|
||||||
set original_connectpath $opt_path |
|
||||||
set modpodpath [modpod::system::normalize $opt_path] ;# |
|
||||||
|
|
||||||
if {$modpodpath in $connected(to)} { |
|
||||||
return [dict create ok ALREADY_CONNECTED] |
|
||||||
} |
|
||||||
lappend connected(to) $modpodpath |
|
||||||
|
|
||||||
set connected(connectpath,$opt_path) $original_connectpath |
|
||||||
set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info script]]}] |
|
||||||
|
|
||||||
set connected(location,$modpodpath) [file dirname $modpodpath] |
|
||||||
set connected(startdata,$modpodpath) -1 |
|
||||||
set connected(type,$modpodpath) [dict get $argd opts -type] |
|
||||||
set connected(fh,$modpodpath) "" |
|
||||||
|
|
||||||
if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { |
|
||||||
set connected(type,$modpodpath) "unwrapped" |
|
||||||
lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
|
||||||
set this_pkg_tm_folder [file dirname [file dirname $modpodpath]] |
|
||||||
|
|
||||||
} else { |
|
||||||
#connect to .tm but may still be unwrapped version available |
|
||||||
lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
|
||||||
set this_pkg_tm_folder [file dirname $modpodpath] |
|
||||||
if {$connected(type,$modpodpath) ne "unwrapped"} { |
|
||||||
#Not directly connected to unwrapped version - but may still be redirected there |
|
||||||
set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)] |
|
||||||
if {[file exists $unwrappedFolder]} { |
|
||||||
#folder with exact version-match must exist for redirect to 'unwrapped' |
|
||||||
set con(type,$modpodpath) "modpod-redirecting" |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
} |
|
||||||
set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm" |
|
||||||
set connected(tmfile,$modpodpath) |
|
||||||
set tail_segments [list] |
|
||||||
set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]] |
|
||||||
set lcase_modulepaths [string tolower [tcl::tm::list]] |
|
||||||
foreach lc_mpath $lcase_modulepaths { |
|
||||||
set mpath_segments [file split $lc_mpath] |
|
||||||
if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
|
||||||
set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end] |
|
||||||
break |
|
||||||
} |
|
||||||
} |
|
||||||
if {[llength $tail_segments]} { |
|
||||||
set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require |
|
||||||
} else { |
|
||||||
set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)] |
|
||||||
} |
|
||||||
|
|
||||||
switch -exact -- $connected(type,$modpodpath) { |
|
||||||
"modpod-redirecting" { |
|
||||||
#redirect to the unwrapped version |
|
||||||
set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl] |
|
||||||
|
|
||||||
} |
|
||||||
"unwrapped" { |
|
||||||
if {[info commands ::thread::id] ne ""} { |
|
||||||
set from [pid],[thread::id] |
|
||||||
} else { |
|
||||||
set from [pid] |
|
||||||
} |
|
||||||
#::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath" |
|
||||||
return [list ok ""] |
|
||||||
} |
|
||||||
default { |
|
||||||
#autodetect .tm - zip/tar ? |
|
||||||
#todo - use vfs ? |
|
||||||
|
|
||||||
#connect to tarball - start at 1st header |
|
||||||
set connected(startdata,$modpodpath) 0 |
|
||||||
set fh [open $modpodpath r] |
|
||||||
set connected(fh,$modpodpath) $fh |
|
||||||
fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {} |
|
||||||
|
|
||||||
if {$connected(startdata,$modpodpath) >= 0} { |
|
||||||
#verify we have a valid tar header |
|
||||||
if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} { |
|
||||||
seek $fh $connected(startdata,$modpodpath) start |
|
||||||
return [list ok $fh] |
|
||||||
} else { |
|
||||||
#error "cannot verify tar header" |
|
||||||
} |
|
||||||
} |
|
||||||
lpop connected(to) end |
|
||||||
set connected(startdata,$modpodpath) -1 |
|
||||||
unset connected(fh,$modpodpath) |
|
||||||
catch {close $fh} |
|
||||||
return [dict create err {Does not appear to be a valid modpod}] |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
proc disconnect {{modpod ""}} { |
|
||||||
variable connected |
|
||||||
if {![llength $connected(to)]} { |
|
||||||
return 0 |
|
||||||
} |
|
||||||
if {$modpod eq ""} { |
|
||||||
puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]" |
|
||||||
set modpod [lindex $connected(to) end] |
|
||||||
} |
|
||||||
|
|
||||||
if {[set posn [lsearch $connected(to) $modpod]] == -1} { |
|
||||||
puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod" |
|
||||||
return 0 |
|
||||||
} |
|
||||||
if {[string length $connected(fh,$modpod)]} { |
|
||||||
close $connected(fh,$modpod) |
|
||||||
} |
|
||||||
array unset connected *,$modpod |
|
||||||
set connected(to) [lreplace $connected(to) $posn $posn] |
|
||||||
return 1 |
|
||||||
} |
|
||||||
proc get {args} { |
|
||||||
set argd [punk::args::get_dict { |
|
||||||
-from -default "" -help "path to pod" |
|
||||||
*values -min 1 -max 1 |
|
||||||
filename |
|
||||||
} $args] |
|
||||||
set frompod [dict get $argd opts -from] |
|
||||||
set filename [dict get $argd values filename] |
|
||||||
|
|
||||||
variable connected |
|
||||||
#//review |
|
||||||
set modpod [::modpod::system::connect_if_not $frompod] |
|
||||||
set fh $connected(fh,$modpod) |
|
||||||
if {$connected(type,$modpod) eq "unwrapped"} { |
|
||||||
#for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder |
|
||||||
if {[string range $filename 0 0 eq "/"]} { |
|
||||||
#absolute path (?) |
|
||||||
set path [file join $connected(location,$modpod) .. [string trim $filename /]] |
|
||||||
} else { |
|
||||||
#relative path - use #modpod-xxx as base |
|
||||||
set path [file join $connected(location,$modpod) $filename] |
|
||||||
} |
|
||||||
set fd [open $path r] |
|
||||||
#utf-8? |
|
||||||
#fconfigure $fd -encoding iso8859-1 -translation binary |
|
||||||
return [list ok [lindex [list [read $fd] [close $fd]] 0]] |
|
||||||
} else { |
|
||||||
#read from vfs |
|
||||||
puts stderr "get $filename from wrapped pod '$frompod' not implemented" |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[list_end] [comment {--- end definitions namespace modpod ---}] |
|
||||||
} |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
# Secondary API namespace |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
namespace eval modpod::lib { |
|
||||||
namespace export {[a-z]*}; # Convention: export all lowercase |
|
||||||
namespace path [namespace parent] |
|
||||||
#*** !doctools |
|
||||||
#[subsection {Namespace modpod::lib}] |
|
||||||
#[para] Secondary functions that are part of the API |
|
||||||
#[list_begin definitions] |
|
||||||
|
|
||||||
#proc utility1 {p1 args} { |
|
||||||
# #*** !doctools |
|
||||||
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
|
||||||
# #[para]Description of utility1 |
|
||||||
# return 1 |
|
||||||
#} |
|
||||||
|
|
||||||
proc is_valid_tm_version {versionpart} { |
|
||||||
#Needs to be suitable for use with Tcl's 'package vcompare' |
|
||||||
if {![catch [list package vcompare $versionparts $versionparts]]} { |
|
||||||
return 1 |
|
||||||
} else { |
|
||||||
return 0 |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
#zipfile is a pure zip at this point - ie no script/exe header |
|
||||||
proc make_zip_modpod {args} { |
|
||||||
set argd [punk::args::get_dict { |
|
||||||
@id -id ::modpod::lib::make_zip_modpod |
|
||||||
-offsettype -default "archive" -choices {archive file} -help\ |
|
||||||
"Whether zip offsets are relative to start of file or start of zip-data within the file. |
|
||||||
'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip, |
|
||||||
but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip) |
|
||||||
info-zip's 'zip -A' can sometimes convert archive-relative to file-relative. |
|
||||||
-offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'" |
|
||||||
@values -min 2 -max 2 |
|
||||||
zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" |
|
||||||
outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" |
|
||||||
} $args] |
|
||||||
set zipfile [dict get $argd values zipfile] |
|
||||||
set outfile [dict get $argd values outfile] |
|
||||||
set opt_offsettype [dict get $argd opts -offsettype] |
|
||||||
|
|
||||||
|
|
||||||
set mount_stub [string map [list %offsettype% $opt_offsettype] { |
|
||||||
#zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. |
|
||||||
#Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. |
|
||||||
#generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% <zipfile> <tmfile> |
|
||||||
if {[catch {file normalize [info script]} modfile]} { |
|
||||||
error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" |
|
||||||
} |
|
||||||
if {$modfile eq "" || ![file exists $modfile]} { |
|
||||||
error "modpod zip stub error. Unable to determine module path" |
|
||||||
} |
|
||||||
set moddir [file dirname $modfile] |
|
||||||
set mod_and_ver [file rootname [file tail $modfile]] |
|
||||||
lassign [split $mod_and_ver -] moduletail version |
|
||||||
if {[file exists $moddir/#modpod-$mod_and_ver]} { |
|
||||||
source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm |
|
||||||
} else { |
|
||||||
#determine module namespace so we can mount appropriately |
|
||||||
proc intersect {A B} { |
|
||||||
if {[llength $A] == 0} {return {}} |
|
||||||
if {[llength $B] == 0} {return {}} |
|
||||||
if {[llength $B] > [llength $A]} { |
|
||||||
set res $A |
|
||||||
set A $B |
|
||||||
set B $res |
|
||||||
} |
|
||||||
set res {} |
|
||||||
foreach x $A {set ($x) {}} |
|
||||||
foreach x $B { |
|
||||||
if {[info exists ($x)]} { |
|
||||||
lappend res $x |
|
||||||
} |
|
||||||
} |
|
||||||
return $res |
|
||||||
} |
|
||||||
set lcase_tmfile_segments [string tolower [file split $moddir]] |
|
||||||
set lcase_modulepaths [string tolower [tcl::tm::list]] |
|
||||||
foreach lc_mpath $lcase_modulepaths { |
|
||||||
set mpath_segments [file split $lc_mpath] |
|
||||||
if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
|
||||||
set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use properly cased tail |
|
||||||
break |
|
||||||
} |
|
||||||
} |
|
||||||
if {[llength $tail_segments]} { |
|
||||||
set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require |
|
||||||
set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver |
|
||||||
} else { |
|
||||||
set fullpackage $moduletail |
|
||||||
set mount_at #modpod/#mounted-modpod-$mod_and_ver |
|
||||||
} |
|
||||||
|
|
||||||
if {[info commands tcl::zipfs::mount] ne ""} { |
|
||||||
#argument order changed to be consistent with vfs::zip::Mount etc |
|
||||||
#early versions: zipfs::Mount mountpoint zipname |
|
||||||
#since 2023-09: zipfs::Mount zipname mountpoint |
|
||||||
#don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance) |
|
||||||
#This is presumably related to // being interpreted as a network path |
|
||||||
set mountpoints [dict keys [tcl::zipfs::mount]] |
|
||||||
if {"//zipfs:/$mount_at" ni $mountpoints} { |
|
||||||
#despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it |
|
||||||
if {[catch { |
|
||||||
#tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) |
|
||||||
#puts "tcl::zipfs::mount $modfile $mount_at" |
|
||||||
tcl::zipfs::mount $modfile $mount_at |
|
||||||
} errM]} { |
|
||||||
#try old api |
|
||||||
if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { |
|
||||||
puts stderr "modpod stub>>> tcl::zipfs::mount <file> <mountpoint> failed.\nbut old api: tcl::zipfs::mount <mountpoint> <file> succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" |
|
||||||
puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" |
|
||||||
} |
|
||||||
} |
|
||||||
if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
|
||||||
puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]" |
|
||||||
#tcl::zipfs::unmount //zipfs:/$mount_at |
|
||||||
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" |
|
||||||
} |
|
||||||
} |
|
||||||
# #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form |
|
||||||
source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm |
|
||||||
} else { |
|
||||||
#fallback to slower vfs::zip |
|
||||||
#NB. We don't create the intermediate dirs - but the mount still works |
|
||||||
if {![file exists $moddir/$mount_at]} { |
|
||||||
if {[catch {package require vfs::zip} errM]} { |
|
||||||
set msg "Unable to load vfs::zip package to mount module $mod_and_ver (and zipfs not available either)" |
|
||||||
append msg \n "If neither zipfs or vfs::zip are available - the module can still be loaded by manually unzipping the file $modfile in place." |
|
||||||
append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" |
|
||||||
error $msg |
|
||||||
} else { |
|
||||||
set fd [vfs::zip::Mount $modfile $moddir/$mount_at] |
|
||||||
if {![file exists $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
|
||||||
vfs::zip::Unmount $fd $moddir/$mount_at |
|
||||||
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
source $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm |
|
||||||
} |
|
||||||
} |
|
||||||
#zipped data follows |
|
||||||
}] |
|
||||||
#todo - test if supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? |
|
||||||
append mount_stub \x1A |
|
||||||
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub $opt_offsettype |
|
||||||
|
|
||||||
} |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[list_end] [comment {--- end definitions namespace modpod::lib ---}] |
|
||||||
} |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
#*** !doctools |
|
||||||
#[section Internal] |
|
||||||
namespace eval modpod::system { |
|
||||||
#*** !doctools |
|
||||||
#[subsection {Namespace modpod::system}] |
|
||||||
#[para] Internal functions that are not part of the API |
|
||||||
|
|
||||||
#deflate,store only supported |
|
||||||
|
|
||||||
#zipfile here is plain zip - no script/exe prefix part. |
|
||||||
proc make_mountable_zip {zipfile outfile mount_stub {offsettype "archive"}} { |
|
||||||
set inzip [open $zipfile r] |
|
||||||
fconfigure $inzip -encoding iso8859-1 -translation binary |
|
||||||
set out [open $outfile w+] |
|
||||||
fconfigure $out -encoding iso8859-1 -translation binary |
|
||||||
puts -nonewline $out $mount_stub |
|
||||||
set stuboffset [tell $out] |
|
||||||
lappend report "stub size: $stuboffset" |
|
||||||
fcopy $inzip $out |
|
||||||
close $inzip |
|
||||||
|
|
||||||
set size [tell $out] |
|
||||||
lappend report "tmfile : [file tail $outfile]" |
|
||||||
lappend report "output size : $size" |
|
||||||
lappend report "offsettype : $offsettype" |
|
||||||
|
|
||||||
if {$offsettype eq "file"} { |
|
||||||
#make zip offsets relative to start of whole file including prepended script. |
|
||||||
#same offset structure as Tcl's 'zipfs mkimg' as at 2024-10 |
|
||||||
#not editable by 7z,nanazip,peazip |
|
||||||
|
|
||||||
#we aren't adding any new files/folders so we can edit the offsets in place |
|
||||||
|
|
||||||
#Now seek in $out to find the end of directory signature: |
|
||||||
#The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text |
|
||||||
if {$size < 65559} { |
|
||||||
set tailsearch_start 0 |
|
||||||
} else { |
|
||||||
set tailsearch_start [expr {$size - 65559}] |
|
||||||
} |
|
||||||
seek $out $tailsearch_start |
|
||||||
set data [read $out] |
|
||||||
#EOCD - End of Central Directory record |
|
||||||
#PK\5\6 |
|
||||||
set start_of_end [string last "\x50\x4b\x05\x06" $data] |
|
||||||
#set start_of_end [expr {$start_of_end + $seek}] |
|
||||||
#incr start_of_end $seek |
|
||||||
set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] |
|
||||||
|
|
||||||
lappend report "kitfile-relative START-OF-EOCD: $filerelative_eocd_posn" |
|
||||||
|
|
||||||
seek $out $filerelative_eocd_posn |
|
||||||
set end_of_ctrl_dir [read $out] |
|
||||||
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
|
||||||
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
|
||||||
|
|
||||||
lappend report "End of central directory: [array get eocd]" |
|
||||||
seek $out [expr {$filerelative_eocd_posn+16}] |
|
||||||
|
|
||||||
#adjust offset of start of central directory by the length of our sfx stub |
|
||||||
puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $stuboffset}]] |
|
||||||
flush $out |
|
||||||
|
|
||||||
seek $out $filerelative_eocd_posn |
|
||||||
set end_of_ctrl_dir [read $out] |
|
||||||
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
|
||||||
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
|
||||||
|
|
||||||
# 0x06054b50 - end of central dir signature |
|
||||||
puts stderr "$end_of_ctrl_dir" |
|
||||||
puts stderr "comment_len: $eocd(comment_len)" |
|
||||||
puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" |
|
||||||
lappend report "New dir offset: $eocd(diroffset)" |
|
||||||
lappend report "Adjusting $eocd(totalnum) zip file items." |
|
||||||
catch { |
|
||||||
punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies |
|
||||||
} |
|
||||||
|
|
||||||
seek $out $eocd(diroffset) |
|
||||||
for {set i 0} {$i <$eocd(totalnum)} {incr i} { |
|
||||||
set current_file [tell $out] |
|
||||||
set fileheader [read $out 46] |
|
||||||
puts -------------- |
|
||||||
puts [ansistring VIEW -lf 1 $fileheader] |
|
||||||
puts -------------- |
|
||||||
#binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
|
||||||
# x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
|
||||||
|
|
||||||
binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
|
||||||
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
|
||||||
set ::last_header $fileheader |
|
||||||
|
|
||||||
puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" |
|
||||||
puts "ver: $x(version)" |
|
||||||
puts "method: $x(method)" |
|
||||||
|
|
||||||
#PK\1\2 |
|
||||||
#33639248 dec = 0x02014b50 - central directory file header signature |
|
||||||
if { $x(sig) != 33639248 } { |
|
||||||
error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" |
|
||||||
} |
|
||||||
|
|
||||||
foreach size $x(lengths) var {filename extrafield comment} { |
|
||||||
if { $size > 0 } { |
|
||||||
set x($var) [read $out $size] |
|
||||||
} else { |
|
||||||
set x($var) "" |
|
||||||
} |
|
||||||
} |
|
||||||
set next_file [tell $out] |
|
||||||
lappend report "file $i: $x(offset) $x(sizes) $x(filename)" |
|
||||||
|
|
||||||
seek $out [expr {$current_file+42}] |
|
||||||
puts -nonewline $out [binary format i [expr {$x(offset)+$stuboffset}]] |
|
||||||
|
|
||||||
#verify: |
|
||||||
flush $out |
|
||||||
seek $out $current_file |
|
||||||
set fileheader [read $out 46] |
|
||||||
lappend report "old $x(offset) + $stuboffset" |
|
||||||
binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
|
||||||
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
|
||||||
lappend report "new $x(offset)" |
|
||||||
|
|
||||||
seek $out $next_file |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
close $out |
|
||||||
#pdict/showdict reuire punk & textlib - ie lots of dependencies |
|
||||||
#don't fall over just because of that |
|
||||||
catch { |
|
||||||
punk::lib::showdict -roottype list -chan stderr $report |
|
||||||
} |
|
||||||
#puts [join $report \n] |
|
||||||
return |
|
||||||
} |
|
||||||
|
|
||||||
proc connect_if_not {{podpath ""}} { |
|
||||||
upvar ::modpod::connected connected |
|
||||||
set podpath [::modpod::system::normalize $podpath] |
|
||||||
set docon 0 |
|
||||||
if {![llength $connected(to)]} { |
|
||||||
if {![string length $podpath]} { |
|
||||||
error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified" |
|
||||||
} else { |
|
||||||
set docon 1 |
|
||||||
} |
|
||||||
} else { |
|
||||||
if {![string length $podpath]} { |
|
||||||
set podpath [lindex $connected(to) end] |
|
||||||
puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]" |
|
||||||
} else { |
|
||||||
if {$podpath ni $connected(to)} { |
|
||||||
set docon 1 |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
if {$docon} { |
|
||||||
if {[lindex [modpod::connect $podpath]] 0] ne "ok"} { |
|
||||||
error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod" |
|
||||||
} else { |
|
||||||
return $podpath |
|
||||||
} |
|
||||||
} |
|
||||||
#we were already connected |
|
||||||
return $podpath |
|
||||||
} |
|
||||||
|
|
||||||
proc myversion {} { |
|
||||||
upvar ::modpod::connected connected |
|
||||||
set script [info script] |
|
||||||
if {![string length $script]} { |
|
||||||
error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod" |
|
||||||
} |
|
||||||
set fname [file tail [file rootname [file normalize $script]]] |
|
||||||
set scriptdir [file dirname $script] |
|
||||||
|
|
||||||
if {![string match "#modpod-*" $fname]} { |
|
||||||
lassign [lrange [split $fname -] end-1 end] _pkgname version |
|
||||||
} else { |
|
||||||
lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version |
|
||||||
if {![string length $version]} { |
|
||||||
#try again on the name of the containing folder |
|
||||||
lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version |
|
||||||
#todo - proper walk up the directory tree |
|
||||||
if {![string length $version]} { |
|
||||||
#try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod) |
|
||||||
lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
#tarjar::Log debug "'myversion' determined version for [info script]: $version" |
|
||||||
return $version |
|
||||||
} |
|
||||||
|
|
||||||
proc myname {} { |
|
||||||
upvar ::modpod::connected connected |
|
||||||
set script [info script] |
|
||||||
if {![string length $script]} { |
|
||||||
error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod" |
|
||||||
} |
|
||||||
return $connected(fullpackage,$script) |
|
||||||
} |
|
||||||
proc myfullname {} { |
|
||||||
upvar ::modpod::connected connected |
|
||||||
set script [info script] |
|
||||||
#set script [::tarjar::normalize $script] |
|
||||||
set script [file normalize $script] |
|
||||||
if {![string length $script]} { |
|
||||||
error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar" |
|
||||||
} |
|
||||||
return $::tarjar::connected(fullpackage,$script) |
|
||||||
} |
|
||||||
proc normalize {path} { |
|
||||||
#newer versions of Tcl don't do tilde sub |
|
||||||
|
|
||||||
#Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths) |
|
||||||
# we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function. |
|
||||||
set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes.. |
|
||||||
set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after |
|
||||||
set path [file normalize $path] |
|
||||||
#set path [string tolower $path] ;#must do this after file normalize |
|
||||||
return [string map [list $matilda ~] $path] ;#get our tildes back. |
|
||||||
} |
|
||||||
} |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
## Ready |
|
||||||
package provide modpod [namespace eval modpod { |
|
||||||
variable pkg modpod |
|
||||||
variable version |
|
||||||
set version 0.1.2 |
|
||||||
}] |
|
||||||
return |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[manpage_end] |
|
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
@ -1,643 +0,0 @@ |
|||||||
|
|
||||||
|
|
||||||
#JMN 2005 - Public Domain |
|
||||||
# |
|
||||||
#REVIEW: This package may not robustly output xml. More testing & development required. |
|
||||||
# |
|
||||||
|
|
||||||
#NOTE: the 'x' attribute on the 'info' tag may have its value truncated. |
|
||||||
#It is a human-readable indicator only and should not be used to cross-reference to the corresponding 'require' tag using the 'p' attribute. |
|
||||||
#Use the fact that the corresponding 'info' tag directly follows its 'require' tag. |
|
||||||
|
|
||||||
|
|
||||||
#changes |
|
||||||
#2021-09-17 |
|
||||||
# - added variable ::packagetrace::showpresent with default 1 |
|
||||||
# setting this to 0 will hide the <present/> tags which sometimes make the output too verbose. |
|
||||||
# - changed t from an integer number of milliseconds to show fractional millis by using ([clock microseconds]-$t0)/1000.0 in the expr. |
|
||||||
|
|
||||||
namespace eval packagetrace::class { |
|
||||||
if {[info commands [namespace current]::tracer] eq ""} { |
|
||||||
oo::class create tracer { |
|
||||||
method get {} { |
|
||||||
} |
|
||||||
method test {} { |
|
||||||
return tracertest |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
namespace eval packagetrace { |
|
||||||
variable tracerlist [list] |
|
||||||
variable chan stderr |
|
||||||
variable showpresent 1 |
|
||||||
variable output "" |
|
||||||
|
|
||||||
|
|
||||||
proc help {} { |
|
||||||
return { |
|
||||||
REVIEW - documentation inaccurate |
|
||||||
Enable package tracing using 'package require packagetrace' |
|
||||||
Disable package tracing using 'package forget packagetrace; package require packagetrace' |
|
||||||
(This 2nd 'package require packagetrace' will raise an error. This is deliberate.) |
|
||||||
use packagetrace::channel <chan> to desired output channel or none. (default stderr) |
|
||||||
|
|
||||||
set packagetrace::showpresent 0 to skip <present/> output |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
# == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == |
|
||||||
# Maintenance - tm_version... functions - primary source is punk::lib module |
|
||||||
# - these should be synced with code from latest punk::lib |
|
||||||
# == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == |
|
||||||
proc tm_version_isvalid {versionpart} { |
|
||||||
#Needs to be suitable for use with Tcl's 'package vcompare' |
|
||||||
if {![catch [list package vcompare $versionpart $versionpart]]} { |
|
||||||
return 1 |
|
||||||
} else { |
|
||||||
return 0 |
|
||||||
} |
|
||||||
} |
|
||||||
proc tm_version_major {version} { |
|
||||||
if {![tm_version_isvalid $version]} { |
|
||||||
error "Invalid version '$version' is not a proper Tcl module version number" |
|
||||||
} |
|
||||||
set firstpart [lindex [split $version .] 0] |
|
||||||
#check for a/b in first segment |
|
||||||
if {[string is integer -strict $firstpart]} { |
|
||||||
return $firstpart |
|
||||||
} |
|
||||||
if {[string first a $firstpart] > 0} { |
|
||||||
return [lindex [split $firstpart a] 0] |
|
||||||
} |
|
||||||
if {[string first b $firstpart] > 0} { |
|
||||||
return [lindex [split $firstpart b] 0] |
|
||||||
} |
|
||||||
error "tm_version_major unable to determine major version from version number '$version'" |
|
||||||
} |
|
||||||
proc tm_version_canonical {ver} { |
|
||||||
#accepts a single valid version only - not a bounded or unbounded spec |
|
||||||
if {![tm_version_isvalid $ver]} { |
|
||||||
error "tm_version_canonical version '$ver' is not valid for a package version" |
|
||||||
} |
|
||||||
set parts [split $ver .] |
|
||||||
set newparts [list] |
|
||||||
foreach o $parts { |
|
||||||
set trimmed [string trimleft $o 0] |
|
||||||
set firstnonzero [string index $trimmed 0] |
|
||||||
switch -exact -- $firstnonzero { |
|
||||||
"" { |
|
||||||
lappend newparts 0 |
|
||||||
} |
|
||||||
a - b { |
|
||||||
#e.g 000bnnnn -> bnnnnn |
|
||||||
set tailtrimmed [string trimleft [string range $trimmed 1 end] 0] |
|
||||||
if {$tailtrimmed eq ""} { |
|
||||||
set tailtrimmed 0 |
|
||||||
} |
|
||||||
lappend newparts 0$firstnonzero$tailtrimmed |
|
||||||
} |
|
||||||
default { |
|
||||||
#digit |
|
||||||
if {[string is integer -strict $trimmed]} { |
|
||||||
#e.g 0100 -> 100 |
|
||||||
lappend newparts $trimmed |
|
||||||
} else { |
|
||||||
#e.g 0100b003 -> 100b003 (still need to process tail) |
|
||||||
if {[set apos [string first a $trimmed]] > 0} { |
|
||||||
set lhs [string range $trimmed 0 $apos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch |
|
||||||
set rhs [string range $trimmed $apos+1 end] ;#assert rhs non-empty and only digits |
|
||||||
set rhs [string trimleft $rhs 0] |
|
||||||
if {$rhs eq ""} { |
|
||||||
set rhs 0 |
|
||||||
} |
|
||||||
lappend newparts ${lhs}a${rhs} |
|
||||||
} elseif {[set bpos [string first b $trimmed]] > 0} { |
|
||||||
set lhs [string range $trimmed 0 $bpos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch |
|
||||||
set rhs [string range $trimmed $bpos+1 end] ;#assert rhs non-empty and only digits |
|
||||||
set rhs [string trimleft $rhs 0] |
|
||||||
if {$rhs eq ""} { |
|
||||||
set rhs 0 |
|
||||||
} |
|
||||||
lappend newparts ${lhs}b${rhs} |
|
||||||
} else { |
|
||||||
#assert - shouldn't get here trimmed val should have been empty, an int or contained an a or b |
|
||||||
error "tm_version_canonical error - trimfail - unexpected" |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
return [join $newparts .] |
|
||||||
} |
|
||||||
proc tm_version_required_canonical {versionspec} { |
|
||||||
#also trim leading zero from any dottedpart? |
|
||||||
#Tcl *allows* leading zeros in any of the dotted parts - but they are not significant. |
|
||||||
#e.g 1.01 is equivalent to 1.1 and 01.001 |
|
||||||
#also 1b3 == 1b0003 |
|
||||||
|
|
||||||
if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version |
|
||||||
set errmsg "tm_version_required_canonical - invalid version specification" |
|
||||||
if {[string first - $versionspec] < 0} { |
|
||||||
#no dash |
|
||||||
#looks like a minbounded version (ie a single version with no dash) convert to min-max form |
|
||||||
set from $versionspec |
|
||||||
if {![tm_version_isvalid $from]} { |
|
||||||
error "$errmsg '$versionpec'" |
|
||||||
} |
|
||||||
if {![catch {tm_version_major $from} majorv]} { |
|
||||||
set from [tm_version_canonical $from] |
|
||||||
return "${from}-[expr {$majorv +1}]" |
|
||||||
} else { |
|
||||||
error "$errmsg '$versionspec'" |
|
||||||
} |
|
||||||
} else { |
|
||||||
# min- or min-max |
|
||||||
#validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b) |
|
||||||
set parts [split $versionspec -] ;#we expect only 2 parts |
|
||||||
lassign $parts from to |
|
||||||
if {![tm_version_isvalid $from]} { |
|
||||||
error "$errmsg '$versionspec'" |
|
||||||
} |
|
||||||
set from [tm_version_canonical $from] |
|
||||||
if {[llength $parts] == 2} { |
|
||||||
if {$to ne ""} { |
|
||||||
if {![tm_version_isvalid $to]} { |
|
||||||
error "$errmsg '$versionspec'" |
|
||||||
} |
|
||||||
set to [tm_version_canonical $to] |
|
||||||
return $from-$to |
|
||||||
} else { |
|
||||||
return $from- |
|
||||||
} |
|
||||||
} else { |
|
||||||
error "$errmsg '$versionspec'" |
|
||||||
} |
|
||||||
error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point" |
|
||||||
} |
|
||||||
} |
|
||||||
# end tm_version... functions |
|
||||||
# == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == |
|
||||||
|
|
||||||
#convenience function in case the sequence 'package forget packagetrace;package require packagetrace' is too unintuitive or weird. |
|
||||||
#REVIEW |
|
||||||
proc unload {} { |
|
||||||
package forget packagetrace |
|
||||||
if {[catch {package require packagetrace}]} { |
|
||||||
return 1 ;#yes - we get an error if we unloaded successfully |
|
||||||
} else { |
|
||||||
error "packagetrace was not unloaded" |
|
||||||
} |
|
||||||
} |
|
||||||
proc emit {str} { |
|
||||||
variable chan |
|
||||||
variable output |
|
||||||
append output $str |
|
||||||
if {$chan ne "none"} { |
|
||||||
puts -nonewline $chan $str |
|
||||||
} |
|
||||||
return |
|
||||||
} |
|
||||||
proc get {{as raw}} { |
|
||||||
variable output |
|
||||||
switch -- [string tolower $as] { |
|
||||||
asxml { |
|
||||||
if {[package provide tdom] eq ""} { |
|
||||||
set previous_output $output |
|
||||||
package require tdom |
|
||||||
set output $previous_output |
|
||||||
} |
|
||||||
set d [dom parse $output] |
|
||||||
return [$d asXML] |
|
||||||
} |
|
||||||
aslist { |
|
||||||
if {[package provide tdom] eq ""} { |
|
||||||
set previous_output $output |
|
||||||
package require tdom |
|
||||||
set output $previous_output |
|
||||||
} |
|
||||||
set d [dom parse $output] |
|
||||||
return [$d asList] |
|
||||||
} |
|
||||||
default { |
|
||||||
return $output |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
proc channel {{ch ""}} { |
|
||||||
variable chan |
|
||||||
switch -exact -- $ch { |
|
||||||
"" { |
|
||||||
return $chan |
|
||||||
} |
|
||||||
none { |
|
||||||
set chan none |
|
||||||
return none |
|
||||||
} |
|
||||||
stderr - stdout { |
|
||||||
#note stderr stdout not necessarily in [chan names] (due to transforms etc?) but can still work |
|
||||||
set chan $ch |
|
||||||
return $ch |
|
||||||
} |
|
||||||
default { |
|
||||||
if {$ch in [chan names]} { |
|
||||||
set chan $ch |
|
||||||
return $ch |
|
||||||
} else { |
|
||||||
error "chan '$ch' not in \[chan names\]: [chan names]" |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
proc init {} { |
|
||||||
uplevel 1 { |
|
||||||
set ::packagetrace::level -1 |
|
||||||
if {![llength [info commands tcl_findLibrary]]} { |
|
||||||
tcl::namespace::eval :: $::auto_index(tcl_findLibrary) |
|
||||||
} |
|
||||||
package require commandstack |
|
||||||
|
|
||||||
|
|
||||||
set targetcommand [namespace which tcl_findLibrary] ;# normalize to presumably ::tcl_findLibrary |
|
||||||
set stackrecord [commandstack::rename_command -renamer packagetrace $targetcommand [info args $targetcommand] { |
|
||||||
set marg [string repeat { } $::packagetrace::level] |
|
||||||
packagetrace::emit "${marg}<extra> tcl_findLibrary $basename $version $patch $initScript $enVarName $varName </extra>\n" |
|
||||||
uplevel 1 [list $COMMANDSTACKNEXT $basename $version $patch $initScript $enVarName $varName] |
|
||||||
}] |
|
||||||
if {[dict get $stackrecord implementation] ne ""} { |
|
||||||
set old_tcl_findLibrary [dict get $stackrecord implementation] |
|
||||||
puts stderr "packagetrace::init renamed $targetcommand to $old_tcl_findLibrary and is providing an override" |
|
||||||
} else { |
|
||||||
puts stderr "packagetrace::init failed to rename $targetcommand" |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
set package_command [namespace which package] |
|
||||||
set stackrecord [commandstack::rename_command -renamer packagetrace $package_command {subcommand args} { |
|
||||||
set tracerlist $::packagetrace::tracerlist |
|
||||||
set tracer [lindex $tracerlist end] |
|
||||||
if {$tracer eq ""} { |
|
||||||
|
|
||||||
} |
|
||||||
set ch $::packagetrace::chan |
|
||||||
set next $COMMANDSTACKNEXT |
|
||||||
if {$next ne "$COMMANDSTACKNEXT_ORIGINAL"} { |
|
||||||
puts stderr "(packagetrace package) DEBUG - command changed since start: $COMMANDSTACKNEXT_ORIGINAL is now $next" |
|
||||||
} |
|
||||||
|
|
||||||
#cache $ch instead of using upvar, |
|
||||||
#because namespace may be deleted during call. |
|
||||||
|
|
||||||
#!todo - optionally silence Tcl & Tk requires to reduce output? |
|
||||||
#if {[lindex $args 0] eq "Tcl"} { |
|
||||||
# return [$next $subcommand {*}$args] |
|
||||||
#} |
|
||||||
switch -exact -- [tcl::prefix::match {files forget ifneeded names prefer present provide require unknown vcompare versions vsatisfies} $subcommand] { |
|
||||||
require { |
|
||||||
#columns |
|
||||||
set c1 [string repeat { } 30] ;#tree col |
|
||||||
set c1a " " |
|
||||||
set c2 [string repeat { } 20] ;#package name col |
|
||||||
set c2a " " ;# close require/present tags |
|
||||||
set c3 [string repeat { } 18] ;#version col - must handle v= "999999.0a1.0" without truncation |
|
||||||
set c4 [string repeat { } 12] ;#timing col 5 chars of punct leaving remainder for value. |
|
||||||
set c5 [string repeat { } 10] ;#module col |
|
||||||
set c5a [string repeat { } 3] ;#close result tag col |
|
||||||
|
|
||||||
#we assume 'package require' API sticks to solo option flags like -exact and is relatively stable. |
|
||||||
set argidx 0 |
|
||||||
set is_exact 0 |
|
||||||
foreach a $args { |
|
||||||
if {[string range $a 0 0] ne "-"} { |
|
||||||
#assume 1st non-dashed argument is package name |
|
||||||
set pkg $a |
|
||||||
set v_requirements [lrange $args $argidx+1 end] |
|
||||||
#normalize |
|
||||||
if {$is_exact} { |
|
||||||
set req [lindex $v_requirements 0] ;#only one is allowed for -exact |
|
||||||
set v_requirements $req-$req ;#translate to v-v normalised equiv of -exact |
|
||||||
} else { |
|
||||||
set reqs [list] |
|
||||||
foreach req $v_requirements { |
|
||||||
lappend reqs [::packagetrace::tm_version_required_canonical $v_requirement] ;#empty remains empty, v -> v-<majorv+1>, leading zeros stripped from all segments. |
|
||||||
} |
|
||||||
set v_requirements $reqs ;#each normalised |
|
||||||
} |
|
||||||
set pkg_ [lrange $args $argidx end] ;# raw e.g "Tcl 8.6" or "Tcl 8.5 9" |
|
||||||
break |
|
||||||
} else { |
|
||||||
if {$a eq "-exact"} { |
|
||||||
set is_exact 1 |
|
||||||
} |
|
||||||
} |
|
||||||
incr argidx |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
incr ::packagetrace::level |
|
||||||
if {$::packagetrace::level == 0} { |
|
||||||
set packagetrace::output "" |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
set marg [string repeat { } $::packagetrace::level] |
|
||||||
set margnext [string repeat { } [expr {$::packagetrace::level + 1}]] |
|
||||||
|
|
||||||
if {![catch {set ver [$next present {*}$args]}]} { |
|
||||||
if {$::packagetrace::showpresent} { |
|
||||||
#already loaded.. |
|
||||||
set f1 [packagetrace::overtype::left $c1 "${marg}<present"] |
|
||||||
set f2 [packagetrace::overtype::left -overflow 1 $c2 "p= \"$pkg_\""] ;#disallow truncation! |
|
||||||
set f2a $c2a |
|
||||||
set f3 [packagetrace::overtype::left $c3 "v= \"$ver\""] |
|
||||||
set f4 $c4 |
|
||||||
set f5 $c5 |
|
||||||
set f5a "/> " |
|
||||||
#puts -nonewline $ch $f1$c1a$f2$f2a$f3$f4$f5\n |
|
||||||
packagetrace::emit $f1$c1a$f2$f2a$f3$f4$f5$f5a\n |
|
||||||
} |
|
||||||
} else { |
|
||||||
set f1 [packagetrace::overtype::left $c1 "${marg}<require"] |
|
||||||
set f2 [packagetrace::overtype::left -overflow 1 $c2 "p= \"$pkg_\""] ;#disallow truncation! |
|
||||||
set f2a $c2a |
|
||||||
set f3 $c3 |
|
||||||
set f4 $c4 |
|
||||||
set f5 $c5 |
|
||||||
set f5a " > " |
|
||||||
#puts -nonewline $ch $f1$c1a$f2$f2a$f3$f4$f5\n |
|
||||||
packagetrace::emit $f1$c1a$f2$f2a$f3$f4$f5$f5a\n |
|
||||||
|
|
||||||
set errMsg "" |
|
||||||
#set t0 [clock clicks -milliseconds] |
|
||||||
set t0 [clock microseconds] |
|
||||||
|
|
||||||
if {[catch {set ver [$next require {*}$args]} errMsg]} { |
|
||||||
set ver "" |
|
||||||
# |
|
||||||
#NOTE error must be raised at some point - see below |
|
||||||
} |
|
||||||
#set t [expr {[clock clicks -millisec]-$t0}] |
|
||||||
set t [expr {([clock microseconds]-$t0)/1000.0}] |
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
#jmn |
|
||||||
set f1 [packagetrace::overtype::left $c1 "${margnext}<info "] |
|
||||||
#set f1a "<info " |
|
||||||
set f1a "" |
|
||||||
|
|
||||||
set f2 [packagetrace::overtype::left -ellipsis 1 [string range $c2 0 end-1] "x= \"$args"] |
|
||||||
if {[string length [string trimright $f2]] <= [expr [string length $c2]-1]} { |
|
||||||
#right-trimmed value shorter than field.. therefore we need to close attribute |
|
||||||
set f2 [packagetrace::overtype::left $c2 [string trimright $f2]\"] |
|
||||||
} |
|
||||||
|
|
||||||
#we use the attributename x because this is not necessarily the same as p! may be truncated. |
|
||||||
|
|
||||||
set f3 [packagetrace::overtype::left $c3 "v= \"$ver\""] |
|
||||||
|
|
||||||
#truncate time to c4 width - possibly losing some precision. If truncated - add closing double quote. |
|
||||||
set f4 [packagetrace::overtype::left -overflow 1 $c4 "t= \"[lrange $t 0 1]\""] |
|
||||||
if {[string length [string trimright $f4]] > [expr {[string length $c4]}]} { |
|
||||||
set f4 "[packagetrace::overtype::left [string range $c4 0 end-1] [string trimright $f4]]\"" |
|
||||||
} |
|
||||||
|
|
||||||
if {[string length $ver]} { |
|
||||||
set num "" |
|
||||||
foreach c [split $ver ""] { |
|
||||||
if {[string is digit $c] || $c eq "."} { |
|
||||||
append num $c |
|
||||||
} else { |
|
||||||
break |
|
||||||
} |
|
||||||
} |
|
||||||
set ver $num |
|
||||||
|
|
||||||
#review - scr not guaranteed to be valid tcl list - should parse properly? |
|
||||||
set scr [$next ifneeded $pkg $ver] |
|
||||||
if {[string range $scr end-2 end] ne ".tm"} { |
|
||||||
set f5 $c5 |
|
||||||
} else { |
|
||||||
#!todo - optionally output module path instead of boolean? |
|
||||||
#set f5 [packagetrace::overtype::left -ellipsis 1 -ellipsistext ... [string range $c5 0 end-1] "tm= \"[lindex $scr end]"] |
|
||||||
set f5 [packagetrace::overtype::left -ellipsis 1 -ellipsistext ... [string range $c5 0 end-1] "tm= \"1"] |
|
||||||
if {[string length [string trimright $f5]] <= [expr [string length $c5]-1]} { |
|
||||||
set f5 [packagetrace::overtype::left $c5 [string trimright $f5]\"] |
|
||||||
} |
|
||||||
} |
|
||||||
} else { |
|
||||||
set f5 $c5 |
|
||||||
} |
|
||||||
|
|
||||||
set f5a [packagetrace::overtype::left $c5a "/>"] ;#end of <info |
|
||||||
#puts -nonewline $ch "$f1$c1a$f2$c2a$f3$f4 $f5$f5a\n" |
|
||||||
packagetrace::emit "$f1$c1a$f2$c2a$f3$f4 $f5$f5a\n" |
|
||||||
|
|
||||||
|
|
||||||
set f1 [packagetrace::overtype::left $c1 "${marg}</require>"] |
|
||||||
set f1a "" |
|
||||||
set f2 "" |
|
||||||
set c2a "" |
|
||||||
set f3 "" |
|
||||||
set f4 "" |
|
||||||
set f5 "" |
|
||||||
set f5a "" |
|
||||||
#puts -nonewline $ch $f1$f1a$f2$c2a$f3$f4$f5$f5a\n |
|
||||||
packagetrace::emit $f1$f1a$f2$c2a$f3$f4$f5$f5a\n |
|
||||||
|
|
||||||
|
|
||||||
if {![string length $ver]} { |
|
||||||
if {[lindex $args 0] eq "packagetrace"} { |
|
||||||
#REVIEW - what is going on here? |
|
||||||
namespace delete ::packagetrace::overtype |
|
||||||
} |
|
||||||
|
|
||||||
#we must raise an error if original 'package require' would have |
|
||||||
incr ::packagetrace::level -1 |
|
||||||
error $errMsg |
|
||||||
} |
|
||||||
|
|
||||||
} |
|
||||||
incr ::packagetrace::level -1 |
|
||||||
return $ver |
|
||||||
} |
|
||||||
vcompare - vsatisifies - provide - ifneeded { |
|
||||||
set result [$next $subcommand {*}$args] |
|
||||||
#puts -nonewline $ch " -- package $subcommand $args\n" |
|
||||||
return $result |
|
||||||
} |
|
||||||
default { |
|
||||||
set result [$next $subcommand {*}$args] |
|
||||||
#puts $ch "*** here $subcommand $args" |
|
||||||
return $result |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
}] |
|
||||||
if {[set stored_target [dict get $stackrecord implementation]] ne ""} { |
|
||||||
puts stderr "packagetrace::init renamed $package_command to $stored_target and is providing an override" |
|
||||||
set f1 [string repeat { } 30] |
|
||||||
#set f1a " " |
|
||||||
set f1a "" |
|
||||||
set f2 [packagetrace::overtype::left [string repeat { } 20] "PACKAGE"] |
|
||||||
set f2a " " |
|
||||||
set f3 [packagetrace::overtype::left [string repeat { } 15] "VERSION"] |
|
||||||
set f4 [packagetrace::overtype::left [string repeat { } 12] "LOAD-ms"] |
|
||||||
set f5 [packagetrace::overtype::left [string repeat { } 10] "MODULE"] |
|
||||||
|
|
||||||
#puts -nonewline $::packagetrace::chan "-$f1$f1a$f2$f2a$f3$f4$f5\n" |
|
||||||
#packagetrace::emit "-$f1$f1a$f2$f2a$f3$f4$f5\n" |
|
||||||
puts -nonewline stderr "-$f1$f1a$f2$f2a$f3$f4$f5\n" |
|
||||||
unset f1 f1a f2 f2a f3 f4 f5 |
|
||||||
} else { |
|
||||||
puts stderr "packagetrace::init failed to rename $package_command" |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
#The preferred source of the ::overtype::<direction> functions is the 'overtype' package |
|
||||||
# - pasted here because packagetrace should have no extra dependencies. |
|
||||||
# - overtype package has better support for ansi and supports wide chars |
|
||||||
namespace eval packagetrace::overtype {set version INLINE} |
|
||||||
|
|
||||||
namespace eval packagetrace::overtype { |
|
||||||
proc left {args} { |
|
||||||
# @c overtype starting at left (overstrike) |
|
||||||
# @c can/should we use something like this?: 'format "%-*s" $len $overtext |
|
||||||
|
|
||||||
if {[llength $args] < 2} { |
|
||||||
error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} |
|
||||||
} |
|
||||||
foreach {undertext overtext} [lrange $args end-1 end] break |
|
||||||
|
|
||||||
set opt(-ellipsis) 0 |
|
||||||
set opt(-ellipsistext) {...} |
|
||||||
set opt(-overflow) 0 |
|
||||||
array set opt [lrange $args 0 end-2] |
|
||||||
|
|
||||||
|
|
||||||
set len [string length $undertext] |
|
||||||
set overlen [string length $overtext] |
|
||||||
set diff [expr {$overlen - $len}] |
|
||||||
if {$diff > 0} { |
|
||||||
if {$opt(-overflow)} { |
|
||||||
return $overtext |
|
||||||
} else { |
|
||||||
if {$opt(-ellipsis)} { |
|
||||||
return [right [string range $overtext 0 [expr {$len -1}]] $opt(-ellipsistext)] |
|
||||||
} else { |
|
||||||
return [string range $overtext 0 [expr {$len -1}]] |
|
||||||
} |
|
||||||
} |
|
||||||
} else { |
|
||||||
|
|
||||||
return "$overtext[string range $undertext $overlen end]" |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
proc centre {args} { |
|
||||||
if {[llength $args] < 2} { |
|
||||||
error {usage: ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} |
|
||||||
} |
|
||||||
foreach {undertext overtext} [lrange $args end-1 end] break |
|
||||||
|
|
||||||
set opt(-bias) left |
|
||||||
set opt(-overflow) 0 |
|
||||||
array set opt [lrange $args 0 end-2] |
|
||||||
|
|
||||||
|
|
||||||
set olen [string length $overtext] |
|
||||||
set ulen [string length $undertext] |
|
||||||
set diff [expr {$ulen - $olen}] |
|
||||||
if {$diff > 0} { |
|
||||||
set half [expr {round(int($diff / 2))}] |
|
||||||
if {[string match right $opt(-bias)]} { |
|
||||||
if {[expr {2 * $half}] < $diff} { |
|
||||||
incr half |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
set rhs [expr {$diff - $half - 1}] |
|
||||||
set lhs [expr {$half - 1}] |
|
||||||
|
|
||||||
set a [string range $undertext 0 $lhs] |
|
||||||
set b $overtext |
|
||||||
set c [string range $undertext end-$rhs end] |
|
||||||
return $a$b$c |
|
||||||
} else { |
|
||||||
if {$diff < 0} { |
|
||||||
if {$opt(-overflow)} { |
|
||||||
return $overtext |
|
||||||
} else { |
|
||||||
return [string range $overtext 0 [expr {$ulen - 1}]] |
|
||||||
} |
|
||||||
} else { |
|
||||||
return $overtext |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
proc right {args} { |
|
||||||
if {[llength $args] < 2} { |
|
||||||
error {usage: ?-overflow [1|0]? undertext overtext} |
|
||||||
} |
|
||||||
lassign [lrange $args end-1 end] undertext overtext |
|
||||||
|
|
||||||
set opt(-overflow) 0 |
|
||||||
array set opt [lrange $args 0 end-2] |
|
||||||
|
|
||||||
set olen [string length $overtext] |
|
||||||
set ulen [string length $undertext] |
|
||||||
|
|
||||||
if {$opt(-overflow)} { |
|
||||||
return [string range $undertext 0 end-$olen]$overtext |
|
||||||
} else { |
|
||||||
if {$olen > $ulen} { |
|
||||||
set diff [expr {$olen - $ulen}] |
|
||||||
return [string range $undertext 0 end-$olen][string range $overtext 0 end-$diff] |
|
||||||
} else { |
|
||||||
return [string range $undertext 0 end-$olen]$overtext |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
proc packagetrace::deinit {} { |
|
||||||
packagetrace::disable |
|
||||||
#namespace delete packagetrace |
|
||||||
#package forget packagetrace |
|
||||||
} |
|
||||||
proc packagetrace::disable {} { |
|
||||||
::commandstack::remove_rename {::tcl_findLibrary packagetrace} |
|
||||||
::commandstack::remove_rename {::package packagetrace} |
|
||||||
} |
|
||||||
proc packagetrace::enable {} { |
|
||||||
#init doesn't clear state - so this is effectively an alias |
|
||||||
tailcall packagetrace::init |
|
||||||
} |
|
||||||
|
|
||||||
#clear state - reset to defaults |
|
||||||
proc packagetrace::clear {} { |
|
||||||
variable chan |
|
||||||
set chan stderr |
|
||||||
variable showpresent |
|
||||||
set showpresent 1 |
|
||||||
} |
|
||||||
|
|
||||||
package provide packagetrace [namespace eval packagetrace { |
|
||||||
set version 0.8 |
|
||||||
}] |
|
||||||
|
|
||||||
|
|
||||||
@ -0,0 +1,245 @@ |
|||||||
|
# uuid.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||||
|
# |
||||||
|
# UUIDs are 128 bit values that attempt to be unique in time and space. |
||||||
|
# |
||||||
|
# Reference: |
||||||
|
# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt |
||||||
|
# |
||||||
|
# uuid: scheme: |
||||||
|
# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html |
||||||
|
# |
||||||
|
# Usage: uuid::uuid generate |
||||||
|
# uuid::uuid equal $idA $idB |
||||||
|
|
||||||
|
package require Tcl 8.5 9 |
||||||
|
|
||||||
|
namespace eval uuid { |
||||||
|
variable accel |
||||||
|
array set accel {critcl 0} |
||||||
|
|
||||||
|
namespace export uuid |
||||||
|
|
||||||
|
variable uid |
||||||
|
if {![info exists uid]} { |
||||||
|
set uid 1 |
||||||
|
} |
||||||
|
|
||||||
|
proc K {a b} {set a} |
||||||
|
} |
||||||
|
|
||||||
|
### |
||||||
|
# Optimization |
||||||
|
# Caches machine info after the first pass |
||||||
|
### |
||||||
|
|
||||||
|
proc ::uuid::generate_tcl_machinfo {} { |
||||||
|
variable machinfo |
||||||
|
if {[info exists machinfo]} { |
||||||
|
return $machinfo |
||||||
|
} |
||||||
|
lappend machinfo [clock seconds]; # timestamp |
||||||
|
lappend machinfo [clock clicks]; # system incrementing counter |
||||||
|
lappend machinfo [info hostname]; # spatial unique id (poor) |
||||||
|
lappend machinfo [pid]; # additional entropy |
||||||
|
lappend machinfo [array get ::tcl_platform] |
||||||
|
|
||||||
|
### |
||||||
|
# If we have /dev/urandom just stream 128 bits from that |
||||||
|
### |
||||||
|
if {[file exists /dev/urandom]} { |
||||||
|
set fin [open /dev/urandom rb] |
||||||
|
binary scan [read $fin 128] H* machinfo |
||||||
|
close $fin |
||||||
|
} elseif {[catch {package require nettool}]} { |
||||||
|
# More spatial information -- better than hostname. |
||||||
|
# bug 1150714: opening a server socket may raise a warning messagebox |
||||||
|
# with WinXP firewall, using ipconfig will return all IP addresses |
||||||
|
# including ipv6 ones if available. ipconfig is OK on win98+ |
||||||
|
if {[string equal $::tcl_platform(platform) "windows"]} { |
||||||
|
catch {exec ipconfig} config |
||||||
|
lappend machinfo $config |
||||||
|
} else { |
||||||
|
catch { |
||||||
|
set s [socket -server void -myaddr [info hostname] 0] |
||||||
|
K [fconfigure $s -sockname] [close $s] |
||||||
|
} r |
||||||
|
lappend machinfo $r |
||||||
|
} |
||||||
|
|
||||||
|
if {[package provide Tk] != {}} { |
||||||
|
lappend machinfo [winfo pointerxy .] |
||||||
|
lappend machinfo [winfo id .] |
||||||
|
} |
||||||
|
} else { |
||||||
|
### |
||||||
|
# If the nettool package works on this platform |
||||||
|
# use the stream of hardware ids from it |
||||||
|
### |
||||||
|
lappend machinfo {*}[::nettool::hwid_list] |
||||||
|
} |
||||||
|
return $machinfo |
||||||
|
} |
||||||
|
|
||||||
|
# Generates a binary UUID as per the draft spec. We generate a pseudo-random |
||||||
|
# type uuid (type 4). See section 3.4 |
||||||
|
# |
||||||
|
proc ::uuid::generate_tcl {} { |
||||||
|
package require md5 2 |
||||||
|
variable uid |
||||||
|
|
||||||
|
set tok [md5::MD5Init] |
||||||
|
md5::MD5Update $tok [incr uid]; # package incrementing counter |
||||||
|
foreach string [generate_tcl_machinfo] { |
||||||
|
md5::MD5Update $tok $string |
||||||
|
} |
||||||
|
set r [md5::MD5Final $tok] |
||||||
|
binary scan $r c* r |
||||||
|
|
||||||
|
# 3.4: set uuid versioning fields |
||||||
|
lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}] |
||||||
|
lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}] |
||||||
|
|
||||||
|
return [binary format c* $r] |
||||||
|
} |
||||||
|
|
||||||
|
if {[string equal $tcl_platform(platform) "windows"] |
||||||
|
&& [package provide critcl] != {}} { |
||||||
|
namespace eval uuid { |
||||||
|
critcl::ccode { |
||||||
|
#define WIN32_LEAN_AND_MEAN |
||||||
|
#define STRICT |
||||||
|
#include <windows.h> |
||||||
|
#include <ole2.h> |
||||||
|
typedef long (__stdcall *LPFNUUIDCREATE)(UUID *); |
||||||
|
typedef const unsigned char cu_char; |
||||||
|
} |
||||||
|
critcl::cproc generate_c {Tcl_Interp* interp} ok { |
||||||
|
HRESULT hr = S_OK; |
||||||
|
int r = TCL_OK; |
||||||
|
UUID uuid = {0}; |
||||||
|
HMODULE hLib; |
||||||
|
LPFNUUIDCREATE lpfnUuidCreate = NULL; |
||||||
|
hLib = LoadLibraryA(("rpcrt4.dll")); |
||||||
|
if (hLib) |
||||||
|
lpfnUuidCreate = (LPFNUUIDCREATE) |
||||||
|
GetProcAddress(hLib, "UuidCreate"); |
||||||
|
if (lpfnUuidCreate) { |
||||||
|
Tcl_Obj *obj; |
||||||
|
lpfnUuidCreate(&uuid); |
||||||
|
obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid)); |
||||||
|
Tcl_SetObjResult(interp, obj); |
||||||
|
} else { |
||||||
|
Tcl_SetResult(interp, "error: failed to create a guid", |
||||||
|
TCL_STATIC); |
||||||
|
r = TCL_ERROR; |
||||||
|
} |
||||||
|
return r; |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Convert a binary uuid into its string representation. |
||||||
|
# |
||||||
|
proc ::uuid::tostring {uuid} { |
||||||
|
binary scan $uuid H* s |
||||||
|
foreach {a b} {0 7 8 11 12 15 16 19 20 end} { |
||||||
|
append r [string range $s $a $b] - |
||||||
|
} |
||||||
|
return [string tolower [string trimright $r -]] |
||||||
|
} |
||||||
|
|
||||||
|
# Convert a string representation of a uuid into its binary format. |
||||||
|
# |
||||||
|
proc ::uuid::fromstring {uuid} { |
||||||
|
return [binary format H* [string map {- {}} $uuid]] |
||||||
|
} |
||||||
|
|
||||||
|
# Compare two uuids for equality. |
||||||
|
# |
||||||
|
proc ::uuid::equal {left right} { |
||||||
|
set l [fromstring $left] |
||||||
|
set r [fromstring $right] |
||||||
|
return [string equal $l $r] |
||||||
|
} |
||||||
|
|
||||||
|
# Call our generate uuid implementation |
||||||
|
proc ::uuid::generate {} { |
||||||
|
variable accel |
||||||
|
if {$accel(critcl)} { |
||||||
|
return [generate_c] |
||||||
|
} else { |
||||||
|
return [generate_tcl] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# uuid generate -> string rep of a new uuid |
||||||
|
# uuid equal uuid1 uuid2 |
||||||
|
# |
||||||
|
proc uuid::uuid {cmd args} { |
||||||
|
switch -exact -- $cmd { |
||||||
|
generate { |
||||||
|
if {[llength $args] != 0} { |
||||||
|
return -code error "wrong # args:\ |
||||||
|
should be \"uuid generate\"" |
||||||
|
} |
||||||
|
return [tostring [generate]] |
||||||
|
} |
||||||
|
equal { |
||||||
|
if {[llength $args] != 2} { |
||||||
|
return -code error "wrong \# args:\ |
||||||
|
should be \"uuid equal uuid1 uuid2\"" |
||||||
|
} |
||||||
|
return [eval [linsert $args 0 equal]] |
||||||
|
} |
||||||
|
default { |
||||||
|
return -code error "bad option \"$cmd\":\ |
||||||
|
must be generate or equal" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
# LoadAccelerator -- |
||||||
|
# |
||||||
|
# This package can make use of a number of compiled extensions to |
||||||
|
# accelerate the digest computation. This procedure manages the |
||||||
|
# use of these extensions within the package. During normal usage |
||||||
|
# this should not be called, but the test package manipulates the |
||||||
|
# list of enabled accelerators. |
||||||
|
# |
||||||
|
proc ::uuid::LoadAccelerator {name} { |
||||||
|
variable accel |
||||||
|
set r 0 |
||||||
|
switch -exact -- $name { |
||||||
|
critcl { |
||||||
|
if {![catch {package require tcllibc}]} { |
||||||
|
set r [expr {[info commands ::uuid::generate_c] != {}}] |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
return -code error "invalid accelerator package:\ |
||||||
|
must be one of [join [array names accel] {, }]" |
||||||
|
} |
||||||
|
} |
||||||
|
set accel($name) $r |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
# Try and load a compiled extension to help. |
||||||
|
namespace eval ::uuid { |
||||||
|
variable e {} |
||||||
|
foreach e {critcl} { |
||||||
|
if {[LoadAccelerator $e]} break |
||||||
|
} |
||||||
|
unset e |
||||||
|
} |
||||||
|
|
||||||
|
package provide uuid 1.0.9 |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
# Local variables: |
||||||
|
# mode: tcl |
||||||
|
# indent-tabs-mode: nil |
||||||
|
# End: |
||||||
Binary file not shown.
@ -0,0 +1,245 @@ |
|||||||
|
# uuid.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||||
|
# |
||||||
|
# UUIDs are 128 bit values that attempt to be unique in time and space. |
||||||
|
# |
||||||
|
# Reference: |
||||||
|
# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt |
||||||
|
# |
||||||
|
# uuid: scheme: |
||||||
|
# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html |
||||||
|
# |
||||||
|
# Usage: uuid::uuid generate |
||||||
|
# uuid::uuid equal $idA $idB |
||||||
|
|
||||||
|
package require Tcl 8.5 9 |
||||||
|
|
||||||
|
namespace eval uuid { |
||||||
|
variable accel |
||||||
|
array set accel {critcl 0} |
||||||
|
|
||||||
|
namespace export uuid |
||||||
|
|
||||||
|
variable uid |
||||||
|
if {![info exists uid]} { |
||||||
|
set uid 1 |
||||||
|
} |
||||||
|
|
||||||
|
proc K {a b} {set a} |
||||||
|
} |
||||||
|
|
||||||
|
### |
||||||
|
# Optimization |
||||||
|
# Caches machine info after the first pass |
||||||
|
### |
||||||
|
|
||||||
|
proc ::uuid::generate_tcl_machinfo {} { |
||||||
|
variable machinfo |
||||||
|
if {[info exists machinfo]} { |
||||||
|
return $machinfo |
||||||
|
} |
||||||
|
lappend machinfo [clock seconds]; # timestamp |
||||||
|
lappend machinfo [clock clicks]; # system incrementing counter |
||||||
|
lappend machinfo [info hostname]; # spatial unique id (poor) |
||||||
|
lappend machinfo [pid]; # additional entropy |
||||||
|
lappend machinfo [array get ::tcl_platform] |
||||||
|
|
||||||
|
### |
||||||
|
# If we have /dev/urandom just stream 128 bits from that |
||||||
|
### |
||||||
|
if {[file exists /dev/urandom]} { |
||||||
|
set fin [open /dev/urandom rb] |
||||||
|
binary scan [read $fin 128] H* machinfo |
||||||
|
close $fin |
||||||
|
} elseif {[catch {package require nettool}]} { |
||||||
|
# More spatial information -- better than hostname. |
||||||
|
# bug 1150714: opening a server socket may raise a warning messagebox |
||||||
|
# with WinXP firewall, using ipconfig will return all IP addresses |
||||||
|
# including ipv6 ones if available. ipconfig is OK on win98+ |
||||||
|
if {[string equal $::tcl_platform(platform) "windows"]} { |
||||||
|
catch {exec ipconfig} config |
||||||
|
lappend machinfo $config |
||||||
|
} else { |
||||||
|
catch { |
||||||
|
set s [socket -server void -myaddr [info hostname] 0] |
||||||
|
K [fconfigure $s -sockname] [close $s] |
||||||
|
} r |
||||||
|
lappend machinfo $r |
||||||
|
} |
||||||
|
|
||||||
|
if {[package provide Tk] != {}} { |
||||||
|
lappend machinfo [winfo pointerxy .] |
||||||
|
lappend machinfo [winfo id .] |
||||||
|
} |
||||||
|
} else { |
||||||
|
### |
||||||
|
# If the nettool package works on this platform |
||||||
|
# use the stream of hardware ids from it |
||||||
|
### |
||||||
|
lappend machinfo {*}[::nettool::hwid_list] |
||||||
|
} |
||||||
|
return $machinfo |
||||||
|
} |
||||||
|
|
||||||
|
# Generates a binary UUID as per the draft spec. We generate a pseudo-random |
||||||
|
# type uuid (type 4). See section 3.4 |
||||||
|
# |
||||||
|
proc ::uuid::generate_tcl {} { |
||||||
|
package require md5 2 |
||||||
|
variable uid |
||||||
|
|
||||||
|
set tok [md5::MD5Init] |
||||||
|
md5::MD5Update $tok [incr uid]; # package incrementing counter |
||||||
|
foreach string [generate_tcl_machinfo] { |
||||||
|
md5::MD5Update $tok $string |
||||||
|
} |
||||||
|
set r [md5::MD5Final $tok] |
||||||
|
binary scan $r c* r |
||||||
|
|
||||||
|
# 3.4: set uuid versioning fields |
||||||
|
lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}] |
||||||
|
lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}] |
||||||
|
|
||||||
|
return [binary format c* $r] |
||||||
|
} |
||||||
|
|
||||||
|
if {[string equal $tcl_platform(platform) "windows"] |
||||||
|
&& [package provide critcl] != {}} { |
||||||
|
namespace eval uuid { |
||||||
|
critcl::ccode { |
||||||
|
#define WIN32_LEAN_AND_MEAN |
||||||
|
#define STRICT |
||||||
|
#include <windows.h> |
||||||
|
#include <ole2.h> |
||||||
|
typedef long (__stdcall *LPFNUUIDCREATE)(UUID *); |
||||||
|
typedef const unsigned char cu_char; |
||||||
|
} |
||||||
|
critcl::cproc generate_c {Tcl_Interp* interp} ok { |
||||||
|
HRESULT hr = S_OK; |
||||||
|
int r = TCL_OK; |
||||||
|
UUID uuid = {0}; |
||||||
|
HMODULE hLib; |
||||||
|
LPFNUUIDCREATE lpfnUuidCreate = NULL; |
||||||
|
hLib = LoadLibraryA(("rpcrt4.dll")); |
||||||
|
if (hLib) |
||||||
|
lpfnUuidCreate = (LPFNUUIDCREATE) |
||||||
|
GetProcAddress(hLib, "UuidCreate"); |
||||||
|
if (lpfnUuidCreate) { |
||||||
|
Tcl_Obj *obj; |
||||||
|
lpfnUuidCreate(&uuid); |
||||||
|
obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid)); |
||||||
|
Tcl_SetObjResult(interp, obj); |
||||||
|
} else { |
||||||
|
Tcl_SetResult(interp, "error: failed to create a guid", |
||||||
|
TCL_STATIC); |
||||||
|
r = TCL_ERROR; |
||||||
|
} |
||||||
|
return r; |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Convert a binary uuid into its string representation. |
||||||
|
# |
||||||
|
proc ::uuid::tostring {uuid} { |
||||||
|
binary scan $uuid H* s |
||||||
|
foreach {a b} {0 7 8 11 12 15 16 19 20 end} { |
||||||
|
append r [string range $s $a $b] - |
||||||
|
} |
||||||
|
return [string tolower [string trimright $r -]] |
||||||
|
} |
||||||
|
|
||||||
|
# Convert a string representation of a uuid into its binary format. |
||||||
|
# |
||||||
|
proc ::uuid::fromstring {uuid} { |
||||||
|
return [binary format H* [string map {- {}} $uuid]] |
||||||
|
} |
||||||
|
|
||||||
|
# Compare two uuids for equality. |
||||||
|
# |
||||||
|
proc ::uuid::equal {left right} { |
||||||
|
set l [fromstring $left] |
||||||
|
set r [fromstring $right] |
||||||
|
return [string equal $l $r] |
||||||
|
} |
||||||
|
|
||||||
|
# Call our generate uuid implementation |
||||||
|
proc ::uuid::generate {} { |
||||||
|
variable accel |
||||||
|
if {$accel(critcl)} { |
||||||
|
return [generate_c] |
||||||
|
} else { |
||||||
|
return [generate_tcl] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# uuid generate -> string rep of a new uuid |
||||||
|
# uuid equal uuid1 uuid2 |
||||||
|
# |
||||||
|
proc uuid::uuid {cmd args} { |
||||||
|
switch -exact -- $cmd { |
||||||
|
generate { |
||||||
|
if {[llength $args] != 0} { |
||||||
|
return -code error "wrong # args:\ |
||||||
|
should be \"uuid generate\"" |
||||||
|
} |
||||||
|
return [tostring [generate]] |
||||||
|
} |
||||||
|
equal { |
||||||
|
if {[llength $args] != 2} { |
||||||
|
return -code error "wrong \# args:\ |
||||||
|
should be \"uuid equal uuid1 uuid2\"" |
||||||
|
} |
||||||
|
return [eval [linsert $args 0 equal]] |
||||||
|
} |
||||||
|
default { |
||||||
|
return -code error "bad option \"$cmd\":\ |
||||||
|
must be generate or equal" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
# LoadAccelerator -- |
||||||
|
# |
||||||
|
# This package can make use of a number of compiled extensions to |
||||||
|
# accelerate the digest computation. This procedure manages the |
||||||
|
# use of these extensions within the package. During normal usage |
||||||
|
# this should not be called, but the test package manipulates the |
||||||
|
# list of enabled accelerators. |
||||||
|
# |
||||||
|
proc ::uuid::LoadAccelerator {name} { |
||||||
|
variable accel |
||||||
|
set r 0 |
||||||
|
switch -exact -- $name { |
||||||
|
critcl { |
||||||
|
if {![catch {package require tcllibc}]} { |
||||||
|
set r [expr {[info commands ::uuid::generate_c] != {}}] |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
return -code error "invalid accelerator package:\ |
||||||
|
must be one of [join [array names accel] {, }]" |
||||||
|
} |
||||||
|
} |
||||||
|
set accel($name) $r |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
# Try and load a compiled extension to help. |
||||||
|
namespace eval ::uuid { |
||||||
|
variable e {} |
||||||
|
foreach e {critcl} { |
||||||
|
if {[LoadAccelerator $e]} break |
||||||
|
} |
||||||
|
unset e |
||||||
|
} |
||||||
|
|
||||||
|
package provide uuid 1.0.9 |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
# Local variables: |
||||||
|
# mode: tcl |
||||||
|
# indent-tabs-mode: nil |
||||||
|
# End: |
||||||
Binary file not shown.
Loading…
Reference in new issue