Julian Noble
3 months ago
76 changed files with 17557 additions and 9669 deletions
@ -1,67 +1,67 @@ |
|||||||
|
|
||||||
#bootsupport modules can be pulled in from within other areas of src or from the built module folders of the project |
#bootsupport modules can be pulled in from within other areas of src or from the built module folders of the project |
||||||
#They must be already built, so generally shouldn't come directly from src/modules. |
#They must be already built, so generally shouldn't come directly from src/modules. |
||||||
|
|
||||||
#each entry - base module |
#each entry - base module |
||||||
set bootsupport_modules [list\ |
set bootsupport_modules [list\ |
||||||
src/vendormodules cksum\ |
src/vendormodules cksum\ |
||||||
src/vendormodules modpod\ |
src/vendormodules modpod\ |
||||||
src/vendormodules overtype\ |
src/vendormodules overtype\ |
||||||
src/vendormodules oolib\ |
src/vendormodules oolib\ |
||||||
src/vendormodules http\ |
src/vendormodules http\ |
||||||
src/vendormodules dictutils\ |
src/vendormodules dictutils\ |
||||||
src/vendormodules fileutil\ |
src/vendormodules fileutil\ |
||||||
src/vendormodules textutil::adjust\ |
src/vendormodules textutil::adjust\ |
||||||
src/vendormodules textutil::repeat\ |
src/vendormodules textutil::repeat\ |
||||||
src/vendormodules textutil::split\ |
src/vendormodules textutil::split\ |
||||||
src/vendormodules textutil::string\ |
src/vendormodules textutil::string\ |
||||||
src/vendormodules textutil::tabify\ |
src/vendormodules textutil::tabify\ |
||||||
src/vendormodules textutil::trim\ |
src/vendormodules textutil::trim\ |
||||||
src/vendormodules textutil::wcswidth\ |
src/vendormodules textutil::wcswidth\ |
||||||
src/vendormodules uuid\ |
src/vendormodules uuid\ |
||||||
src/vendormodules md5\ |
src/vendormodules md5\ |
||||||
src/vendormodules sha1\ |
src/vendormodules sha1\ |
||||||
src/vendormodules tomlish\ |
src/vendormodules tomlish\ |
||||||
src/vendormodules test::tomlish\ |
src/vendormodules test::tomlish\ |
||||||
modules punkcheck\ |
modules punkcheck\ |
||||||
modules natsort\ |
modules natsort\ |
||||||
modules punk::ansi\ |
modules punk::ansi\ |
||||||
modules punk::assertion\ |
modules punk::assertion\ |
||||||
modules punk::args\ |
modules punk::args\ |
||||||
modules punk::cap\ |
modules punk::cap\ |
||||||
modules punk::cap::handlers::caphandler\ |
modules punk::cap::handlers::caphandler\ |
||||||
modules punk::cap::handlers::scriptlibs\ |
modules punk::cap::handlers::scriptlibs\ |
||||||
modules punk::cap::handlers::templates\ |
modules punk::cap::handlers::templates\ |
||||||
modules punk::char\ |
modules punk::char\ |
||||||
modules punk::console\ |
modules punk::console\ |
||||||
modules punk::du\ |
modules punk::du\ |
||||||
modules punk::encmime\ |
modules punk::encmime\ |
||||||
modules punk::fileline\ |
modules punk::fileline\ |
||||||
modules punk::docgen\ |
modules punk::docgen\ |
||||||
modules punk::lib\ |
modules punk::lib\ |
||||||
modules punk::mix\ |
modules punk::mix\ |
||||||
modules punk::mix::base\ |
modules punk::mix::base\ |
||||||
modules punk::mix::cli\ |
modules punk::mix::cli\ |
||||||
modules punk::mix::util\ |
modules punk::mix::util\ |
||||||
modules punk::mix::templates\ |
modules punk::mix::templates\ |
||||||
modules punk::mix::commandset::buildsuite\ |
modules punk::mix::commandset::buildsuite\ |
||||||
modules punk::mix::commandset::debug\ |
modules punk::mix::commandset::debug\ |
||||||
modules punk::mix::commandset::doc\ |
modules punk::mix::commandset::doc\ |
||||||
modules punk::mix::commandset::layout\ |
modules punk::mix::commandset::layout\ |
||||||
modules punk::mix::commandset::loadedlib\ |
modules punk::mix::commandset::loadedlib\ |
||||||
modules punk::mix::commandset::module\ |
modules punk::mix::commandset::module\ |
||||||
modules punk::mix::commandset::project\ |
modules punk::mix::commandset::project\ |
||||||
modules punk::mix::commandset::repo\ |
modules punk::mix::commandset::repo\ |
||||||
modules punk::mix::commandset::scriptwrap\ |
modules punk::mix::commandset::scriptwrap\ |
||||||
modules punk::ns\ |
modules punk::ns\ |
||||||
modules punk::overlay\ |
modules punk::overlay\ |
||||||
modules punk::path\ |
modules punk::path\ |
||||||
modules punk::repo\ |
modules punk::repo\ |
||||||
modules punk::tdl\ |
modules punk::tdl\ |
||||||
modules punk::zip\ |
modules punk::zip\ |
||||||
modules punk::winpath\ |
modules punk::winpath\ |
||||||
modules textblock\ |
modules textblock\ |
||||||
modules natsort\ |
modules natsort\ |
||||||
modules oolib\ |
modules oolib\ |
||||||
] |
] |
||||||
|
|
||||||
|
@ -1,200 +0,0 @@ |
|||||||
#JMN - api should be kept in sync with package patternlib where possible |
|
||||||
# |
|
||||||
package provide oolib [namespace eval oolib { |
|
||||||
variable version |
|
||||||
set version 0.1.1 |
|
||||||
}] |
|
||||||
|
|
||||||
namespace eval oolib { |
|
||||||
oo::class create collection { |
|
||||||
variable o_data ;#dict |
|
||||||
variable o_alias |
|
||||||
constructor {} { |
|
||||||
set o_data [dict create] |
|
||||||
} |
|
||||||
method info {} { |
|
||||||
return [dict info $o_data] |
|
||||||
} |
|
||||||
method count {} { |
|
||||||
return [dict size $o_data] |
|
||||||
} |
|
||||||
method isEmpty {} { |
|
||||||
expr {[dict size $o_data] == 0} |
|
||||||
} |
|
||||||
method names {{globOrIdx {}}} { |
|
||||||
if {[llength $globOrIdx]} { |
|
||||||
if {[string is integer -strict $globOrIdx]} { |
|
||||||
set idx $globOrIdx |
|
||||||
if {$idx < 0} { |
|
||||||
set idx "end-[expr {abs($idx + 1)}]" |
|
||||||
} |
|
||||||
if {[catch {lindex [dict keys $o_data] $idx} result]} { |
|
||||||
error "[self object] no such index : '$idx'" |
|
||||||
} else { |
|
||||||
return $result |
|
||||||
} |
|
||||||
} else { |
|
||||||
#glob |
|
||||||
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] |
|
||||||
} |
|
||||||
} else { |
|
||||||
return [dict keys $o_data] |
|
||||||
} |
|
||||||
} |
|
||||||
#like names but without globbing |
|
||||||
method keys {} { |
|
||||||
dict keys $o_data |
|
||||||
} |
|
||||||
method key {{posn 0}} { |
|
||||||
if {$posn < 0} { |
|
||||||
set posn "end-[expr {abs($posn + 1)}]" |
|
||||||
} |
|
||||||
if {[catch {lindex [dict keys $o_data] $posn} result]} { |
|
||||||
error "[self object] no such index : '$posn'" |
|
||||||
} else { |
|
||||||
return $result |
|
||||||
} |
|
||||||
} |
|
||||||
method hasKey {key} { |
|
||||||
dict exists $o_data $key |
|
||||||
} |
|
||||||
method get {} { |
|
||||||
return $o_data |
|
||||||
} |
|
||||||
method items {} { |
|
||||||
return [dict values $o_data] |
|
||||||
} |
|
||||||
method item {key} { |
|
||||||
if {[string is integer -strict $key]} { |
|
||||||
if {$key >= 0} { |
|
||||||
set valposn [expr {(2*$key) +1}] |
|
||||||
return [lindex $o_data $valposn] |
|
||||||
} else { |
|
||||||
set key "end-[expr {abs($key + 1)}]" |
|
||||||
return [lindex $o_data $key] |
|
||||||
#return [lindex [dict keys $o_data] $key] |
|
||||||
} |
|
||||||
} |
|
||||||
if {[dict exists $o_data $key]} { |
|
||||||
return [dict get $o_data $key] |
|
||||||
} |
|
||||||
} |
|
||||||
#inverse lookup |
|
||||||
method itemKeys {value} { |
|
||||||
set value_indices [lsearch -all [dict values $o_data] $value] |
|
||||||
set keylist [list] |
|
||||||
foreach i $value_indices { |
|
||||||
set idx [expr {(($i + 1) *2) -2}] |
|
||||||
lappend keylist [lindex $o_data $idx] |
|
||||||
} |
|
||||||
return $keylist |
|
||||||
} |
|
||||||
method search {value args} { |
|
||||||
set matches [lsearch {*}$args [dict values $o_data] $value] |
|
||||||
if {"-inline" in $args} { |
|
||||||
return $matches |
|
||||||
} else { |
|
||||||
set keylist [list] |
|
||||||
foreach i $matches { |
|
||||||
set idx [expr {(($i + 1) *2) -2}] |
|
||||||
lappend keylist [lindex $o_data $idx] |
|
||||||
} |
|
||||||
return $keylist |
|
||||||
} |
|
||||||
} |
|
||||||
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? |
|
||||||
method alias {newAlias existingKeyOrAlias} { |
|
||||||
if {[string is integer -strict $newAlias]} { |
|
||||||
error "[self object] collection key alias cannot be integer" |
|
||||||
} |
|
||||||
if {[string length $existingKeyOrAlias]} { |
|
||||||
set o_alias($newAlias) $existingKeyOrAlias |
|
||||||
} else { |
|
||||||
unset o_alias($newAlias) |
|
||||||
} |
|
||||||
} |
|
||||||
method aliases {{key ""}} { |
|
||||||
if {[string length $key]} { |
|
||||||
set result [list] |
|
||||||
foreach {n v} [array get o_alias] { |
|
||||||
if {$v eq $key} { |
|
||||||
lappend result $n $v |
|
||||||
} |
|
||||||
} |
|
||||||
return $result |
|
||||||
} else { |
|
||||||
return [array get o_alias] |
|
||||||
} |
|
||||||
} |
|
||||||
#if the supplied index is an alias, return the underlying key; else return the index supplied. |
|
||||||
method realKey {idx} { |
|
||||||
if {[catch {set o_alias($idx)} key]} { |
|
||||||
return $idx |
|
||||||
} else { |
|
||||||
return $key |
|
||||||
} |
|
||||||
} |
|
||||||
method add {value key} { |
|
||||||
if {[string is integer -strict $key]} { |
|
||||||
error "[self object] collection key must not be an integer. Use another structure if integer keys required" |
|
||||||
} |
|
||||||
if {[dict exists $o_data $key]} { |
|
||||||
error "[self object] col_processors object error: key '$key' already exists in collection" |
|
||||||
} |
|
||||||
dict set o_data $key $value |
|
||||||
return [expr {[dict size $o_data] - 1}] ;#return index of item |
|
||||||
} |
|
||||||
method remove {idx {endRange ""}} { |
|
||||||
if {[string length $endRange]} { |
|
||||||
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" |
|
||||||
} |
|
||||||
if {[string is integer -strict $idx]} { |
|
||||||
if {$idx < 0} { |
|
||||||
set idx "end-[expr {abs($idx+1)}]" |
|
||||||
} |
|
||||||
set key [lindex [dict keys $o_data] $idx] |
|
||||||
set posn $idx |
|
||||||
} else { |
|
||||||
set key $idx |
|
||||||
set posn [lsearch -exact [dict keys $o_data] $key] |
|
||||||
if {$posn < 0} { |
|
||||||
error "[self object] no such index: '$idx' in this collection" |
|
||||||
} |
|
||||||
} |
|
||||||
dict unset o_data $key |
|
||||||
return |
|
||||||
} |
|
||||||
method clear {} { |
|
||||||
set o_data [dict create] |
|
||||||
return |
|
||||||
} |
|
||||||
method reverse_the_collection {} { |
|
||||||
#named slightly obtusely because reversing the data when there may be references held is a potential source of bugs |
|
||||||
#the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy. |
|
||||||
#todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations. |
|
||||||
set dictnew [dict create] |
|
||||||
foreach k [lreverse [dict keys $o_data]] { |
|
||||||
dict set dictnew $k [dict get $o_data $k] |
|
||||||
} |
|
||||||
set o_data $dictnew |
|
||||||
return |
|
||||||
} |
|
||||||
#review - cmd as list vs cmd as script? |
|
||||||
method map {cmd} { |
|
||||||
set seed [list] |
|
||||||
dict for {k v} $o_data { |
|
||||||
lappend seed [uplevel #0 [list {*}$cmd $v]] |
|
||||||
} |
|
||||||
return $seed |
|
||||||
} |
|
||||||
method objectmap {cmd} { |
|
||||||
set seed [list] |
|
||||||
dict for {k v} $o_data { |
|
||||||
lappend seed [uplevel #0 [list $v {*}$cmd]] |
|
||||||
} |
|
||||||
return $seed |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
} |
|
||||||
|
|
Binary file not shown.
File diff suppressed because it is too large
Load Diff
@ -1,9 +1,9 @@ |
|||||||
|
|
||||||
#bootsupport modules can be pulled in from within other areas of src or from the built module folders of the project |
#bootsupport modules can be pulled in from within other areas of src or from the built module folders of the project |
||||||
#They must be already built, so generally shouldn't come directly from src/modules. |
#They must be already built, so generally shouldn't come directly from src/modules. |
||||||
|
|
||||||
#each entry - base module |
#each entry - base module |
||||||
set bootsupport_modules [list\ |
set bootsupport_modules [list\ |
||||||
modules_tcl8 thread\ |
modules_tcl8 thread\ |
||||||
] |
] |
||||||
|
|
||||||
|
@ -0,0 +1,540 @@ |
|||||||
|
## -*- tcl -*- |
||||||
|
## |
||||||
|
## OO-based Tcl/PARAM implementation of the parsing |
||||||
|
## expression grammar |
||||||
|
## |
||||||
|
## calculator grammar |
||||||
|
## |
||||||
|
## Generated from file calctest.tcl |
||||||
|
## for user jnoble |
||||||
|
## |
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## Requirements |
||||||
|
|
||||||
|
package require Tcl 8.5 9 |
||||||
|
package require TclOO |
||||||
|
package require pt::rde::oo ; # OO-based implementation of the |
||||||
|
# PARAM virtual machine |
||||||
|
# underlying the Tcl/PARAM code |
||||||
|
# used below. |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## |
||||||
|
|
||||||
|
oo::class create calculator_test { |
||||||
|
# # ## ### ##### ######## ############# |
||||||
|
## Public API |
||||||
|
|
||||||
|
superclass pt::rde::oo ; # TODO - Define this class. |
||||||
|
# Or can we inherit from a snit |
||||||
|
# class too ? |
||||||
|
|
||||||
|
method parse {channel} { |
||||||
|
my reset $channel |
||||||
|
my MAIN ; # Entrypoint for the generated code. |
||||||
|
return [my complete] |
||||||
|
} |
||||||
|
|
||||||
|
method parset {text} { |
||||||
|
my reset {} |
||||||
|
my data $text |
||||||
|
my MAIN ; # Entrypoint for the generated code. |
||||||
|
return [my complete] |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ###### ######## ############# |
||||||
|
## BEGIN of GENERATED CODE. DO NOT EDIT. |
||||||
|
|
||||||
|
# |
||||||
|
# Grammar Start Expression |
||||||
|
# |
||||||
|
|
||||||
|
method MAIN {} { |
||||||
|
my sym_Expression |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# value Symbol 'AddOp' |
||||||
|
# |
||||||
|
|
||||||
|
method sym_AddOp {} { |
||||||
|
# [+-] |
||||||
|
|
||||||
|
my si:void_symbol_start AddOp |
||||||
|
my si:next_class +- |
||||||
|
my si:void_leaf_symbol_end AddOp |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# value Symbol 'Digit' |
||||||
|
# |
||||||
|
|
||||||
|
method sym_Digit {} { |
||||||
|
# [0123456789] |
||||||
|
|
||||||
|
my si:void_symbol_start Digit |
||||||
|
my si:next_class 0123456789 |
||||||
|
my si:void_leaf_symbol_end Digit |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# value Symbol 'Expression' |
||||||
|
# |
||||||
|
|
||||||
|
method sym_Expression {} { |
||||||
|
# x |
||||||
|
# (Term) |
||||||
|
# * |
||||||
|
# x |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (AddOp) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Term) |
||||||
|
|
||||||
|
my si:value_symbol_start Expression |
||||||
|
my sequence_18 |
||||||
|
my si:reduce_symbol_end Expression |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method sequence_18 {} { |
||||||
|
# x |
||||||
|
# (Term) |
||||||
|
# * |
||||||
|
# x |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (AddOp) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Term) |
||||||
|
|
||||||
|
my si:value_state_push |
||||||
|
my sym_Term |
||||||
|
my si:valuevalue_part |
||||||
|
my kleene_16 |
||||||
|
my si:value_state_merge |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method kleene_16 {} { |
||||||
|
# * |
||||||
|
# x |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (AddOp) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Term) |
||||||
|
|
||||||
|
while {1} { |
||||||
|
my si:void2_state_push |
||||||
|
my sequence_14 |
||||||
|
my si:kleene_close |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method sequence_14 {} { |
||||||
|
# x |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (AddOp) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Term) |
||||||
|
|
||||||
|
my si:void_state_push |
||||||
|
my kleene_8 |
||||||
|
my si:voidvalue_part |
||||||
|
my sym_AddOp |
||||||
|
my si:valuevalue_part |
||||||
|
my kleene_8 |
||||||
|
my si:valuevalue_part |
||||||
|
my sym_Term |
||||||
|
my si:value_state_merge |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method kleene_8 {} { |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
|
||||||
|
while {1} { |
||||||
|
my si:void2_state_push |
||||||
|
my si:next_char \40 |
||||||
|
my si:kleene_close |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# value Symbol 'Factor' |
||||||
|
# |
||||||
|
|
||||||
|
method sym_Factor {} { |
||||||
|
# x |
||||||
|
# (Fragment) |
||||||
|
# * |
||||||
|
# x |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (PowOp) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Fragment) |
||||||
|
|
||||||
|
my si:value_symbol_start Factor |
||||||
|
my sequence_32 |
||||||
|
my si:reduce_symbol_end Factor |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method sequence_32 {} { |
||||||
|
# x |
||||||
|
# (Fragment) |
||||||
|
# * |
||||||
|
# x |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (PowOp) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Fragment) |
||||||
|
|
||||||
|
my si:value_state_push |
||||||
|
my sym_Fragment |
||||||
|
my si:valuevalue_part |
||||||
|
my kleene_30 |
||||||
|
my si:value_state_merge |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method kleene_30 {} { |
||||||
|
# * |
||||||
|
# x |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (PowOp) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Fragment) |
||||||
|
|
||||||
|
while {1} { |
||||||
|
my si:void2_state_push |
||||||
|
my sequence_28 |
||||||
|
my si:kleene_close |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method sequence_28 {} { |
||||||
|
# x |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (PowOp) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Fragment) |
||||||
|
|
||||||
|
my si:void_state_push |
||||||
|
my kleene_8 |
||||||
|
my si:voidvalue_part |
||||||
|
my sym_PowOp |
||||||
|
my si:valuevalue_part |
||||||
|
my kleene_8 |
||||||
|
my si:valuevalue_part |
||||||
|
my sym_Fragment |
||||||
|
my si:value_state_merge |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# value Symbol 'Fragment' |
||||||
|
# |
||||||
|
|
||||||
|
method sym_Fragment {} { |
||||||
|
# / |
||||||
|
# x |
||||||
|
# '\(' |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Expression) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# '\)' |
||||||
|
# (Number) |
||||||
|
# (Var) |
||||||
|
|
||||||
|
my si:value_symbol_start Fragment |
||||||
|
my choice_46 |
||||||
|
my si:reduce_symbol_end Fragment |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method choice_46 {} { |
||||||
|
# / |
||||||
|
# x |
||||||
|
# '\(' |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Expression) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# '\)' |
||||||
|
# (Number) |
||||||
|
# (Var) |
||||||
|
|
||||||
|
my si:value_state_push |
||||||
|
my sequence_42 |
||||||
|
my si:valuevalue_branch |
||||||
|
my sym_Number |
||||||
|
my si:valuevalue_branch |
||||||
|
my sym_Var |
||||||
|
my si:value_state_merge |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method sequence_42 {} { |
||||||
|
# x |
||||||
|
# '\(' |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Expression) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# '\)' |
||||||
|
|
||||||
|
my si:void_state_push |
||||||
|
my si:next_char \50 |
||||||
|
my si:voidvoid_part |
||||||
|
my kleene_8 |
||||||
|
my si:voidvalue_part |
||||||
|
my sym_Expression |
||||||
|
my si:valuevalue_part |
||||||
|
my kleene_8 |
||||||
|
my si:valuevalue_part |
||||||
|
my si:next_char \51 |
||||||
|
my si:value_state_merge |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# value Symbol 'MulOp' |
||||||
|
# |
||||||
|
|
||||||
|
method sym_MulOp {} { |
||||||
|
# [*/] |
||||||
|
|
||||||
|
my si:void_symbol_start MulOp |
||||||
|
my si:next_class */ |
||||||
|
my si:void_leaf_symbol_end MulOp |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# value Symbol 'Number' |
||||||
|
# |
||||||
|
|
||||||
|
method sym_Number {} { |
||||||
|
# x |
||||||
|
# ? |
||||||
|
# (Sign) |
||||||
|
# + |
||||||
|
# (Digit) |
||||||
|
|
||||||
|
my si:value_symbol_start Number |
||||||
|
my sequence_57 |
||||||
|
my si:reduce_symbol_end Number |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method sequence_57 {} { |
||||||
|
# x |
||||||
|
# ? |
||||||
|
# (Sign) |
||||||
|
# + |
||||||
|
# (Digit) |
||||||
|
|
||||||
|
my si:value_state_push |
||||||
|
my optional_52 |
||||||
|
my si:valuevalue_part |
||||||
|
my poskleene_55 |
||||||
|
my si:value_state_merge |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method optional_52 {} { |
||||||
|
# ? |
||||||
|
# (Sign) |
||||||
|
|
||||||
|
my si:void2_state_push |
||||||
|
my sym_Sign |
||||||
|
my si:void_state_merge_ok |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method poskleene_55 {} { |
||||||
|
# + |
||||||
|
# (Digit) |
||||||
|
|
||||||
|
my i_loc_push |
||||||
|
my sym_Digit |
||||||
|
my si:kleene_abort |
||||||
|
while {1} { |
||||||
|
my si:void2_state_push |
||||||
|
my sym_Digit |
||||||
|
my si:kleene_close |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# value Symbol 'PowOp' |
||||||
|
# |
||||||
|
|
||||||
|
method sym_PowOp {} { |
||||||
|
# "**" |
||||||
|
|
||||||
|
my si:void_symbol_start PowOp |
||||||
|
my si:next_str ** |
||||||
|
my si:void_leaf_symbol_end PowOp |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# value Symbol 'Sign' |
||||||
|
# |
||||||
|
|
||||||
|
method sym_Sign {} { |
||||||
|
# [-+] |
||||||
|
|
||||||
|
my si:void_symbol_start Sign |
||||||
|
my si:next_class -+ |
||||||
|
my si:void_leaf_symbol_end Sign |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# value Symbol 'Term' |
||||||
|
# |
||||||
|
|
||||||
|
method sym_Term {} { |
||||||
|
# x |
||||||
|
# (Factor) |
||||||
|
# * |
||||||
|
# x |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (MulOp) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Factor) |
||||||
|
|
||||||
|
my si:value_symbol_start Term |
||||||
|
my sequence_75 |
||||||
|
my si:reduce_symbol_end Term |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method sequence_75 {} { |
||||||
|
# x |
||||||
|
# (Factor) |
||||||
|
# * |
||||||
|
# x |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (MulOp) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Factor) |
||||||
|
|
||||||
|
my si:value_state_push |
||||||
|
my sym_Factor |
||||||
|
my si:valuevalue_part |
||||||
|
my kleene_73 |
||||||
|
my si:value_state_merge |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method kleene_73 {} { |
||||||
|
# * |
||||||
|
# x |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (MulOp) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Factor) |
||||||
|
|
||||||
|
while {1} { |
||||||
|
my si:void2_state_push |
||||||
|
my sequence_71 |
||||||
|
my si:kleene_close |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method sequence_71 {} { |
||||||
|
# x |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (MulOp) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Factor) |
||||||
|
|
||||||
|
my si:void_state_push |
||||||
|
my kleene_8 |
||||||
|
my si:voidvalue_part |
||||||
|
my sym_MulOp |
||||||
|
my si:valuevalue_part |
||||||
|
my kleene_8 |
||||||
|
my si:valuevalue_part |
||||||
|
my sym_Factor |
||||||
|
my si:value_state_merge |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# value Symbol 'Var' |
||||||
|
# |
||||||
|
|
||||||
|
method sym_Var {} { |
||||||
|
# x |
||||||
|
# '$' |
||||||
|
# [xyz] |
||||||
|
|
||||||
|
my si:void_symbol_start Var |
||||||
|
my sequence_80 |
||||||
|
my si:void_leaf_symbol_end Var |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method sequence_80 {} { |
||||||
|
# x |
||||||
|
# '$' |
||||||
|
# [xyz] |
||||||
|
|
||||||
|
my si:void_state_push |
||||||
|
my si:next_char $ |
||||||
|
my si:voidvoid_part |
||||||
|
my si:next_class xyz |
||||||
|
my si:void_state_merge |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
## END of GENERATED CODE. DO NOT EDIT. |
||||||
|
# # ## ### ###### ######## ############# |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## Ready |
||||||
|
|
||||||
|
package provide calculator_test 999999.0a1.0 |
||||||
|
return |
@ -0,0 +1,561 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::winlnk 999999.0a1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license MIT |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin shellspy_module_punk::winlnk 0 999999.0a1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {windows shortcut .lnk library}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {punk::winlnk}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::winlnk] |
||||||
|
#[keywords module shortcut lnk parse windows crossplatform] |
||||||
|
#[description] |
||||||
|
#[para] Tools for reading windows shortcuts (.lnk files) on any platform |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of punk::winlnk |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] Windows shortcuts are a binary format file with a .lnk extension |
||||||
|
#[para] Shell Link (.LNK) Binary File Format is documented in [MS_SHLLINK].pdf published by Microsoft. |
||||||
|
#[para] Revision 8.0 published 2024-04-23 |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by punk::winlnk |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6}] |
||||||
|
|
||||||
|
#TODO - logger |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#tcl::namespace::eval punk::winlnk::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::winlnk::class}] |
||||||
|
#[para] class definitions |
||||||
|
#if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { |
||||||
|
#*** !doctools |
||||||
|
#[list_begin enumerated] |
||||||
|
|
||||||
|
# oo::class create interface_sample1 { |
||||||
|
# #*** !doctools |
||||||
|
# #[enum] CLASS [class interface_sample1] |
||||||
|
# #[list_begin definitions] |
||||||
|
|
||||||
|
# method test {arg1} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# #[para] test method |
||||||
|
# puts "test: $arg1" |
||||||
|
# } |
||||||
|
|
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# } |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end class enumeration ---}] |
||||||
|
#} |
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::winlnk { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
#variable xyz |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::winlnk}] |
||||||
|
#[para] Core API functions for punk::winlnk |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
|
||||||
|
variable magic_HeaderSize "0000004C" ;#HeaderSize MUST equal this |
||||||
|
variable magic_LinkCLSID "00021401-0000-0000-C000-000000000046" ;#LinkCLSID MUST equal this |
||||||
|
|
||||||
|
proc Get_contents {path {bytes all}} { |
||||||
|
if {![file exists $path] || [file type $path] ne "file"} { |
||||||
|
error "punk::winlnk::get_contents cannot find a filesystem object of type 'file' at location: $path" |
||||||
|
} |
||||||
|
set fd [open $path r] |
||||||
|
chan configure $fd -translation binary -encoding iso8859-1 |
||||||
|
if {$bytes eq "all"} { |
||||||
|
set data [read $fd] |
||||||
|
} else { |
||||||
|
set data [read $fd $bytes] |
||||||
|
} |
||||||
|
close $fd |
||||||
|
return $data |
||||||
|
} |
||||||
|
proc Get_HeaderSize {contents} { |
||||||
|
set 4bytes [split [string range $contents 0 3] ""] |
||||||
|
set hex4 "" |
||||||
|
foreach b [lreverse $4bytes] { |
||||||
|
set dec [scan $b %c] ;# 0-255 decimal |
||||||
|
set HH [format %2.2llX $dec] |
||||||
|
append hex4 $HH |
||||||
|
} |
||||||
|
return $hex4 |
||||||
|
} |
||||||
|
proc Get_LinkCLSID {contents} { |
||||||
|
set 16bytes [string range $contents 4 19] |
||||||
|
#CLSID hex textual representation is split as 4-2-2-2-6 bytes(hex pairs) |
||||||
|
#e.g We expect 00021401-0000-0000-C000-000000000046 for .lnk files |
||||||
|
#for endianness - it is little endian all the way but the split is 4-2-2-1-1-1-1-1-1-1-1 REVIEW |
||||||
|
#(so it can appear as mixed endianness if you don't know the splits) |
||||||
|
#https://devblogs.microsoft.com/oldnewthing/20220928-00/?p=107221 |
||||||
|
#This is based on COM textual representation of GUIDS |
||||||
|
#Apparently a CLSID is a GUID that identifies a COM object |
||||||
|
set clsid "" |
||||||
|
set s1 [tcl::string::range $16bytes 0 3] |
||||||
|
set declist [scan [string reverse $s1] %c%c%c%c] |
||||||
|
set fmt "%02X%02X%02X%02X" |
||||||
|
append clsid [format $fmt {*}$declist] |
||||||
|
|
||||||
|
append clsid - |
||||||
|
set s2 [tcl::string::range $16bytes 4 5] |
||||||
|
set declist [scan [string reverse $s2] %c%c] |
||||||
|
set fmt "%02X%02X" |
||||||
|
append clsid [format $fmt {*}$declist] |
||||||
|
|
||||||
|
append clsid - |
||||||
|
set s3 [tcl::string::range $16bytes 6 7] |
||||||
|
set declist [scan [string reverse $s3] %c%c] |
||||||
|
append clsid [format $fmt {*}$declist] |
||||||
|
|
||||||
|
append clsid - |
||||||
|
#now treat bytes individually - so no endianness conversion |
||||||
|
set declist [scan [tcl::string::range $16bytes 8 9] %c%c] |
||||||
|
append clsid [format $fmt {*}$declist] |
||||||
|
|
||||||
|
append clsid - |
||||||
|
set scan [string repeat %c 6] |
||||||
|
set fmt [string repeat %02X 6] |
||||||
|
set declist [scan [tcl::string::range $16bytes 10 15] $scan] |
||||||
|
append clsid [format $fmt {*}$declist] |
||||||
|
|
||||||
|
return $clsid |
||||||
|
} |
||||||
|
proc Contents_check_header {contents} { |
||||||
|
variable magic_HeaderSize |
||||||
|
variable magic_LinkCLSID |
||||||
|
expr {[Get_HeaderSize $contents] eq $magic_HeaderSize && [Get_LinkCLSID $contents] eq $magic_LinkCLSID} |
||||||
|
} |
||||||
|
|
||||||
|
#LinkFlags - 4 bytes - specifies information about the shell link and the presence of optional portions of the structure. |
||||||
|
proc Show_LinkFlags {contents} { |
||||||
|
set 4bytes [string range $contents 20 23] |
||||||
|
set r [binary scan $4bytes i val] ;# i for little endian 32-bit signed int |
||||||
|
puts "val: $val" |
||||||
|
set declist [scan [string reverse $4bytes] %c%c%c%c] |
||||||
|
set fmt [string repeat %08b 4] |
||||||
|
puts "LinkFlags:[format $fmt {*}$declist]" |
||||||
|
|
||||||
|
set r [binary scan $4bytes b32 val] |
||||||
|
puts "bscan-le: $val" |
||||||
|
set r [binary scan [string reverse $4bytes] b32 val] |
||||||
|
puts "bscan-2 : $val" |
||||||
|
} |
||||||
|
proc Get_LinkFlags {contents} { |
||||||
|
set 4bytes [string range $contents 20 23] |
||||||
|
set r [binary scan $4bytes i val] ;# i for little endian 32-bit signed int |
||||||
|
return $val |
||||||
|
} |
||||||
|
variable LinkFlags |
||||||
|
set LinkFlags [dict create\ |
||||||
|
hasLinkTargetIDList 1\ |
||||||
|
HasLinkInfo 2\ |
||||||
|
HasName 4\ |
||||||
|
HasRelativePath 8\ |
||||||
|
HasWorkingDir 16\ |
||||||
|
HasArguments 32\ |
||||||
|
HasIconLocation 64\ |
||||||
|
IsUnicode 128\ |
||||||
|
ForceNoLinkInfo 256\ |
||||||
|
HasExpString 512\ |
||||||
|
RunInSeparateProcess 1024\ |
||||||
|
Unused1 2048\ |
||||||
|
HasDarwinID 4096\ |
||||||
|
RunAsUser 8192\ |
||||||
|
HasExpIcon 16394\ |
||||||
|
NoPidlAlias 32768\ |
||||||
|
Unused2 65536\ |
||||||
|
RunWithShimLayer 131072\ |
||||||
|
ForceNoLinkTrack 262144\ |
||||||
|
EnableTargetMetadata 524288\ |
||||||
|
DisableLinkPathTracking 1048576\ |
||||||
|
DisableKnownFolderTracking 2097152\ |
||||||
|
DisableKnownFolderAlias 4194304\ |
||||||
|
AllowLinkToLink 8388608\ |
||||||
|
UnaliasOnSave 16777216\ |
||||||
|
PreferEnvironmentPath 33554432\ |
||||||
|
KeepLocalIDListForUNCTarget 67108864\ |
||||||
|
] |
||||||
|
variable LinkFlagLetters [list A B C D E F G H I J K L M N O P Q R S T U V W X Y Z AA] |
||||||
|
proc Has_LinkFlag {contents flagname} { |
||||||
|
variable LinkFlags |
||||||
|
variable LinkFlagLetters |
||||||
|
if {[string length $flagname] <= 2} { |
||||||
|
set idx [lsearch $LinkFlagLetters $flagname] |
||||||
|
if {$idx < 0} { |
||||||
|
error "punk::winlnk::Has_LinkFlag error - flagname $flagname not known" |
||||||
|
} |
||||||
|
set binflag [expr {2**$idx}] |
||||||
|
set allflags [Get_LinkFlags $contents] |
||||||
|
return [expr {$allflags & $binflag}] |
||||||
|
} |
||||||
|
if {[dict exists $LinkFlags $flagname]} { |
||||||
|
set binflag [dict get $LinkFlags $flagname] |
||||||
|
set allflags [Get_LinkFlags $contents] |
||||||
|
return [expr {$allflags & $binflag}] |
||||||
|
} else { |
||||||
|
error "punk::winlnk::Has_LinkFlag error - flagname $flagname not known" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#https://github.com/libyal/liblnk/blob/main/documentation/Windows%20Shortcut%20File%20(LNK)%20format.asciidoc |
||||||
|
|
||||||
|
#offset 24 4 bytes |
||||||
|
#File attribute flags |
||||||
|
|
||||||
|
#offset 28 8 bytes |
||||||
|
#creation date and time |
||||||
|
|
||||||
|
#offset 36 8 bytes |
||||||
|
#last access date and time |
||||||
|
|
||||||
|
#offset 44 8 bytes |
||||||
|
#last modification date and time |
||||||
|
|
||||||
|
#offset 52 4 bytes - unsigned int |
||||||
|
#file size in bytes (of target) |
||||||
|
proc Get_FileSize {contents} { |
||||||
|
set 4bytes [string range $contents 52 55] |
||||||
|
set r [binary scan $4bytes i val] |
||||||
|
return $val |
||||||
|
} |
||||||
|
|
||||||
|
#offset 56 4 bytes signed integer |
||||||
|
#icon index value |
||||||
|
|
||||||
|
#offset 60 4 bytes - unsigned integer |
||||||
|
#SW_SHOWNORMAL 0x00000001 |
||||||
|
#SW_SHOWMAXIMIZED 0x00000001 |
||||||
|
#SW_SHOWMINNOACTIVE 0x00000007 |
||||||
|
# - all other values MUST be treated as SW_SHOWNORMAL |
||||||
|
proc Get_ShowCommand {contents} { |
||||||
|
set 4bytes [string range $contents 60 63] |
||||||
|
set r [binary scan $4bytes i val] |
||||||
|
return $val |
||||||
|
} |
||||||
|
|
||||||
|
#offset 64 Bytes 2 |
||||||
|
#Hot key |
||||||
|
|
||||||
|
#offset 66 2 bytes - reserved |
||||||
|
|
||||||
|
#offset 68 4 bytes - reserved |
||||||
|
|
||||||
|
#offset 72 4 bytes - reserved |
||||||
|
|
||||||
|
#next 76 |
||||||
|
|
||||||
|
proc Get_LinkTargetIDList_size {contents} { |
||||||
|
if {[Has_LinkFlag $contents "A"]} { |
||||||
|
set 2bytes [string range $contents 76 77] |
||||||
|
set r [binary scan $2bytes s val] ;#short |
||||||
|
#logger |
||||||
|
#puts stderr "LinkTargetIDList_size: $val" |
||||||
|
return $val |
||||||
|
} else { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} |
||||||
|
proc Get_LinkInfo_content {contents} { |
||||||
|
set idlist_size [Get_LinkTargetIDList_size $contents] |
||||||
|
if {$idlist_size == 0} { |
||||||
|
set offset 0 |
||||||
|
} else { |
||||||
|
set offset [expr {2 + $idlist_size}] ;#LinkTargetIdList IDListSize field + value |
||||||
|
} |
||||||
|
set linkinfo_start [expr {76 + $offset}] |
||||||
|
if {[Has_LinkFlag $contents B]} { |
||||||
|
#puts stderr "linkinfo_start: $linkinfo_start" |
||||||
|
set 4bytes [string range $contents $linkinfo_start $linkinfo_start+3] |
||||||
|
binary scan $4bytes i val ;#size *including* these 4 bytes |
||||||
|
set linkinfo_content [string range $contents $linkinfo_start [expr {$linkinfo_start + $val -1}]] |
||||||
|
return [dict create linkinfo_start $linkinfo_start size $val next_start [expr {$linkinfo_start + $val}] content $linkinfo_content] |
||||||
|
} else { |
||||||
|
return [dict create linkinfo_start $linkinfo_start size 0 next_start $linkinfo_start content ""] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc LinkInfo_get_fields {linkinfocontent} { |
||||||
|
set 4bytes [string range $linkinfocontent 0 3] |
||||||
|
binary scan $4bytes i val ;#size *including* these 4 bytes |
||||||
|
set bytes_linkinfoheadersize [string range $linkinfocontent 4 7] |
||||||
|
set bytes_linkinfoflags [string range $linkinfocontent 8 11] |
||||||
|
set r [binary scan $4bytes i flags] ;# i for little endian 32-bit signed int |
||||||
|
#puts "linkinfoflags: $flags" |
||||||
|
|
||||||
|
set localbasepath "" |
||||||
|
set commonpathsuffix "" |
||||||
|
|
||||||
|
#REVIEW - flags problem? |
||||||
|
if {$flags & 1} { |
||||||
|
#VolumeIDAndLocalBasePath |
||||||
|
#logger |
||||||
|
#puts stderr "VolumeIDAndLocalBasePath" |
||||||
|
} |
||||||
|
if {$flags & 2} { |
||||||
|
#logger |
||||||
|
#puts stderr "CommonNetworkRelativeLinkAndPathSuffix" |
||||||
|
} |
||||||
|
set bytes_volumeid_offset [string range $linkinfocontent 12 15] |
||||||
|
set bytes_localbasepath_offset [string range $linkinfocontent 16 19] ;# a |
||||||
|
set bytes_commonnetworkrelativelinkoffset [string range $linkinfocontent 20 23] |
||||||
|
set bytes_commonpathsuffix_offset [string range $linkinfocontent 24 27] ;# a |
||||||
|
|
||||||
|
binary scan $bytes_localbasepath_offset i bp_offset |
||||||
|
if {$bp_offset > 0} { |
||||||
|
set tail [string range $linkinfocontent $bp_offset end] |
||||||
|
set stringterminator 0 |
||||||
|
set i 0 |
||||||
|
set localbasepath "" |
||||||
|
#TODO |
||||||
|
while {!$stringterminator & $i < 100} { |
||||||
|
set c [string index $tail $i] |
||||||
|
if {$c eq "\x00"} { |
||||||
|
set stringterminator 1 |
||||||
|
} else { |
||||||
|
append localbasepath $c |
||||||
|
} |
||||||
|
incr i |
||||||
|
} |
||||||
|
} |
||||||
|
binary scan $bytes_commonpathsuffix_offset i cps_offset |
||||||
|
if {$cps_offset > 0} { |
||||||
|
set tail [string range $linkinfocontent $cps_offset end] |
||||||
|
set stringterminator 0 |
||||||
|
set i 0 |
||||||
|
set commonpathsuffix "" |
||||||
|
#TODO |
||||||
|
while {!$stringterminator && $i < 100} { |
||||||
|
set c [string index $tail $i] |
||||||
|
if {$c eq "\x00"} { |
||||||
|
set stringterminator 1 |
||||||
|
} else { |
||||||
|
append commonpathsuffix $c |
||||||
|
} |
||||||
|
incr i |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
return [dict create localbasepath $localbasepath commonpathsuffix $commonpathsuffix] |
||||||
|
} |
||||||
|
|
||||||
|
proc contents_get_info {contents} { |
||||||
|
|
||||||
|
#todo - return something like the perl lnk-parse-1.0.pl script? |
||||||
|
|
||||||
|
#Link File: C:/repo/jn/tclmodules/tomlish/src/modules/test/#modpod-tomlish-999999.0a1.0/suites/all/arrays_1.toml#roundtrip+roundtrip_files+arrays_1.toml.fauxlink.lnk |
||||||
|
#Link Flags: HAS SHELLIDLIST | POINTS TO FILE/DIR | NO DESCRIPTION | HAS RELATIVE PATH STRING | HAS WORKING DIRECTORY | NO CMD LINE ARGS | NO CUSTOM ICON | |
||||||
|
#File Attributes: ARCHIVE |
||||||
|
#Create Time: Sun Jul 14 2024 10:41:34 |
||||||
|
#Last Accessed time: Sat Sept 21 2024 02:46:10 |
||||||
|
#Last Modified Time: Tue Sept 10 2024 17:16:07 |
||||||
|
#Target Length: 479 |
||||||
|
#Icon Index: 0 |
||||||
|
#ShowWnd: 1 SW_NORMAL |
||||||
|
#HotKey: 0 |
||||||
|
#(App Path:) Remaining Path: repo\jn\tclmodules\tomlish\src\modules\test\#modpod-tomlish-999999.0a1.0\suites\roundtrip\roundtrip_files\arrays_1.toml |
||||||
|
#Relative Path: ..\roundtrip\roundtrip_files\arrays_1.toml |
||||||
|
#Working Dir: C:\repo\jn\tclmodules\tomlish\src\modules\test\#modpod-tomlish-999999.0a1.0\suites\roundtrip\roundtrip_files |
||||||
|
|
||||||
|
variable LinkFlags |
||||||
|
set flags_enabled [list] |
||||||
|
dict for {k v} $LinkFlags { |
||||||
|
if {[Has_LinkFlag $contents $k] > 0} { |
||||||
|
lappend flags_enabled $k |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set showcommand_val [Get_ShowCommand $contents] |
||||||
|
switch -- $showcommand_val { |
||||||
|
1 { |
||||||
|
set showwnd [list 1 SW_SHOWNORMAL] |
||||||
|
} |
||||||
|
3 { |
||||||
|
set showwnd [list 3 SW_SHOWMAXIMIZED] |
||||||
|
} |
||||||
|
7 { |
||||||
|
set showwnd [list 7 SW_SHOWMINNOACTIVE] |
||||||
|
} |
||||||
|
default { |
||||||
|
set showwnd [list $showcommand_val SW_SHOWNORMAL-effective] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set linkinfo_content_dict [Get_LinkInfo_content $contents] |
||||||
|
set localbase_path "" |
||||||
|
set suffix_path "" |
||||||
|
set linkinfocontent [dict get $linkinfo_content_dict content] |
||||||
|
set link_file "" |
||||||
|
if {$linkinfocontent ne ""} { |
||||||
|
set linkfields [LinkInfo_get_fields $linkinfocontent] |
||||||
|
set localbase_path [dict get $linkfields localbasepath] |
||||||
|
set suffix_path [dict get $linkfields commonpathsuffix] |
||||||
|
set link_file [file join $localbase_path $suffix_path] |
||||||
|
} |
||||||
|
|
||||||
|
set result [dict create\ |
||||||
|
link_file $link_file\ |
||||||
|
link_flags $flags_enabled\ |
||||||
|
file_attributes "<unimplemented>"\ |
||||||
|
create_time "<unimplemented>"\ |
||||||
|
last_accessed_time "<unimplemented"\ |
||||||
|
last_modified_time "<unimplementd>"\ |
||||||
|
target_length [Get_FileSize $contents]\ |
||||||
|
icon_index "<unimplemented>"\ |
||||||
|
showwnd "$showwnd"\ |
||||||
|
hotkey "<unimplemented>"\ |
||||||
|
relative_path "?"\ |
||||||
|
] |
||||||
|
} |
||||||
|
|
||||||
|
proc file_check_header {path} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun file_check_header] [arg path] ] |
||||||
|
#[para]Return 0|1 |
||||||
|
#[para]Determines if the .lnk file specified in path has a valid header for a windows shortcut |
||||||
|
set c [Get_contents $path 20] |
||||||
|
return [Contents_check_header $c] |
||||||
|
} |
||||||
|
proc file_get_info {path} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun file_get_info] [arg path] ] |
||||||
|
#[para] Return a dict of info obtained by parsing the binary data in a windows .lnk file |
||||||
|
#[para] If the .lnk header check fails, then the .lnk file probably isn't really a shortcut file and the dictionary will contain an 'error' key |
||||||
|
set c [Get_contents $path] |
||||||
|
if {[Contents_check_header $c]} { |
||||||
|
return [contents_get_info $c] |
||||||
|
} else { |
||||||
|
return [dict create error "lnk_header_check_failed"] |
||||||
|
} |
||||||
|
} |
||||||
|
proc file_show_info {path} { |
||||||
|
package require punk::lib |
||||||
|
punk::lib::showdict [file_get_info $path] * |
||||||
|
} |
||||||
|
|
||||||
|
#proc sample1 {p1 n args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||||
|
# #[para]Description of sample1 |
||||||
|
# #[para] Arguments: |
||||||
|
# # [list_begin arguments] |
||||||
|
# # [arg_def tring p1] A description of string argument p1. |
||||||
|
# # [arg_def integer n] A description of integer argument n. |
||||||
|
# # [list_end] |
||||||
|
# return "ok" |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::winlnk ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::winlnk::lib { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
tcl::namespace::path [tcl::namespace::parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::winlnk::lib}] |
||||||
|
#[para] Secondary functions that are part of the API |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
#proc utility1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of utility1 |
||||||
|
# return 1 |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::winlnk::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
#tcl::namespace::eval punk::winlnk::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::winlnk::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::winlnk [tcl::namespace::eval punk::winlnk { |
||||||
|
variable pkg punk::winlnk |
||||||
|
variable version |
||||||
|
set version 999999.0a1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
@ -0,0 +1,3 @@ |
|||||||
|
0.1.0 |
||||||
|
#First line must be a semantic version number |
||||||
|
#all other lines are ignored. |
@ -1,67 +1,67 @@ |
|||||||
|
|
||||||
#bootsupport modules can be pulled in from within other areas of src or from the built module folders of the project |
#bootsupport modules can be pulled in from within other areas of src or from the built module folders of the project |
||||||
#They must be already built, so generally shouldn't come directly from src/modules. |
#They must be already built, so generally shouldn't come directly from src/modules. |
||||||
|
|
||||||
#each entry - base module |
#each entry - base module |
||||||
set bootsupport_modules [list\ |
set bootsupport_modules [list\ |
||||||
src/vendormodules cksum\ |
src/vendormodules cksum\ |
||||||
src/vendormodules modpod\ |
src/vendormodules modpod\ |
||||||
src/vendormodules overtype\ |
src/vendormodules overtype\ |
||||||
src/vendormodules oolib\ |
src/vendormodules oolib\ |
||||||
src/vendormodules http\ |
src/vendormodules http\ |
||||||
src/vendormodules dictutils\ |
src/vendormodules dictutils\ |
||||||
src/vendormodules fileutil\ |
src/vendormodules fileutil\ |
||||||
src/vendormodules textutil::adjust\ |
src/vendormodules textutil::adjust\ |
||||||
src/vendormodules textutil::repeat\ |
src/vendormodules textutil::repeat\ |
||||||
src/vendormodules textutil::split\ |
src/vendormodules textutil::split\ |
||||||
src/vendormodules textutil::string\ |
src/vendormodules textutil::string\ |
||||||
src/vendormodules textutil::tabify\ |
src/vendormodules textutil::tabify\ |
||||||
src/vendormodules textutil::trim\ |
src/vendormodules textutil::trim\ |
||||||
src/vendormodules textutil::wcswidth\ |
src/vendormodules textutil::wcswidth\ |
||||||
src/vendormodules uuid\ |
src/vendormodules uuid\ |
||||||
src/vendormodules md5\ |
src/vendormodules md5\ |
||||||
src/vendormodules sha1\ |
src/vendormodules sha1\ |
||||||
src/vendormodules tomlish\ |
src/vendormodules tomlish\ |
||||||
src/vendormodules test::tomlish\ |
src/vendormodules test::tomlish\ |
||||||
modules punkcheck\ |
modules punkcheck\ |
||||||
modules natsort\ |
modules natsort\ |
||||||
modules punk::ansi\ |
modules punk::ansi\ |
||||||
modules punk::assertion\ |
modules punk::assertion\ |
||||||
modules punk::args\ |
modules punk::args\ |
||||||
modules punk::cap\ |
modules punk::cap\ |
||||||
modules punk::cap::handlers::caphandler\ |
modules punk::cap::handlers::caphandler\ |
||||||
modules punk::cap::handlers::scriptlibs\ |
modules punk::cap::handlers::scriptlibs\ |
||||||
modules punk::cap::handlers::templates\ |
modules punk::cap::handlers::templates\ |
||||||
modules punk::char\ |
modules punk::char\ |
||||||
modules punk::console\ |
modules punk::console\ |
||||||
modules punk::du\ |
modules punk::du\ |
||||||
modules punk::encmime\ |
modules punk::encmime\ |
||||||
modules punk::fileline\ |
modules punk::fileline\ |
||||||
modules punk::docgen\ |
modules punk::docgen\ |
||||||
modules punk::lib\ |
modules punk::lib\ |
||||||
modules punk::mix\ |
modules punk::mix\ |
||||||
modules punk::mix::base\ |
modules punk::mix::base\ |
||||||
modules punk::mix::cli\ |
modules punk::mix::cli\ |
||||||
modules punk::mix::util\ |
modules punk::mix::util\ |
||||||
modules punk::mix::templates\ |
modules punk::mix::templates\ |
||||||
modules punk::mix::commandset::buildsuite\ |
modules punk::mix::commandset::buildsuite\ |
||||||
modules punk::mix::commandset::debug\ |
modules punk::mix::commandset::debug\ |
||||||
modules punk::mix::commandset::doc\ |
modules punk::mix::commandset::doc\ |
||||||
modules punk::mix::commandset::layout\ |
modules punk::mix::commandset::layout\ |
||||||
modules punk::mix::commandset::loadedlib\ |
modules punk::mix::commandset::loadedlib\ |
||||||
modules punk::mix::commandset::module\ |
modules punk::mix::commandset::module\ |
||||||
modules punk::mix::commandset::project\ |
modules punk::mix::commandset::project\ |
||||||
modules punk::mix::commandset::repo\ |
modules punk::mix::commandset::repo\ |
||||||
modules punk::mix::commandset::scriptwrap\ |
modules punk::mix::commandset::scriptwrap\ |
||||||
modules punk::ns\ |
modules punk::ns\ |
||||||
modules punk::overlay\ |
modules punk::overlay\ |
||||||
modules punk::path\ |
modules punk::path\ |
||||||
modules punk::repo\ |
modules punk::repo\ |
||||||
modules punk::tdl\ |
modules punk::tdl\ |
||||||
modules punk::zip\ |
modules punk::zip\ |
||||||
modules punk::winpath\ |
modules punk::winpath\ |
||||||
modules textblock\ |
modules textblock\ |
||||||
modules natsort\ |
modules natsort\ |
||||||
modules oolib\ |
modules oolib\ |
||||||
] |
] |
||||||
|
|
||||||
|
@ -1,200 +0,0 @@ |
|||||||
#JMN - api should be kept in sync with package patternlib where possible |
|
||||||
# |
|
||||||
package provide oolib [namespace eval oolib { |
|
||||||
variable version |
|
||||||
set version 0.1.1 |
|
||||||
}] |
|
||||||
|
|
||||||
namespace eval oolib { |
|
||||||
oo::class create collection { |
|
||||||
variable o_data ;#dict |
|
||||||
variable o_alias |
|
||||||
constructor {} { |
|
||||||
set o_data [dict create] |
|
||||||
} |
|
||||||
method info {} { |
|
||||||
return [dict info $o_data] |
|
||||||
} |
|
||||||
method count {} { |
|
||||||
return [dict size $o_data] |
|
||||||
} |
|
||||||
method isEmpty {} { |
|
||||||
expr {[dict size $o_data] == 0} |
|
||||||
} |
|
||||||
method names {{globOrIdx {}}} { |
|
||||||
if {[llength $globOrIdx]} { |
|
||||||
if {[string is integer -strict $globOrIdx]} { |
|
||||||
set idx $globOrIdx |
|
||||||
if {$idx < 0} { |
|
||||||
set idx "end-[expr {abs($idx + 1)}]" |
|
||||||
} |
|
||||||
if {[catch {lindex [dict keys $o_data] $idx} result]} { |
|
||||||
error "[self object] no such index : '$idx'" |
|
||||||
} else { |
|
||||||
return $result |
|
||||||
} |
|
||||||
} else { |
|
||||||
#glob |
|
||||||
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] |
|
||||||
} |
|
||||||
} else { |
|
||||||
return [dict keys $o_data] |
|
||||||
} |
|
||||||
} |
|
||||||
#like names but without globbing |
|
||||||
method keys {} { |
|
||||||
dict keys $o_data |
|
||||||
} |
|
||||||
method key {{posn 0}} { |
|
||||||
if {$posn < 0} { |
|
||||||
set posn "end-[expr {abs($posn + 1)}]" |
|
||||||
} |
|
||||||
if {[catch {lindex [dict keys $o_data] $posn} result]} { |
|
||||||
error "[self object] no such index : '$posn'" |
|
||||||
} else { |
|
||||||
return $result |
|
||||||
} |
|
||||||
} |
|
||||||
method hasKey {key} { |
|
||||||
dict exists $o_data $key |
|
||||||
} |
|
||||||
method get {} { |
|
||||||
return $o_data |
|
||||||
} |
|
||||||
method items {} { |
|
||||||
return [dict values $o_data] |
|
||||||
} |
|
||||||
method item {key} { |
|
||||||
if {[string is integer -strict $key]} { |
|
||||||
if {$key >= 0} { |
|
||||||
set valposn [expr {(2*$key) +1}] |
|
||||||
return [lindex $o_data $valposn] |
|
||||||
} else { |
|
||||||
set key "end-[expr {abs($key + 1)}]" |
|
||||||
return [lindex $o_data $key] |
|
||||||
#return [lindex [dict keys $o_data] $key] |
|
||||||
} |
|
||||||
} |
|
||||||
if {[dict exists $o_data $key]} { |
|
||||||
return [dict get $o_data $key] |
|
||||||
} |
|
||||||
} |
|
||||||
#inverse lookup |
|
||||||
method itemKeys {value} { |
|
||||||
set value_indices [lsearch -all [dict values $o_data] $value] |
|
||||||
set keylist [list] |
|
||||||
foreach i $value_indices { |
|
||||||
set idx [expr {(($i + 1) *2) -2}] |
|
||||||
lappend keylist [lindex $o_data $idx] |
|
||||||
} |
|
||||||
return $keylist |
|
||||||
} |
|
||||||
method search {value args} { |
|
||||||
set matches [lsearch {*}$args [dict values $o_data] $value] |
|
||||||
if {"-inline" in $args} { |
|
||||||
return $matches |
|
||||||
} else { |
|
||||||
set keylist [list] |
|
||||||
foreach i $matches { |
|
||||||
set idx [expr {(($i + 1) *2) -2}] |
|
||||||
lappend keylist [lindex $o_data $idx] |
|
||||||
} |
|
||||||
return $keylist |
|
||||||
} |
|
||||||
} |
|
||||||
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? |
|
||||||
method alias {newAlias existingKeyOrAlias} { |
|
||||||
if {[string is integer -strict $newAlias]} { |
|
||||||
error "[self object] collection key alias cannot be integer" |
|
||||||
} |
|
||||||
if {[string length $existingKeyOrAlias]} { |
|
||||||
set o_alias($newAlias) $existingKeyOrAlias |
|
||||||
} else { |
|
||||||
unset o_alias($newAlias) |
|
||||||
} |
|
||||||
} |
|
||||||
method aliases {{key ""}} { |
|
||||||
if {[string length $key]} { |
|
||||||
set result [list] |
|
||||||
foreach {n v} [array get o_alias] { |
|
||||||
if {$v eq $key} { |
|
||||||
lappend result $n $v |
|
||||||
} |
|
||||||
} |
|
||||||
return $result |
|
||||||
} else { |
|
||||||
return [array get o_alias] |
|
||||||
} |
|
||||||
} |
|
||||||
#if the supplied index is an alias, return the underlying key; else return the index supplied. |
|
||||||
method realKey {idx} { |
|
||||||
if {[catch {set o_alias($idx)} key]} { |
|
||||||
return $idx |
|
||||||
} else { |
|
||||||
return $key |
|
||||||
} |
|
||||||
} |
|
||||||
method add {value key} { |
|
||||||
if {[string is integer -strict $key]} { |
|
||||||
error "[self object] collection key must not be an integer. Use another structure if integer keys required" |
|
||||||
} |
|
||||||
if {[dict exists $o_data $key]} { |
|
||||||
error "[self object] col_processors object error: key '$key' already exists in collection" |
|
||||||
} |
|
||||||
dict set o_data $key $value |
|
||||||
return [expr {[dict size $o_data] - 1}] ;#return index of item |
|
||||||
} |
|
||||||
method remove {idx {endRange ""}} { |
|
||||||
if {[string length $endRange]} { |
|
||||||
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" |
|
||||||
} |
|
||||||
if {[string is integer -strict $idx]} { |
|
||||||
if {$idx < 0} { |
|
||||||
set idx "end-[expr {abs($idx+1)}]" |
|
||||||
} |
|
||||||
set key [lindex [dict keys $o_data] $idx] |
|
||||||
set posn $idx |
|
||||||
} else { |
|
||||||
set key $idx |
|
||||||
set posn [lsearch -exact [dict keys $o_data] $key] |
|
||||||
if {$posn < 0} { |
|
||||||
error "[self object] no such index: '$idx' in this collection" |
|
||||||
} |
|
||||||
} |
|
||||||
dict unset o_data $key |
|
||||||
return |
|
||||||
} |
|
||||||
method clear {} { |
|
||||||
set o_data [dict create] |
|
||||||
return |
|
||||||
} |
|
||||||
method reverse_the_collection {} { |
|
||||||
#named slightly obtusely because reversing the data when there may be references held is a potential source of bugs |
|
||||||
#the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy. |
|
||||||
#todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations. |
|
||||||
set dictnew [dict create] |
|
||||||
foreach k [lreverse [dict keys $o_data]] { |
|
||||||
dict set dictnew $k [dict get $o_data $k] |
|
||||||
} |
|
||||||
set o_data $dictnew |
|
||||||
return |
|
||||||
} |
|
||||||
#review - cmd as list vs cmd as script? |
|
||||||
method map {cmd} { |
|
||||||
set seed [list] |
|
||||||
dict for {k v} $o_data { |
|
||||||
lappend seed [uplevel #0 [list {*}$cmd $v]] |
|
||||||
} |
|
||||||
return $seed |
|
||||||
} |
|
||||||
method objectmap {cmd} { |
|
||||||
set seed [list] |
|
||||||
dict for {k v} $o_data { |
|
||||||
lappend seed [uplevel #0 [list $v {*}$cmd]] |
|
||||||
} |
|
||||||
return $seed |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
} |
|
||||||
|
|
File diff suppressed because it is too large
Load Diff
Binary file not shown.
File diff suppressed because it is too large
Load Diff
@ -1,67 +1,67 @@ |
|||||||
|
|
||||||
#bootsupport modules can be pulled in from within other areas of src or from the built module folders of the project |
#bootsupport modules can be pulled in from within other areas of src or from the built module folders of the project |
||||||
#They must be already built, so generally shouldn't come directly from src/modules. |
#They must be already built, so generally shouldn't come directly from src/modules. |
||||||
|
|
||||||
#each entry - base module |
#each entry - base module |
||||||
set bootsupport_modules [list\ |
set bootsupport_modules [list\ |
||||||
src/vendormodules cksum\ |
src/vendormodules cksum\ |
||||||
src/vendormodules modpod\ |
src/vendormodules modpod\ |
||||||
src/vendormodules overtype\ |
src/vendormodules overtype\ |
||||||
src/vendormodules oolib\ |
src/vendormodules oolib\ |
||||||
src/vendormodules http\ |
src/vendormodules http\ |
||||||
src/vendormodules dictutils\ |
src/vendormodules dictutils\ |
||||||
src/vendormodules fileutil\ |
src/vendormodules fileutil\ |
||||||
src/vendormodules textutil::adjust\ |
src/vendormodules textutil::adjust\ |
||||||
src/vendormodules textutil::repeat\ |
src/vendormodules textutil::repeat\ |
||||||
src/vendormodules textutil::split\ |
src/vendormodules textutil::split\ |
||||||
src/vendormodules textutil::string\ |
src/vendormodules textutil::string\ |
||||||
src/vendormodules textutil::tabify\ |
src/vendormodules textutil::tabify\ |
||||||
src/vendormodules textutil::trim\ |
src/vendormodules textutil::trim\ |
||||||
src/vendormodules textutil::wcswidth\ |
src/vendormodules textutil::wcswidth\ |
||||||
src/vendormodules uuid\ |
src/vendormodules uuid\ |
||||||
src/vendormodules md5\ |
src/vendormodules md5\ |
||||||
src/vendormodules sha1\ |
src/vendormodules sha1\ |
||||||
src/vendormodules tomlish\ |
src/vendormodules tomlish\ |
||||||
src/vendormodules test::tomlish\ |
src/vendormodules test::tomlish\ |
||||||
modules punkcheck\ |
modules punkcheck\ |
||||||
modules natsort\ |
modules natsort\ |
||||||
modules punk::ansi\ |
modules punk::ansi\ |
||||||
modules punk::assertion\ |
modules punk::assertion\ |
||||||
modules punk::args\ |
modules punk::args\ |
||||||
modules punk::cap\ |
modules punk::cap\ |
||||||
modules punk::cap::handlers::caphandler\ |
modules punk::cap::handlers::caphandler\ |
||||||
modules punk::cap::handlers::scriptlibs\ |
modules punk::cap::handlers::scriptlibs\ |
||||||
modules punk::cap::handlers::templates\ |
modules punk::cap::handlers::templates\ |
||||||
modules punk::char\ |
modules punk::char\ |
||||||
modules punk::console\ |
modules punk::console\ |
||||||
modules punk::du\ |
modules punk::du\ |
||||||
modules punk::encmime\ |
modules punk::encmime\ |
||||||
modules punk::fileline\ |
modules punk::fileline\ |
||||||
modules punk::docgen\ |
modules punk::docgen\ |
||||||
modules punk::lib\ |
modules punk::lib\ |
||||||
modules punk::mix\ |
modules punk::mix\ |
||||||
modules punk::mix::base\ |
modules punk::mix::base\ |
||||||
modules punk::mix::cli\ |
modules punk::mix::cli\ |
||||||
modules punk::mix::util\ |
modules punk::mix::util\ |
||||||
modules punk::mix::templates\ |
modules punk::mix::templates\ |
||||||
modules punk::mix::commandset::buildsuite\ |
modules punk::mix::commandset::buildsuite\ |
||||||
modules punk::mix::commandset::debug\ |
modules punk::mix::commandset::debug\ |
||||||
modules punk::mix::commandset::doc\ |
modules punk::mix::commandset::doc\ |
||||||
modules punk::mix::commandset::layout\ |
modules punk::mix::commandset::layout\ |
||||||
modules punk::mix::commandset::loadedlib\ |
modules punk::mix::commandset::loadedlib\ |
||||||
modules punk::mix::commandset::module\ |
modules punk::mix::commandset::module\ |
||||||
modules punk::mix::commandset::project\ |
modules punk::mix::commandset::project\ |
||||||
modules punk::mix::commandset::repo\ |
modules punk::mix::commandset::repo\ |
||||||
modules punk::mix::commandset::scriptwrap\ |
modules punk::mix::commandset::scriptwrap\ |
||||||
modules punk::ns\ |
modules punk::ns\ |
||||||
modules punk::overlay\ |
modules punk::overlay\ |
||||||
modules punk::path\ |
modules punk::path\ |
||||||
modules punk::repo\ |
modules punk::repo\ |
||||||
modules punk::tdl\ |
modules punk::tdl\ |
||||||
modules punk::zip\ |
modules punk::zip\ |
||||||
modules punk::winpath\ |
modules punk::winpath\ |
||||||
modules textblock\ |
modules textblock\ |
||||||
modules natsort\ |
modules natsort\ |
||||||
modules oolib\ |
modules oolib\ |
||||||
] |
] |
||||||
|
|
||||||
|
Binary file not shown.
File diff suppressed because it is too large
Load Diff
@ -1,19 +1,19 @@ |
|||||||
|
|
||||||
|
|
||||||
#e.g |
#e.g |
||||||
#set local_modules [list\ |
#set local_modules [list\ |
||||||
# c:/repo/jn/tclmodules/gridplus/modules gridplus\ |
# c:/repo/jn/tclmodules/gridplus/modules gridplus\ |
||||||
# c:/repo/jn/tclmodules/tablelist/modules tablelist\ |
# c:/repo/jn/tclmodules/tablelist/modules tablelist\ |
||||||
# c:/repo/jn/tclmodules/tablelist/modules tablelist_tile\ |
# c:/repo/jn/tclmodules/tablelist/modules tablelist_tile\ |
||||||
#] |
#] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
set local_modules [list\ |
set local_modules [list\ |
||||||
] |
] |
||||||
|
|
||||||
set fossil_modules [dict create\ |
set fossil_modules [dict create\ |
||||||
] |
] |
||||||
|
|
||||||
set git_modules [dict create\ |
set git_modules [dict create\ |
||||||
] |
] |
@ -1,19 +1,19 @@ |
|||||||
|
|
||||||
|
|
||||||
#e.g |
#e.g |
||||||
#set local_modules [list\ |
#set local_modules [list\ |
||||||
# c:/repo/jn/tclmodules/gridplus/modules gridplus\ |
# c:/repo/jn/tclmodules/gridplus/modules gridplus\ |
||||||
# c:/repo/jn/tclmodules/tablelist/modules tablelist\ |
# c:/repo/jn/tclmodules/tablelist/modules tablelist\ |
||||||
# c:/repo/jn/tclmodules/tablelist/modules tablelist_tile\ |
# c:/repo/jn/tclmodules/tablelist/modules tablelist_tile\ |
||||||
#] |
#] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
set local_modules [list\ |
set local_modules [list\ |
||||||
] |
] |
||||||
|
|
||||||
set fossil_modules [dict create\ |
set fossil_modules [dict create\ |
||||||
] |
] |
||||||
|
|
||||||
set git_modules [dict create\ |
set git_modules [dict create\ |
||||||
] |
] |
@ -1,19 +1,19 @@ |
|||||||
|
|
||||||
|
|
||||||
#e.g |
#e.g |
||||||
#set local_modules [list\ |
#set local_modules [list\ |
||||||
# c:/repo/jn/tclmodules/gridplus/modules gridplus\ |
# c:/repo/jn/tclmodules/gridplus/modules gridplus\ |
||||||
# c:/repo/jn/tclmodules/tablelist/modules tablelist\ |
# c:/repo/jn/tclmodules/tablelist/modules tablelist\ |
||||||
# c:/repo/jn/tclmodules/tablelist/modules tablelist_tile\ |
# c:/repo/jn/tclmodules/tablelist/modules tablelist_tile\ |
||||||
#] |
#] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
set local_modules [list\ |
set local_modules [list\ |
||||||
] |
] |
||||||
|
|
||||||
set fossil_modules [dict create\ |
set fossil_modules [dict create\ |
||||||
] |
] |
||||||
|
|
||||||
set git_modules [dict create\ |
set git_modules [dict create\ |
||||||
] |
] |
@ -0,0 +1,336 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application fauxlink 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin fauxlink_module_fauxlink 0 0.1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require fauxlink] |
||||||
|
#[keywords module] |
||||||
|
#[description] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of fauxlink |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by fauxlink |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6-}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval fauxlink::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace fauxlink::class}] |
||||||
|
#[para] class definitions |
||||||
|
if {[info commands [namespace current]::interface_sample1] eq ""} { |
||||||
|
#*** !doctools |
||||||
|
#[list_begin enumerated] |
||||||
|
|
||||||
|
# oo::class create interface_sample1 { |
||||||
|
# #*** !doctools |
||||||
|
# #[enum] CLASS [class interface_sample1] |
||||||
|
# #[list_begin definitions] |
||||||
|
|
||||||
|
# method test {arg1} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# #[para] test method |
||||||
|
# puts "test: $arg1" |
||||||
|
# } |
||||||
|
|
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# } |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end class enumeration ---}] |
||||||
|
} |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval fauxlink { |
||||||
|
namespace export {[a-z]*}; # Convention: export all lowercase |
||||||
|
|
||||||
|
#todo - enforce utf-8 |
||||||
|
|
||||||
|
#literal unicode chars supported by modern filesystems - leave as is - REVIEW |
||||||
|
|
||||||
|
|
||||||
|
variable encode_map |
||||||
|
variable decode_map |
||||||
|
#most filesystems don't allow NULL - map to empty string |
||||||
|
|
||||||
|
#Make sure % is not in encode_map |
||||||
|
set encode_map [dict create\ |
||||||
|
\x00 ""\ |
||||||
|
{ } %20\ |
||||||
|
\t %09\ |
||||||
|
+ %2B\ |
||||||
|
# %23\ |
||||||
|
* %2A\ |
||||||
|
? %3F\ |
||||||
|
\\ %5C\ |
||||||
|
/ %2F\ |
||||||
|
| %7C\ |
||||||
|
: %3A\ |
||||||
|
{;} %3B\ |
||||||
|
{"} %22\ |
||||||
|
< %3C\ |
||||||
|
> %3E\ |
||||||
|
] |
||||||
|
#must_encode |
||||||
|
# + # * ? \ / | : ; " < > <sp> \t |
||||||
|
# also NUL to empty string |
||||||
|
# also ctrl chars 01 to 1F (1..31) |
||||||
|
for {set i 1} {$i < 32} {incr i} { |
||||||
|
set ch [format %c $i] |
||||||
|
set enc "%[format %02X $i]" |
||||||
|
set enc_lower [string tolower $enc] |
||||||
|
dict set encode_map $ch $enc |
||||||
|
dict set decode_map $enc $ch |
||||||
|
dict set decode_map $enc_lower $ch |
||||||
|
} |
||||||
|
|
||||||
|
variable must_encode |
||||||
|
set must_encode [dict keys $encode_map] |
||||||
|
|
||||||
|
|
||||||
|
set decode_map [dict create\ |
||||||
|
%20 { }\ |
||||||
|
%21 "!"\ |
||||||
|
%22 {"}\ |
||||||
|
%23 "#"\ |
||||||
|
%24 "$"\ |
||||||
|
%25 "%"\ |
||||||
|
%26 "&"\ |
||||||
|
%27 "'"\ |
||||||
|
%28 "("\ |
||||||
|
%29 ")"\ |
||||||
|
%2A "*"\ |
||||||
|
%2a "*"\ |
||||||
|
%2B "+"\ |
||||||
|
%2b "+"\ |
||||||
|
%2C ","\ |
||||||
|
%2c ","\ |
||||||
|
%2F "/"\ |
||||||
|
%2f "/"\ |
||||||
|
%3A ":"\ |
||||||
|
%3a ":"\ |
||||||
|
%3B {;}\ |
||||||
|
%3b {;}\ |
||||||
|
%3D "="\ |
||||||
|
%3C "<"\ |
||||||
|
%3c "<"\ |
||||||
|
%3d "="\ |
||||||
|
%3E ">"\ |
||||||
|
%3e ">"\ |
||||||
|
%3F "?"\ |
||||||
|
%3f "?"\ |
||||||
|
%40 "@"\ |
||||||
|
%5B "\["\ |
||||||
|
%5b "\["\ |
||||||
|
%5C "\\"\ |
||||||
|
%5c "\\"\ |
||||||
|
%5D "\]"\ |
||||||
|
%5d "\]"\ |
||||||
|
%5E "^"\ |
||||||
|
%5e "^"\ |
||||||
|
%60 "`"\ |
||||||
|
%7B "{"\ |
||||||
|
%7b "{"\ |
||||||
|
%7C "|"\ |
||||||
|
%7c "|"\ |
||||||
|
%7D "}"\ |
||||||
|
%7d "}"\ |
||||||
|
%7E "~"\ |
||||||
|
%7e "~"\ |
||||||
|
] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace fauxlink}] |
||||||
|
#[para] Core API functions for fauxlink |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
proc resolve {link} { |
||||||
|
variable decode_map |
||||||
|
variable encode_map |
||||||
|
variable must_encode |
||||||
|
set ftail [file tail $link] |
||||||
|
if {[file extension $ftail] ne ".fauxlink"} { |
||||||
|
error "fauxlink::resolve refusing to process link $link - file extension must be .fauxlink" |
||||||
|
} |
||||||
|
set linkspec [file rootname $ftail] |
||||||
|
# - any # or + within the target path or name should have been uri encoded as %23 and %2b |
||||||
|
if {[tcl::string::first # $linkspec] < 0} { |
||||||
|
error "fauxlink::resolve error. Link must contain a # (usually at start if name matches target)" |
||||||
|
} |
||||||
|
#only the 1st 2 parts of split on # are significant. |
||||||
|
#if there are more # chars present - the subsequent parts are effectively a comment |
||||||
|
|
||||||
|
#check namepec already has required chars encoded |
||||||
|
lassign [split $linkspec #] namespec targetspec |
||||||
|
#puts stderr "-->namespec $namespec" |
||||||
|
set nametest [tcl::string::map $encode_map $namespec] |
||||||
|
#puts stderr "-->nametest $nametest" |
||||||
|
#nothing should be changed - if there are unencoded chars that must be encoded it is an error |
||||||
|
if {[tcl::string::length $nametest] ne [tcl::string::length $namespec]} { |
||||||
|
set err "fauxlink::resolve invalid chars in name part (section prior to first #)" |
||||||
|
set idx 0 |
||||||
|
foreach ch [split $namespec ""] { |
||||||
|
if {$ch in $must_encode} { |
||||||
|
set enc [dict get $encode_map $ch] |
||||||
|
append err " char $idx should be encoded as $enc" \n |
||||||
|
} |
||||||
|
incr idx |
||||||
|
} |
||||||
|
error $err |
||||||
|
} |
||||||
|
set name [tcl::string::map $decode_map $namespec] |
||||||
|
#puts stderr "-->name: $name" |
||||||
|
|
||||||
|
set targetsegment [split $targetspec +] |
||||||
|
#check each + delimited part of targetspec already has required chars encoded |
||||||
|
set s 0 ;#segment index |
||||||
|
set result_segments [list] |
||||||
|
foreach segment $targetsegment { |
||||||
|
set targettest [tcl::string::map $encode_map $segment] |
||||||
|
if {[tcl::string::length $targettest] ne [tcl::string::length $segment]} { |
||||||
|
set err "fauxlink::resolve invalid chars in targetpath (section following first #)" |
||||||
|
set idx 0 |
||||||
|
foreach ch [split $segment ""] { |
||||||
|
if {$ch in $must_encode} { |
||||||
|
set enc [dict get $encode_map $ch] |
||||||
|
append err " segment $s char $idx should be encoded as $enc" \n |
||||||
|
} |
||||||
|
incr idx |
||||||
|
} |
||||||
|
error $err |
||||||
|
} |
||||||
|
lappend result_segments [tcl::string::map $decode_map $segment] |
||||||
|
incr s |
||||||
|
} |
||||||
|
set targetpath [join $result_segments /] |
||||||
|
|
||||||
|
return [dict create name $name targetpath $targetpath] |
||||||
|
} |
||||||
|
|
||||||
|
proc link_as {name target} { |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
#proc sample1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call [fun sample1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of sample1 |
||||||
|
# return "ok" |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace fauxlink ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval fauxlink::lib { |
||||||
|
namespace export {[a-z]*}; # Convention: export all lowercase |
||||||
|
namespace path [namespace parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace fauxlink::lib}] |
||||||
|
#[para] Secondary functions that are part of the API |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
#proc utility1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of utility1 |
||||||
|
# return 1 |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace fauxlink::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
namespace eval fauxlink::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace fauxlink::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide fauxlink [namespace eval fauxlink { |
||||||
|
variable pkg fauxlink |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
Binary file not shown.
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,540 @@ |
|||||||
|
## -*- tcl -*- |
||||||
|
## |
||||||
|
## OO-based Tcl/PARAM implementation of the parsing |
||||||
|
## expression grammar |
||||||
|
## |
||||||
|
## calculator grammar |
||||||
|
## |
||||||
|
## Generated from file calctest.tcl |
||||||
|
## for user jnoble |
||||||
|
## |
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## Requirements |
||||||
|
|
||||||
|
package require Tcl 8.5 9 |
||||||
|
package require TclOO |
||||||
|
package require pt::rde::oo ; # OO-based implementation of the |
||||||
|
# PARAM virtual machine |
||||||
|
# underlying the Tcl/PARAM code |
||||||
|
# used below. |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## |
||||||
|
|
||||||
|
oo::class create calculator_test { |
||||||
|
# # ## ### ##### ######## ############# |
||||||
|
## Public API |
||||||
|
|
||||||
|
superclass pt::rde::oo ; # TODO - Define this class. |
||||||
|
# Or can we inherit from a snit |
||||||
|
# class too ? |
||||||
|
|
||||||
|
method parse {channel} { |
||||||
|
my reset $channel |
||||||
|
my MAIN ; # Entrypoint for the generated code. |
||||||
|
return [my complete] |
||||||
|
} |
||||||
|
|
||||||
|
method parset {text} { |
||||||
|
my reset {} |
||||||
|
my data $text |
||||||
|
my MAIN ; # Entrypoint for the generated code. |
||||||
|
return [my complete] |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ###### ######## ############# |
||||||
|
## BEGIN of GENERATED CODE. DO NOT EDIT. |
||||||
|
|
||||||
|
# |
||||||
|
# Grammar Start Expression |
||||||
|
# |
||||||
|
|
||||||
|
method MAIN {} { |
||||||
|
my sym_Expression |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# value Symbol 'AddOp' |
||||||
|
# |
||||||
|
|
||||||
|
method sym_AddOp {} { |
||||||
|
# [+-] |
||||||
|
|
||||||
|
my si:void_symbol_start AddOp |
||||||
|
my si:next_class +- |
||||||
|
my si:void_leaf_symbol_end AddOp |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# value Symbol 'Digit' |
||||||
|
# |
||||||
|
|
||||||
|
method sym_Digit {} { |
||||||
|
# [0123456789] |
||||||
|
|
||||||
|
my si:void_symbol_start Digit |
||||||
|
my si:next_class 0123456789 |
||||||
|
my si:void_leaf_symbol_end Digit |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# value Symbol 'Expression' |
||||||
|
# |
||||||
|
|
||||||
|
method sym_Expression {} { |
||||||
|
# x |
||||||
|
# (Term) |
||||||
|
# * |
||||||
|
# x |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (AddOp) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Term) |
||||||
|
|
||||||
|
my si:value_symbol_start Expression |
||||||
|
my sequence_18 |
||||||
|
my si:reduce_symbol_end Expression |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method sequence_18 {} { |
||||||
|
# x |
||||||
|
# (Term) |
||||||
|
# * |
||||||
|
# x |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (AddOp) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Term) |
||||||
|
|
||||||
|
my si:value_state_push |
||||||
|
my sym_Term |
||||||
|
my si:valuevalue_part |
||||||
|
my kleene_16 |
||||||
|
my si:value_state_merge |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method kleene_16 {} { |
||||||
|
# * |
||||||
|
# x |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (AddOp) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Term) |
||||||
|
|
||||||
|
while {1} { |
||||||
|
my si:void2_state_push |
||||||
|
my sequence_14 |
||||||
|
my si:kleene_close |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method sequence_14 {} { |
||||||
|
# x |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (AddOp) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Term) |
||||||
|
|
||||||
|
my si:void_state_push |
||||||
|
my kleene_8 |
||||||
|
my si:voidvalue_part |
||||||
|
my sym_AddOp |
||||||
|
my si:valuevalue_part |
||||||
|
my kleene_8 |
||||||
|
my si:valuevalue_part |
||||||
|
my sym_Term |
||||||
|
my si:value_state_merge |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method kleene_8 {} { |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
|
||||||
|
while {1} { |
||||||
|
my si:void2_state_push |
||||||
|
my si:next_char \40 |
||||||
|
my si:kleene_close |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# value Symbol 'Factor' |
||||||
|
# |
||||||
|
|
||||||
|
method sym_Factor {} { |
||||||
|
# x |
||||||
|
# (Fragment) |
||||||
|
# * |
||||||
|
# x |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (PowOp) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Fragment) |
||||||
|
|
||||||
|
my si:value_symbol_start Factor |
||||||
|
my sequence_32 |
||||||
|
my si:reduce_symbol_end Factor |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method sequence_32 {} { |
||||||
|
# x |
||||||
|
# (Fragment) |
||||||
|
# * |
||||||
|
# x |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (PowOp) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Fragment) |
||||||
|
|
||||||
|
my si:value_state_push |
||||||
|
my sym_Fragment |
||||||
|
my si:valuevalue_part |
||||||
|
my kleene_30 |
||||||
|
my si:value_state_merge |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method kleene_30 {} { |
||||||
|
# * |
||||||
|
# x |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (PowOp) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Fragment) |
||||||
|
|
||||||
|
while {1} { |
||||||
|
my si:void2_state_push |
||||||
|
my sequence_28 |
||||||
|
my si:kleene_close |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method sequence_28 {} { |
||||||
|
# x |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (PowOp) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Fragment) |
||||||
|
|
||||||
|
my si:void_state_push |
||||||
|
my kleene_8 |
||||||
|
my si:voidvalue_part |
||||||
|
my sym_PowOp |
||||||
|
my si:valuevalue_part |
||||||
|
my kleene_8 |
||||||
|
my si:valuevalue_part |
||||||
|
my sym_Fragment |
||||||
|
my si:value_state_merge |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# value Symbol 'Fragment' |
||||||
|
# |
||||||
|
|
||||||
|
method sym_Fragment {} { |
||||||
|
# / |
||||||
|
# x |
||||||
|
# '\(' |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Expression) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# '\)' |
||||||
|
# (Number) |
||||||
|
# (Var) |
||||||
|
|
||||||
|
my si:value_symbol_start Fragment |
||||||
|
my choice_46 |
||||||
|
my si:reduce_symbol_end Fragment |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method choice_46 {} { |
||||||
|
# / |
||||||
|
# x |
||||||
|
# '\(' |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Expression) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# '\)' |
||||||
|
# (Number) |
||||||
|
# (Var) |
||||||
|
|
||||||
|
my si:value_state_push |
||||||
|
my sequence_42 |
||||||
|
my si:valuevalue_branch |
||||||
|
my sym_Number |
||||||
|
my si:valuevalue_branch |
||||||
|
my sym_Var |
||||||
|
my si:value_state_merge |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method sequence_42 {} { |
||||||
|
# x |
||||||
|
# '\(' |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Expression) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# '\)' |
||||||
|
|
||||||
|
my si:void_state_push |
||||||
|
my si:next_char \50 |
||||||
|
my si:voidvoid_part |
||||||
|
my kleene_8 |
||||||
|
my si:voidvalue_part |
||||||
|
my sym_Expression |
||||||
|
my si:valuevalue_part |
||||||
|
my kleene_8 |
||||||
|
my si:valuevalue_part |
||||||
|
my si:next_char \51 |
||||||
|
my si:value_state_merge |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# value Symbol 'MulOp' |
||||||
|
# |
||||||
|
|
||||||
|
method sym_MulOp {} { |
||||||
|
# [*/] |
||||||
|
|
||||||
|
my si:void_symbol_start MulOp |
||||||
|
my si:next_class */ |
||||||
|
my si:void_leaf_symbol_end MulOp |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# value Symbol 'Number' |
||||||
|
# |
||||||
|
|
||||||
|
method sym_Number {} { |
||||||
|
# x |
||||||
|
# ? |
||||||
|
# (Sign) |
||||||
|
# + |
||||||
|
# (Digit) |
||||||
|
|
||||||
|
my si:value_symbol_start Number |
||||||
|
my sequence_57 |
||||||
|
my si:reduce_symbol_end Number |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method sequence_57 {} { |
||||||
|
# x |
||||||
|
# ? |
||||||
|
# (Sign) |
||||||
|
# + |
||||||
|
# (Digit) |
||||||
|
|
||||||
|
my si:value_state_push |
||||||
|
my optional_52 |
||||||
|
my si:valuevalue_part |
||||||
|
my poskleene_55 |
||||||
|
my si:value_state_merge |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method optional_52 {} { |
||||||
|
# ? |
||||||
|
# (Sign) |
||||||
|
|
||||||
|
my si:void2_state_push |
||||||
|
my sym_Sign |
||||||
|
my si:void_state_merge_ok |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method poskleene_55 {} { |
||||||
|
# + |
||||||
|
# (Digit) |
||||||
|
|
||||||
|
my i_loc_push |
||||||
|
my sym_Digit |
||||||
|
my si:kleene_abort |
||||||
|
while {1} { |
||||||
|
my si:void2_state_push |
||||||
|
my sym_Digit |
||||||
|
my si:kleene_close |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# value Symbol 'PowOp' |
||||||
|
# |
||||||
|
|
||||||
|
method sym_PowOp {} { |
||||||
|
# "**" |
||||||
|
|
||||||
|
my si:void_symbol_start PowOp |
||||||
|
my si:next_str ** |
||||||
|
my si:void_leaf_symbol_end PowOp |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# value Symbol 'Sign' |
||||||
|
# |
||||||
|
|
||||||
|
method sym_Sign {} { |
||||||
|
# [-+] |
||||||
|
|
||||||
|
my si:void_symbol_start Sign |
||||||
|
my si:next_class -+ |
||||||
|
my si:void_leaf_symbol_end Sign |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# value Symbol 'Term' |
||||||
|
# |
||||||
|
|
||||||
|
method sym_Term {} { |
||||||
|
# x |
||||||
|
# (Factor) |
||||||
|
# * |
||||||
|
# x |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (MulOp) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Factor) |
||||||
|
|
||||||
|
my si:value_symbol_start Term |
||||||
|
my sequence_75 |
||||||
|
my si:reduce_symbol_end Term |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method sequence_75 {} { |
||||||
|
# x |
||||||
|
# (Factor) |
||||||
|
# * |
||||||
|
# x |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (MulOp) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Factor) |
||||||
|
|
||||||
|
my si:value_state_push |
||||||
|
my sym_Factor |
||||||
|
my si:valuevalue_part |
||||||
|
my kleene_73 |
||||||
|
my si:value_state_merge |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method kleene_73 {} { |
||||||
|
# * |
||||||
|
# x |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (MulOp) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Factor) |
||||||
|
|
||||||
|
while {1} { |
||||||
|
my si:void2_state_push |
||||||
|
my sequence_71 |
||||||
|
my si:kleene_close |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method sequence_71 {} { |
||||||
|
# x |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (MulOp) |
||||||
|
# * |
||||||
|
# '<blank>' |
||||||
|
# (Factor) |
||||||
|
|
||||||
|
my si:void_state_push |
||||||
|
my kleene_8 |
||||||
|
my si:voidvalue_part |
||||||
|
my sym_MulOp |
||||||
|
my si:valuevalue_part |
||||||
|
my kleene_8 |
||||||
|
my si:valuevalue_part |
||||||
|
my sym_Factor |
||||||
|
my si:value_state_merge |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# value Symbol 'Var' |
||||||
|
# |
||||||
|
|
||||||
|
method sym_Var {} { |
||||||
|
# x |
||||||
|
# '$' |
||||||
|
# [xyz] |
||||||
|
|
||||||
|
my si:void_symbol_start Var |
||||||
|
my sequence_80 |
||||||
|
my si:void_leaf_symbol_end Var |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method sequence_80 {} { |
||||||
|
# x |
||||||
|
# '$' |
||||||
|
# [xyz] |
||||||
|
|
||||||
|
my si:void_state_push |
||||||
|
my si:next_char $ |
||||||
|
my si:voidvoid_part |
||||||
|
my si:next_class xyz |
||||||
|
my si:void_state_merge |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
## END of GENERATED CODE. DO NOT EDIT. |
||||||
|
# # ## ### ###### ######## ############# |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## Ready |
||||||
|
|
||||||
|
package provide calculator_test 0.1 |
||||||
|
return |
Binary file not shown.
Binary file not shown.
File diff suppressed because it is too large
Load Diff
Binary file not shown.
@ -0,0 +1,456 @@ |
|||||||
|
|
||||||
|
#main.tcl - we expect to be in the context of a zipkit or tclkit vfs attached to a tcl executable. |
||||||
|
#review - what happens if both are somehow attached and both vfs and zipfs are available? |
||||||
|
# - if that's even possible - we have no control here over which main.tcl was selected as we're already here |
||||||
|
#The logic below will add appropriate package paths from starkit and zipfs vfs paths |
||||||
|
# - and restrict package paths to those coming from a vfs (if not launched with 'dev' first arg which allows external paths to remain) |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
apply { args { |
||||||
|
#here we make an attempt to avoid premature (costly) auto_path/tcl::tm::list scanning caused by our initial 'package require starkit'. |
||||||
|
#we will first look for a starkit.tcl in an expected location and try to load that, then fallback to package require. |
||||||
|
|
||||||
|
#standard way to avoid symlinking issues - review! |
||||||
|
set normscript [file dirname [file normalize [file join [info script] __dummy__]]] |
||||||
|
set normexe [file dirname [file normalize [file join [info nameofexecutable] __dummy__]]] |
||||||
|
|
||||||
|
set topdir [file dirname $normscript] |
||||||
|
set found_starkit_tcl 0 |
||||||
|
set possible_lib_vfs_folders [glob -dir [file join $topdir lib] -type d vfs*] |
||||||
|
foreach test_folder $possible_lib_vfs_folders { |
||||||
|
#e.g <name_of_exe>/lib/vfs1.4.1 |
||||||
|
#we don't expect multiple vfs* folders - but we will process any found and load the pkgIndex.tcl from these folders. |
||||||
|
#order of folder processing shouldn't matter (rely on order returned by 'package versions' - review) |
||||||
|
if {[file exists $test_folder/starkit.tcl] && [file exists $test_folder/pkgIndex.tcl]} { |
||||||
|
set dir $test_folder |
||||||
|
source $test_folder/pkgIndex.tcl |
||||||
|
} |
||||||
|
} |
||||||
|
if {[set starkitv [lindex [package versions starkit] end]] ne ""} { |
||||||
|
#run the ifneeded script for the latest found (assuming package versions ordering is correct) |
||||||
|
eval [package ifneeded starkit $starkitv] |
||||||
|
set found_starkit_tcl 1 |
||||||
|
} |
||||||
|
if {!$found_starkit_tcl} { |
||||||
|
#our internal search for starkit failed. |
||||||
|
#either we are in a pure zipfs system - or the starkit package is somewhere unexpected |
||||||
|
#for pure zipfs - it's wasteful to perform exhaustive search for starkit |
||||||
|
#review - only keep searching if not 'dev' first arg? |
||||||
|
|
||||||
|
#Initially we've done no scans of auto_path/tcl::tm::list - but there will already be a core set of packages known by the kit |
||||||
|
#retain it so we can 'forget' the difference after our first 'package require' forces a full scan which includes some paths we may not wish to include or at least include with different preferences |
||||||
|
puts "main.tcl 1)--> package name count: [llength [package names]]" |
||||||
|
puts stderr [join [package names] \n] |
||||||
|
set original_packages [package names] |
||||||
|
|
||||||
|
|
||||||
|
if {![catch {package require starkit}]} { |
||||||
|
#known side-effects of starkit::startup |
||||||
|
#sets the ::starkit::mode variable to the way in which it was launched. One of: {starpack starkit unwrapped tclhttpd plugin service sourced} |
||||||
|
#set the ::starkit::topdir variable |
||||||
|
#if mode not starpack, then: |
||||||
|
# - adds $::starkit::topdir/lib to the auto_path if not already present |
||||||
|
# |
||||||
|
#In this context (vfs attached to tcl kit executable - we expect the launch mode to be 'starkit' |
||||||
|
set starkit_startmode [starkit::startup] |
||||||
|
puts stderr "STARKIT MODE: $starkit_startmode" |
||||||
|
} |
||||||
|
puts "main.tcl 2)--> package name count: [llength [package names]]" |
||||||
|
foreach pkg [package names] { |
||||||
|
if {$pkg ni $original_packages} { |
||||||
|
package forget $pkg |
||||||
|
} |
||||||
|
} |
||||||
|
puts "main.tcl 3)--> package name count: [llength [package names]]" |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# -- --- --- |
||||||
|
#when run as a tclkit - the exe is mounted as a dir and Tcl's auto_execok doesn't find it |
||||||
|
#review - do we want $normexe or [info nameofexecutable] for $thisexe here? Presumably [info nameofexecutable] (possible symlink) ok |
||||||
|
set thisexe [file tail [info nameofexecutable]] ;#e.g punk86.exe |
||||||
|
set thisexeroot [file rootname $thisexe] ;#e.g punk86 |
||||||
|
set ::auto_execs($thisexeroot) [info nameofexecutable] |
||||||
|
if {$thisexe ne $thisexeroot} { |
||||||
|
set ::auto_execs($thisexe) [info nameofexecutable] |
||||||
|
} |
||||||
|
# -- --- --- |
||||||
|
set tclmajorv [lindex [split [info tclversion] .] 0] |
||||||
|
|
||||||
|
if {[info exists ::tcl::kitpath]} { |
||||||
|
set kp $::tcl::kitpath |
||||||
|
set existing_module_paths [string tolower [tcl::tm::list]] |
||||||
|
foreach p [list modules modules_tcl$tclmajorv] { |
||||||
|
if {[string tolower [file join $kp $p]] ni $existing_module_paths} { |
||||||
|
tcl::tm::add [file join $kp $p] |
||||||
|
} |
||||||
|
} |
||||||
|
foreach l [list lib lib_tcl$tclmajorv] { |
||||||
|
if {[string tolower [file join $kp $l]] ni [string tolower $::auto_path]} { |
||||||
|
lappend ::auto_path [file join $kp $l] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
if {[info commands tcl::zipfs::root] ne ""} { |
||||||
|
#review build option may be different - tclZipFs.c ZIPFS_APP_MOUNT defaults to ZIPFS_VOLUME/app - but it could be something else. |
||||||
|
set zipbase [file join [tcl::zipfs::root] app] ;#zipfs root has trailing slash - but file join does the right thing |
||||||
|
if {"$zipbase" in [tcl::zipfs::mount]} { |
||||||
|
set existing_module_paths [string tolower [tcl::tm::list]] |
||||||
|
foreach p [list modules modules_tcl$tclmajorv] { |
||||||
|
if {[string tolower [file join $zipbase $p]] ni $existing_module_paths} { |
||||||
|
tcl::tm::add [file join $zipbase $p] |
||||||
|
} |
||||||
|
} |
||||||
|
foreach l [list lib lib_tcl$tclmajorv] { |
||||||
|
if {[string tolower [file join $zipbase $l]] ni [string tolower $::auto_path]} { |
||||||
|
lappend ::auto_path [file join $zipbase $l] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
set internal_paths [list] |
||||||
|
if {[info commands tcl::zipfs::root] ne ""} { |
||||||
|
set ziproot [tcl::zipfs::root] ;#root is enough to determine internal zipkit path |
||||||
|
lappend internal_paths $ziproot |
||||||
|
} |
||||||
|
if {[info exists ::tcl::kitpath]} { |
||||||
|
lappend internal_paths $::tcl::kitpath |
||||||
|
} |
||||||
|
|
||||||
|
if {[lindex $args 0] in {dev devquiet}} { |
||||||
|
set arglist [lassign $args devmode] |
||||||
|
set ::argv $arglist |
||||||
|
set ::argc [llength $arglist] |
||||||
|
if {$devmode ne "devquiet"} { |
||||||
|
puts stderr "DEV MODE - preferencing external libraries and modules" |
||||||
|
} |
||||||
|
#Note regarding the use of package forget and binary packages |
||||||
|
#If the package has loaded a binary component - then a package forget and a subsequent package require can result in both binaries being present, as seen in 'info loaded' result - potentially resulting in anomalous behaviour |
||||||
|
#In general package forget after a package has already been required may need special handling and should be avoided where possible. |
||||||
|
#Only a limited set of package support unloading a binary component |
||||||
|
#We limit the use of 'package forget' here to packages that have not been loaded (whether pure-tcl or not) |
||||||
|
#ie in this context it is used only for manipulating preferences of which packages are loaded in the first place |
||||||
|
|
||||||
|
#Unintuitive preferencing can occur if the same package version is for example present in a tclkit and in a module or lib folder external to the kit. |
||||||
|
#It may be desired for performance or testing reasons to preference the library outside of the kit - and raising the version number may not always be possible/practical. |
||||||
|
|
||||||
|
#If the executable is a kit - we don't know what packages it contains or whether it allows loading from env based external paths. |
||||||
|
#For app-punk projects - the lib/module paths based on the project being run should take preference, even if the version number is the same. |
||||||
|
#(these are the 'info nameofexecutable' or 'info script' or 'pwd' relative paths that are added here) |
||||||
|
#Some kits will remove lib/module paths (from auto_path & tcl::tm::list) that have been added via TCLLIBPATH / TCLX_Y_TM_PATH environment variables |
||||||
|
#Some kits will remove those env-provided lib paths but fail to remove the env-provided module paths |
||||||
|
#(differences in boot.tcl in the kits) |
||||||
|
|
||||||
|
#------------------------------------------------------------------------------ |
||||||
|
#Module loading |
||||||
|
#------------------------------------------------------------------------------ |
||||||
|
#If the current directory contains .tm files when the punk repl starts - then it will attempt to preference them |
||||||
|
# - but first add our other known relative modules paths - as it won't make sense to use current directory as a modulepath if it's an ancestor of one of these.. |
||||||
|
|
||||||
|
#original tm list at this point consists of whatever the kit decided + some prepended internal kit paths that punk decided on. |
||||||
|
#we want to bring the existing external paths to the front (probably from the kit looking at various env TCL* values) |
||||||
|
#we want to maintain the order of the internal paths. |
||||||
|
#we then want to add our external dev paths of the total list |
||||||
|
|
||||||
|
#assert [llength [package names]] should be small at this point ~ <10 ? |
||||||
|
|
||||||
|
set original_tm_list [tcl::tm::list] |
||||||
|
tcl::tm::remove {*}$original_tm_list |
||||||
|
|
||||||
|
# -- --- --- --- --- --- --- --- |
||||||
|
#split existing paths into internal & external |
||||||
|
set internal_tm_dirs [list] ;# |
||||||
|
set external_tm_dirs [list] |
||||||
|
set lcase_internal_paths [string tolower $internal_paths] |
||||||
|
foreach tm $original_tm_list { |
||||||
|
set tmlower [string tolower $tm] |
||||||
|
set is_internal 0 |
||||||
|
foreach okprefix $lcase_internal_paths { |
||||||
|
if {[string match "$okprefix*" $tmlower]} { |
||||||
|
lappend internal_tm_dirs $tm |
||||||
|
set is_internal 1 |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
if {!$is_internal} { |
||||||
|
lappend external_tm_dirs $tm |
||||||
|
} |
||||||
|
} |
||||||
|
# -- --- --- --- --- --- --- --- |
||||||
|
set original_external_tm_dirs $external_tm_dirs ;#we check some of our additions and bring to front - so we refer to external list as provided by kit |
||||||
|
#assert internal_tm_dirs and external_tm_dirs have their case preserved.. |
||||||
|
|
||||||
|
set module_folders [list] |
||||||
|
|
||||||
|
#review - the below statement doesn't seem to be true. |
||||||
|
#tm list first added end up later in the list - and then override earlier ones if version the same - so add pwd-relative 1st to give higher priority |
||||||
|
#(only if Tcl has scanned all paths - see below bogus package load) |
||||||
|
#1 |
||||||
|
|
||||||
|
#2) |
||||||
|
# .../bin/punkXX.exe look for ../modules (i.e modules folder at same level as bin folder) |
||||||
|
#using normexe under assumption [info name] might be symlink - and more likely to be where the modules are located. |
||||||
|
#we will try both relative to symlink and relative to underlying exe - with those at symlink location earlier in the list |
||||||
|
#review - a user may have other expectations. |
||||||
|
|
||||||
|
#case differences could represent different paths on unix-like platforms. |
||||||
|
#It's perhaps a little unwise to configure matching paths with only case differences for a cross-platform tool .. but we should support it for those who use it and have no interest in windows - todo! review |
||||||
|
set normexe_dir [file dirname $normexe] |
||||||
|
if {[file tail $normexe_dir] eq "bin"} { |
||||||
|
#underlying exe in a bin dir - backtrack 1 |
||||||
|
lappend exe_module_folders [file dirname $normexe_dir]/modules |
||||||
|
lappend exe_module_folders [file dirname $normexe_dir]/modules_tcl$tclmajorv |
||||||
|
} else { |
||||||
|
lappend exe_module_folders $normexe_dir/modules |
||||||
|
lappend exe_module_folders $normexe_dir/modules_tcl$tclmajorv |
||||||
|
} |
||||||
|
set nameexe_dir [file dirname [info nameofexecutable]] |
||||||
|
#possible symlink (may resolve to same path as above - we check below to not add in twice) |
||||||
|
if {[file tail $nameexe_dir] eq "bin"} { |
||||||
|
lappend exe_module_folders [file dirname $nameexe_dir]/modules |
||||||
|
lappend exe_module_folders [file dirname $nameexe_dir]/modules_tcl$tclmajorv |
||||||
|
} else { |
||||||
|
lappend exe_module_folders $nameexe_dir/modules |
||||||
|
lappend exe_module_folders $nameexe_dir/modules_tcl$tclmajorv |
||||||
|
} |
||||||
|
|
||||||
|
foreach modulefolder $exe_module_folders { |
||||||
|
set lc_external_tm_dirs [string tolower $external_tm_dirs] |
||||||
|
set lc_modulefolder [string tolower $modulefolder] |
||||||
|
if {$lc_modulefolder in [string tolower $original_external_tm_dirs]} { |
||||||
|
#perhaps we have an env var set pointing to one of our dev foldersl. We don't want to rely on how the kit ordered it. |
||||||
|
#bring to front if not already there. |
||||||
|
#assert it must be present in $lc_external_tm_dirs if it's in $original_external_tm_dirs |
||||||
|
set posn [lsearch $lc_external_tm_dirs $lc_modulefolder] |
||||||
|
if {$posn > 0} { |
||||||
|
#don't rely on lremove here. Not all runtimes have it and we don't want to load our forward-compatibility packages yet. |
||||||
|
#(still need to support tcl 8.6 - and this script used in multiple kits) |
||||||
|
set external_tm_dirs [lreplace $external_tm_dirs $posn $posn] |
||||||
|
#don't even add it back in if it doesn't exist in filesystem |
||||||
|
if {[file isdirectory $modulefolder]} { |
||||||
|
set external_tm_dirs [linsert $external_tm_dirs 0 $modulefolder] |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
if {$lc_modulefolder ni $lc_external_tm_dirs && [file isdirectory $modulefolder]} { |
||||||
|
set external_tm_dirs [linsert $external_tm_dirs 0 $modulefolder] ;#linsert seems faster than 'concat [list $modulefolder] $external_tm_dirs' - review |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
if {![llength $exe_module_folders]} { |
||||||
|
puts stderr "Warning - no 'modules' or 'modules_tcl$tclmajorv' folders found relative to executable (or it's symlink if any)" |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#add lib and lib_tcl8 lib_tcl9 etc based on tclmajorv |
||||||
|
#libs are appended to end - so add higher priority libraries last (opposite to modules) |
||||||
|
#auto_path - add exe-relative after exe-relative path |
||||||
|
if {"windows" eq $::tcl_platform(platform)} { |
||||||
|
#case differences dont matter - but can stop us finding path in auto_path |
||||||
|
foreach libsub [list lib_tcl$tclmajorv lib] { |
||||||
|
if {[file tail $nameexe_dir] eq "bin"} { |
||||||
|
set libfolder [file dirname $nameexe_dir]/$libsub |
||||||
|
} else { |
||||||
|
set libfolder $nameexe_dir/$libsub |
||||||
|
} |
||||||
|
if {[string tolower $libfolder] ni [string tolower $::auto_path] && [file isdirectory $libfolder]} { |
||||||
|
lappend ::auto_path $libfolder |
||||||
|
} |
||||||
|
# ------------- |
||||||
|
if {[file tail $normexe_dir] eq "bin"} { |
||||||
|
set libfolder [file dirname $normexe_dir]/$libsub |
||||||
|
} else { |
||||||
|
set libfolder $normexe_dir/$libsub |
||||||
|
} |
||||||
|
if {[string tolower $libfolder] ni [string tolower $::auto_path] && [file isdirectory $libfolder]} { |
||||||
|
lappend ::auto_path $libfolder |
||||||
|
} |
||||||
|
# ------------- |
||||||
|
set libfolder [pwd]/$libsub |
||||||
|
if {[string tolower $libfolder] ni [string tolower $::auto_path] && [file isdirectory $libfolder]} { |
||||||
|
lappend ::auto_path $libfolder |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
#on other platforms, case differences could represent different paths |
||||||
|
foreach libsub [list lib_tcl$tclmajorv lib] { |
||||||
|
if {[file tail $nameexe_dir] eq "bin"} { |
||||||
|
set libfolder [file dirname $nameexe_dir]/$libsub |
||||||
|
} else { |
||||||
|
set libfolder $nameexe_dir/$libsub |
||||||
|
} |
||||||
|
if {$libfolder ni $::auto_path && [file isdirectory $libfolder]} { |
||||||
|
lappend ::auto_path $libfolder |
||||||
|
} |
||||||
|
# ------------- |
||||||
|
if {[file tail $normexe_dir] eq "bin"} { |
||||||
|
set libfolder [file dirname $normexe_dir]/$libsub |
||||||
|
} else { |
||||||
|
set libfolder $normexe_dir/$libsub |
||||||
|
} |
||||||
|
if {$libfolder ni $::auto_path && [file isdirectory $libfolder]} { |
||||||
|
lappend ::auto_path $libfolder |
||||||
|
} |
||||||
|
# ------------- |
||||||
|
set libfolder [pwd]/$libsub |
||||||
|
if {$libfolder ni $::auto_path && [file isdirectory $libfolder]} { |
||||||
|
lappend ::auto_path $libfolder |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#2) support developer running from a folder containing *.tm files they want to make available |
||||||
|
# could cause problems if user happens to be in a subdirectory of a tm folder structure as namespaced modules won't work if not at a tm path root. |
||||||
|
#The current dir could also be a subdirectory of an existing tm_dir which would fail during tcl::tm::add - we will need to wrap all additions in catch |
||||||
|
set currentdir_modules [glob -nocomplain -dir [pwd] -type f -tail *.tm] |
||||||
|
#we assume [pwd] will always return an external (not kit) path at this point - REVIEW |
||||||
|
if {[llength $currentdir_modules]} { |
||||||
|
#now add current dir (if no conflict with above) |
||||||
|
#catch {tcl::tm::add [pwd]} |
||||||
|
set external_tm_dirs [linsert $external_tm_dirs 0 $currentdir_modules] |
||||||
|
if {[file exists [pwd]/modules] || [file exists [pwd]/modules_tcl$tclmajorv]} { |
||||||
|
puts stderr "WARNING: modules or modules_tcl$tclmajorv folders not added to tcl::tm::path due to modules found in current workding dir [pwd]" |
||||||
|
} |
||||||
|
} else { |
||||||
|
#modules or modules_tclX subdir relative to cwd cannot be added if [pwd] has been added |
||||||
|
set cwd_modules_folder [file normalize [file join [pwd] modules]] |
||||||
|
if {[file isdirectory $cwd_modules_folder]} { |
||||||
|
if {[string tolower $cwd_modules_folder] ni [string tolower $external_tm_dirs]} { |
||||||
|
#prepend |
||||||
|
set external_tm_dirs [linsert $external_tm_dirs 0 $cwd_modules_folder] |
||||||
|
} |
||||||
|
} |
||||||
|
set cwd_modules_folder [file normalize [file join [pwd] modules_tcl$tclmajorv]] |
||||||
|
if {[file isdirectory $cwd_modules_folder]} { |
||||||
|
if {[string tolower $cwd_modules_folder] ni [string tolower $external_tm_dirs]} { |
||||||
|
#prepend |
||||||
|
set external_tm_dirs [linsert $external_tm_dirs 0 $cwd_modules_folder] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#assert tcl::tm::list still empty here |
||||||
|
#restore module paths |
||||||
|
#add internals first as in 'dev' mode (dev as first argument on launch) we preference external modules |
||||||
|
#note use of lreverse to maintain same order |
||||||
|
foreach p [lreverse $internal_tm_dirs] { |
||||||
|
if {$p ni [tcl::tm::list]} { |
||||||
|
#the prior tm paths go to the head of the list. |
||||||
|
#They are processed first.. but an item of same version later in the list will override one at the head. (depending on when list was scanned) REVIEW - true statement??? |
||||||
|
#addition can fail if one path is a prefix of another |
||||||
|
if {[catch {tcl::tm::add $p} errM]} { |
||||||
|
puts stderr "Failed to add internal module dir '$p' to tcl::tm::list\n$errM" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
foreach p [lreverse $external_tm_dirs] { |
||||||
|
if {$p ni [tcl::tm::list]} { |
||||||
|
if {[catch {tcl::tm::add $p} errM]} { |
||||||
|
puts stderr "Failed to add external module dir '$p' to tcl::tm::list\n$errM" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#------------------------------------------------------------------------------ |
||||||
|
#REVIEW |
||||||
|
#package require a bogus package to ensure Tcl scans the whole auto_path/tm list - otherwise a lower-versioned module earlier in the path may be loaded |
||||||
|
#This seems to take not insignificant time depending on size of auto_path and tcl::tm::list (e.g 2023 i9 ssd 100ms) - but seems unavoidable for now |
||||||
|
#catch {package require flobrudder666_nonexistant} |
||||||
|
#------------------------------------------------------------------------------ |
||||||
|
|
||||||
|
|
||||||
|
} else { |
||||||
|
#Tcl_Init will most likely have set up some external paths |
||||||
|
#As our app has been started without the 'dev' first arg - we will prune paths that are not zipfs or tclkit |
||||||
|
set new_auto_path [list] |
||||||
|
#review - case insensitive ok for windows - but could cause issues on other platforms? |
||||||
|
foreach ap $::auto_path { |
||||||
|
set aplower [string tolower $ap] |
||||||
|
foreach okprefix $internal_paths { |
||||||
|
if {[string match "[string tolower $okprefix]*" $aplower]} { |
||||||
|
lappend new_auto_path $ap |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
set ::auto_path $new_auto_path |
||||||
|
|
||||||
|
set new_tm_list [list] |
||||||
|
foreach tm [tcl::tm::list] { |
||||||
|
set tmlower [string tolower $tm] |
||||||
|
foreach okprefix $internal_paths { |
||||||
|
if {[string match "[string tolower $okprefix]*" $tmlower]} { |
||||||
|
lappend new_tm_list $tm |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
tcl::tm::remove {*}[tcl::tm::list] |
||||||
|
tcl::tm::add {*}[lreverse $new_tm_list] |
||||||
|
|
||||||
|
|
||||||
|
#If it looks like we are running the vfs/xxx.vfs/main.tcl from an external tclsh - try to use vfs folders to simulate kit state |
||||||
|
#set script_relative_lib [file normalize [file join [file dirname [info script]] lib]] |
||||||
|
set scriptdir [file dirname [info script]] |
||||||
|
if {![string match //zipfs:/* $scriptdir] && ![info exists ::tcl::kitpath]} { |
||||||
|
#presumably running the vfs/xxx.vfs/main.tcl script using a non-kit tclsh that doesn't have starkit lib available.. lets see if we can move forward anyway |
||||||
|
set vfscontainer [file normalize [file dirname $scriptdir]] |
||||||
|
set vfscommon [file join $vfscontainer _vfscommon] |
||||||
|
set vfsdir [file normalize $scriptdir] |
||||||
|
set projectroot [file dirname [file dirname $vfscontainer]] ;#back below src/vfs/xxx.vfs/main.tcl |
||||||
|
puts stdout "no starkit. projectroot?: $projectroot" |
||||||
|
puts stdout "info lib: [info library]" |
||||||
|
|
||||||
|
#add back the info lib reported by the executable.. as we can't access the one built into a kit |
||||||
|
if {[file exists [info library]]} { |
||||||
|
lappend ::auto_path [info library] |
||||||
|
} |
||||||
|
|
||||||
|
set lib_types [list lib lib_tcl$tclmajorv] |
||||||
|
foreach l $lib_types { |
||||||
|
set lib [file join $vfsdir $l] |
||||||
|
if {[file exists $lib] && [string tolower $lib] ni [string tolower $::auto_path]} { |
||||||
|
lappend ::auto_path $lib |
||||||
|
} |
||||||
|
} |
||||||
|
foreach l $lib_types { |
||||||
|
set lib [file join $vfscommon $l] |
||||||
|
if {[file exists $lib] && [string tolower $lib] ni [string tolower $::auto_path]} { |
||||||
|
lappend ::auto_path $lib |
||||||
|
} |
||||||
|
} |
||||||
|
set mod_types [list modules modules_tcl$tclmajorv] |
||||||
|
foreach m $mod_types { |
||||||
|
set modpath [file join $vfsdir $m] |
||||||
|
if {[file exists $modpath] && [string tolower $modpath] ni [string tolower [tcl::tm::list]]} { |
||||||
|
tcl::tm::add $modpath |
||||||
|
} |
||||||
|
} |
||||||
|
foreach m $mod_types { |
||||||
|
set modpath [file join $vfscommon $m] |
||||||
|
if {[file exists $modpath] && [string tolower $modpath] ni [string tolower [tcl::tm::list]]} { |
||||||
|
tcl::tm::add $modpath |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#force rescan |
||||||
|
#catch {package require flobrudder666_nonexistant} |
||||||
|
set arglist $args |
||||||
|
} |
||||||
|
|
||||||
|
if {[llength $arglist]} { |
||||||
|
#puts stdout "main.tcl launching app-shellspy" |
||||||
|
package require app-shellspy |
||||||
|
} else { |
||||||
|
puts stdout "main.tcl launching app-punk. pkg names count:[llength [package names]]" |
||||||
|
package require app-punk |
||||||
|
#app-punk starts repl |
||||||
|
#repl::start stdin -title "main.tcl" |
||||||
|
} |
||||||
|
}} {*}$::argv |
Loading…
Reference in new issue