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