@ -1,4 +1,6 @@
# s o u r c e i s a t s r c / v f s / _ c o n f i g / p u n k _ m a i n . t c l
# T h i s m a i n s c r i p t w i l l c o n s u m e a f i r s t a r g u m e n t o f t h e f o r m d e v | o s | i n t e r n a l
# o r a n y d a s h - d e l i m i t e d c o m b i n a t i o n s u c h a s d e v - o s
#
@ -21,7 +23,102 @@
# - a n d r e s t r i c t p a c k a g e p a t h s t o t h o s e c o m i n g f r o m a v f s ( i f n o t l a u n c h e d w i t h ' d e v ' o r ' o s ' f i r s t a r g w h i c h a l l o w s e x t e r n a l p a t h s t o r e m a i n )
apply { args {
set : : punkargv $args
set tclmajorv [ lindex [ split [ info tclversion] .] 0 ]
# - - r u n t i m e s t a t i c / b u i l t i n p a c k a g e c a p t u r e ( G - 0 5 8 ) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# R u n t i m e s m a y s t a t i c a l l y l i n k p a c k a g e s ( e . g t c l - s f e : T h r e a d , t w a p i , s q l i t e 3 , t d b c ) .
# S t a t i c r e g i s t r a t i o n s a r e p r o c e s s - g l o b a l ( ' l o a d { } < p r e f i x > ' w o r k s i n a n y i n t e r p / t h r e a d )
# b u t ' p a c k a g e r e q u i r e ' n e e d s a p a c k a g e - n a m e - > l o a d m a p p i n g i n E A C H i n t e r p . A k i t ' s
# a p p e n d e d v f s r e p l a c e s t h e r u n t i m e ' s o w n / / z i p f s : / a p p m o u n t , s o a n y p k g I n d e x . t c l t h e
# r u n t i m e s h i p p e d f o r i t s s t a t i c s i s g o n e - a n d t h e p a t h s e t u p b e l o w c o n t r o l s r e s o l u t i o n
# a n y w a y . C a p t u r e t h e s t a t i c p r e f i x e s n o w , d i s c o v e r t h e p a c k a g e n a m e s / v e r s i o n s e a c h
# p r o v i d e s b y l o a d i n g i n t o a t h r o w a w a y i n t e r p , a n d r e c o r d t h e r e s u l t s i n : : p u n k b o o t s o
# t h a t ( a ) t h i s i n t e r p a n d ( b ) e v e r y i n t e r p / t h r e a d p u n k s h e l l f a b r i c a t e s c a n s e e d
# ' p a c k a g e i f n e e d e d < n a m e > < v e r > { l o a d { } < p r e f i x > } ' e n t r i e s .
# ( s e e p u n k : : l i b : : i n t e r p _ s y n c _ p a c k a g e _ p a t h s / s n a p s h o t _ p a c k a g e _ p a t h s a n d t h e
# p u n k : : p a c k a g e p r e f e r e n c e s t a t i c - v s - b u n d l e d p o l i c y )
# P r o b e - l o a d i n g i s s a f e f o r s e l f - c o n t a i n e d e x t e n s i o n s ; s t a t i c _ p r o b e _ d e n y l i s t e x c l u d e s
# p r e f i x e s w h o s e i n i t h a s s i d e e f f e c t s ( t k * c r e a t e s ' . ' ) o r w h o s e p a c k a g e i s k n o w n t o b e
# c o m p o s i t e ( C p a r t + o n - d i s k s c r i p t s : v f s , t d b c * , a n d k i t m a c h i n e r y m k 4 t c l / v l e r q ) -
# t h o s e k e e p t h e i r e x i s t i n g r e s o l u t i o n b e h a v i o u r . C o m p o s i t e s t a t i c s a r e A L S O e x c l u d e d
# n a t u r a l l y : o n l y p a c k a g e s a p r o b e - l o a d a c t u a l l y P R O V I D E S a r e r e c o r d e d , s o a n i n i t t h a t
# d e f e r s t o s c r i p t f i l e s w h i c h n o l o n g e r e x i s t ( e . g s t a t i c t w a p i w h o s e s c r i p t l a y e r
# l i v e d i n t h e r u n t i m e ' s r e p l a c e d z i p ) i s n e v e r s e e d e d , a n d a n y b u n d l e d c o m p l e t e c o p y
# r e s o l v e s a s b e f o r e .
namespace eval : : punkboot {
variable static_prefixes [ list ]
variable static_packages [ dict create] ; # p k g n a m e - > { v e r s i o n < v > p r e f i x < p > }
variable static_probe_denylist [ list tk* vfs mk4tcl vlerq tdbc* ]
}
apply { { } {
foreach rec [ info loaded] {
lassign $rec fpath prefix
if { $fpath eq " " && $prefix ne " " } {
lappend : : punkboot::static_prefixes $prefix
}
}
if { ! [ llength $::punkboot::static_prefixes ] } {
return
}
set probeable [ list ]
foreach prefix $::punkboot::static_prefixes {
set denied 0
foreach dpat $::punkboot::static_probe_denylist {
if { [ string match - nocase $dpat $prefix ] } {
set denied 1
break
}
}
if { ! $denied } {
lappend probeable $prefix
}
}
set probe __punkboot_staticprobe
catch { interp delete $probe }
interp create $probe
# d i f f o n P R O V I D E D p a c k a g e s ( n o t ' p a c k a g e n a m e s ' - a p r o b e l o a d c a n t r i g g e r a n i n d e x
# s c a n t h a t r e g i s t e r s m a n y n a m e s a s i f n e e d e d w i t h o u t p r o v i d i n g t h e m )
set provided_in_probe { { probe } {
set pdict [ dict create]
foreach n [ interp eval $probe { package names} ] {
set pv [ interp eval $probe [ list package provide $n ] ]
if { $pv ne " " } {
dict set pdict $n $pv
}
}
return $pdict
} }
# a n i n i t m a y d e p e n d o n a n o t h e r s t a t i c - r e t r y f a i l u r e s o n c e
set attempts [ list { * } $probeable { * } $probeable ]
set done [ list ]
foreach prefix $attempts {
if { $prefix in $done } {
continue
}
set before_prov [ apply $provided_in_probe $probe ]
if { [ catch { load { } $prefix $probe } ] } {
continue
}
lappend done $prefix
dict for { pkgname v} [ apply $provided_in_probe $probe ] {
if { ! [ dict exists $before_prov $pkgname ] } {
dict set : : punkboot::static_packages $pkgname [ dict create version $v prefix $prefix ]
}
}
}
interp delete $probe
# s e e d t h i s i n t e r p ' s p a c k a g e d b s o r e q u i r e s h e r e c a n r e s o l v e t o t h e r u n t i m e ' s o w n
# c o p y . C o e x i s t i n g i f n e e d e d e n t r i e s ( s t a t i c + a n y v f s / m o d u l e c o p i e s r e g i s t e r e d b y
# i n d e x s c a n s ) r e s o l v e v e r s i o n - a w a r e u n d e r t h e s t a n d a r d p a c k a g e m a c h i n e r y .
dict for { pkgname pinfo} $::punkboot::static_packages {
if { [ package provide $pkgname ] eq " " } {
package ifneeded $pkgname [ dict get $pinfo version] [ list load { } [ dict get $pinfo prefix] ]
}
}
} }
# - - e n d r u n t i m e s t a t i c / b u i l t i n p a c k a g e c a p t u r e - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
namespace eval : : punkboot {
# T h i s i s s o m e w h a t u g l y - b u t w e d o n ' t w a n t t o d o a n y ' p a c k a g e r e q u i r e ' o p e r a t i o n s a t t h i s s t a g e
# e v e n f o r s o m e t h i n g t h a t i s a v a i l a b l e i n t c l _ l i b r a r y .
@ -122,6 +219,59 @@ apply { args {
return " $ { p l a t } - $ { c p u } "
}
proc platform_punk { } {
# c a n o n i c a l p u n k s h e l l p l a t f o r m - d i r n a m e : p l a t f o r m _ g e n e r i c n o r m a l i z e d .
# I N L I N E C O P Y o f p u n k : : p l a t f o r m : : n o r m a l i z e ( s r c / m o d u l e s / p u n k / p l a t f o r m - * . t m ;
# ' h e l p p l a t f o r m s ' d o c u m e n t s t h e c a n o n ) - t h e b o o t s t a g e c a n n o t p a c k a g e
# r e q u i r e , s o k e e p t h i s m a p p i n g i n s y n c w i t h t h a t m o d u l e :
# a m d 6 4 - > x 8 6 _ 6 4 , a a r c h 6 4 - > a r m 6 4 , m a c o s - > m a c o s x , m a c o s x a r m - > a r m 6 4 .
set parts [ split [ platform_generic ] - ]
set cpu [ lindex $parts end]
set os [ join [ lrange $parts 0 end-1] - ]
if { $os eq " m a c o s " } { set os macosx}
switch - - $cpu {
amd64 { set cpu x86_64}
aarch64 { set cpu arm64}
arm { if { $os eq " m a c o s x " } { set cpu arm64} }
}
return " $ { o s } - $ { c p u } "
}
proc is_interactive { } {
if { " w i n d o w s " eq $::tcl_platform ( platform ) && [ package vcompare [ info patchlevel] 9.0 ] == - 1 } {
# t c l 8 . 6 e t c
if { ! [ catch { package require twapi} ] } {
set h_console [ twapi : : GetStdHandle - 10 ] ; # S T D _ I N P U T _ H A N D L E
if { [ catch { twapi : : GetConsoleMode $h_console } result] } {
return 0
} else {
return 1
}
} else {
# T O D O
# R E V I E W
# w e h a v e n o c u r r e n t w a y t o d e t e c t i f w e a r e r u n n i n g i n a c o n s o l e i n t c l 8 o n w i n d o w s w i t h o u t t w a p i - s o w e ' l l a s s u m e n o t i n t e r a c t i v e f o r n o w .
# T h i s i m p l i e s t h e r e i s n o m e c h a n i s m f o r t h i s i n e a r l y T c l v e r s i o n s .
# h t t p s : / / s t a c k o v e r f l o w . c o m / q u e s t i o n s / 4 3 6 6 0 6 1 2 / h o w - t o - c h e c k - i f - s t d i n - s t d o u t - a r e - c o n n e c t e d - t o - a - t e r m i n a l - i n - t c l
# s e t t c l _ i n t e r a c t i v e 0
puts stderr " W A R N I N G : i s _ i n t e r a c t i v e c a n n o t d e t e c t c o n s o l e o n W i n d o w s T c l [ i n f o p a t c h l e v e l ] w i t h o u t t w a p i p a c k a g e - p r o b a b l y n o t i n t e r a c t i v e "
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
set stdin_info [ chan configure stdin]
if { [ dict exists $stdin_info - inputmode] } {
# t h i s i s t h e o n l y w a y I c u r r e n t l y k n o w t o d e t e c t c o n s o l e o n w i n d o w s . . d o e s n ' t w o r k o n A l m a l i n u x .
# t c l _ i n t e r a c t i v e u s e d b y r e p l t o d e t e r m i n e i f s t d e r r o u t p u t p r o m p t t o b e p r i n t e d .
# ( t h a t w a y , p i p i n g c o m m a n d s i n t o s t d i n s h o u l d n o t p r o d u c e p r o m p t s f o r e a c h c o m m a n d )
# s e t t c l _ i n t e r a c t i v e 1
return 1
}
# h o w e v e r , t h e - m o d e o p t i o n o n l y s e e m s t o a p p e a r o n l i n u x w h e n a t e r m i n a l e x i s t s . .
if { [ dict exists $stdin_info - mode] } {
return 1
}
return 0
}
}
set has_zipfs [ expr { [ info commands tcl::zipfs::root] ne " " } ]
@ -234,8 +384,10 @@ apply { args {
set tm_additions_internal [ list ]
set tm_additions_dev [ list ]
set tm_additions_src [ list ]
set auto_path_additions_internal [ list ]
set auto_path_additions_dev [ list ]
set auto_path_additions_src [ list ]
set lc_auto_path [ string tolower $::auto_path ]
@ -318,46 +470,50 @@ apply { args {
# d e v - r e f e r s t o m o d u l e a n d l i b r a r y p a t h s r e l a t i v e t o t h e p r o j e c t ( e x e c u t a b l e p a t h )
# o s - r e f e r s t o m o d u l e s a n d l i b r a r y p a t h s g l e a n e d f r o m : : e n v ( T C L L I B P A T H a n d T C L < M A J O R > _ < M I N O R > _ T M _ P A T H )
# i n t e r n a l - r e f e r s t o m o d u l e s a n d l i b r a r i e s s u p p l i e d f r o m t h e m o u n t e d f i l e s y s t e m o f a k i t o r z i p f s b a s e d e x e c u t a b l e
# s r c - r e f e r s t o u n b u i l t m o d u l e s a n d l i b r a r i e s u n d e r t h e p r o j e c t ' s s r c / t r e e ( s r c / m o d u l e s , s r c / l i b , s r c / b o o t s u p p o r t , s r c / v e n d o r m o d u l e s )
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# N o t e t h a t u n l i k e s t a n d a r d ' p a c k a g e u n k n o w n ' p u n k : : l i b u n k n o w n d o e s n o t s t o p s e a r c h i n g f o r p a c k a g e s w h e n a . t m f i l e i s f o u n d t h a t m a t c h e s r e q u i r e m e n t s ,
# T h e a u t o _ p a t h i s s t i l l e x a m i n e d . ( a v o i d s q u i r k s w h e r e h i g h e r v e r s i o n e d p k g I n d e x b a s e d p a c k a g e n o t a l w a y s f o u n d )
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
set all_package_modes [ list dev os internal]
set all_package_modes [ list dev os internal src ]
# p a c k a g e _ m o d e i s s p e c i f i e d a s a d a s h - d e l i m i t e d o r d e r e d v a l u e e . g d e v - o s
# " i n t e r n a l " i s t h e d e f a u l t a n d i f n o t p r e s e n t i s a l w a y s a d d e d t o t h e l i s t
# i . e " d e v - o s " i s e q u i v a l e n t t o " d e v - o s - i n t e r n a l "
# " o s " i s e q u i v a l e n t t o " o s - i n t e r n a l "
# " i n t e r n a l - o s " a n d " i n t e r n a l " a r e l e f t a s i s .
# T h e e f f e c t i v e p a c k a g e _ m o d e h a s 1 2 o r 3 m e m b e r s .
# T h e e f f e c t i v e p a c k a g e _ m o d e h a s 1 2 3 o r 4 m e m b e r s .
# T h e o n l y c a s e w h e r e i t h a s 1 m e m b e r i s i f j u s t " i n t e r n a l " i s s p e c i f i e d .
# T h i s g i v e s t h e n u m b e r o f p e r m u t a t i o n s a s h o w m a n y w a y s t o c h o o s e 3 i t e m s p l u s h o w m a n y w a y s t o c h o o s e 2 o f t h e 3 i t e m s ( o n e m u s t b e ' i n t e r n a l ' ) p l u s t h e s o l e a l l o w a b l e w a y t o c h o o s e 1
# f o r a t o t a l o f 1 1 p o s s i b l e f i n a l o r d e r i n g s .
# ( 1 6 p o s s i b l e v a l u e s f o r p a c k a g e _ m o d e a r g u m e n t w h e n y o u i n c l u d e t h e s h o r t - f o r m s " " , o s , d e v , o s - d e v , d e v - o s w h i c h a l w a y s h a v e ' i n t e r n a l ' a p p e n d e d )
set test_package_mode [ lindex $args 0 ]
switch - exact - - $test_package_mode {
internal -
os-internal - dev-internal - internal-os - internal-dev -
os-dev-internal - os-internal-dev - dev-os-internal - dev-internal-os - internal-os-dev - internal-dev-os {
# f u l l y s p e c i f i e d ( ' i n t e r n a l ' i s p r e s e n t )
set package_modes [ split $test_package_mode - ]
set arglist [ lrange $args 1 end]
# p u t s s t d e r r " m a i n . t c l t e s t _ p a c k a g e _ m o d e : ' $ t e s t _ p a c k a g e _ m o d e ' "
# T o k e n - b y - t o k e n v a l i d a t i o n : i n s t e a d o f e x h a u s t i v e l y l i s t i n g a l l p e r m u t a t i o n s ,
# s p l i t t h e f i r s t a r g o n d a s h a n d v a l i d a t e e a c h t o k e n a g a i n s t t h e k n o w n m o d e s e t .
# T h i s s c a l e s t o a n y n u m b e r o f m o d e s w i t h o u t e n u m e r a t i n g e v e r y p e r m u t a t i o n .
set package_modes " "
set arglist " "
if { $test_package_mode eq " " } {
# e m p t y f i r s t a r g c o n s u m e d a s e q u i v a l e n t o f ' i n t e r n a l '
set package_modes internal
set arglist [ lrange $args 1 end]
} else {
set tokens [ split $test_package_mode - ]
set valid 1
foreach t $tokens {
if { $t ni $all_package_modes } {
set valid 0
break
}
}
os - dev - os-dev - dev-os {
# p a r t i a l l y s p e c i f i e d - ' i n t e r n a l ' o m m i t t e d b u t i m p l i e d a t t a i l
set package_modes [ list { * } [ split $test_package_mode - ] internal]
if { $valid && [ llength $tokens ] >= 1 } {
set package_modes $tokens
if { " i n t e r n a l " ni $package_modes } {
lappend package_modes internal
}
set arglist [ lrange $args 1 end]
}
default {
# e m p t y f i r s t a r g - o r s o m e u n r e l a t e d a r g
} else {
# n o t a p a c k a g e _ m o d e - t r e a t a s s u b c o m m a n d
set package_modes internal
if { $test_package_mode eq " " } {
# c o n s u m e t h e e m p t y f i r s t a r g a s a n e q u i v a l e n t o f ' i n t e r n a l '
# d o n ' t c o n s u m e a n y f i r s t a r g t h a t i s n ' t r e c o g n i s e d a s a p a c k a g e _ m o d e
set arglist [ lrange $args 1 end]
} else {
set arglist $args
}
set arglist $args
}
}
# a s s e r t : a r g l i s t h a s h a d a n y f i r s t a r g t h a t i s a p a c k a g e _ m o d e ( i n c l u d i n g e m p t y s t r i n g ) s t r i p p e d .
@ -492,6 +648,54 @@ apply { args {
}
}
# s r c m o d e : d i s c o v e r t h e p r o j e c t ' s s r c / t r e e a n d a d d u n b u i l t m o d u l e p a t h s .
# U n l i k e d e v m o d e ( w h i c h p o i n t s a t b u i l t o u t p u t i n < p r o j e c t r o o t > / m o d u l e s ) ,
# s r c m o d e p o i n t s a t t h e u n b u i l t s o u r c e i n < p r o j e c t r o o t > / s r c / m o d u l e s e t c .
if { " s r c " in $package_modes } {
# r e u s e t h e d e v - m o d e p r o j e c t r o o t d i s c o v e r y ( e x e i n b i n / - > b a c k t r a c k 1 )
set src_project_root " "
set normexe_dir_for_src [ file dirname $normexe ]
if { [ file tail $normexe_dir_for_src ] eq " b i n " } {
set src_project_root [ file dirname $normexe_dir_for_src ]
} else {
set src_project_root $normexe_dir_for_src
}
# a l s o c h e c k s y m l i n k t a r g e t
if { $src_project_root eq " " } {
set nameexe_dir_for_src [ file dirname [ file normalize [ info nameofexecutable] ] ]
if { [ file tail $nameexe_dir_for_src ] eq " b i n " } {
set src_project_root [ file dirname $nameexe_dir_for_src ]
} else {
set src_project_root $nameexe_dir_for_src
}
}
if { $src_project_root ne " " && [ file isdirectory [ file join $src_project_root src] ] } {
foreach p [ list modules modules_tcl$tclmajorv ] {
set modpath [ file join $src_project_root src $p ]
if { [ file isdirectory $modpath ] && $modpath ni $tm_additions_src } {
lappend tm_additions_src $modpath
}
}
# b o o t s u p p o r t m o d u l e s ( f o r b o o t - c r i t i c a l p a c k a g e s l i k e p u n k c h e c k , p u n k : : m i x e t c )
foreach p [ list modules modules_tcl$tclmajorv ] {
set modpath [ file join $src_project_root src bootsupport $p ]
if { [ file isdirectory $modpath ] && $modpath ni $tm_additions_src } {
lappend tm_additions_src $modpath
}
}
# v e n d o r m o d u l e s ( v e n d o r e d d e p e n d e n c i e s l i k e v o o )
foreach p [ list vendormodules vendormodules_tcl$tclmajorv ] {
set modpath [ file join $src_project_root src $p ]
if { [ file isdirectory $modpath ] && $modpath ni $tm_additions_src } {
lappend tm_additions_src $modpath
}
}
} else {
puts stderr " W a r n i n g - s r c m o d e : n o s r c / d i r e c t o r y f o u n d r e l a t i v e t o e x e c u t a b l e ( $ n o r m e x e _ d i r _ f o r _ s r c ) "
}
}
@ -555,6 +759,13 @@ apply { args {
}
}
}
src {
foreach n $tm_additions_src {
if { $n ni $new_tm_path } {
lappend new_tm_path $n
}
}
}
os {
foreach n $external_tm_dirs {
if { $n ni $new_tm_path } {
@ -607,7 +818,7 @@ apply { args {
# s o w e p r e p e n d t o a u t o _ p a t h u s i n g a s l i g h t l y i n e f f i c i e n t m e t h o d . S h o u l d b e f i n e o n r e l a t i v e l y s m a l l l i s t l i k e t h i s
# e v e n t u a l l y i t s h o u l d j u s t b e s o m e t h i n g l i k e ' l e d i t : : a u t o _ p a t h - 1 - 1 $ l i b f o l d e r '
if { " d e v " in $package_modes } {
set platform [ : : punkboot : : platform_generic ]
set platform [ : : punkboot : : platform_punk ]
# o n w i n d o w s - c a s e d i f f e r e n c e s d o n t m a t t e r - b u t c a n s t o p u s f i n d i n g p a t h i n a u t o _ p a t h
# o n o t h e r p l a t f o r m s , c a s e d i f f e r e n c e s c o u l d r e p r e s e n t d i f f e r e n t p a t h s
# r e v i e w
@ -658,6 +869,42 @@ apply { args {
}
}
# s r c m o d e : a d d u n b u i l t s o u r c e l i b r a r y p a t h s f r o m t h e p r o j e c t ' s s r c / t r e e .
if { " s r c " in $package_modes && [ info exists src_project_root] && $src_project_root ne " " } {
set platform [ : : punkboot : : platform_punk]
set src_lib_base [ file join $src_project_root src]
# s r c / l i b a n d s r c / l i b _ t c l < t c l m a j o r > ( e d i t a b l e l i b r a r y s o u r c e )
foreach libsub [ list lib_tcl$tclmajorv lib] {
set libfolder [ file join $src_lib_base $libsub ]
if { [ file isdirectory $libfolder ] } {
if { [ string match lib_tcl* [ file tail $libfolder ] ] } {
if { [ file exists $libfolder / allplatforms] } {
lappend auto_path_additions_src $libfolder / allplatforms
}
if { [ file exists $libfolder / $platform ] } {
lappend auto_path_additions_src $libfolder / $platform
}
} else {
lappend auto_path_additions_src $libfolder
}
}
}
# s r c / b o o t s u p p o r t / l i b ( b o o t s t r a p l i b r a r i e s )
set src_bs_lib [ file join $src_lib_base bootsupport lib]
if { [ file isdirectory $src_bs_lib ] } {
if { $src_bs_lib ni $auto_path_additions_src } {
lappend auto_path_additions_src $src_bs_lib
}
}
# s r c / b o o t s u p p o r t / l i b / t c l < t c l m a j o r > / < a r c h > ( p l a t f o r m - s p e c i f i c b o o t s t r a p l i b r a r i e s )
set src_bs_lib_arch [ file join $src_lib_base bootsupport lib tcl$tclmajorv $platform ]
if { [ file isdirectory $src_bs_lib_arch ] } {
if { $src_bs_lib_arch ni $auto_path_additions_src } {
lappend auto_path_additions_src $src_bs_lib_arch
}
}
}
# - - - - - - - - - - - - - - - - - - - - - - -
# s p l i t e x i s t i n g : : a u t o _ p a t h e n t r i e s i n t o i n t e r n a l & e x t e r n a l
set internal_ap_dirs [ list ] ; #
@ -703,6 +950,13 @@ apply { args {
}
}
}
src {
foreach n $auto_path_additions_src {
if { $n ni $new_auto_path } {
lappend new_auto_path $n
}
}
}
os {
foreach n $external_ap_dirs {
if { $n ni $new_auto_path } {
@ -857,49 +1111,261 @@ apply { args {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# N o w t h a t n e w ' p a c k a g e u n k n o w n ' m e c h a n i s m i s i n p l a c e - w e c a n u s e p a c k a g e r e q u i r e
# a s s e r t a r g l i s t h a s h a d ' d e v | o s | o s - d e v e t c ' f i r s t a r g r e m o v e d i f i t w a s p r e s e n t .
if { [ llength $arglist ] == 1 && [ lindex $arglist 0 ] eq " t c l s h " } {
# c a l l e d a s < e x e c u t a b l e > d e v t c l s h o r < e x e c u t a b l e > t c l s h
# w e w o u l d l i k e t o d r o p t h r o u g h t o s t a n d a r d t c l s h r e p l w i t h o u t l a u n c h i n g a n o t h e r p r o c e s s
# t c l M a i n . c d o e s n ' t a l l o w i t u n l e s s p a t c h e d .
if { ! [ info exists : : env( TCLSH_PIPEREPL ) ] } {
set is_tclsh_piperepl_env_true 0
} else {
if { [ string is boolean - strict $::env ( TCLSH_PIPEREPL ) ] } {
set is_tclsh_piperepl_env_true $::env ( TCLSH_PIPEREPL )
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# s r c m o d e : r e g i s t e r # m o d p o d m o d u l e s f r o m s r c / m o d u l e s v i a p a c k a g e i f n e e d e d
# a n d s e t p a c k a g e p r e f e r l a t e s t s o 9 9 9 9 9 9 . 0 a 1 . 0 d e v m o d u l e s a r e p r e f e r r e d
# o v e r s t a b l e b o o t s u p p o r t / v e n d o r e d c o p i e s o n u n v e r s i o n e d p a c k a g e r e q u i r e .
# U s e s o n l y T c l b u i l t i n s ( g l o b , f i l e , s t r i n g ) s i n c e n o p u n k m o d u l e s a r e l o a d e d y e t .
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if { " s r c " in $package_modes && [ info exists src_project_root] && $src_project_root ne " " } {
# p a c k a g e p r e f e r l a t e s t i s s e t h e r e s o 9 9 9 9 9 9 . 0 a 1 . 0 d e v m o d u l e s a r e p r e f e r r e d
# o v e r s t a b l e b o o t s u p p o r t / v e n d o r e d c o p i e s o n u n v e r s i o n e d p a c k a g e r e q u i r e .
# T h i s m u s t b e s e t a f t e r l i b u n k n o w n : : i n i t ( w h i c h m a y r e s e t t h e p r e f e r e n c e t o s t a b l e )
# a n d b e f o r e a n y p a c k a g e r e q u i r e c a l l s i n t h e s u b c o m m a n d h a n d l e r b e l o w .
# W e s e t i t a g a i n j u s t b e f o r e s u b c o m m a n d d i s p a t c h t o e n s u r e i t i s n ' t o v e r r i d d e n .
# i n l i n e # m o d p o d s c a n n e r — e q u i v a l e n t t o p u n k : : t c l t e s t r u n : : t m _ p a t h _ a d d i t i o n a l _ i f n e e d e d
# b u t u s i n g o n l y T c l b u i l t i n s s i n c e p u n k : : p a t h i s n ' t l o a d e d a t b o o t t i m e .
set src_modules_dir [ file join $src_project_root src modules]
set modpod_count 0
if { [ file isdirectory $src_modules_dir ] } {
# r e c u r s i v e g l o b f o r # m o d p o d - * d i r e c t o r i e s ( T c l 8 . 6 + s u p p o r t s * * i n g l o b )
set modpod_dirs [ list ]
foreach found [ glob - nocomplain - type d - directory $src_modules_dir ** # modpod-* ] {
# s k i p _ b u i l d s u b d i r e c t o r i e s
if { [ string match " * _ b u i l d * " $found ] } { continue }
lappend modpod_dirs $found
}
foreach modpod_dir $modpod_dirs {
set tail [ file tail $modpod_dir ]
# d i r e c t o r y n a m e f o r m a t : # m o d p o d - < m o d n a m e > - < v e r s i o n >
# s t r i p l e a d i n g " # m o d p o d - " ( 8 c h a r s ) , t h e n s p l i t o n l a s t " - " t o s e p a r a t e m o d n a m e f r o m v e r s i o n
set rest [ string range $tail 8 end]
set last_dash [ string last " - " $rest ]
if { $last_dash < 0 } { continue }
set modname [ string range $rest 0 [ expr { $last_dash - 1 } ] ]
set modver [ string range $rest [ expr { $last_dash + 1 } ] end]
set modpath [ file join $modpod_dir " $ m o d n a m e - $ m o d v e r . t m " ]
# c o m p u t e f u l l y q u a l i f i e d m o d u l e n a m e f r o m p a t h r e l a t i v e t o s r c / m o d u l e s
# f i l e r e l a t i v e i s n ' t a v a i l a b l e i n a l l T c l b u i l d s a t b o o t t i m e , s o c o m p u t e m a n u a l l y
set reldir " "
set checkdir $modpod_dir
set base $src_modules_dir
# w a l k u p f r o m m o d p o d _ d i r u n t i l w e r e a c h s r c / m o d u l e s , c o l l e c t i n g p a t h c o m p o n e n t s
while { $checkdir ne $base && $checkdir ne " " } {
set reldir [ linsert $reldir 0 [ file tail $checkdir ] ]
set checkdir [ file dirname $checkdir ]
}
if { $reldir eq " " } {
set fullmodname $modname
} else {
set fullmodname [ join $reldir : : ] : : $modname
}
if { [ file exists $modpath ] } {
eval [ list package ifneeded $fullmodname $modver [ list source $modpath ] ]
incr modpod_count
}
}
if { $modpod_count > 0 } {
puts stderr " s r c m o d e : r e g i s t e r e d $ m o d p o d _ c o u n t # m o d p o d m o d u l e [ e x p r { $ m o d p o d _ c o u n t = = 1 ? " " : " s " } ] f r o m $ s r c _ m o d u l e s _ d i r "
}
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# s r c m o d e : s e t p a c k a g e p r e f e r l a t e s t a s l a t e a s p o s s i b l e ( a f t e r l i b u n k n o w n : : i n i t
# w h i c h m a y r e s e t i t t o s t a b l e ) s o 9 9 9 9 9 9 . 0 a 1 . 0 d e v m o d u l e s a r e p r e f e r r e d o v e r
# s t a b l e b o o t s u p p o r t / v e n d o r e d c o p i e s o n u n v e r s i o n e d p a c k a g e r e q u i r e .
if { " s r c " in $package_modes } {
package prefer latest
# F o r c e a s c a n o f a l l t c l : : t m : : l i s t p a t h s b y t r i g g e r i n g p a c k a g e u n k n o w n .
# T h e V F S - b u n d l e d s t a b l e v e r s i o n s ( e . g p u n k 0 . 1 . 1 ) a r e a l r e a d y r e g i s t e r e d
# f r o m T c l ' s i n i t , s o p a c k a g e r e q u i r e f o r t h o s e p a c k a g e s w o u l d n e v e r c a l l
# p a c k a g e u n k n o w n — m e a n i n g 9 9 9 9 9 9 . 0 a 1 . 0 d e v v e r s i o n s i n s r c / m o d u l e s w o u l d
# n e v e r b e d i s c o v e r e d . T h i s d u m m y r e q u i r e f o r c e s p a c k a g e u n k n o w n t o s c a n
# a l l t m p a t h s a n d r e g i s t e r a l l i f n e e d e d s c r i p t s , i n c l u d i n g t h e d e v v e r s i o n s .
# A f t e r t h i s , p a c k a g e p r e f e r l a t e s t w i l l s e l e c t 9 9 9 9 9 9 . 0 a 1 . 0 o v e r 0 . 1 . 1 .
catch { package require __src_mode_tm_scan__}
}
# t c l s h , s h e l l s p y , p u n k , s c r i p t , s h e l l
set subcommand [ lindex $arglist 0 ]
switch - - $subcommand {
tclsh - shellspy - punk - shell - script {
set subcommand_arglist [ lrange $arglist 1 end]
}
default {
set subcommand_arglist $arglist
if { [ llength $subcommand_arglist ] } {
set subcommand script
} else {
set is_tclsh_piperepl_env_true 0
set subcommand shell
}
}
if { ! $is_tclsh_piperepl_env_true } {
puts stderr " t c l _ i n t e r a c t i v e : $ : : t c l _ i n t e r a c t i v e "
puts stderr " s t d i n : [ c h a n c o n f i g u r e s t d i n ] "
puts stderr " E n v i r o n m e n t v a r i a b l e T C L S H _ P I P E R E P L i s n o t s e t o r i s f a l s e o r i s n o t a b o o l e a n "
} else {
# a c c o r d i n g t o e n v T C L S H _ P I P E R E P L a n d o u r c o m m a n d l i n e a r g u m e n t - t c l s h r e p l i s d e s i r e d
# c h e c k i f t c l s h / p u n k h a s h a d t h e p i p e r e p l p a t c h a p p l i e d - i n w h i c h c a s e t c l s h ( i s t t y ) s h o u l d e x i s t
if { ! [ info exists : : tclsh( istty ) ] } {
puts stderr " e r r o r : t h e r u n t i m e d o e s n ' t a p p e a r t o h a v e b e e n c o m p i l e d w i t h t h e p i p e r e p l p a t c h "
}
}
set : : tcl_interactive 1
set : : tclsh( dorepl ) 1
} elseif { [ lindex $arglist 0 ] eq " s h e l l s p y " } {
# p a s s t h r o u g h t o s h e l l s p y c o m m a n d l i n e p r o c e s s o r
# p u t s s t d o u t " m a i n . t c l l a u n c h i n g a p p - s h e l l s p y "
package require app-shellspy
} elseif { [ llength $arglist ] } {
package require app-punkshell
} else {
# p u n k s h e l l
# t o d o l o g g e r ?
# p u t s s t d o u t " m a i n . t c l l a u n c h i n g a p p - p u n k . p k g n a m e s c o u n t : [ l l e n g t h [ p a c k a g e n a m e s ] ] "
# p u t s " > > $ : : a u t o _ p a t h "
# p u t s " > > > [ t c l : : t m : : l i s t ] "
# p u t s " > > > > [ p a c k a g e u n k n o w n ] "
package require app-punk
# a p p - p u n k s t a r t s r e p l
# r e p l : : s t a r t s t d i n - t i t l e " m a i n . t c l "
}
set : : argv $subcommand_arglist
set : : argc [ llength $subcommand_arglist ]
switch - - $subcommand {
tclsh {
# c a l l e d a s < e x e c u t a b l e > d e v t c l s h o r < e x e c u t a b l e > t c l s h
# w e w o u l d l i k e t o d r o p t h r o u g h t o s t a n d a r d t c l s h r e p l w i t h o u t l a u n c h i n g a n o t h e r p r o c e s s
# t c l M a i n . c d o e s n ' t a l l o w i t u n l e s s p a t c h e d .
if { ! [ info exists : : env( TCLSH_PIPEREPL ) ] } {
set is_tclsh_piperepl_env_true 1
} else {
if { [ string is boolean - strict $::env ( TCLSH_PIPEREPL ) ] } {
set is_tclsh_piperepl_env_true $::env ( TCLSH_PIPEREPL )
} else {
set is_tclsh_piperepl_env_true 1
}
}
if { $is_tclsh_piperepl_env_true && ! [ info exists : : tclsh( istty ) ] } {
# r u n t i m e l a c k s t h e p i p e r e p l p a t c h ( a p a t c h e d r u n t i m e w i t h t h e g a t e o p e n
# p u b l i s h e s : : t c l s h ( i s t t y ) b e f o r e t h i s s c r i p t r u n s ) . I n f o r m a t i o n a l o n l y :
# s c r i p t - a r g a n d p i p e d f o r m s w o r k r e g a r d l e s s ; t h e i n t e r a c t i v e r e p l f o r m
# f a i l s f a s t b e l o w . A d e l i b e r a t e T C L S H _ P I P E R E P L = 0 o p t - o u t s t a y s q u i e t .
puts stderr " n o t e : t h e r u n t i m e d o e s n ' t a p p e a r t o h a v e b e e n c o m p i l e d w i t h t h e p i p e r e p l p a t c h "
}
# s t o c k t c l s h a r g u m e n t f o r m s ( t c l M a i n . c ) : t h e o n l y r e c o g n i s e d l e a d i n g o p t i o n i s
# ' - e n c o d i n g n a m e f i l e N a m e ' ( a n d o n l y w h e n f i l e N a m e d o e s n o t b e g i n w i t h ' - ' ) ;
# a n y o t h e r l e a d i n g ' - ' a r g u m e n t m e a n s N O s c r i p t f i l e - a l l a r g u m e n t s s t a y i n
# : : a r g v ( a l r e a d y s e t a b o v e ) a n d t c l s h p r o c e e d s t o t h e r e p l ( t t y ) o r s t d i n
# e v a l u a t i o n ( p i p e d ) .
set tclsh_have_script 0
set tclsh_encoding " "
if { [ llength $subcommand_arglist ] >= 3 && [ lindex $subcommand_arglist 0 ] eq " - e n c o d i n g " && ! [ string match - * [ lindex $subcommand_arglist 2 ] ] } {
set tclsh_encoding [ lindex $subcommand_arglist 1 ]
set tclsh_script [ lindex $subcommand_arglist 2 ]
set tclsh_scriptargs [ lrange $subcommand_arglist 3 end]
set tclsh_have_script 1
} elseif { [ llength $subcommand_arglist ] && ! [ string match - * [ lindex $subcommand_arglist 0 ] ] } {
set tclsh_script [ lindex $subcommand_arglist 0 ]
set tclsh_scriptargs [ lrange $subcommand_arglist 1 end]
set tclsh_have_script 1
}
if { $tclsh_have_script } {
if { [ string match - nocase lib:* $tclsh_script ] } {
# s c r i p t l i b r e s o l u t i o n i s a p u n k f a c i l i t y - t h e t c l s h s u b c o m m a n d k e e p s p l a i n
# t c l s h s e m a n t i c s ( n o p u n k m o d u l e s l o a d e d ) , s o p o i n t a t t h e ' s c r i p t ' s u b c o m m a n d
# i n s t e a d o f f a i l i n g o n a l i t e r a l ' l i b : . . . ' p a t h ( i l l e g a l o n w i n d o w s f i l e s y s t e m s
# a n y w a y ; r e a c h a b l e v i a . / l i b : . . . o r a n a b s o l u t e p a t h o n o t h e r p l a t f o r m s ) .
set exebase [ file rootname [ file tail [ info nameofexecutable] ] ]
puts stderr " p u n k t c l s h : ' l i b : ' s c r i p t l i b r e s o l u t i o n i s n o t s u p p o r t e d b y t h e t c l s h s u b c o m m a n d ( p l a i n t c l s h s e m a n t i c s ) "
puts stderr " u s e : $ e x e b a s e s c r i p t $ t c l s h _ s c r i p t ? a r g s . . . ? "
exit 1
}
set normscript [ file normalize $tclsh_script ]
if { ! [ file exists $normscript ] } {
# n o t - f o u n d g e t s a c l e a n m e s s a g e ( ' s c r i p t ' s u b c o m m a n d c o h e r e n c e ) ; e r r o r s
# f r o m a n e x i s t i n g s c r i p t k e e p t h e i r f u l l t r a c e
puts stderr " p u n k t c l s h : s c r i p t f i l e n o t f o u n d : ' $ n o r m s c r i p t ' "
exit 1
}
info script $normscript
set : : argv0 $normscript
set : : argv $tclsh_scriptargs
set : : argc [ llength $::argv ]
# w e a r e i n a n a p p l y c o n t e x t h e r e - s o w e n e e d t o u p l e v e l t o g e t t h e s o u r c e t o w o r k a s e x p e c t e d
if { $tclsh_encoding ne " " } {
uplevel 1 [ list source - encoding $tclsh_encoding $tclsh_script ]
} else {
uplevel 1 [ list source $tclsh_script ]
}
# d e f a u l t t c l s h b e h a v i o u r i s t o r u n t h e s c r i p t a n d e x i t
# t h e s c r i p t c a n s e t : : t c l s h ( d o r e p l ) 1 t o f o r c e t h e t c l s h r e p l a f t e r t h e s c r i p t h a s r u n
} else {
# n o s c r i p t f i l e : a l l a r g u m e n t s ( i f a n y ) a r e a l r e a d y i n : : a r g v , m a t c h i n g
# s t o c k t c l s h ; a r g v 0 i s t h e e x e c u t a b l e i t s e l f , n o t t h e k i t b o o t s c r i p t
set : : argv0 [ info nameofexecutable]
if { [ info exists : : tclsh( istty ) ] } {
if { $::tclsh ( istty ) } {
# t c l s h p i p e r e p l p a t c h a p p l i e d - s t d i n i s a t t y - w e c a n r u n t h e t c l s h r e p l
set : : tclsh( dorepl ) 1
set : : tcl_interactive 1
} else {
# s t d i n i s n o t a t t y - p i p e d i n p u t i s e v a l u a t e d a s a s c r i p t , t h e n e x i t
set : : tclsh( dorepl ) 0
set : : tcl_interactive 0
# s c r i p t o n s t d i n c o u l d s e t : : t c l s h ( d o r e p l ) 1 t o f o r c e t h e t c l s h r e p l a f t e r t h e s c r i p t h a s r u n
set data [ read stdin]
uplevel 1 [ list eval $data ]
}
} else {
# n o p i p e r e p l m a c h i n e r y ( u n p a t c h e d r u n t i m e , o r T C L S H _ P I P E R E P L = 0 ) : t h e
# i n t e r a c t i v e r e p l i s u n a v a i l a b l e . F a i l f a s t o n t e r m i n a l s t d i n i n s t e a d o f
# b l o c k i n g i n a r a w c o n s o l e r e a d ( a p p - p u n k s c r i p t t e r m i n a l - p r o b e p r e c e d e n t ) ;
# p i p e d / r e d i r e c t e d s t d i n k e e p s t h e e v a l u a t e - a n d - e x i t b e h a v i o u r .
set conf " "
catch { set conf [ chan configure stdin] }
if { [ dict exists $conf - inputmode] || [ dict exists $conf - mode] } {
set exebase [ file rootname [ file tail [ info nameofexecutable] ] ]
puts stderr " p u n k t c l s h : t h e i n t e r a c t i v e t c l s h r e p l r e q u i r e s a p i p e r e p l - c a p a b l e r u n t i m e ( t h i s r u n t i m e l a c k s t h e p a t c h , o r T C L S H _ P I P E R E P L = 0 ) "
puts stderr " u s a g e : < c o m m a n d s > | $ e x e b a s e t c l s h "
puts stderr " o r : $ e x e b a s e t c l s h < s c r i p t f i l e > ? a r g s . . . ? "
exit 1
}
set : : tcl_interactive 0
set data [ read stdin]
uplevel 1 [ list eval $data ]
}
}
}
shellspy {
# p a s s t h r o u g h t o s h e l l s p y c o m m a n d l i n e p r o c e s s o r
package require app-shellspy
}
punk {
# T h e p u n k e x e c u t a b l e m u s t a l s o s u p p o r t r u n n i n g c o m m a n d s p i p e d i n t o s t d i n .
# e . g e c h o " p u t s h e l l o " | p u n k
# e . g f r o m a n o t h e r t c l s h - b a s e d s h e l l :
# e x e c p u n k < < { p u t s h e l l o }
# N o t e t h a t i f t h e p u n k e x e c u t a b l e o u t p u t s a n y t h i n g t o s t d e r r - e x e c b y d e f a u l t w i l l t r e a t t h e c o m m a n d a s h a v i n g f a i l e d a n d w i l l t h r o w a n e r r o r .
# S o t h e p u n k e x e c u t a b l e s h o u l d a v o i d o u t p u t t i n g t o s t d e r r u n l e s s i t i s a n a c t u a l e r r o r c o n d i t i o n .
# Y o u c a n w o r k a r o u n d t h i s b y p a s s i n g - i g n o r e s t d e r r t o e x e c , b u t f o r t o o l s l i k e ' b e n c h : : l o c a t e ' w e n e e d c l e a n o u t p u t .
# ( e . g b e n c h : : l o c a t e u s e s :
# i f { [ c a t c h { e x e c $ i p < < " e x i t " } r e s u l t ] } { . . . }
# )
if { [ llength $subcommand_arglist ] } {
# p u t s s t d o u t " m a i n . t c l l a u n c h i n g a p p - p u n k s h e l l w i t h a r g s : $ s u b c o m m a n d _ a r g l i s t "
package require app-punkshell
} else {
# p u n k i n t e r a c t i v e s h e l l
package require app-repl
}
}
script {
# r u n a s c r i p t ( f i l e a r g u m e n t , o r p i p e d s t d i n w h e n n o a r g u m e n t ) a n d e x i t - g o a l G - 0 1 5
# l e a n d e d i c a t e d a p p p a c k a g e : d e f a u l t p u n k s h e l l m o d u l e / a l i a s e n v i r o n m e n t ,
# n o s h e l l f i l t e r s t a c k s / t r a n s f o r m s , n o i n t e r a c t i v e f a l l b a c k , h o n e s t e x i t c o d e s .
# T h e l a u n c h p l u m b i n g m u s t e m i t n o t h i n g o n s t d o u t / s t d e r r ( e x e c - s t y l e c a l l e r s ) .
set : : tcl_interactive 0
package require app-punkscript
}
shell {
# a p p - p u n k s h e l l s u p p o r t s r u n n i n g a s c r i p t a n d m a i n t a i n i n g a n i n t e r a c t i v e s h e l l a f t e r w a r d s
# o r j u s t l a u n c h i n g a n i n t e r a c t i v e s h e l l i f n o s c r i p t i s s p e c i f i e d
package require app-punkshell
# i f { [ l l e n g t h $ s u b c o m m a n d _ a r g l i s t ] } {
# # r u n s c r i p t a n d m a i n t a i n i n t e r a c t i v e s h e l l .
# p a c k a g e r e q u i r e a p p - p u n k s h e l l
# } e l s e {
# # p u n k i n t e r a c t i v e s h e l l
# p a c k a g e r e q u i r e a p p - r e p l
# }
}
}
# i f { [ l l e n g t h $ a r g l i s t ] = = 1 & & [ l i n d e x $ a r g l i s t 0 ] e q " t c l s h " } {
# } e l s e i f { [ l i n d e x $ a r g l i s t 0 ] e q " s h e l l s p y " } {
# } e l s e i f { [ l l e n g t h $ a r g l i s t ] } {
# } e l s e {
# }
} } { * } $::argv
