3432 changed files with 1128786 additions and 76753 deletions
@ -1,385 +0,0 @@
|
||||
|
||||
|
||||
#JMN 2005 - Public Domain |
||||
# |
||||
#WARNING: This package does 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. |
||||
|
||||
package provide packageTrace [namespace eval packageTrace { |
||||
variable chan stderr |
||||
variable showpresent 1 |
||||
set version 0.5 |
||||
}] |
||||
|
||||
proc packageTrace::help {} { |
||||
return { |
||||
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.) |
||||
set packageTrace::chan to desired output channel. (default stderr) |
||||
|
||||
set packageTrace::showpresent 0 to skip <present/> output |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
#The preferred source of the ::overtype::<direction> functions is the 'overtype' package: http://mini.net/tcl/overtype |
||||
# - pasted here because packageTrace should have no extra dependencies. |
||||
# |
||||
namespace eval packageTrace_overtype {set version INLINE} |
||||
proc packageTrace_overtype::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 [packageTrace_overtype::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 packageTrace_overtype::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 packageTrace_overtype::right {args} { |
||||
# @d !todo - implement overflow, length checks etc |
||||
|
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-overflow [1|0]? undertext overtext} |
||||
} |
||||
#foreach {undertext overtext} [lrange $args end-1 end] break |
||||
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 |
||||
} |
||||
} |
||||
} |
||||
|
||||
#convenience function in case the sequence 'package forget packageTrace;package require packageTrace' is too unintuitive or weird. |
||||
proc ::packageTrace::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 ::packageTrace::init {} { |
||||
uplevel 1 { |
||||
set ::packageTrace::level -1 |
||||
if {![llength [info commands tcl_findLibrary]]} { |
||||
eval $::auto_index(tcl_findLibrary) |
||||
} |
||||
package require commandstack |
||||
|
||||
|
||||
#rename tcl_findLibrary _tcl_findLibrary |
||||
set stackrecord [commandstack::rename_command tcl_findLibrary packageTrace] |
||||
set old_tcl_findLibrary [dict get $stackrecord implementation] |
||||
#set old_tcl_findLibrary [::commandstack::get_next_command package packageTrace] |
||||
|
||||
proc tcl_findLibrary [info args $old_tcl_findLibrary] { |
||||
set original [::commandstack::get_next_command tcl_findLibrary packageTrace] |
||||
|
||||
set marg [string repeat { } $::packageTrace::level] |
||||
|
||||
puts -nonewline $::packageTrace::chan "${marg}<extra> tcl_findLibrary $basename $version $patch $initScript $enVarName $varName </extra>\n" |
||||
uplevel 1 [list $original $basename $version $patch $initScript $enVarName $varName] |
||||
} |
||||
|
||||
|
||||
|
||||
set stackrecord [commandstack::rename_command package packageTrace] |
||||
set stored_target [dict get $stackrecord implementation] |
||||
set next_target [::commandstack::get_next_command package packageTrace] |
||||
if {$stored_target ne $next_target} { |
||||
error "(packageTrace::init) something went wrong renaming command 'package'" |
||||
} |
||||
|
||||
|
||||
|
||||
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 { } 13] "VERSION"] |
||||
set f4 [packageTrace_overtype::left [string repeat { } 10] "LOAD-ms"] |
||||
set f5 [packageTrace_overtype::left [string repeat { } 10] "MODULE"] |
||||
|
||||
puts -nonewline $::packageTrace::chan "-$f1$f1a$f2$f2a$f3$f4$f5\n" |
||||
unset f1 f1a f2 f2a f3 f4 f5 |
||||
|
||||
|
||||
proc package {sub args} [string map [list %next% $next_target] { |
||||
set ch $::packageTrace::chan |
||||
set next [::commandstack::get_next_command package packageTrace] |
||||
if {$next ne "%next%"} { |
||||
puts stderr "(packageTrace package) DEBUG - command changed since start: %next% 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 $sub {*}$args] |
||||
#} |
||||
|
||||
if {$sub eq "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 { } 13] ;#version col |
||||
set c4 [string repeat { } 10] ;#timing col |
||||
set c5 [string repeat { } 10] ;#module col |
||||
set c5a [string repeat { } 5] ;#close result tag col |
||||
|
||||
foreach a $args { |
||||
if {[string range $a 0 0] ne "-"} { |
||||
#assume 1st non-dashed argument is package name |
||||
set pkg $a |
||||
set pkg_ [lrange $args [lsearch $args $a] end] ;# e.g "Tcl 8.6" |
||||
break |
||||
} |
||||
} |
||||
|
||||
|
||||
incr ::packageTrace::level |
||||
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 "/> " |
||||
set f3 "" |
||||
set f4 "" |
||||
set f5 "" |
||||
puts -nonewline $ch $f1$c1a$f2$f2a$f3$f4$f5\n |
||||
} |
||||
} else { |
||||
set f1 [packageTrace_overtype::left $c1 "${marg}<require"] |
||||
set f2 [packageTrace_overtype::left -overflow 1 $c2 "p= \"$pkg_\""] ;#disallow truncation! |
||||
set f2a " > " |
||||
set f3 "" |
||||
set f4 "" |
||||
set f5 "" |
||||
puts -nonewline $ch $f1$c1a$f2$f2a$f3$f4$f5\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\""] |
||||
|
||||
set f4 [packageTrace_overtype::left $c4 "t= \"[lrange $t 0 1]\""] |
||||
|
||||
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 |
||||
|
||||
set scr [$next ifneeded $pkg $ver] |
||||
if {[string range [lindex $scr 1] 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 1]"] |
||||
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$f1a$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 |
||||
|
||||
|
||||
if {![string length $ver]} { |
||||
if {[lindex $args 0] eq "packageTrace"} { |
||||
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 |
||||
} elseif {[lsearch [list vcompare vsatisfies provide ifneeded] $sub] < 0} { |
||||
set ver [$next $sub {*}$args] |
||||
#puts -nonewline $ch " -- package $sub $args\n" |
||||
} else { |
||||
set ver [$next $sub {*}$args] |
||||
#puts $ch "*** here $sub $args" |
||||
} |
||||
return $ver |
||||
}] |
||||
} |
||||
} |
||||
proc packageTrace::deinit {} { |
||||
packageTrace::disable |
||||
#namespace delete packageTrace |
||||
#package forget packageTrace |
||||
} |
||||
proc packageTrace::disable {} { |
||||
::commandstack::remove_renaming_package tcl_findLibrary packageTrace |
||||
::commandstack::remove_renaming_package 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 |
||||
} |
||||
packageTrace::init |
||||
|
||||
|
||||
|
||||
@ -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_requirement $req-$req ;#translate to v-v normalised equiv of -exact |
||||
} else { |
||||
set reqs [list] |
||||
foreach req $v_requirements { |
||||
lappend reqs [::packagetrace::tm_version_required_canonical $v_requirement] ;#empty remains empty, v -> v-<majorv+1>, leading zeros stripped from all segments. |
||||
} |
||||
set v_requirements $reqs ;#each normalised |
||||
} |
||||
set pkg_ [lrange $args $argidx end] ;# raw e.g "Tcl 8.6" or "Tcl 8.5 9" |
||||
break |
||||
} else { |
||||
if {$a eq "-exact"} { |
||||
set is_exact 1 |
||||
} |
||||
} |
||||
incr argidx |
||||
} |
||||
|
||||
|
||||
incr ::packagetrace::level |
||||
if {$::packagetrace::level == 0} { |
||||
set packagetrace::output "" |
||||
} |
||||
|
||||
|
||||
set marg [string repeat { } $::packagetrace::level] |
||||
set margnext [string repeat { } [expr {$::packagetrace::level + 1}]] |
||||
|
||||
if {![catch {set ver [$next present {*}$args]}]} { |
||||
if {$::packagetrace::showpresent} { |
||||
#already loaded.. |
||||
set f1 [packagetrace::overtype::left $c1 "${marg}<present"] |
||||
set f2 [packagetrace::overtype::left -overflow 1 $c2 "p= \"$pkg_\""] ;#disallow truncation! |
||||
set f2a $c2a |
||||
set f3 [packagetrace::overtype::left $c3 "v= \"$ver\""] |
||||
set f4 $c4 |
||||
set f5 $c5 |
||||
set f5a "/> " |
||||
#puts -nonewline $ch $f1$c1a$f2$f2a$f3$f4$f5\n |
||||
packagetrace::emit $f1$c1a$f2$f2a$f3$f4$f5$f5a\n |
||||
} |
||||
} else { |
||||
set f1 [packagetrace::overtype::left $c1 "${marg}<require"] |
||||
set f2 [packagetrace::overtype::left -overflow 1 $c2 "p= \"$pkg_\""] ;#disallow truncation! |
||||
set f2a $c2a |
||||
set f3 $c3 |
||||
set f4 $c4 |
||||
set f5 $c5 |
||||
set f5a " > " |
||||
#puts -nonewline $ch $f1$c1a$f2$f2a$f3$f4$f5\n |
||||
packagetrace::emit $f1$c1a$f2$f2a$f3$f4$f5$f5a\n |
||||
|
||||
set errMsg "" |
||||
#set t0 [clock clicks -milliseconds] |
||||
set t0 [clock microseconds] |
||||
|
||||
if {[catch {set ver [$next require {*}$args]} errMsg]} { |
||||
set ver "" |
||||
# |
||||
#NOTE error must be raised at some point - see below |
||||
} |
||||
#set t [expr {[clock clicks -millisec]-$t0}] |
||||
set t [expr {([clock microseconds]-$t0)/1000.0}] |
||||
|
||||
|
||||
|
||||
|
||||
#jmn |
||||
set f1 [packagetrace::overtype::left $c1 "${margnext}<info "] |
||||
#set f1a "<info " |
||||
set f1a "" |
||||
|
||||
set f2 [packagetrace::overtype::left -ellipsis 1 [string range $c2 0 end-1] "x= \"$args"] |
||||
if {[string length [string trimright $f2]] <= [expr [string length $c2]-1]} { |
||||
#right-trimmed value shorter than field.. therefore we need to close attribute |
||||
set f2 [packagetrace::overtype::left $c2 [string trimright $f2]\"] |
||||
} |
||||
|
||||
#we use the attributename x because this is not necessarily the same as p! may be truncated. |
||||
|
||||
set f3 [packagetrace::overtype::left $c3 "v= \"$ver\""] |
||||
|
||||
#truncate time to c4 width - possibly losing some precision. If truncated - add closing double quote. |
||||
set f4 [packagetrace::overtype::left -overflow 1 $c4 "t= \"[lrange $t 0 1]\""] |
||||
if {[string length [string trimright $f4]] > [expr {[string length $c4]}]} { |
||||
set f4 "[packagetrace::overtype::left [string range $c4 0 end-1] [string trimright $f4]]\"" |
||||
} |
||||
|
||||
if {[string length $ver]} { |
||||
set num "" |
||||
foreach c [split $ver ""] { |
||||
if {[string is digit $c] || $c eq "."} { |
||||
append num $c |
||||
} else { |
||||
break |
||||
} |
||||
} |
||||
set ver $num |
||||
|
||||
#review - scr not guaranteed to be valid tcl list - should parse properly? |
||||
set scr [$next ifneeded $pkg $ver] |
||||
if {[string range $scr end-2 end] ne ".tm"} { |
||||
set f5 $c5 |
||||
} else { |
||||
#!todo - optionally output module path instead of boolean? |
||||
#set f5 [packagetrace::overtype::left -ellipsis 1 -ellipsistext ... [string range $c5 0 end-1] "tm= \"[lindex $scr end]"] |
||||
set f5 [packagetrace::overtype::left -ellipsis 1 -ellipsistext ... [string range $c5 0 end-1] "tm= \"1"] |
||||
if {[string length [string trimright $f5]] <= [expr [string length $c5]-1]} { |
||||
set f5 [packagetrace::overtype::left $c5 [string trimright $f5]\"] |
||||
} |
||||
} |
||||
} else { |
||||
set f5 $c5 |
||||
} |
||||
|
||||
set f5a [packagetrace::overtype::left $c5a "/>"] ;#end of <info |
||||
#puts -nonewline $ch "$f1$c1a$f2$c2a$f3$f4 $f5$f5a\n" |
||||
packagetrace::emit "$f1$c1a$f2$c2a$f3$f4 $f5$f5a\n" |
||||
|
||||
|
||||
set f1 [packagetrace::overtype::left $c1 "${marg}</require>"] |
||||
set f1a "" |
||||
set f2 "" |
||||
set c2a "" |
||||
set f3 "" |
||||
set f4 "" |
||||
set f5 "" |
||||
set f5a "" |
||||
#puts -nonewline $ch $f1$f1a$f2$c2a$f3$f4$f5$f5a\n |
||||
packagetrace::emit $f1$f1a$f2$c2a$f3$f4$f5$f5a\n |
||||
|
||||
|
||||
if {![string length $ver]} { |
||||
if {[lindex $args 0] eq "packagetrace"} { |
||||
#REVIEW - what is going on here? |
||||
namespace delete ::packagetrace::overtype |
||||
} |
||||
|
||||
#we must raise an error if original 'package require' would have |
||||
incr ::packagetrace::level -1 |
||||
error $errMsg |
||||
} |
||||
|
||||
} |
||||
incr ::packagetrace::level -1 |
||||
return $ver |
||||
} |
||||
vcompare - vsatisifies - provide - ifneeded { |
||||
set result [$next $subcommand {*}$args] |
||||
#puts -nonewline $ch " -- package $subcommand $args\n" |
||||
return $result |
||||
} |
||||
default { |
||||
set result [$next $subcommand {*}$args] |
||||
#puts $ch "*** here $subcommand $args" |
||||
return $result |
||||
} |
||||
} |
||||
|
||||
}] |
||||
if {[set stored_target [dict get $stackrecord implementation]] ne ""} { |
||||
puts stderr "packagetrace::init renamed $package_command to $stored_target and is providing an override" |
||||
set f1 [string repeat { } 30] |
||||
#set f1a " " |
||||
set f1a "" |
||||
set f2 [packagetrace::overtype::left [string repeat { } 20] "PACKAGE"] |
||||
set f2a " " |
||||
set f3 [packagetrace::overtype::left [string repeat { } 15] "VERSION"] |
||||
set f4 [packagetrace::overtype::left [string repeat { } 12] "LOAD-ms"] |
||||
set f5 [packagetrace::overtype::left [string repeat { } 10] "MODULE"] |
||||
|
||||
#puts -nonewline $::packagetrace::chan "-$f1$f1a$f2$f2a$f3$f4$f5\n" |
||||
#packagetrace::emit "-$f1$f1a$f2$f2a$f3$f4$f5\n" |
||||
puts -nonewline stderr "-$f1$f1a$f2$f2a$f3$f4$f5\n" |
||||
unset f1 f1a f2 f2a f3 f4 f5 |
||||
} else { |
||||
puts stderr "packagetrace::init failed to rename $package_command" |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
#The preferred source of the ::overtype::<direction> functions is the 'overtype' package |
||||
# - pasted here because packagetrace should have no extra dependencies. |
||||
# - overtype package has better support for ansi and supports wide chars |
||||
namespace eval packagetrace::overtype {set version INLINE} |
||||
|
||||
namespace eval packagetrace::overtype { |
||||
proc left {args} { |
||||
# @c overtype starting at left (overstrike) |
||||
# @c can/should we use something like this?: 'format "%-*s" $len $overtext |
||||
|
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} |
||||
} |
||||
foreach {undertext overtext} [lrange $args end-1 end] break |
||||
|
||||
set opt(-ellipsis) 0 |
||||
set opt(-ellipsistext) {...} |
||||
set opt(-overflow) 0 |
||||
array set opt [lrange $args 0 end-2] |
||||
|
||||
|
||||
set len [string length $undertext] |
||||
set overlen [string length $overtext] |
||||
set diff [expr {$overlen - $len}] |
||||
if {$diff > 0} { |
||||
if {$opt(-overflow)} { |
||||
return $overtext |
||||
} else { |
||||
if {$opt(-ellipsis)} { |
||||
return [right [string range $overtext 0 [expr {$len -1}]] $opt(-ellipsistext)] |
||||
} else { |
||||
return [string range $overtext 0 [expr {$len -1}]] |
||||
} |
||||
} |
||||
} else { |
||||
|
||||
return "$overtext[string range $undertext $overlen end]" |
||||
} |
||||
} |
||||
|
||||
proc centre {args} { |
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} |
||||
} |
||||
foreach {undertext overtext} [lrange $args end-1 end] break |
||||
|
||||
set opt(-bias) left |
||||
set opt(-overflow) 0 |
||||
array set opt [lrange $args 0 end-2] |
||||
|
||||
|
||||
set olen [string length $overtext] |
||||
set ulen [string length $undertext] |
||||
set diff [expr {$ulen - $olen}] |
||||
if {$diff > 0} { |
||||
set half [expr {round(int($diff / 2))}] |
||||
if {[string match right $opt(-bias)]} { |
||||
if {[expr {2 * $half}] < $diff} { |
||||
incr half |
||||
} |
||||
} |
||||
|
||||
set rhs [expr {$diff - $half - 1}] |
||||
set lhs [expr {$half - 1}] |
||||
|
||||
set a [string range $undertext 0 $lhs] |
||||
set b $overtext |
||||
set c [string range $undertext end-$rhs end] |
||||
return $a$b$c |
||||
} else { |
||||
if {$diff < 0} { |
||||
if {$opt(-overflow)} { |
||||
return $overtext |
||||
} else { |
||||
return [string range $overtext 0 [expr {$ulen - 1}]] |
||||
} |
||||
} else { |
||||
return $overtext |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc right {args} { |
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-overflow [1|0]? undertext overtext} |
||||
} |
||||
lassign [lrange $args end-1 end] undertext overtext |
||||
|
||||
set opt(-overflow) 0 |
||||
array set opt [lrange $args 0 end-2] |
||||
|
||||
set olen [string length $overtext] |
||||
set ulen [string length $undertext] |
||||
|
||||
if {$opt(-overflow)} { |
||||
return [string range $undertext 0 end-$olen]$overtext |
||||
} else { |
||||
if {$olen > $ulen} { |
||||
set diff [expr {$olen - $ulen}] |
||||
return [string range $undertext 0 end-$olen][string range $overtext 0 end-$diff] |
||||
} else { |
||||
return [string range $undertext 0 end-$olen]$overtext |
||||
} |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
proc packagetrace::deinit {} { |
||||
packagetrace::disable |
||||
#namespace delete packagetrace |
||||
#package forget packagetrace |
||||
} |
||||
proc packagetrace::disable {} { |
||||
::commandstack::remove_rename {::tcl_findLibrary packagetrace} |
||||
::commandstack::remove_rename {::package packagetrace} |
||||
} |
||||
proc packagetrace::enable {} { |
||||
#init doesn't clear state - so this is effectively an alias |
||||
tailcall packagetrace::init |
||||
} |
||||
|
||||
#clear state - reset to defaults |
||||
proc packagetrace::clear {} { |
||||
variable chan |
||||
set chan stderr |
||||
variable showpresent |
||||
set showpresent 1 |
||||
} |
||||
|
||||
package provide packagetrace [namespace eval packagetrace { |
||||
set version 0.8 |
||||
}] |
||||
|
||||
|
||||
@ -0,0 +1,801 @@
|
||||
#!/bin/sh |
||||
# -*- tcl -*- \ |
||||
exec tclsh "$0" ${1+"$@"} |
||||
package require Tcl 8.6 9 |
||||
unset -nocomplain ::errorInfo |
||||
set me [file normalize [info script]] |
||||
proc main {} { |
||||
global argv |
||||
if {![llength $argv]} { set argv help} |
||||
if {[catch { |
||||
eval _$argv |
||||
}]} usage |
||||
exit 0 |
||||
} |
||||
set packages { |
||||
{app-critcl {.. critcl critcl.tcl} critcl-app} |
||||
{critcl critcl.tcl} |
||||
{critcl-bitmap bitmap.tcl} |
||||
{critcl-class class.tcl} |
||||
{critcl-cutil cutil.tcl} |
||||
{critcl-emap emap.tcl} |
||||
{critcl-enum enum.tcl} |
||||
{critcl-iassoc iassoc.tcl} |
||||
{critcl-literals literals.tcl} |
||||
{critcl-platform platform.tcl} |
||||
{critcl-util util.tcl} |
||||
{stubs_container container.tcl} |
||||
{stubs_gen_decl gen_decl.tcl} |
||||
{stubs_gen_header gen_header.tcl} |
||||
{stubs_gen_init gen_init.tcl} |
||||
{stubs_gen_lib gen_lib.tcl} |
||||
{stubs_gen_macro gen_macro.tcl} |
||||
{stubs_gen_slot gen_slot.tcl} |
||||
{stubs_genframe genframe.tcl} |
||||
{stubs_reader reader.tcl} |
||||
{stubs_writer writer.tcl} |
||||
} |
||||
proc usage {{status 1}} { |
||||
global errorInfo |
||||
if {[info exists errorInfo] && ($errorInfo ne {}) && |
||||
![string match {invalid command name "_*"*} $errorInfo] |
||||
} { |
||||
puts stderr $::errorInfo |
||||
exit |
||||
} |
||||
|
||||
global argv0 |
||||
set prefix "Usage: " |
||||
foreach c [lsort -dict [info commands _*]] { |
||||
set c [string range $c 1 end] |
||||
if {[catch { |
||||
H${c} |
||||
} res]} { |
||||
puts stderr "$prefix[underlined]$argv0 $c[reset] args...\n" |
||||
} else { |
||||
puts stderr "$prefix[underlined]$argv0 $c[reset] $res\n" |
||||
} |
||||
set prefix " " |
||||
} |
||||
exit $status |
||||
} |
||||
|
||||
proc underlined {} { return "\033\[4m" } |
||||
proc reset {} { return "\033\[0m" } |
||||
|
||||
proc +x {path} { |
||||
catch { file attributes $path -permissions ugo+x } |
||||
return |
||||
} |
||||
proc critapp {dst} { |
||||
global tcl_platform |
||||
set app [file join $dst critcl] |
||||
if {$tcl_platform(platform) eq "windows"} { |
||||
append app .tcl |
||||
} |
||||
return $app |
||||
} |
||||
proc vfile {dir vfile} { |
||||
global me |
||||
set selfdir [file dirname $me] |
||||
eval [linsert $vfile 0 file join $selfdir lib $dir] |
||||
} |
||||
proc grep {file pattern} { |
||||
set lines [split [read [set chan [open $file r]]] \n] |
||||
close $chan |
||||
return [lsearch -all -inline -glob $lines $pattern] |
||||
} |
||||
proc version {file} { |
||||
set provisions [grep $file {*package provide*}] |
||||
#puts /$provisions/ |
||||
return [lindex $provisions 0 3] |
||||
} |
||||
proc tmpdir {} { |
||||
set tmpraw "critcl.[clock clicks]" |
||||
set tmpdir $tmpraw.[pid] |
||||
file delete -force $tmpdir |
||||
file mkdir $tmpdir |
||||
file delete -force $tmpraw |
||||
|
||||
puts "Assembly in: $tmpdir" |
||||
return $tmpdir |
||||
} |
||||
proc relativedir {dest here} { |
||||
# Convert dest into a relative path which is relative to `here`. |
||||
set save $dest |
||||
|
||||
#puts stderr [list relativedir $dest $label] |
||||
|
||||
set here [file split $here] |
||||
set dest [file split $dest] |
||||
|
||||
#puts stderr [list relativedir < $here] |
||||
#puts stderr [list relativedir > $dest] |
||||
|
||||
while {[string equal [lindex $dest 0] [lindex $here 0]]} { |
||||
set dest [lrange $dest 1 end] |
||||
set here [lrange $here 1 end] |
||||
if {[llength $dest] == 0} {break} |
||||
} |
||||
set ul [llength $dest] |
||||
set hl [llength $here] |
||||
|
||||
if {$ul == 0} { |
||||
set dest [lindex [file split $save] end] |
||||
} else { |
||||
while {$hl > 1} { |
||||
set dest [linsert $dest 0 ..] |
||||
incr hl -1 |
||||
} |
||||
set dest [eval file join $dest] |
||||
} |
||||
|
||||
#puts stderr [list relativedir --> $dest] |
||||
return $dest |
||||
} |
||||
proc id {cv vv} { |
||||
upvar 1 $cv commit $vv version |
||||
|
||||
set commit [exec git log -1 --pretty=format:%H] |
||||
set version [exec git describe] |
||||
|
||||
puts "Commit: $commit" |
||||
puts "Version: $version" |
||||
return |
||||
} |
||||
proc savedoc {tmpdir} { |
||||
puts {Collecting the documentation ...} |
||||
file copy -force [file join embedded www] [file join $tmpdir doc] |
||||
return |
||||
} |
||||
proc pkgdirname {name version} { |
||||
return $name-$version |
||||
} |
||||
proc placedoc {tmpdir} { |
||||
file delete -force doc |
||||
file copy -force [file join $tmpdir doc] doc |
||||
return |
||||
} |
||||
proc 2website {} { |
||||
puts {Switching to gh-pages...} |
||||
exec 2>@ stderr >@ stdout git checkout gh-pages |
||||
return |
||||
} |
||||
proc reminder {commit} { |
||||
puts "" |
||||
puts "We are in branch gh-pages now, coming from $commit" |
||||
puts "" |
||||
return |
||||
} |
||||
proc shquote value { |
||||
return "\"[string map [list \\ \\\\ $ \\$ ` \\`] $value]\"" |
||||
} |
||||
proc dest-dir {} { |
||||
global paths |
||||
if {![info exists paths(dest-dir)]} { |
||||
global env |
||||
if {[info exists env(DESTDIR)]} { |
||||
set paths(dest-dir) [string trimright $env(DESTDIR) /] |
||||
} else { |
||||
set paths(dest-dir) "" |
||||
} |
||||
} elseif {$paths(dest-dir) ne ""} { |
||||
set paths(dest-dir) [string trimright $paths(dest-dir) /] |
||||
} |
||||
return $paths(dest-dir) |
||||
} |
||||
proc prefix {} { |
||||
global paths |
||||
if {![info exists paths(prefix)]} { |
||||
set paths(prefix) [file dirname [file dirname [norm [info nameofexecutable]]]] |
||||
} |
||||
return $paths(prefix) |
||||
} |
||||
proc exec-prefix {} { |
||||
global paths |
||||
if {![info exists paths(exec-prefix)]} { |
||||
set paths(exec-prefix) [prefix] |
||||
} |
||||
return $paths(exec-prefix) |
||||
} |
||||
proc bin-dir {} { |
||||
global paths |
||||
if {![info exists paths(bin-dir)]} { |
||||
set paths(bin-dir) [exec-prefix]/bin |
||||
} |
||||
return $paths(bin-dir) |
||||
} |
||||
proc lib-dir {} { |
||||
global paths |
||||
if {![info exists paths(lib-dir)]} { |
||||
set paths(lib-dir) [exec-prefix]/lib |
||||
} |
||||
return $paths(lib-dir) |
||||
} |
||||
proc include-dir {} { |
||||
global paths |
||||
if {![info exists paths(include-dir)]} { |
||||
set paths(include-dir) [prefix]/include |
||||
} |
||||
return $paths(include-dir) |
||||
} |
||||
proc process-install-options {} { |
||||
upvar 1 args argv target target |
||||
while {[llength $argv]} { |
||||
set o [lindex $argv 0] |
||||
if {![string match -* $o]} break |
||||
switch -exact -- $o { |
||||
-target { |
||||
# ignore 0 |
||||
set target [lindex $argv 1] |
||||
set argv [lrange $argv 2 end] |
||||
} |
||||
--dest-dir - |
||||
--prefix - |
||||
--exec-prefix - |
||||
--bin-dir - |
||||
--lib-dir - |
||||
--include-dir { |
||||
# ignore 0 |
||||
set path [lindex $argv 1] |
||||
set argv [lrange $argv 2 end] |
||||
set key [string range $o 2 end] |
||||
global paths |
||||
set paths($key) [norm $path] |
||||
} |
||||
-- break |
||||
default { |
||||
puts [Hinstall] |
||||
exit 1 |
||||
} |
||||
} |
||||
} |
||||
return |
||||
} |
||||
proc norm {path} { |
||||
# normalize smybolic links in the path, including the last element. |
||||
return [file dirname [file normalize [file join $path ...]]] |
||||
} |
||||
proc query {q c} { |
||||
puts -nonewline "$q ? " |
||||
flush stdout |
||||
set a [string tolower [gets stdin]] |
||||
if {($a ne "y" ) && ($a ne "yes")} { |
||||
puts "$c" |
||||
exit 1 |
||||
} |
||||
} |
||||
proc thisexe {} { |
||||
return [info nameofexecutable] |
||||
} |
||||
proc wfile {path data} { |
||||
# Easier to write our own copy than requiring fileutil and then using fileutil::writeFile. |
||||
set fd [open $path w] |
||||
puts -nonewline $fd $data |
||||
close $fd |
||||
return |
||||
} |
||||
proc cat {path} { |
||||
# Easier to write our own copy than requiring fileutil and then using fileutil::cat. |
||||
set fd [open $path r] |
||||
set data [read $fd] |
||||
close $fd |
||||
return $data |
||||
} |
||||
proc Hsynopsis {} { return "\n\tGenerate a synopsis of procs and builtin types" } |
||||
proc _synopsis {} { |
||||
puts Public: |
||||
puts [exec grep -n ^proc lib/critcl/critcl.tcl \ |
||||
| sed -e "s| \{$||" -e {s/:proc ::critcl::/ /} \ |
||||
| grep -v { [A-Z]} \ |
||||
| grep -v { at::[A-Z]} \ |
||||
| sort -k 2 \ |
||||
| sed -e {s/^/ /}] |
||||
|
||||
puts Private: |
||||
puts [exec grep -n ^proc lib/critcl/critcl.tcl \ |
||||
| sed -e "s| \{$||" -e {s/:proc ::critcl::/ /} \ |
||||
| grep {[A-Z]} \ |
||||
| sort -k 2 \ |
||||
| sed -e {s/^/ /}] |
||||
|
||||
puts "Builtin argument types:" |
||||
puts [exec grep -n { argtype} lib/critcl/critcl.tcl \ |
||||
| grep -v "\\\$ntype" \ |
||||
| sed -e "s| \{$||" -e {s/:[ ]*argtype/ /} \ |
||||
| sort -k 2 \ |
||||
| sed -e {s/^/ /}] |
||||
|
||||
puts "Builtin result types:" |
||||
puts [exec grep -n { resulttype} lib/critcl/critcl.tcl \ |
||||
| sed -e "s| \{$||" -e {s/:[ ]*resulttype/ /} \ |
||||
| sort -k 2 \ |
||||
| sed -e {s/^/ /}] |
||||
|
||||
return |
||||
} |
||||
|
||||
proc Hhelp {} { return "\n\tPrint this help" } |
||||
proc _help {} { |
||||
usage 0 |
||||
return |
||||
} |
||||
proc Hrecipes {} { return "\n\tList all build commands, without details" } |
||||
proc _recipes {} { |
||||
set r {} |
||||
foreach c [info commands _*] { |
||||
lappend r [string range $c 1 end] |
||||
} |
||||
puts [lsort -dict $r] |
||||
return |
||||
} |
||||
proc Htest {} { return "\n\tRun the testsuite" } |
||||
proc _test {} { |
||||
global argv |
||||
set argv {} ;# clear -- tcltest shall see nothing |
||||
# Run all .test files in the test directory. |
||||
set selfdir [file dirname $::me] |
||||
foreach testsuite [lsort -dict [glob -directory [file join $selfdir test] *.test]] { |
||||
puts "" |
||||
puts "_ _ __ ___ _____ ________ _____________ _____________________ *** [file tail $testsuite] ***" |
||||
if {[catch { |
||||
exec >@ stdout 2>@ stderr [thisexe] $testsuite |
||||
}]} { |
||||
puts $::errorInfo |
||||
} |
||||
} |
||||
|
||||
puts "" |
||||
puts "_ _ __ ___ _____ ________ _____________ _____________________" |
||||
puts "" |
||||
return |
||||
} |
||||
proc Hdoc {} { return "\n\t(Re)Generate the embedded documentation" } |
||||
proc _doc {} { |
||||
cd [file join [file dirname $::me] doc] |
||||
|
||||
puts "Removing old documentation..." |
||||
file delete -force [file join .. embedded man] |
||||
file delete -force [file join .. embedded www] |
||||
file delete -force [file join .. embedded md] |
||||
|
||||
file mkdir [file join .. embedded man] |
||||
file mkdir [file join .. embedded www] |
||||
file mkdir [file join .. embedded md] |
||||
|
||||
puts "Generating man pages..." |
||||
exec 2>@ stderr >@ stdout dtplite -ext n -o [file join .. embedded man] nroff . |
||||
puts "Generating html..." |
||||
exec 2>@ stderr >@ stdout dtplite -o [file join .. embedded www] html . |
||||
puts "Generating markdown..." |
||||
exec 2>@ stderr >@ stdout dtplite -ext md -o [file join .. embedded md] markdown . |
||||
|
||||
cd [file join .. embedded man] |
||||
file delete -force .idxdoc .tocdoc |
||||
cd [file join .. www] |
||||
file delete -force .idxdoc .tocdoc |
||||
cd [file join .. md] |
||||
file delete -force .idxdoc .tocdoc |
||||
|
||||
return |
||||
} |
||||
proc Htextdoc {} { return "destination\n\tWrite plain text documentation to the specified directory" } |
||||
proc _textdoc {dst} { |
||||
set destination [file normalize $dst] |
||||
|
||||
cd [file join [file dirname $::me] doc] |
||||
|
||||
puts "Removing old text documentation at ${dst}..." |
||||
file delete -force $destination |
||||
|
||||
file mkdir $destination |
||||
|
||||
puts "Generating pages..." |
||||
exec 2>@ stderr >@ stdout dtplite -ext txt -o $destination text . |
||||
|
||||
cd $destination |
||||
file delete -force .idxdoc .tocdoc |
||||
|
||||
return |
||||
} |
||||
proc Hfigures {} { return "\n\t(Re)Generate the figures and diagrams for the documentation" } |
||||
proc _figures {} { |
||||
cd [file join [file dirname $::me] doc figures] |
||||
|
||||
puts "Generating (tklib) diagrams..." |
||||
eval [linsert [glob *.dia] 0 exec 2>@ stderr >@ stdout dia convert -t -o . png] |
||||
|
||||
return |
||||
} |
||||
proc Hrelease {} { return "\n\tGenerate a release from the current commit.\n\tAssumed to be properly tagged.\n\tLeaves checkout in the gh-pages branch, ready for commit+push" } |
||||
proc _release {} { |
||||
# # ## ### ##### ######## ############# |
||||
# Get scratchpad to assemble the release in. |
||||
# Get version and hash of the commit to be released. |
||||
|
||||
query "Have you run the tests" "Please do" |
||||
query "Have you run the examples" "Please do" |
||||
query "Have you bumped the version numbers" "Came back after doing so!" |
||||
|
||||
set tmpdir [tmpdir] |
||||
id commit version |
||||
|
||||
savedoc $tmpdir |
||||
|
||||
# # ## ### ##### ######## ############# |
||||
#puts {Generate starkit...} |
||||
#_starkit [file join $tmpdir critcl31.kit] |
||||
|
||||
# # ## ### ##### ######## ############# |
||||
#puts {Collecting starpack prefix...} |
||||
# which we use the existing starpack for, from the gh-pages branch |
||||
|
||||
#exec 2>@ stderr >@ stdout git checkout gh-pages |
||||
#file copy [file join download critcl31.exe] [file join $tmpdir prefix.exe] |
||||
#exec 2>@ stderr >@ stdout git checkout $commit |
||||
|
||||
# # ## ### ##### ######## ############# |
||||
#puts {Generate starpack...} |
||||
#_starpack [file join $tmpdir prefix.exe] [file join $tmpdir critcl31.exe] |
||||
# TODO: vacuum the thing. fix permissions if so. |
||||
|
||||
# # ## ### ##### ######## ############# |
||||
2website |
||||
placedoc $tmpdir |
||||
|
||||
#file copy -force [file join $tmpdir critcl31.kit] [file join download critcl31.kit] |
||||
#file copy -force [file join $tmpdir critcl31.exe] [file join download critcl31.exe] |
||||
|
||||
set index [cat index.html] |
||||
set pattern "\\\[commit .*\\\] \\(v\[^)\]*\\)<!-- current" |
||||
set replacement "\[commit $commit\] (v$version)<!-- current" |
||||
regsub $pattern $index $replacement index |
||||
wfile index.html $index |
||||
|
||||
# # ## ### ##### ######## ############# |
||||
reminder $commit |
||||
|
||||
# # ## ### ##### ######## ############# |
||||
return |
||||
} |
||||
proc Hrelease-doc {} { return "\n\tUpdate the release documentation from the current commit.\n\tAssumed to be properly tagged.\n\tLeaves the checkout in the gh-pages branch, ready for commit+push" } |
||||
proc _release-doc {} { |
||||
# # ## ### ##### ######## ############# |
||||
# Get scratchpad to assemble the release in. |
||||
# Get version and hash of the commit to be released. |
||||
|
||||
set tmpdir [tmpdir] |
||||
id _ commit ; # Just for the printout, we are actually not using the data. |
||||
|
||||
savedoc $tmpdir |
||||
2website |
||||
placedoc $tmpdir |
||||
reminder $commit |
||||
|
||||
# # ## ### ##### ######## ############# |
||||
return |
||||
} |
||||
|
||||
proc Hdirs {} { return "[Ioptions]\n\tShow directory setup" } |
||||
proc _dirs args { |
||||
process-install-options |
||||
|
||||
puts "destdir = [dest-dir]" |
||||
puts "prefix = [dest-dir][prefix]" |
||||
puts "exec-prefix = [dest-dir][exec-prefix]" |
||||
puts "bin-dir = [dest-dir][bin-dir]" |
||||
puts "lib-dir = [dest-dir][lib-dir]" |
||||
puts "include-dir = [dest-dir][include-dir]" |
||||
puts "" |
||||
return |
||||
} |
||||
|
||||
proc Ioptions {} { return "?--dest-dir path? ?--prefix path? ?--exec-prefix path? ?--bin-dir path? ?--lib-dir path? ?--include-dir path?" } |
||||
|
||||
proc Htargets {} { return "[Ioptions]\n\tShow available targets.\n\tExpects critcl app to be installed in the \"--bin-dir\" derived from the options and defaults" } |
||||
proc _targets args { |
||||
process-install-options |
||||
set dsta [dest-dir][bin-dir] |
||||
puts [join [split [exec [file join $dsta critcl] -targets]] \n] |
||||
return |
||||
} |
||||
|
||||
proc Hinstall {} { return "?-target T? [Ioptions]\n\tInstall all packages, and application.\n\tDefault --prefix is \"\$(dirname \$(dirname /path/to/tclsh))\"" } |
||||
proc _install {args} { |
||||
global packages me |
||||
|
||||
set target {} |
||||
|
||||
process-install-options |
||||
|
||||
set dsta [dest-dir][bin-dir] |
||||
set dstl [dest-dir][lib-dir] |
||||
set dsti [dest-dir][include-dir] |
||||
|
||||
set selfdir [file dirname $me] |
||||
|
||||
puts {Installing into:} |
||||
puts \tPackages:\t$dstl |
||||
puts \tApplication:\t$dsta |
||||
puts \tHeaders:\t$dsti |
||||
|
||||
file mkdir $dsta $dsti |
||||
|
||||
if {[catch { |
||||
# Create directories, might not exist. |
||||
file mkdir $dstl |
||||
file mkdir $dsta |
||||
set prefix \n |
||||
foreach item $packages { |
||||
# Package: /name/ |
||||
|
||||
if {[llength $item] == 3} { |
||||
foreach {dir vfile name} $item break |
||||
} elseif {[llength $item] == 1} { |
||||
set dir $item |
||||
set vfile {} |
||||
set name $item |
||||
} else { |
||||
foreach {dir vfile} $item break |
||||
set name $dir |
||||
} |
||||
|
||||
if {$vfile ne {}} { |
||||
set version [version [vfile $dir $vfile]] |
||||
} else { |
||||
set version {} |
||||
} |
||||
|
||||
set namevers [file join $dstl [pkgdirname $name $version]] |
||||
|
||||
file copy -force [file join $selfdir lib $dir] [file join $dstl ${name}-new] |
||||
file delete -force $namevers |
||||
puts "${prefix}Installed package: $namevers" |
||||
file rename [file join $dstl ${name}-new] $namevers |
||||
set prefix {} |
||||
} |
||||
|
||||
# Application: critcl |
||||
|
||||
set theapp [critapp $dsta] |
||||
set reldstl [relativedir $dstl $theapp] |
||||
|
||||
set c [open $theapp w] |
||||
lappend map @bs@ "\\" |
||||
lappend map @exe@ [shquote [norm [thisexe]]] |
||||
lappend map @relpath@ [file split $reldstl] ;# insert the dst path |
||||
lappend map "\t " {} ;# de-dent |
||||
lappend map "\t\t" { } ;# de-dent |
||||
puts $c [string trimleft [string map $map { |
||||
#!/bin/sh |
||||
# -*-tcl -*- |
||||
# hide next line from tcl @bs@ |
||||
exec @exe@ "$0" ${1+"$@"} |
||||
|
||||
# Add location of critcl packages to the package load path, if not |
||||
# yet present. Computed relative to the location of the application, |
||||
# as per the installation paths. |
||||
set libpath [file join [file dirname [info script]] @relpath@] |
||||
set libpath [file dirname [file normalize [file join $libpath ...]]] |
||||
if {[lsearch -exact $auto_path $libpath] < 0} { |
||||
set auto_path [linsert $auto_path[set auto_path {}] 0 $libpath] |
||||
} |
||||
unset libpath |
||||
|
||||
package require critcl::app |
||||
critcl::app::main $argv}]] |
||||
close $c |
||||
+x $theapp |
||||
|
||||
puts "${prefix}Installed application: $theapp" |
||||
|
||||
# C packages - Need major Tcl version |
||||
set major [lindex [split [info patchlevel] .] 0] |
||||
|
||||
# Special package: critcl_md5c |
||||
# Local MD5 hash implementation. |
||||
|
||||
puts "\nInstalled C package:\tcritcl::md5c" |
||||
|
||||
# It is special because it is a critcl-based package, not pure |
||||
# Tcl as everything else of critcl. Its installation makes it |
||||
# the first package which will be compiled with critcl on this |
||||
# machine. It uses the just-installed application for |
||||
# that. This is package-mode, where MD5 itself is not used, so |
||||
# there is no chicken vs. egg. |
||||
|
||||
set src [file join $selfdir lib critcl-md5c md5c.tcl] |
||||
set version [version $src] |
||||
set name critcl_md5c_tcl$major |
||||
set dst [file join $dstl [pkgdirname $name $version]] |
||||
set cmd {} |
||||
|
||||
lappend cmd exec >@ stdout 2>@ stderr |
||||
lappend cmd [thisexe] |
||||
lappend cmd $theapp |
||||
if {$target ne {}} { |
||||
lappend cmd -target $target |
||||
} |
||||
lappend cmd -libdir [file join $dstl tmp] -pkg $src |
||||
puts [list executing $cmd] |
||||
eval $cmd |
||||
|
||||
file delete -force $dst |
||||
file rename [file join $dstl tmp md5c] $dst |
||||
file delete -force [file join $dstl tmp] |
||||
|
||||
puts "${prefix}Installed package: $dst" |
||||
|
||||
# Special package: critcl::callback |
||||
# C/Tcl callback utility code. |
||||
|
||||
puts "\nInstalled C package:\tcritcl::callback" |
||||
|
||||
# It is special because it is a critcl-based package, not pure |
||||
# Tcl as everything else of critcl. Its installation makes it |
||||
# the second package which will be compiled with critcl on this |
||||
# machine. It uses the just-installed application for |
||||
# that. |
||||
|
||||
set src [file join $selfdir lib critcl-callback callback.tcl] |
||||
set version [version $src] |
||||
set name critcl_callback_tcl$major |
||||
set dst [file join $dstl [pkgdirname $name $version]] |
||||
set dsth [file join $dsti critcl_callback] ;# headers unversioned |
||||
set cmd {} |
||||
|
||||
lappend cmd exec >@ stdout 2>@ stderr |
||||
lappend cmd [thisexe] |
||||
lappend cmd $theapp |
||||
if {$target ne {}} { |
||||
lappend cmd -target $target |
||||
} |
||||
set dstl_tmp [file join $dstl tmp] |
||||
lappend cmd -libdir $dstl_tmp |
||||
lappend cmd -includedir $dstl_tmp |
||||
lappend cmd -pkg $src |
||||
eval $cmd |
||||
|
||||
file delete -force $dst $dsth |
||||
file rename [file join $dstl tmp callback] $dst |
||||
file rename [file join $dstl tmp critcl_callback] $dsth |
||||
file delete -force $dstl_tmp |
||||
|
||||
puts "${prefix}Installed package: $dst" |
||||
puts "${prefix}Installed headers: [ |
||||
file join $dsti critcl_callback]" |
||||
|
||||
} msg]} { |
||||
if {![string match {*permission denied*} $msg]} { |
||||
return -code error -errorcode $::errorCode -errorinfo $::errorInfo $msg |
||||
} |
||||
puts stderr "\n$msg\n\nUse 'sudo' or some other way of running the operation under the user having access to the destination paths.\n" |
||||
exit |
||||
} |
||||
return |
||||
} |
||||
proc Huninstall {} { Hdrop } |
||||
proc _uninstall {args} { eval [linsert $args 0 _drop] } |
||||
|
||||
proc Hdrop {} { return "[Ioptions]\n\tRemove packages" } |
||||
proc _drop {args} { |
||||
global packages me |
||||
|
||||
process-install-options |
||||
|
||||
set dsta [dest-dir][bin-dir] |
||||
set dstl [dest-dir][lib-dir] |
||||
set dsti [dest-dir][include-dir] |
||||
|
||||
# C packages - Need major Tcl version |
||||
set major [lindex [split [info patchlevel] .] 0] |
||||
|
||||
# Add the special packages (see install). Not special with regard |
||||
# to removal. Except for the name |
||||
lappend packages [list critcl-md5c md5c.tcl critcl_md5c_tcl$major] |
||||
lappend packages [list critcl-callback callback.tcl critcl_callback_tcl$major] |
||||
|
||||
set selfdir [file dirname $me] |
||||
|
||||
foreach item $packages { |
||||
# Package: /name/ |
||||
|
||||
if {[llength $item] == 3} { |
||||
foreach {dir vfile name} $item break |
||||
} elseif {[llength $item] == 1} { |
||||
set dir $item |
||||
set vfile {} |
||||
set name $item |
||||
} else { |
||||
foreach {dir vfile} $item break |
||||
set name $dir |
||||
} |
||||
|
||||
if {$vfile ne {}} { |
||||
set version [version [vfile $dir $vfile]] |
||||
} else { |
||||
set version {} |
||||
} |
||||
|
||||
set namevers [file join $dstl [pkgdirname $name $version]] |
||||
|
||||
file delete -force $namevers |
||||
puts "Removed package: $namevers" |
||||
} |
||||
|
||||
# Application: critcl |
||||
set theapp [critapp $dsta] |
||||
file delete $theapp |
||||
puts "Removed application: $theapp" |
||||
|
||||
# Includes/Headers (critcl::callback) |
||||
set dsth [file join $dsti critcl_callback] |
||||
file delete -force $dsth |
||||
puts "Removed headers: $dsth" |
||||
|
||||
return |
||||
} |
||||
proc Hstarkit {} { return "?destination? ?interpreter?\n\tGenerate a starkit\n\tdestination = path of result file, default 'critcl.kit'\n\tinterpreter = (path) name of tcl shell to use for execution, default 'tclkit'" } |
||||
proc _starkit {{dst critcl.kit} {interp tclkit}} { |
||||
package require vfs::mk4 |
||||
|
||||
set c [open $dst wb] |
||||
puts -nonewline $c "#!/bin/sh\n# -*- tcl -*- \\\nexec $interp \"\$0\" \$\{1+\"\$@\"\}\npackage require starkit\nstarkit::header mk4 -readonly\n\032################################################################################################################################################################" |
||||
close $c |
||||
|
||||
vfs::mk4::Mount $dst /KIT |
||||
file copy -force lib /KIT |
||||
file copy -force main.tcl /KIT |
||||
vfs::unmount /KIT |
||||
+x $dst |
||||
|
||||
puts "Created starkit: $dst" |
||||
return |
||||
} |
||||
proc Hstarpack {} { return "prefix ?destination?\n\tGenerate a fully-selfcontained executable, i.e. a starpack\n\tprefix = path of tclkit/basekit runtime to use\n\tdestination = path of result file, default 'critcl'" } |
||||
proc _starpack {prefix {dst critcl}} { |
||||
package require vfs::mk4 |
||||
|
||||
file copy -force $prefix $dst |
||||
|
||||
vfs::mk4::Mount $dst /KIT |
||||
file mkdir [file join /KIT lib] |
||||
|
||||
foreach d [glob -directory lib *] { |
||||
file delete -force [file join /KIT lib [file tail $d]] |
||||
file copy -force $d [file join /KIT lib] |
||||
} |
||||
|
||||
file copy -force main.tcl /KIT |
||||
vfs::unmount /KIT |
||||
+x $dst |
||||
|
||||
puts "Created starpack: $dst" |
||||
return |
||||
} |
||||
proc Hexamples {} { return "?args...?\n\tWithout arguments, list the examples.\n\tOtherwise run the recipe with its arguments on the examples" } |
||||
proc _examples {args} { |
||||
global me |
||||
set selfdir [file dirname $me] |
||||
set self [file tail $me] |
||||
|
||||
# List examples, or run the build code on the examples, passing any arguments. |
||||
|
||||
set examples [lsort -dict [glob -directory [file join $selfdir examples] */$self]] |
||||
|
||||
puts "" |
||||
if {![llength $args]} { |
||||
foreach b $examples { |
||||
puts "* [file dirname $b]" |
||||
} |
||||
} else { |
||||
foreach b $examples { |
||||
puts "$b _______________________________________________" |
||||
eval [linsert $args 0 exec 2>@ stderr >@ stdout [thisexe] $b] |
||||
puts "" |
||||
puts "" |
||||
} |
||||
} |
||||
return |
||||
} |
||||
main |
||||
@ -0,0 +1,51 @@
|
||||
# genStubs.tcl -- |
||||
# |
||||
# This script generates a set of stub files for a given |
||||
# interface. |
||||
# |
||||
# |
||||
# Copyright (c) 1998-1999 by Scriptics Corporation. |
||||
# Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> |
||||
# Copyright (c) 2011,2022 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
# (Conversion into package set). |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
|
||||
package require Tcl 8.6 9 |
||||
|
||||
lappend auto_path [file dirname [file normalize [info script]]]/lib/stubs |
||||
lappend auto_path [file dirname [file normalize [info script]]]/lib/util84 |
||||
|
||||
package require stubs::container |
||||
package require stubs::reader |
||||
package require stubs::gen::init |
||||
package require stubs::gen::header |
||||
|
||||
proc main {} { |
||||
global argv argv0 |
||||
|
||||
if {[llength $argv] < 2} { |
||||
puts stderr "usage: $argv0 outDir declFile ?declFile...?" |
||||
exit 1 |
||||
} |
||||
|
||||
set outDir [lindex $argv 0] |
||||
|
||||
set T [stubs::container::new] |
||||
|
||||
foreach file [lrange $argv 1 end] { |
||||
stubs::reader::file T $file |
||||
} |
||||
|
||||
foreach name [lsort [stubs::container::interfaces $T]] { |
||||
puts "Emitting $name" |
||||
stubs::gen::header::rewrite@ $outDir $T $name |
||||
} |
||||
|
||||
stubs::gen::init::rewrite@ $outDir $T |
||||
return |
||||
} |
||||
|
||||
main |
||||
exit 0 |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,2 @@
|
||||
if {![package vsatisfies [package provide Tcl] 8.6 9]} {return} |
||||
package ifneeded critcl::app 3.3.1 [list source [file join $dir critcl.tcl]] |
||||
@ -0,0 +1,86 @@
|
||||
## -*- tcl -*- |
||||
# # ## ### ##### ######## ############# ##################### |
||||
# Pragmas for MetaData Scanner. |
||||
# n/a |
||||
|
||||
# CriTcl Utility Commands To Provide Common C-level utility functions. |
||||
# |
||||
# Copyright (c) 2017-2024 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
package provide critcl::cutil 0.5 |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Requirements. |
||||
|
||||
package require Tcl 8.6 9 ; # Min supported version. |
||||
package require critcl 3.2 |
||||
|
||||
namespace eval ::critcl::cutil {} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Implementation -- API: Embed C Code |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
|
||||
proc critcl::cutil::alloc {} { |
||||
variable selfdir |
||||
critcl::cheaders -I$selfdir/allocs |
||||
critcl::include critcl_alloc.h |
||||
return |
||||
} |
||||
|
||||
proc critcl::cutil::assertions {{enable 0}} { |
||||
variable selfdir |
||||
critcl::cheaders -I$selfdir/asserts |
||||
critcl::include critcl_assert.h |
||||
if {!$enable} return |
||||
critcl::cflags -DCRITCL_ASSERT |
||||
return |
||||
} |
||||
|
||||
proc critcl::cutil::tracer {{enable 0}} { |
||||
variable selfdir |
||||
alloc ;# Tracer uses the allocation utilities in its implementation |
||||
critcl::cheaders -I$selfdir/trace |
||||
critcl::include critcl_trace.h |
||||
if {!$enable} return |
||||
critcl::csources $selfdir/trace/trace.c |
||||
critcl::cflags -DCRITCL_TRACER |
||||
return |
||||
} |
||||
|
||||
proc critcl::cutil::tracer-config {args} { |
||||
while {[llength $args]} { |
||||
set o [lindex $args 0] |
||||
switch -exact -- $o { |
||||
-unthreaded - |
||||
-nothreads { |
||||
critcl::cflags -DCRITCL_TRACE_NOTHREADS |
||||
} |
||||
default { |
||||
return -code error \ |
||||
"Unknown option $o, expected -nothreads, or -unthreaded" |
||||
} |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## State |
||||
|
||||
namespace eval ::critcl::cutil { |
||||
variable selfdir [file dirname [file normalize [info script]]] |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Export API |
||||
|
||||
namespace eval ::critcl::cutil { |
||||
namespace export alloc assert tracer |
||||
catch { namespace ensemble create } |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Ready |
||||
return |
||||
@ -0,0 +1,2 @@
|
||||
if {![package vsatisfies [package provide Tcl] 8.6 9]} {return} |
||||
package ifneeded critcl::cutil 0.5 [list source [file join $dir cutil.tcl]] |
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,144 @@
|
||||
/*
|
||||
* tclPlatDecls.h -- |
||||
* |
||||
* Declarations of platform specific Tcl APIs. |
||||
* |
||||
* Copyright (c) 1998-1999 by Scriptics Corporation. |
||||
* All rights reserved. |
||||
*/ |
||||
|
||||
#ifndef _TCLPLATDECLS |
||||
#define _TCLPLATDECLS |
||||
|
||||
#undef TCL_STORAGE_CLASS |
||||
#ifdef BUILD_tcl |
||||
# define TCL_STORAGE_CLASS DLLEXPORT |
||||
#else |
||||
# ifdef USE_TCL_STUBS |
||||
# define TCL_STORAGE_CLASS |
||||
# else |
||||
# define TCL_STORAGE_CLASS DLLIMPORT |
||||
# endif |
||||
#endif |
||||
|
||||
/*
|
||||
* WARNING: This file is automatically generated by the tools/genStubs.tcl |
||||
* script. Any modifications to the function declarations below should be made |
||||
* in the generic/tcl.decls script. |
||||
*/ |
||||
|
||||
/*
|
||||
* TCHAR is needed here for win32, so if it is not defined yet do it here. |
||||
* This way, we don't need to include <tchar.h> just for one define. |
||||
*/ |
||||
#if (defined(_WIN32) || defined(__CYGWIN__)) && !defined(_TCHAR_DEFINED) |
||||
# if defined(_UNICODE) |
||||
typedef wchar_t TCHAR; |
||||
# else |
||||
typedef char TCHAR; |
||||
# endif |
||||
# define _TCHAR_DEFINED |
||||
#endif |
||||
|
||||
/* !BEGIN!: Do not edit below this line. */ |
||||
|
||||
#ifdef __cplusplus |
||||
extern "C" { |
||||
#endif |
||||
|
||||
/*
|
||||
* Exported function declarations: |
||||
*/ |
||||
|
||||
#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ |
||||
/* 0 */ |
||||
EXTERN TCHAR * Tcl_WinUtfToTChar(const char *str, int len, |
||||
Tcl_DString *dsPtr); |
||||
/* 1 */ |
||||
EXTERN char * Tcl_WinTCharToUtf(const TCHAR *str, int len, |
||||
Tcl_DString *dsPtr); |
||||
/* Slot 2 is reserved */ |
||||
/* 3 */ |
||||
EXTERN void TclWinConvertError_(unsigned errCode); |
||||
#endif /* WIN */ |
||||
#ifdef MAC_OSX_TCL /* MACOSX */ |
||||
/* 0 */ |
||||
EXTERN int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp, |
||||
const char *bundleName, int hasResourceFile, |
||||
int maxPathLen, char *libraryPath); |
||||
/* 1 */ |
||||
EXTERN int Tcl_MacOSXOpenVersionedBundleResources( |
||||
Tcl_Interp *interp, const char *bundleName, |
||||
const char *bundleVersion, |
||||
int hasResourceFile, int maxPathLen, |
||||
char *libraryPath); |
||||
/* 2 */ |
||||
EXTERN void TclMacOSXNotifierAddRunLoopMode_( |
||||
const void *runLoopMode); |
||||
#endif /* MACOSX */ |
||||
|
||||
typedef struct TclPlatStubs { |
||||
int magic; |
||||
void *hooks; |
||||
|
||||
#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ |
||||
TCHAR * (*tcl_WinUtfToTChar) (const char *str, int len, Tcl_DString *dsPtr); /* 0 */ |
||||
char * (*tcl_WinTCharToUtf) (const TCHAR *str, int len, Tcl_DString *dsPtr); /* 1 */ |
||||
void (*reserved2)(void); |
||||
void (*tclWinConvertError_) (unsigned errCode); /* 3 */ |
||||
#endif /* WIN */ |
||||
#ifdef MAC_OSX_TCL /* MACOSX */ |
||||
int (*tcl_MacOSXOpenBundleResources) (Tcl_Interp *interp, const char *bundleName, int hasResourceFile, int maxPathLen, char *libraryPath); /* 0 */ |
||||
int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, int maxPathLen, char *libraryPath); /* 1 */ |
||||
void (*tclMacOSXNotifierAddRunLoopMode_) (const void *runLoopMode); /* 2 */ |
||||
#endif /* MACOSX */ |
||||
} TclPlatStubs; |
||||
|
||||
extern const TclPlatStubs *tclPlatStubsPtr; |
||||
|
||||
#ifdef __cplusplus |
||||
} |
||||
#endif |
||||
|
||||
#if defined(USE_TCL_STUBS) |
||||
|
||||
/*
|
||||
* Inline function declarations: |
||||
*/ |
||||
|
||||
#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ |
||||
#define Tcl_WinUtfToTChar \ |
||||
(tclPlatStubsPtr->tcl_WinUtfToTChar) /* 0 */ |
||||
#define Tcl_WinTCharToUtf \ |
||||
(tclPlatStubsPtr->tcl_WinTCharToUtf) /* 1 */ |
||||
/* Slot 2 is reserved */ |
||||
#define TclWinConvertError_ \ |
||||
(tclPlatStubsPtr->tclWinConvertError_) /* 3 */ |
||||
#endif /* WIN */ |
||||
#ifdef MAC_OSX_TCL /* MACOSX */ |
||||
#define Tcl_MacOSXOpenBundleResources \ |
||||
(tclPlatStubsPtr->tcl_MacOSXOpenBundleResources) /* 0 */ |
||||
#define Tcl_MacOSXOpenVersionedBundleResources \ |
||||
(tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */ |
||||
#define TclMacOSXNotifierAddRunLoopMode_ \ |
||||
(tclPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode_) /* 2 */ |
||||
#endif /* MACOSX */ |
||||
|
||||
#endif /* defined(USE_TCL_STUBS) */ |
||||
|
||||
/* !END!: Do not edit above this line. */ |
||||
|
||||
#undef TclUnusedStubEntry |
||||
#undef TclMacOSXNotifierAddRunLoopMode_ |
||||
#undef TclWinConvertError_ |
||||
#ifdef MAC_OSX_TCL /* MACOSX */ |
||||
#undef Tcl_MacOSXOpenBundleResources |
||||
#define Tcl_MacOSXOpenBundleResources(a,b,c,d,e) Tcl_MacOSXOpenVersionedBundleResources(a,b,NULL,c,d,e) |
||||
#endif |
||||
|
||||
#undef TCL_STORAGE_CLASS |
||||
#define TCL_STORAGE_CLASS DLLIMPORT |
||||
|
||||
#endif /* _TCLPLATDECLS */ |
||||
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,73 @@
|
||||
#ifndef CRITCL_TCL9_COMPAT_H |
||||
#define CRITCL_TCL9_COMPAT_H |
||||
|
||||
/* Disable the macros making us believe that everything is hunky-dory on compilation, and then
|
||||
* reward us with runtime crashes for being a sucker to have believed them. |
||||
*/ |
||||
#define TCL_NO_DEPRECATED |
||||
|
||||
#include "tcl.h" |
||||
|
||||
/*
|
||||
* - - -- --- ----- -------- ------------- --------------------- |
||||
* Check for support of the `Tcl_Size` typdef and associated definitions. |
||||
* It was introduced in Tcl 8.7 and 9, and we need backward compatibility |
||||
* definitions for 8.6. |
||||
*/ |
||||
|
||||
#ifndef TCL_SIZE_MAX |
||||
#include <limits.h> |
||||
#define TCL_SIZE_MAX INT_MAX |
||||
|
||||
#ifndef Tcl_Size |
||||
typedef int Tcl_Size; |
||||
#endif |
||||
|
||||
/* TIP #494 constants, for 8.6 too */ |
||||
#define TCL_IO_FAILURE ((Tcl_Size)-1) |
||||
#define TCL_AUTO_LENGTH ((Tcl_Size)-1) |
||||
#define TCL_INDEX_NONE ((Tcl_Size)-1) |
||||
|
||||
#define TCL_SIZE_MODIFIER "" |
||||
#define Tcl_GetSizeIntFromObj Tcl_GetIntFromObj |
||||
#define Tcl_NewSizeIntObj Tcl_NewIntObj |
||||
#else |
||||
#define Tcl_NewSizeIntObj Tcl_NewWideIntObj |
||||
#endif |
||||
|
||||
#define TCL_SIZE_FMT "%" TCL_SIZE_MODIFIER "d" |
||||
|
||||
/*
|
||||
* - - -- --- ----- -------- ------------- --------------------- |
||||
* Critcl (3.3+) emits the command creation API using Tcl_Size by default. |
||||
* Map this to the older int-based API when compiling against Tcl 8.x or older. |
||||
* |
||||
* Further map use of `Tcl_GetBytesFromObj` to the old `Tcl_GetByteArrayFromObj`. |
||||
* This loses the interp argument, and the ability to return NULL. |
||||
*/ |
||||
|
||||
#if TCL_MAJOR_VERSION <= 8 |
||||
#define Tcl_CreateObjCommand2 Tcl_CreateObjCommand |
||||
#define Tcl_GetBytesFromObj(interp,obj,sizeptr) Tcl_GetByteArrayFromObj(obj,sizeptr) |
||||
#endif |
||||
|
||||
/*
|
||||
* - - -- --- ----- -------- ------------- --------------------- |
||||
*/ |
||||
|
||||
#ifndef CONST |
||||
#define CONST const |
||||
#endif |
||||
|
||||
#ifndef CONST84 |
||||
#define CONST84 const |
||||
#endif |
||||
|
||||
#ifndef CONST86 |
||||
#define CONST86 const |
||||
#endif |
||||
|
||||
/*
|
||||
* - - -- --- ----- -------- ------------- --------------------- |
||||
*/ |
||||
#endif /* CRITCL_TCL9_COMPAT_H */ |
||||
@ -0,0 +1,2 @@
|
||||
if {![package vsatisfies [package provide Tcl] 8.6 9]} {return} |
||||
package ifneeded critcl 3.3.1 [list source [file join $dir critcl.tcl]] |
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in new issue