76 changed files with 17557 additions and 9669 deletions
@ -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
@ -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,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
Binary file not shown.
File diff suppressed because it is too large
Load Diff
@ -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