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