78 changed files with 4432 additions and 1179 deletions
Binary file not shown.
Binary file not shown.
Binary file not shown.
@ -0,0 +1,643 @@ |
|||||||
|
|
||||||
|
|
||||||
|
#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 $req] ;#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.9 |
||||||
|
}] |
||||||
|
|
||||||
|
|
||||||
@ -0,0 +1,643 @@ |
|||||||
|
|
||||||
|
|
||||||
|
#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 $req] ;#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.9 |
||||||
|
}] |
||||||
|
|
||||||
|
|
||||||
Binary file not shown.
Loading…
Reference in new issue