93 changed files with 43377 additions and 1383 deletions
@ -0,0 +1,218 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::cap 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta description pkg capability register |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::cap { |
||||
variable pkgcap [dict create] |
||||
variable caps [dict create] |
||||
proc register_package {pkg capabilitylist} { |
||||
variable pkgcap |
||||
variable caps |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
#for each capability |
||||
# - ensure 1st element is a single word |
||||
# - ensure that if 2nd element (capdict) is present - it is dict shaped |
||||
foreach c $capabilitylist { |
||||
lassign $c capname capdict |
||||
if {[llength $capname] !=1} { |
||||
error "register_package error. pkg: '$pkg' An entry in the capability list doesn't appear to have a single-word name. Problematic entry:'$c'" |
||||
} |
||||
if {[expr {[llength $capdict] %2 != 0}]} { |
||||
error "register_package error. pkg:'$pkg' The second element for capname:'$capname' doesn't appear to be a valid dict. Problematic entry: '$c'" |
||||
} |
||||
if {[dict exists $caps $capname]} { |
||||
set cap_pkgs [dict get $caps $capname] |
||||
} else { |
||||
set cap_pkgs [list] |
||||
} |
||||
if {$pkg ni $cap_pkgs} { |
||||
dict lappend caps $capname $pkg |
||||
} |
||||
} |
||||
dict set pkgcap $pkg $capabilitylist |
||||
} |
||||
proc promote_package {pkg} { |
||||
variable pkgcap |
||||
variable caps |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
if {![dict exists $pkgcap $pkg]} { |
||||
error "punk::cap::promote_package error pkg'$pkg' not registered. Use register_package \$pkg first" |
||||
} |
||||
if {[dict size $pkgcap] > 1} { |
||||
set pkginfo [dict get $pkgcap $pkg] |
||||
#remove and re-add at end of dict |
||||
dict unset pkgcap $pkg |
||||
dict set pkgcap $pkg $pkginfo |
||||
foreach {cap cap_pkgs} $caps { |
||||
if {$pkg in $cap_pkgs} { |
||||
set posn [lsearch $cap_pkgs $pkg] |
||||
if {$posn >=0} { |
||||
#rewrite package list with pkg at tail of list for this capability |
||||
set cap_pkgs [lreplace $cap_pkgs $posn $posn] |
||||
lappend cap_pkgs $pkg |
||||
dict set caps $cap $cap_pkgs |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
proc demote_package {pkg} { |
||||
variable pkgcap |
||||
variable caps |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
if {![dict exists $pkgcap $pkg]} { |
||||
error "punk::cap::promote_package error pkg'$pkg' not registered. Use register_package \$pkg first" |
||||
} |
||||
if {[dict size $pkgcap] > 1} { |
||||
set pkginfo [dict get $pkgcap $pkg] |
||||
#remove and re-add at start of dict |
||||
dict unset pkgcap $pkg |
||||
dict set pkgcap $pkg $pkginfo |
||||
set pkgcap [dict merge [dict create $pkg $pkginfo] $pkgcap] |
||||
foreach {cap cap_pkgs} $caps { |
||||
if {$pkg in $cap_pkgs} { |
||||
set posn [lsearch $cap_pkgs $pkg] |
||||
if {$posn >=0} { |
||||
#rewrite package list with pkg at head of list for this capability |
||||
set cap_pkgs [lreplace $cap_pkgs $posn $posn] |
||||
set cap_pkgs [list $pkg {*}$cap_pkgs] |
||||
dict set caps $cap $cap_pkgs |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
proc unregister_package {pkg} { |
||||
variable pkgcap |
||||
variable caps |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
if {[dict exists $pkgcap $pkg]} { |
||||
#remove corresponding entries in caps |
||||
set capabilitylist [dict get $pkgcap $pkg] |
||||
foreach c $capabilitylist { |
||||
lassign $c capname _capdict |
||||
set pkglist [dict get $caps $capname] |
||||
set posn [lsearch $pkglist $pkg] |
||||
if {$posn >= 0} { |
||||
set pkglist [lreplace $pkglist $posn $posn] |
||||
dict set caps $capname $pkglist |
||||
} |
||||
} |
||||
#delete the main registration record |
||||
dict unset pkgcap $pkg |
||||
} |
||||
} |
||||
proc registered_package {pkg} { |
||||
variable pkgcap |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
if {[dict exists $pkgcap $pkg]} { |
||||
return [dict get $pkgcap $pkg] |
||||
} else { |
||||
return |
||||
} |
||||
} |
||||
proc registered_packages {} { |
||||
variable pkgcap |
||||
return $pkgcap |
||||
} |
||||
|
||||
proc capabilities {{glob *}} { |
||||
variable caps |
||||
set keys [lsort [dict keys $caps $glob]] |
||||
set cap_list [list] |
||||
foreach k $keys { |
||||
lappend cap_list [list $k [dict get $caps $k]] |
||||
} |
||||
return $cap_list |
||||
} |
||||
|
||||
namespace eval templates { |
||||
#return a dict keyed on folder with source pkg as value |
||||
proc folders {} { |
||||
package require punk::cap |
||||
set caplist [punk::cap::capabilities templates] |
||||
# e.g {templates {punk::mix::templates ::somepkg}} |
||||
set templates_record [lindex $caplist 0] |
||||
set pkgs [lindex $templates_record 1] |
||||
|
||||
set folderdict [dict create] |
||||
foreach pkg $pkgs { |
||||
set caplist [punk::cap::registered_package $pkg] |
||||
set templates_entries [lsearch -all -inline -index 0 $caplist templates] ;#we generally expect only one - but if multiple exist - use them |
||||
foreach templates_info $templates_entries { |
||||
lassign $templates_info _templates templates_dict |
||||
if {[dict exists $templates_dict relpath]} { |
||||
set provide_statement [package ifneeded $pkg [package require $pkg]] |
||||
set tmfile [lindex $provide_statement end] |
||||
#set tmdir [file dirname [lindex $provide_statement end]] |
||||
set tpath [file normalize [file join $tmfile [dict get $templates_dict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder |
||||
#relpath relative to file is important for tm files that are zip/tar based containers |
||||
if {[file isdirectory $tpath]} { |
||||
dict set folderdict $tpath [list source $pkg sourcetype package] |
||||
} else { |
||||
puts stderr "punk::cap::templates::folders WARNING - unable to determine base folder for package '$pkg' which is registered with punk::mix as a provider of 'templates' capability" |
||||
} |
||||
} else { |
||||
puts stderr "punk::cap::templates::folders WARNING - registered pkg 'pkg' has capability 'templates' but no 'relpath' key - unable to use as source of templates" |
||||
} |
||||
} |
||||
} |
||||
return $folderdict |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::cap [namespace eval punk::cap { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,904 @@
|
||||
package provide punk::mix::base [namespace eval punk::mix::base { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
||||
|
||||
#base internal plumbing functions |
||||
namespace eval punk::mix::base { |
||||
proc set_alias {cmdname args} { |
||||
#--------- |
||||
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||
lassign [_split_args $args] _opts opts _args args |
||||
if {[dict exists $opts -extension]} { |
||||
set extension [dict get $opts -extension] |
||||
} else { |
||||
set extension "" |
||||
} |
||||
#--------- |
||||
|
||||
uplevel #0 [list interp alias {} $cmdname {} punk::mix::base::_cli -extension $extension] |
||||
} |
||||
proc _cli {args} { |
||||
#--------- |
||||
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||
lassign [_split_args $args] _opts opts _args args |
||||
if {[dict exists $opts -extension]} { |
||||
set extension [dict get $opts -extension] |
||||
} else { |
||||
set extension "" |
||||
} |
||||
#--------- |
||||
if {![string length $extension]} { |
||||
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||
} |
||||
#puts stderr "punk::mix::base extension: [string trimleft $extension :]" |
||||
if {![string length $extension]} { |
||||
#if still no extension - must have been called dirctly as punk::mix::base::_cli |
||||
if {![llength $args]} { |
||||
set args "help" |
||||
} |
||||
set extension [namespace current] |
||||
} |
||||
if {![llength $args]} { |
||||
if {[info exists ${extension}::default_command]} { |
||||
tailcall $extension [set ${extension}::default_command] |
||||
} |
||||
tailcall $extension |
||||
} else { |
||||
tailcall $extension {*}$args |
||||
} |
||||
} |
||||
proc _unknown {ns args} { |
||||
#--------- |
||||
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||
lassign [_split_args $args] _opts opts _args args |
||||
if {[dict exists $opts -extension]} { |
||||
set extension [dict get $opts -extension] |
||||
} else { |
||||
set extension "" |
||||
} |
||||
#--------- |
||||
|
||||
if {![string length $extension]} { |
||||
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||
} |
||||
#puts stderr "arglen:[llength $args]" |
||||
#puts stdout "_unknown '$ns' '$args'" |
||||
|
||||
set d_commands [get_commands -extension $extension] |
||||
set all_commands [list {*}[dict get $d_commands main] {*}[dict get $d_commands base]] |
||||
error "Unknown subcommand \"[lindex $args 0]\": must be one of: $all_commands" "punk::mix::base _unknown $ns $args" [list unknown_ensemble_subcommand ensemble punk::mix::base] |
||||
} |
||||
proc _redirected {from_ns subcommand args} { |
||||
#puts stderr "_redirected from_ns: $from_ns subcommand:$subcommand args:$args" |
||||
set pname [namespace current]::$subcommand |
||||
if {$pname in [info procs $pname]} { |
||||
set argnames [info args $pname] |
||||
#puts stderr "_redirected $subcommand argnames: $argnames" |
||||
if {[lindex $argnames end] eq "args"} { |
||||
set pos_argnames [lrange $argnames 0 end-1] |
||||
} else { |
||||
set pos_argnames $argnames |
||||
} |
||||
set argvals [list] |
||||
set numargs [llength $pos_argnames] |
||||
if {$numargs > 0} { |
||||
set argvals [lrange $args 0 $numargs-1] |
||||
set args [lrange $args $numargs end] |
||||
} |
||||
if {[llength $argvals] < $numargs} { |
||||
error "wrong # args: $from_ns $subcommand requires args: $pos_argnames" |
||||
} |
||||
tailcall [namespace current] $subcommand {*}$argvals {*}$args -extension $from_ns |
||||
} else { |
||||
tailcall [namespace current] $subcommand {*}$args -extension $from_ns |
||||
} |
||||
} |
||||
proc _split_args {arglist} { |
||||
#don't assume arglist is fully paired. |
||||
set posn [lsearch $arglist -extension] |
||||
set opts [list] |
||||
if {$posn >= 0} { |
||||
if {$posn+2 <= [llength $arglist]} { |
||||
set opts [list -extension [lindex $arglist $posn+1]] |
||||
set argsremaining [lreplace $arglist $posn $posn+1] |
||||
} else { |
||||
#no value supplied to -extension |
||||
error "punk::mix::base::_split_args - no value found for option '-extension'. Supply a value or omit the option." |
||||
} |
||||
} else { |
||||
set argsremaining $arglist |
||||
} |
||||
|
||||
return [list opts $opts args $argsremaining] |
||||
} |
||||
} |
||||
|
||||
|
||||
#base API (potentially overridden functions - may also be called from overriding namespace) |
||||
#commands should either handle or silently ignore -extension <namespace/ensemble> |
||||
namespace eval punk::mix::base { |
||||
namespace ensemble create |
||||
namespace export help dostuff get_commands set_alias |
||||
namespace ensemble configure [namespace current] -unknown punk::mix::base::_unknown |
||||
proc get_commands {args} { |
||||
#--------- |
||||
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||
lassign [_split_args $args] _opts opts _args args |
||||
if {[dict exists $opts -extension]} { |
||||
set extension [dict get $opts -extension] |
||||
} else { |
||||
set extension "" |
||||
} |
||||
#--------- |
||||
if {![string length $extension]} { |
||||
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||
} |
||||
|
||||
set maincommands [list] |
||||
#extension may still be blank e.g if punk::mix::base::get_commands called directly |
||||
if {[string length $extension]} { |
||||
set nsmain $extension |
||||
#puts stdout "get_commands nsmain: $nsmain" |
||||
set parentpatterns [namespace eval $nsmain [list namespace export]] |
||||
set nscommands [list] |
||||
foreach p $parentpatterns { |
||||
lappend nscommands {*}[info commands ${nsmain}::$p] |
||||
} |
||||
foreach c $nscommands { |
||||
set cmd [namespace tail $c] |
||||
lappend maincommands $cmd |
||||
} |
||||
set maincommands [lsort $maincommands] |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
set nsbase [namespace current] |
||||
set basepatterns [namespace export] |
||||
#puts stdout "basepatterns:$basepatterns" |
||||
set nscommands [list] |
||||
foreach p $basepatterns { |
||||
lappend nscommands {*}[info commands ${nsbase}::$p] |
||||
} |
||||
|
||||
set basecommands [list] |
||||
foreach c $nscommands { |
||||
set cmd [namespace tail $c] |
||||
if {$cmd ni $maincommands} { |
||||
lappend basecommands $cmd |
||||
} |
||||
} |
||||
set basecommands [lsort $basecommands] |
||||
|
||||
|
||||
return [list main $maincommands base $basecommands] |
||||
} |
||||
proc help {args} { |
||||
#' **%ensemblecommand% help** *args* |
||||
#' |
||||
#' Help for ensemble commands in the command line interface |
||||
#' |
||||
#' |
||||
#' Arguments: |
||||
#' |
||||
#' * args - first word of args is the helptopic requested - usually a command name |
||||
#' - calling help with no arguments will list available commands |
||||
#' |
||||
#' Returns: help text (text) |
||||
#' |
||||
#' Examples: |
||||
#' |
||||
#' ``` |
||||
#' %ensemblecommand% help <commandname> |
||||
#' ``` |
||||
#' |
||||
#' |
||||
|
||||
|
||||
#extension.= @@opts/@?@-extension,args@@args=>. [_split_args $args] {| |
||||
# >} inspect -label a {| |
||||
# >} .=e>end,data>end pipeswitch { |
||||
# pipecase ,0/1/#= $switchargs {| |
||||
# e/0 |
||||
# >} .=>. {set e} |
||||
# pipecase /1,1/1/#= $switchargs |
||||
#} |@@ok/result> <e/0| [namespace qualifiers [lindex [info level -1] 0]] |
||||
|
||||
|
||||
#--------- |
||||
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||
lassign [_split_args $args] _opts opts _args args |
||||
if {[dict exists $opts -extension]} { |
||||
set extension [dict get $opts -extension] |
||||
} else { |
||||
set extension "" |
||||
} |
||||
#--------- |
||||
|
||||
|
||||
|
||||
if {![string length $extension]} { |
||||
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||
} |
||||
#puts stderr "-1:[info level -1]" |
||||
|
||||
set command_info [punk::mix::base::get_commands -extension $extension] |
||||
set subhelp1 [lindex $args 0] |
||||
if {[string length $subhelp1]} { |
||||
if {[regexp {[*?]} $subhelp1]} { |
||||
set helpstr "" |
||||
append helpstr "matched commands:\n" |
||||
dict for {source cmdlist} $command_info { |
||||
set matches [lsearch -all -inline -glob $cmdlist $subhelp1] |
||||
if {[llength $matches]} { |
||||
append helpstr \n " $source" |
||||
foreach cmd $matches { |
||||
append helpstr \n " - $cmd" |
||||
} |
||||
} |
||||
} |
||||
return $helpstr |
||||
} else { |
||||
dict for {source cmdlist} $command_info { |
||||
if {$subhelp1 in $cmdlist} { |
||||
if {$source eq "base"} { |
||||
set ns [namespace current] |
||||
} else { |
||||
set ns $extension |
||||
} |
||||
set procname ${ns}::$subhelp1 |
||||
if {$procname in [info procs $procname]} { |
||||
return "proc: $subhelp1 arguments: [info args $procname]" |
||||
} else { |
||||
set a [interp alias {} ${ns}::$subhelp1] |
||||
if {[string length $a]} { |
||||
return "alias: $subhelp1 target: $a" |
||||
} else { |
||||
return "command: $subhelp1 (No info available)" |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
return "No info found" |
||||
} |
||||
|
||||
} |
||||
#result for just 'pmix help' |
||||
set helpstr "" |
||||
append helpstr "commands:\n" |
||||
|
||||
foreach {source cmdlist} $command_info { |
||||
append helpstr \n " $source" |
||||
foreach cmd $cmdlist { |
||||
append helpstr \n " - $cmd" |
||||
} |
||||
} |
||||
return $helpstr |
||||
} |
||||
#proc dostuff {args} { |
||||
# extension@@opts/@?@-extension,args@@args= [_split_args $args] |
||||
# puts stdout "base doingstuff-with-args:'$args'-in-namespace:'[namespace current]'" |
||||
#} |
||||
namespace eval lib { |
||||
variable sha3_implementation "" ;#set by cksum_algorithms (which is called by cksum_path) It looks for fossil or sqlite3. Todo - add proper Tcl implementation. |
||||
namespace export * |
||||
|
||||
#----------------------------------------------------- |
||||
#literate-programming style naming for some path tests |
||||
#Note the naming of the operator portion of a_op_b is consistent in that it is the higher side of the filesystem tree first. |
||||
#hence aboveorat vs atorbelow |
||||
#These names also sort in the logical order of higher to lower in the filesystem (when considering the root as 'higher' in the filesystem) |
||||
proc path_a_above_b {path_a path_b} { |
||||
#stripPath prefix path |
||||
return [expr {[fileutil::stripPath $path_a $path_b] ni [list . $path_b]}] |
||||
} |
||||
proc path_a_aboveorat_b {path_a path_b} { |
||||
return [expr {[fileutil::stripPath $path_a $path_b] ne $path_b}] |
||||
} |
||||
proc path_a_at_b {path_a path_b} { |
||||
return [expr {[fileutil::stripPath $path_a $path_b] eq "." }] |
||||
} |
||||
proc path_a_atorbelow_b {path_a path_b} { |
||||
return [expr {[fileutil::stripPath $path_b $path_a] ne $path_a}] |
||||
} |
||||
proc path_a_below_b {path_a path_b} { |
||||
return [expr {[fileutil::stripPath $path_b $path_a] ni [list . $path_a]}] |
||||
} |
||||
proc path_a_inlinewith_b {path_a path_b} { |
||||
return [expr {[path_a_aboveorat_b $path_a $path_b] || [path_a_below_b $path_a $path_b]}] |
||||
} |
||||
#----------------------------------------------------- |
||||
|
||||
|
||||
|
||||
#find src/something folders which are not certain known folders with other purposes, (such as: bootsupport .vfs folders or vendor folders etc) and contain .tm file(s) |
||||
proc find_source_module_paths {{path {}}} { |
||||
if {![string length [set candidate [punk::repo::find_candidate $path]]]} { |
||||
error "find_source_module_paths cannot determine a suitable project root at or above path '$path' - path supplied should be within a project" |
||||
} |
||||
#we can return module paths even if the project isn't yet under revision control |
||||
set src_subs [glob -nocomplain -dir [file join $candidate src] -type d -tail *] |
||||
set antipatterns [list *.vfs vendor* lib _build doc embedded runtime bootsupport] |
||||
set tm_folders [list] |
||||
foreach sub $src_subs { |
||||
set is_ok 1 |
||||
foreach anti $antipatterns { |
||||
if {[string match $anti $sub]} { |
||||
set is_ok 0 |
||||
break |
||||
} |
||||
} |
||||
if {!$is_ok} { |
||||
continue |
||||
} |
||||
set testfolder [file join $candidate src $sub] |
||||
set tmfiles [glob -nocomplain -dir $testfolder -type f -tail *.tm] |
||||
if {[llength $tmfiles]} { |
||||
lappend tm_folders $testfolder |
||||
} |
||||
} |
||||
return $tm_folders |
||||
} |
||||
|
||||
proc mix_templates_dir {} { |
||||
puts stderr "mix_templates_dir WARNING: deprecated - use get_template_basefolders instead" |
||||
set provide_statement [package ifneeded punk::mix [package require punk::mix]] |
||||
set tmdir [file dirname [lindex $provide_statement end]] |
||||
set tpldir $tmdir/mix/templates |
||||
if {![file exists $tpldir]} { |
||||
error "punk::mix::lib::mix_templates_dir unable to locate mix templates folder at '$tpldir'" |
||||
} |
||||
return $tpldir |
||||
} |
||||
|
||||
#get_template_basefolders |
||||
# scriptpath - file or folder |
||||
# It represents the base point from which to search for mixtemplates folders either directly related to the scriptpath (../) or in the containing project if any |
||||
# The cwd will also be searched for project root - but with lower precedence in the resultset (later in list) |
||||
proc get_template_basefolders {{scriptpath ""}} { |
||||
#1 lowest precedence - templates from packages (ordered by order in which packages registered with punk::cap) |
||||
set folderdict [dict create] |
||||
set template_folder_dict [punk::cap::templates::folders] |
||||
dict for {dir folderinfo} $template_folder_dict { |
||||
dict set folderdict $dir $folderinfo |
||||
} |
||||
|
||||
#2 middle precedence - mixtemplates folder relative to cwd |
||||
set searchbase [pwd] |
||||
set fld [file join $searchbase mixtemplates] |
||||
if {[file isdirectory $fld]} { |
||||
if {![dict exists $folderdict $fld]} { |
||||
dict set folderdict $fld [list source $searchbase sourcetype cwd] |
||||
} |
||||
} |
||||
set pathinfo [punk::repo::find_repos $searchbase] |
||||
set pwd_projectroot [dict get $pathinfo closest] |
||||
if {$pwd_projectroot ne ""} { |
||||
set fld [file join $pwd_projectroot src/mixtemplates] |
||||
if {![dict exists $folderdict $fld]} { |
||||
dict set folderdict $fld [list source $pwd_projectroot sourcetype project] |
||||
} |
||||
} |
||||
|
||||
#3 highest precedence - mixtemplates relative to scriptpath argument |
||||
if {$scriptpath ne ""} { |
||||
if {[file type $scriptpath] eq "file"} { |
||||
set searchbase [file dirname $scriptpath] |
||||
} else { |
||||
set searchbase $scriptpath |
||||
} |
||||
if {[file isdirectory [file join $searchbase mixtemplates]]} { |
||||
dict set folderdict [file join $searchbase mixtemplates] [list source $searchbase sourcetype pathsearch] |
||||
} |
||||
set pathinfo [punk::repo::find_repos $searchbase] |
||||
set scriptpath_projectroot [dict get $pathinfo closest] |
||||
if {$scriptpath_projectroot ne ""} { |
||||
set fld [file join $scriptpath_projectroot src/mixtemplates] |
||||
if {[file isdirectory $fld]} { |
||||
dict set folderdict $fld [list source $scriptpath_projectroot sourcetype project] |
||||
} |
||||
} |
||||
} |
||||
#don't sort - order in which encountered defines the precedence - with later overriding earlier |
||||
return $folderdict |
||||
} |
||||
|
||||
proc module_subpath {modulename} { |
||||
set modulename [string trim $modulename :] |
||||
set nsq [namespace qualifiers $modulename] |
||||
return [string map [list :: /] $nsq] |
||||
} |
||||
|
||||
proc get_build_workdir {path} { |
||||
set repo_info [punk::repo::find_repos $path] |
||||
set base [lindex [dict get $repo_info project] 0] |
||||
if {![string length $base]} { |
||||
error "get_build_workdir unable to determine project base for path '$path'" |
||||
} |
||||
if {![file exists $base/src] || ![file writable $base/src]} { |
||||
error "get_build_workdir unable to access $base/src" |
||||
} |
||||
file mkdir $base/src/_build |
||||
return $base/src/_build |
||||
} |
||||
|
||||
|
||||
|
||||
#todo - move cksum stuff to punkcheck - more logical home |
||||
proc cksum_path_content {path args} { |
||||
dict set args -cksum_content 1 |
||||
dict set args -cksum_meta 0 |
||||
tailcall cksum_path $path {*}$args |
||||
} |
||||
|
||||
#not just used by cksum_path. used by caller (e.g fill_relativecksums_from_base_and_relativepathdict via cksum_filter_opts) to determine what opt names passed through |
||||
proc cksum_default_opts {} { |
||||
return [dict create -cksum_content 1 -cksum_meta auto -cksum_acls 0 -cksum_usetar auto -cksum_algorithm sha1] |
||||
} |
||||
|
||||
#crc::cksum is extremely slow in tcllib as at 2023 e.g 20x slower (no c implementation?) |
||||
#sha1 is performant - and this is not being used in a cryptographic or adversarial context - so performance and practical unlikelihood of accidental collisions should be the main consideration. |
||||
#adler32 is fastest for some larger files of a few MB but slower on small files (possibly due to Tcl-based file load?) |
||||
#sha1 as at 2023 seems a good default |
||||
proc cksum_algorithms {} { |
||||
variable sha3_implementation |
||||
#sha2 is an alias for sha256 |
||||
#2023 - no sha3 available in tcllib - we can exec fossil for now - which will be very slow |
||||
set algs [list md5 sha1 sha2 sha256 cksum adler32] |
||||
set sha3_algs [list sha3 sha3-224 sha3-256 sha3-384 sha3-512] |
||||
if {[auto_execok sqlite3] ne ""} { |
||||
lappend algs {*}$sha3_algs |
||||
set sha3_implementation sqlite3_sha3 |
||||
} else { |
||||
if {[auto_execok fossil] ne ""} { |
||||
lappend algs {*}$sha3_algs |
||||
set sha3_implementation fossil_sha3 |
||||
} |
||||
} |
||||
return $algs |
||||
} |
||||
|
||||
proc sqlite3_sha3 {bits filename} { |
||||
return [exec sqlite3 :memory: "select lower(hex(sha3(readfile('$filename'),$bits)))"] |
||||
} |
||||
proc fossil_sha3 {bits filename} { |
||||
return [lindex [exec fossil sha3sum -$bits $filename] 0] |
||||
} |
||||
|
||||
#adler32 via file-slurp |
||||
proc cksum_adler32_file {filename} { |
||||
package require zlib; #should be builtin anyway |
||||
set data [punk::mix::util::fcat -translation binary $filename] |
||||
#set data [fileutil::cat -translation binary $filename] ;#no significant performance diff on windows - and doesn't handle win-illegal names |
||||
zlib adler32 $data |
||||
} |
||||
|
||||
|
||||
#required to be able to accept relative paths |
||||
#for full cksum - using tar could reduce number of hashes to be made.. |
||||
#but as it stores metadata such as permission - we don't know if/how the archive will vary based on platform/filesystem |
||||
#-noperms only available on extraction - so that doesn't help |
||||
#Needs to operate on non-existant paths and return empty string in cksum field |
||||
proc cksum_path {path args} { |
||||
variable sha3_implementation |
||||
if {$path eq {}} { set path [pwd] } |
||||
if {[file pathtype $path] eq "relative"} { |
||||
set path [file normalize $path] |
||||
} |
||||
set base [file dirname $path] |
||||
set startdir [pwd] |
||||
|
||||
set defaults [cksum_default_opts] |
||||
set known_opts [dict keys $defaults] |
||||
foreach {k v} $args { |
||||
if {$k ni $known_opts} { |
||||
error "cksum_path unknown option '$k' known_options: $known_opts" |
||||
} |
||||
} |
||||
|
||||
set opts [dict merge $defaults $args] |
||||
set opts_actual $opts ;#default - auto updated to 0 or 1 later |
||||
|
||||
#if {![file exists $path]} { |
||||
# return [list cksum "" opts $opts] |
||||
#} |
||||
|
||||
if {[catch {file type $path} ftype]} { |
||||
return [list cksum "<PATHNOTFOUND>" opts $opts] |
||||
} |
||||
if {$ftype ni [list file directory]} { |
||||
#review - links? |
||||
error "cksum_path error file type '$ftype' not supported" |
||||
} |
||||
|
||||
|
||||
set opt_cksum_algorithm [dict get $opts -cksum_algorithm] |
||||
if {$opt_cksum_algorithm ni [cksum_algorithms]} { |
||||
return [list error unsupported_cksum_algorithm cksum "<ERR>" opts $opts] |
||||
} |
||||
set opt_cksum_acls [dict get $opts -cksum_acls] |
||||
if {$opt_cksum_acls} { |
||||
puts stderr "cksum_path is not yet able to cksum ACLs" |
||||
return |
||||
} |
||||
|
||||
set opt_cksum_meta [dict get $opts -cksum_meta] |
||||
set opt_use_tar [dict get $opts -cksum_usetar] |
||||
if {$ftype eq "file"} { |
||||
if {$opt_use_tar eq "auto"} { |
||||
if {$opt_cksum_meta eq "1"} { |
||||
set opt_use_tar 1 |
||||
} else { |
||||
#prefer no tar if meta not required - faster/simpler |
||||
#meta == auto or 0 |
||||
set opt_cksum_meta 0 |
||||
set opt_use_tar 0 |
||||
} |
||||
} elseif {$opt_use_tar eq "0"} { |
||||
if {$opt_cksum_meta eq "1"} { |
||||
puts stderr "cksum_path doesn't yet support a non-tar cksum with metadata for a file" |
||||
return [list error unsupported_meta_without_tar cksum "<ERR>" opts $opts] |
||||
} else { |
||||
#meta == auto or 0 |
||||
set opt_cksum_meta 0 |
||||
} |
||||
} else { |
||||
#tar == 1 |
||||
if {$opt_cksum_meta eq "0"} { |
||||
puts stderr "cksum_path doesn't yet support a tar cksum without metadata for a file" |
||||
return [list error unsupported_tar_without_meta cksum "<ERR>" opts $opts] |
||||
} else { |
||||
#meta == auto or 1 |
||||
set opt_cksum_meta 1 |
||||
} |
||||
} |
||||
} elseif {$ftype eq "directory"} { |
||||
if {$opt_use_tar eq "auto"} { |
||||
if {$opt_cksum_meta in [list "auto" "1"]} { |
||||
set opt_use_tar 1 |
||||
set opt_cksum_meta 1 |
||||
} else { |
||||
puts stderr "cksum_path doesn't yet support a content-only cksum of a folder structure. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto" |
||||
return [list error unsupported_directory_cksum_without_meta cksum "<ERR>" opts $opts] |
||||
} |
||||
} elseif {$opt_use_tar eq "0"} { |
||||
puts stderr "cksum_path doesn't yet support a cksum of a folder structure without tar. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" |
||||
return [list error unsupported_directory_cksum_without_tar cksum "<ERR>" opts $opts] |
||||
} else { |
||||
#tar 1 |
||||
if {$opt_cksum_meta eq "0"} { |
||||
puts stderr "cksum_path doesn't yet support a tar checksum of a folder structure without metadat. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" |
||||
return [list error unsupported_without_meta cksum "<ERR>" opts $opts] |
||||
} else { |
||||
#meta == auto or 1 |
||||
set opt_cksum_meta 1 |
||||
} |
||||
} |
||||
} |
||||
|
||||
dict set opts_actual -cksum_meta $opt_cksum_meta |
||||
dict set opts_actual -cksum_usetar $opt_use_tar |
||||
|
||||
|
||||
if {$opt_use_tar} { |
||||
package require tar ;#from tcllib |
||||
} |
||||
|
||||
if {$path eq $base} { |
||||
#attempting to cksum at root/volume level of a filesystem.. extra work |
||||
#This needs fixing for general use.. not necessarily just for project repos |
||||
puts stderr "cksum_path doesn't yet support cksum of entire volume. (todo)" |
||||
return [list error unsupported_path opts $opts] |
||||
} |
||||
|
||||
if {$opt_cksum_algorithm eq "sha1"} { |
||||
package require sha1 |
||||
set cksum_command [list sha1::sha1 -hex -file] |
||||
} elseif {$opt_cksum_algorithm in [list "sha2" "sha256"]} { |
||||
package require sha256 |
||||
set cksum_command [list sha2::sha256 -hex -file] |
||||
} elseif {$opt_cksum_algorithm eq "md5"} { |
||||
package require md5 |
||||
set cksum_command [list md5::md5 -hex -file] |
||||
} elseif {$opt_cksum_algorithm eq "cksum"} { |
||||
package require cksum ;#tcllib |
||||
set cksum_command [list crc::cksum -format 0x%X -file] |
||||
} elseif {$opt_cksum_algorithm eq "adler32"} { |
||||
set cksum_command [list cksum_adler32_file] |
||||
} elseif {$opt_cksum_algorithm in [list "sha3" "sha3-256"]} { |
||||
#todo - replace with something that doesn't call another process |
||||
#set cksum_command [list apply {{file} {lindex [exec fossil sha3sum -256 $file] 0}}] |
||||
set cksum_command [list $sha3_implementation 256] |
||||
} elseif {$opt_cksum_algorithm in [list "sha3-224" "sha3-384" "sha3-512"]} { |
||||
set bits [lindex [split $opt_cksum_algorithm -] 1] |
||||
#set cksum_command [list apply {{bits file} {lindex [exec fossil sha3sum -$bits $file] 0}} $bits] |
||||
set cksum_command [list $sha3_implementation $bits] |
||||
} |
||||
|
||||
set cksum "" |
||||
if {$opt_use_tar != 0} { |
||||
set target [file tail $path] |
||||
set tmplocation [punk::mix::util::tmpdir] |
||||
set archivename $tmplocation/[punk::mix::util::tmpfile].tar |
||||
|
||||
cd $base ;#cd is process-wide.. keep cd in effect for as small a scope as possible. (review for thread issues) |
||||
|
||||
#temp emission to stdout.. todo - repl telemetry channel |
||||
puts stdout "cksum_path: creating temporary tar archive at: $archivename .." |
||||
tar::create $archivename $target |
||||
if {$ftype eq "file"} { |
||||
set sizeinfo "(size [file size $target])" |
||||
} else { |
||||
set sizeinfo "(file type $ftype - size unknown)" |
||||
} |
||||
puts stdout "cksum_path: calculating cksum for $target $sizeinfo..." |
||||
set cksum [{*}$cksum_command $archivename] |
||||
#puts stdout "cksum_path: cleaning up.. " |
||||
file delete -force $archivename |
||||
cd $startdir |
||||
|
||||
} else { |
||||
#todo |
||||
if {$ftype eq "file"} { |
||||
if {$opt_cksum_meta} { |
||||
return [list error unsupported_opts_combo cksum "<ERR>" opts $opts] |
||||
} else { |
||||
set cksum [{*}$cksum_command $path] |
||||
} |
||||
} else { |
||||
error "cksum_path unsupported $opts for path type [file type $path]" |
||||
} |
||||
} |
||||
set result [dict create] |
||||
dict set result cksum $cksum |
||||
dict set result opts $opts_actual |
||||
return $result |
||||
} |
||||
|
||||
#dict_path_cksum keyed on path - with value as a dict that must contain cksum key - but can contain other keys |
||||
#e.g -cksum_usetar which is one of the keys understood by the punk::mix::base::lib::cksum_path function - or unrelated keys which will also be passed through |
||||
#cksum only calculated for keys in dict where cksum is empty - ie return same dict but with empty cksums filled out. |
||||
#base can be empty string in which case paths must be absolute |
||||
proc fill_relativecksums_from_base_and_relativepathdict {base {dict_path_cksum {}}} { |
||||
if {$base eq ""} { |
||||
set error_paths [list] |
||||
dict for {path pathinfo} $dict_path_cksum { |
||||
if {[file pathtype $path] ne "absolute"} { |
||||
lappend error_paths $path |
||||
} |
||||
} |
||||
if {[llength $error_paths]} { |
||||
puts stderr "get_relativecksums_from_base_and_relativepathdict has empty base - and non-absolute paths in the supplied checksum dict - aborting" |
||||
puts stderr "error_paths: $error_paths" |
||||
error "fill_relativecksums_from_base_and_relativepathdict error: non-absolute paths when base empty. $error_paths" |
||||
} |
||||
} else { |
||||
if {[file pathtype $base] ne "absolute"} { |
||||
error "fill_relativecksums_from_base_and_relativepathdict error: base supplied but was not absolute path. $base" |
||||
} |
||||
#conversely now we have a base - so we require all paths are relative. |
||||
#We will ignore/disallow volume-relative - as these shouldn't be used here either |
||||
set error_paths [list] |
||||
dict for {path pathinfo} $dict_path_cksum { |
||||
if {[file pathtype $path] ne "relative"} { |
||||
lappend error_paths $path |
||||
} |
||||
} |
||||
if {[llength $error_paths]} { |
||||
puts stderr "fill_relativecksums_from_base_and_relativepathdict has a supplied absolute base path, but some of the paths in the supplied dict are not relative - aborting" |
||||
error "fill_relativecksums_from_base_and_relativepathdict error: non-relative paths when base supplied. $error_paths" |
||||
} |
||||
} |
||||
|
||||
|
||||
dict for {path pathinfo} $dict_path_cksum { |
||||
if {![dict exists $pathinfo cksum]} { |
||||
dict set pathinfo cksum "" |
||||
} else { |
||||
if {[dict get $pathinfo cksum] ne "" && ![cksum_is_tag [dict get $pathinfo cksum]]} { |
||||
continue ;#already filled with non-tag value |
||||
} |
||||
} |
||||
if {$base ne ""} { |
||||
set fullpath [file join $base $path] |
||||
} else { |
||||
set fullpath $path |
||||
} |
||||
|
||||
set ckopts [cksum_filter_opts {*}$pathinfo] |
||||
|
||||
if {![file exists $fullpath]} { |
||||
dict set dict_path_cksum $path cksum "<PATHNOTFOUND>" |
||||
} else { |
||||
set ckinfo [cksum_path $fullpath {*}$ckopts] |
||||
dict set dict_path_cksum $path cksum [dict get $ckinfo cksum] |
||||
dict set dict_path_cksum $path cksum_all_opts [dict get $ckinfo opts] |
||||
if {[dict exists $ckinfo error]} { |
||||
dict set dict_path_cksum $path cksum_error [dict get $ckinfo error] |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $dict_path_cksum |
||||
} |
||||
#whether cksum is <XXX> e.g <ERR> <PATHNOTFOUND> |
||||
proc cksum_is_tag {cksum} { |
||||
expr {[string index $cksum 0] eq "<" && [string index $cksum end] eq ">"} |
||||
} |
||||
proc cksum_filter_opts {args} { |
||||
set ck_opt_names [dict keys [cksum_default_opts]] |
||||
set ck_opts [dict create] |
||||
dict for {k v} $args { |
||||
if {$k in $ck_opt_names} { |
||||
dict set ck_opts $k $v |
||||
} |
||||
} |
||||
return $ck_opts |
||||
} |
||||
|
||||
#convenience so caller doesn't have to pre-calculate the relative path from the base |
||||
#Note semantic difference from fill_relativecksums_from_base_and_relativepathdict (hence get_ vs fill_) |
||||
#Here we will raise an error if cksum exists and is not empty or a tag - whereas the multiple path version will ignore valid-looking prefilled cksum values |
||||
#base is the presumed location to store the checksum file. The caller should retain (normalize if relative) |
||||
proc get_relativecksum_from_base {base specifiedpath args} { |
||||
if {$base ne ""} { |
||||
#targetpath ideally should be within same project tree as base if base supplied - but not necessarily below it |
||||
#we don't necessarily want to restrict this to use in punk projects though - so we'll allow anything with a common prefix |
||||
if {[file pathtype $specifiedpath] eq "relative"} { |
||||
if {[file pathtype $base] eq "relative"} { |
||||
set normbase [file normalize $base] |
||||
set normtarg [file normalize [file join $normbase $specifiedpath]] |
||||
set targetpath $normtarg |
||||
set storedpath [punk::mix::util::path_relative $normbase $normtarg] |
||||
} else { |
||||
set targetpath [file join $base $specifiedpath] |
||||
set storedpath $specifiedpath |
||||
} |
||||
} else { |
||||
#specifed absolute |
||||
if {[file pathtype $base] eq "relative"} { |
||||
#relative to cwd or to specifiedpath? For consistency it should arguably be cwd but a case could be made that when one path is relative it is in reference to the other |
||||
#there is a strong possibility that allowing this combination will cause confusion - better to disallow |
||||
error "get_relativecksum_from_base error: disallowed pathtype combination. Base must be empty or absolute when specified path is absolute" |
||||
} |
||||
#both absolute - compute relative path if they share a common prefix |
||||
set commonprefix [punk::mix::util::path_common_prefix $base $specifiedpath] |
||||
if {$commonprefix eq ""} { |
||||
#absolute base with no shared prefix doesn't make sense - we could ignore it - but better to error-out and require the caller specify an empty base |
||||
error "get_relativecksum_from_base error: base '$base' and specifiedpath '$specifiedpath' don't share a common root. Use empty-string for base if independent absolute path is required" |
||||
} |
||||
set targetpath $specifiedpath |
||||
set storedpath [punk::mix::util::path_relative $base $specifiedpath] |
||||
|
||||
} |
||||
} else { |
||||
if {[file type $specifiedpath] eq "relative"} { |
||||
#if specifiedpath is relative - and we don't have a base, we now need to convert relative to cwd to an absolute path for storage |
||||
set targetpath [file normalize $specifiedpath] |
||||
set storedpath $targetpath |
||||
} else { |
||||
set targetpath $specifiedpath |
||||
set storedpath $targetpath |
||||
} |
||||
} |
||||
|
||||
# |
||||
#NOTE: specifiedpath can be a relative path (to cwd) when base is empty |
||||
#OR - a relative path when base itself is relative e.g base: somewhere targetpath somewhere/etc |
||||
#possibly also: base: somewhere targetpath: ../elsewhere/etc |
||||
# |
||||
#todo - write tests |
||||
|
||||
|
||||
if {([llength $args] % 2) != 0} { |
||||
error "get_relativecksum_from_base error. args supplied must be in the form of key-value pairs. received '$args' " |
||||
} |
||||
if {[dict exists $args cksum]} { |
||||
if {[dict get $args cksum] ne "" && ![cksum_is_tag [dict get $args cksum]]} { |
||||
error "get_relativecksum_from_base called with existing cksum value (and is not a tag or empty-value to be replaced) cksum: [dict get $args cksum] Set cksum to be empty, any tag such as <REPLACE> or remove the key and try again." |
||||
} |
||||
} |
||||
|
||||
|
||||
set ckopts [cksum_filter_opts {*}$args] |
||||
set ckinfo [cksum_path $targetpath {*}$ckopts] |
||||
|
||||
set keyvals $args |
||||
dict set keyvals cksum [dict get $ckinfo cksum] |
||||
dict set keyvals cksum_all_opts [dict get $ckinfo opts] |
||||
if {[dict exists $ckinfo error]} { |
||||
dict set keyvals cksum_error [dict get $ckinfo error] |
||||
} |
||||
|
||||
#set relpath [punk::repo::path_strip_alreadynormalized_prefixdepth $fullpath $base] ;#empty base ok noop |
||||
#storedpath is relative if possible |
||||
return [dict create $storedpath $keyvals] |
||||
} |
||||
|
||||
#calculate the runtime checksum and vfs checksums |
||||
proc get_all_vfs_build_cksums {path} { |
||||
set buildfolder [get_build_workdir $path] |
||||
set cksum_base_folder [file dirname $buildfolder] ;#this is the <project>/src folder - a reasonable base for our vfs cksums |
||||
set dict_cksums [dict create] |
||||
|
||||
set buildrelpath [punk::repo::path_strip_alreadynormalized_prefixdepth $buildfolder $cksum_base_folder] |
||||
set vfs_tail_list [glob -nocomplain -dir $cksum_base_folder -type d -tails *.vfs] |
||||
|
||||
foreach vfstail $vfs_tail_list { |
||||
set vname [file rootname $vfstail] |
||||
dict set dict_cksums $vfstail [list cksum ""] |
||||
dict set dict_cksums [file join $buildrelpath $vname.exe] [list cksum ""] |
||||
} |
||||
|
||||
set fullpath_buildruntime $buildfolder/buildruntime.exe |
||||
|
||||
set ckinfo_buildruntime [cksum_path $fullpath_buildruntime] |
||||
set ck [dict get $ckinfo_buildruntime cksum] |
||||
|
||||
|
||||
set relpath [file join $buildrelpath "buildruntime.exe"] |
||||
dict set dict_cksums $relpath [list cksum $ck] |
||||
|
||||
set dict_cksums [fill_relativecksums_from_base_and_relativepathdict $cksum_base_folder $dict_cksums] |
||||
|
||||
return $dict_cksums |
||||
} |
||||
|
||||
proc get_vfs_build_cksums_stored {vfsfolder} { |
||||
set vfscontainer [file dirname $vfsfolder] |
||||
set buildfolder $vfscontainer/_build |
||||
set vfs [file tail $vfsfolder] |
||||
set vname [file rootname $vfs] |
||||
set dict_vfs [list $vname.vfs "" $vname.exe "" buildruntime.exe ""] |
||||
set ckfile $buildfolder/$vname.cksums |
||||
if {[file exists $ckfile]} { |
||||
set data [punk::mix::util::fcat -translation binary $ckfile] |
||||
foreach ln [split $data \n] { |
||||
if {[string trim $ln] eq ""} {continue} |
||||
lassign $ln path cksum |
||||
dict set dict_vfs $path $cksum |
||||
} |
||||
} |
||||
return $dict_vfs |
||||
} |
||||
proc get_all_build_cksums_stored {path} { |
||||
set buildfolder [get_build_workdir $path] |
||||
|
||||
set vfscontainer [file dirname $buildfolder] |
||||
set vfslist [glob -nocomplain -dir $vfscontainer -type d -tail *.vfs] |
||||
set dict_cksums [dict create] |
||||
foreach vfs $vfslist { |
||||
set vname [file rootname $vfs] |
||||
set dict_vfs [get_vfs_build_cksums_stored $vfscontainer/$vfs] |
||||
|
||||
dict set dict_cksums $vname $dict_vfs |
||||
} |
||||
return $dict_cksums |
||||
} |
||||
|
||||
proc store_vfs_build_cksums {vfsfolder} { |
||||
if {![file isdirectory $vfsfolder]} { |
||||
error "Unable to find supplied vfsfolder: $vfsfolder" |
||||
} |
||||
set vfscontainer [file dirname $vfsfolder] |
||||
set buildfolder $vfscontainer/_build |
||||
set dict_vfs [get_vfs_build_cksums $vfsfolder] |
||||
set data "" |
||||
dict for {path cksum} $dict_vfs { |
||||
append data "$path $cksum" \n |
||||
} |
||||
set fd [open $buildfolder/$vname.cksums w] |
||||
chan configure $fd -translation binary |
||||
puts $fd $data |
||||
close $fd |
||||
return $dict_vfs |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
} |
||||
@ -0,0 +1,909 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::cli 0.3 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
package require punk::repo |
||||
package require punkcheck ;#checksum and/or timestamp records |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
namespace eval punk::mix::cli { |
||||
namespace eval temp_import { |
||||
} |
||||
namespace ensemble create |
||||
|
||||
package require punk::overlay |
||||
catch { |
||||
punk::overlay::import_commandset module . ::punk::mix::commandset::module |
||||
} |
||||
punk::overlay::import_commandset debug . ::punk::mix::commandset::debug |
||||
punk::overlay::import_commandset repo . ::punk::mix::commandset::repo |
||||
punk::overlay::import_commandset lib . ::punk::mix::commandset::loadedlib |
||||
|
||||
catch { |
||||
package require punk::mix::commandset::project |
||||
punk::overlay::import_commandset project . ::punk::mix::commandset::project |
||||
punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection |
||||
} |
||||
if {[catch { |
||||
package require punk::mix::commandset::layout |
||||
punk::overlay::import_commandset project.layout . ::punk::mix::commandset::layout |
||||
punk::overlay::import_commandset project.layouts . ::punk::mix::commandset::layout::collection |
||||
} errM]} { |
||||
puts stderr "error loading punk::mix::commandset::layout" |
||||
puts stderr $errM |
||||
} |
||||
if {[catch { |
||||
package require punk::mix::commandset::buildsuite |
||||
punk::overlay::import_commandset buildsuite . ::punk::mix::commandset::buildsuite |
||||
punk::overlay::import_commandset buildsuites . ::punk::mix::commandset::buildsuite::collection |
||||
} errM]} { |
||||
puts stderr "error loading punk::mix::commandset::buildsuite" |
||||
puts stderr $errM |
||||
} |
||||
punk::overlay::import_commandset scriptwrap . ::punk::mix::commandset::scriptwrap |
||||
if {[catch { |
||||
package require punk::mix::commandset::doc |
||||
punk::overlay::import_commandset doc . ::punk::mix::commandset::doc |
||||
punk::overlay::import_commandset "" "" ::punk::mix::commandset::doc::collection |
||||
} errM]} { |
||||
puts stderr "error loading punk::mix::commandset::doc" |
||||
puts stderr $errM |
||||
} |
||||
|
||||
|
||||
proc help {args} { |
||||
#set basehelp [punk::mix::base::help -extension [namespace current] {*}$args] |
||||
set basehelp [punk::mix::base help {*}$args] |
||||
#puts stdout "punk::mix help" |
||||
return $basehelp |
||||
} |
||||
|
||||
proc stat {{workingdir ""} args} { |
||||
dict set args -v 0 |
||||
punk::mix::cli::lib::get_status $workingdir {*}$args |
||||
} |
||||
proc status {{workingdir ""} args} { |
||||
dict set args -v 1 |
||||
punk::mix::cli::lib::get_status $workingdir {*}$args |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
namespace eval punk::mix::cli { |
||||
|
||||
|
||||
#interp alias {} ::punk::mix::cli::project.new {} ::punk::mix::cli::new |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
proc make {args} { |
||||
set startdir [pwd] |
||||
set project_base "" ;#empty for unknown |
||||
if {[punk::repo::is_git $startdir]} { |
||||
set project_base [punk::repo::find_git] |
||||
set sourcefolder $project_base/src |
||||
} elseif {[punk::repo::is_fossil $startdir]} { |
||||
set project_base [punk::repo::find_fossil] |
||||
set sourcefolder $project_base/src |
||||
} else { |
||||
if {[punk::repo::is_candidate $startdir]} { |
||||
set project_base [punk::repo::find_candidate] |
||||
set sourcefolder $project_base/src |
||||
puts stderr "WARNING - project not under git or fossil control" |
||||
puts stderr "Using base folder $project_base" |
||||
} else { |
||||
set sourcefolder $startdir |
||||
} |
||||
} |
||||
|
||||
#review - why can't we be anywhere in the project? |
||||
if {([file tail $sourcefolder] ne "src") || (![file exists $sourcefolder/make.tcl])} { |
||||
puts stderr "pmix make must be run from src folder containing make.tcl - unable to proceed (cwd: [pwd])" |
||||
if {[string length $project_base]} { |
||||
if {[file exists $project_base/src] && [string tolower [pwd]] ne [string tolower $project_base/src]} { |
||||
puts stderr "Try cd to $project_base/src" |
||||
} |
||||
} else { |
||||
if {[file exists $startdir/Makefile]} { |
||||
puts stdout "A Makefile exists at $startdir/Makefile." |
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
puts stdout "Try running: msys2 -ucrt64 -here -c \"make build\" or bash -c \"make build\"" |
||||
} else { |
||||
puts stdout "Try runing: make build" |
||||
} |
||||
} |
||||
} |
||||
return false |
||||
} |
||||
|
||||
if {![string length $project_base]} { |
||||
puts stderr "WARNING no git or fossil repository detected." |
||||
puts stderr "Using base folder $startdir" |
||||
set project_base $startdir |
||||
} |
||||
|
||||
set lc_this_exe [string tolower [info nameofexecutable]] |
||||
set lc_proj_bin [string tolower $project_base/bin] |
||||
set lc_build_bin [string tolower $project_base/src/_build] |
||||
|
||||
if {"project" in $args} { |
||||
set is_own_exe 0 |
||||
if {[string match "${lc_proj_bin}*" $lc_this_exe] || [string match "${lc_build_bin}" $lc_this_exe]} { |
||||
set is_own_exe 1 |
||||
puts stderr "WARNING - running make using executable that may be created by the project being built" |
||||
set answer [util::askuser "Do you want to proceed using this executable? (build will probably stop when it is unable to update the executable) Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
} |
||||
cd $sourcefolder |
||||
#use run so that stdout visible as it goes |
||||
if {![catch {run --timeout=5000 -debug [info nameofexecutable] $sourcefolder/make.tcl {*}$args} exitinfo]} { |
||||
puts stderr "exitinfo: $exitinfo" |
||||
set exitcode [dict get $exitinfo exitcode] |
||||
} else { |
||||
puts stderr "Error unable to determine exitcode. err: $exitinfo" |
||||
cd $startdir |
||||
return false |
||||
} |
||||
|
||||
cd $startdir |
||||
if {$exitcode != 0} { |
||||
puts stderr "FAILED with exitcode $exitcode" |
||||
return false |
||||
} else { |
||||
puts stdout "OK make finished " |
||||
return true |
||||
} |
||||
} |
||||
|
||||
proc Kettle {args} { |
||||
tailcall lib::kettle_call lib {*}$args |
||||
} |
||||
proc KettleShell {args} { |
||||
tailcall lib::kettle_call shell {*}$args |
||||
} |
||||
|
||||
|
||||
|
||||
namespace eval lib { |
||||
namespace path ::punk::mix::util |
||||
|
||||
|
||||
proc module_types {} { |
||||
#first in list is default for unspecified -type when creating new module |
||||
return [list plain tarjar zipkit] |
||||
} |
||||
|
||||
proc validate_modulename {modulename args} { |
||||
set defaults [list\ |
||||
-name_description modulename\ |
||||
] |
||||
if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"} |
||||
set known_opts [dict keys $defaults] |
||||
foreach k [dict keys $args] { |
||||
if {$k ni $known_opts} { |
||||
error "validate_modulename error: unknown option $k. known options: $known_opts" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_name_description [dict get $opts -name_description] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
|
||||
validate_name_not_empty_or_spaced $modulename -name_description $opt_name_description |
||||
set testname [string map [list :: ""] $modulename] |
||||
if {[string first : $testname] >=0} { |
||||
error "$opt_name_description '$modulename' can only contain paired colons" |
||||
} |
||||
set badchars [list - "$" "?" "*"] |
||||
foreach bc $badchars { |
||||
if {[string first $bc $modulename] >= 0} { |
||||
error "$opt_name_description '$modulename' can not contain character '$bc'" |
||||
} |
||||
} |
||||
return $modulename |
||||
} |
||||
|
||||
proc validate_projectname {projectname args} { |
||||
set defaults [list\ |
||||
-name_description projectname\ |
||||
] |
||||
if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"} |
||||
set known_opts [dict keys $defaults] |
||||
foreach k [dict keys $args] { |
||||
if {$k ni $known_opts} { |
||||
error "validate_modulename error: unknown option $k. known options: $known_opts" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_name_description [dict get $opts -name_description] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
validate_name_not_empty_or_spaced $projectname -name_description $opt_name_description |
||||
set reserved_words [list etc lib bin modules src doc vendorlib vendormodules embedded runtime _aside _build] |
||||
if {$projectname in $reserved_words } { |
||||
error "$opt_name_description '$projectname' cannot be one of reserved_words: $reserved_words" |
||||
} |
||||
if {[string first "::" $projectname] >= 0} { |
||||
error "$opt_name_description '$projectname' cannot contain namespace separator '::'" |
||||
} |
||||
return $projectname |
||||
} |
||||
proc validate_name_not_empty_or_spaced {name args} { |
||||
set defaults [list\ |
||||
-name_description projectname\ |
||||
] |
||||
if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"} |
||||
set known_opts [dict keys $defaults] |
||||
foreach k [dict keys $args] { |
||||
if {$k ni $known_opts} { |
||||
error "validate_modulename error: unknown option $k. known options: $known_opts" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_name_description [dict get $opts -name_description] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
if {![string length $name]} { |
||||
error "$opt_name_description cannot be empty" |
||||
} |
||||
if {[string length [string map [list " " "" \n "" \r "" \t ""] $name]] != [string length $name]} { |
||||
error "$opt_name_description cannot contain whitespace" |
||||
} |
||||
return $name |
||||
} |
||||
|
||||
#split modulename (as present in a filename or namespaced name) into name/version ignoring leading namespace path |
||||
#ignore trailing .tm .TM if present |
||||
#if version doesn't pass validation - treat it as part of the modulename and return empty version string without error |
||||
#Up to caller to validate. |
||||
proc split_modulename_version {modulename} { |
||||
set lastpart [namespace tail $modulename] |
||||
set lastpart [file tail $lastpart] ;# should be ok to use file tail now that we've ensured no namespace components |
||||
if {[string equal -nocase [file extension $modulename] ".tm"]} { |
||||
set fileparts [split [file rootname $lastpart] -] |
||||
} else { |
||||
set fileparts [split $lastpart -] |
||||
} |
||||
if {[punk::mix::util::is_valid_tm_version [lindex $fileparts end]]} { |
||||
set versionsegment [lindex $fileparts end] |
||||
set namesegment [join [lrange $fileparts 0 end-1] -];#re-stitch |
||||
} else { |
||||
# |
||||
set namesegment [join $fileparts -] |
||||
set versionsegment "" |
||||
} |
||||
return [list $namesegment $versionsegment] |
||||
} |
||||
|
||||
proc get_status {{workingdir ""} args} { |
||||
set result "" |
||||
if {$workingdir ne ""} { |
||||
if {[file pathtype $workingdir] ne "absolute"} { |
||||
set workingdir [file normalize $workingdir] |
||||
} |
||||
set active_dir $workingdir |
||||
} else { |
||||
set active_dir [pwd] |
||||
} |
||||
set defaults [dict create\ |
||||
-v 1\ |
||||
] |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- --- --- |
||||
set opt_v [dict get $opts -v] |
||||
# -- --- --- --- --- --- --- --- --- |
||||
|
||||
|
||||
set repopaths [punk::repo::find_repos [pwd]] |
||||
set repos [dict get $repopaths repos] |
||||
if {![llength $repos]} { |
||||
append result [dict get $repopaths warnings] |
||||
} else { |
||||
append result [dict get $repopaths warnings] |
||||
lassign [lindex $repos 0] repopath repotypes |
||||
if {"fossil" in $repotypes} { |
||||
#review - multiple process launches to fossil a bit slow on windows.. |
||||
#could we query global db in one go instead? |
||||
# |
||||
set fossil_prog [auto_execok fossil] |
||||
append result "FOSSIL project based at $repopath with revision: [punk::repo::fossil_revision $repopath]" \n |
||||
set fosinfo [exec {*}$fossil_prog info] |
||||
append result [join [punk::repo::grep {repository:*} $fosinfo] \n] \n |
||||
|
||||
set fosrem [exec {*}$fossil_prog remote ls] |
||||
if {[string length $fosrem]} { |
||||
append result "Remotes:\n" |
||||
append result " " $fosrem \n |
||||
} |
||||
|
||||
|
||||
append result [join [punk::repo::grep {tags:*} $fosinfo] \n] \n |
||||
|
||||
set dbinfo [exec {*}$fossil_prog dbstat] |
||||
append result [join [punk::repo::grep {project-name:*} $dbinfo] \n] \n |
||||
append result [join [punk::repo::grep {tickets:*} $dbinfo] \n] \n |
||||
append result [join [punk::repo::grep {project-age:*} $dbinfo] \n] \n |
||||
append result [join [punk::repo::grep {latest-change:*} $dbinfo] \n] \n |
||||
append result [join [punk::repo::grep {files:*} $dbinfo] \n] \n |
||||
append result [join [punk::repo::grep {check-ins:*} $dbinfo] \n] \n |
||||
if {"project" in $repotypes} { |
||||
#punk project |
||||
if {![catch {package require textblock; package require patternpunk}]} { |
||||
set result [textblock::join [textblock::join [>punk . logo] " "] $result] |
||||
append result \n |
||||
} |
||||
} |
||||
|
||||
set timeline [exec fossil timeline -n 5 -t ci] |
||||
set timeline [string map [list \r\n \n] $timeline] |
||||
append result $timeline |
||||
if {$opt_v} { |
||||
set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes fossil] |
||||
append result \n [punk::repo::workingdir_state_summary $repostate] |
||||
} |
||||
|
||||
} |
||||
#repotypes *could* be both git and fossil - so report both if so |
||||
if {"git" in $repotypes} { |
||||
append result "GIT project based at $repopath with revision: [punk::repo::git_revision $repopath]" \n |
||||
if {[string length [set git_prog [auto_execok git]]]} { |
||||
set git_remotes [exec {*}$git_prog remote -v] |
||||
append result $git_remotes |
||||
if {$opt_v} { |
||||
set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes git] |
||||
append result \n [punk::repo::workingdir_state_summary $repostate] |
||||
} |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
|
||||
proc build_modules_from_source_to_base {srcdir basedir args} { |
||||
set antidir [list "#*" "_aside" ".git" ".fossil*"] ;#exact or glob patterns for folders we don't want to search in. |
||||
set defaults [list\ |
||||
-installer punk::mix::cli::build_modules_from_source_to_base\ |
||||
-call-depth-internal 0\ |
||||
-max_depth 1000\ |
||||
-subdirlist {}\ |
||||
-punkcheck_eventobj "\uFFFF"\ |
||||
-glob *.tm\ |
||||
] |
||||
set opts [dict merge $defaults $args] |
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set installername [dict get $opts -installer] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set CALLDEPTH [dict get $opts -call-depth-internal] |
||||
set max_depth [dict get $opts -max_depth] |
||||
set subdirlist [dict get $opts -subdirlist] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set fileglob [dict get $opts -glob] |
||||
if {![string match "*.tm" $fileglob]} { |
||||
error "build_modules_from_source_to_base -glob '$fileglob' doesn't seem to target tcl modules." |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_punkcheck_eventobj [dict get $opts -punkcheck_eventobj] |
||||
|
||||
set magicversion [punk::mix::util::magic_tm_version] ;#deliberately large so given load-preference when testing |
||||
set module_list [list] |
||||
|
||||
if {[file tail [file dirname $srcdir]] ne "src"} { |
||||
puts stderr "ERROR build_modules_from_source_to_base can only be called with a srcdir that is a subfolder of your 'src' directory" |
||||
puts stderr "The .tm modules are namespaced based on their directory depth - so we need to start at the root" |
||||
puts stderr "To build a subtree of your modules - use an appropriate src/modules folder and pass in the -subdirlist." |
||||
puts stderr "e.g if your modules are based at /x/src/modules2 and you wish to build only the .tm files at /x/src/modules2/skunkworks/lib" |
||||
puts stderr "Use: >build_modules_from_source_to_base /x/src/modules2 /x/modules2 -subdirlist {skunkworks lib}" |
||||
exit 2 |
||||
} |
||||
set srcdirname [file tail $srcdir] |
||||
|
||||
set build [file dirname $srcdir]/_build/$srcdirname ;#relative to *original* srcdir - not current_source_dir |
||||
if {[llength $subdirlist] == 0} { |
||||
set target_module_dir $basedir |
||||
set current_source_dir $srcdir |
||||
} else { |
||||
set target_module_dir $basedir/[file join {*}$subdirlist] |
||||
set current_source_dir $srcdir/[file join {*}$subdirlist] |
||||
} |
||||
if {![file exists $target_module_dir]} { |
||||
error "build_modules_from_source_to_base from current source dir: '$current_source_dir'. Basedir:'$current_module_dir' doesn't exist or is empty" |
||||
} |
||||
if {![file exists $current_source_dir]} { |
||||
error "build_modules_from_source_to_base from current source dir:'$current_source_dir' doesn't exist or is empty" |
||||
} |
||||
|
||||
#---------------------------------------- |
||||
set punkcheck_file [file join $basedir/.punkcheck] |
||||
if {$CALLDEPTH == 0} { |
||||
|
||||
set config [dict create\ |
||||
-glob $fileglob\ |
||||
-max_depth 0\ |
||||
] |
||||
#lassign [punkcheck::start_installer_event $punkcheck_file $installername $srcdir $basedir $config] _eventid punkcheck_eventid _recordset record_list |
||||
# -- --- |
||||
set installer [punkcheck::installtrack new $installername $punkcheck_file] |
||||
$installer set_source_target $srcdir $basedir |
||||
set event [$installer start_event $config] |
||||
# -- --- |
||||
|
||||
} else { |
||||
set event $opt_punkcheck_eventobj |
||||
} |
||||
#---------------------------------------- |
||||
|
||||
|
||||
|
||||
set src_modules [glob -nocomplain -dir $current_source_dir -type f -tail $fileglob] |
||||
|
||||
set did_skip 0 ;#flag for stdout/stderr formatting only |
||||
foreach m $src_modules { |
||||
#puts "build_modules_from_source_to_base >>> module $m" |
||||
set fileparts [split [file rootname $m] -] |
||||
set tmfile_versionsegment [lindex $fileparts end] |
||||
if {$tmfile_versionsegment eq $magicversion} { |
||||
#rebuild the .tm from the #tarjar |
||||
set basename [join [lrange $fileparts 0 end-1] -] |
||||
set versionfile $current_source_dir/$basename-buildversion.txt |
||||
set versionfiledata "" |
||||
if {![file exists $versionfile]} { |
||||
puts stderr "\nWARNING: Missing buildversion text file: $versionfile" |
||||
puts stderr "Using version 0.1 - create $versionfile containing the desired version number as the top line to avoid this warning\n" |
||||
set module_build_version "0.1" |
||||
} else { |
||||
set fd [open $versionfile r] |
||||
set versionfiledata [read $fd]; close $fd |
||||
set ln0 [lindex [split $versionfiledata \n] 0] |
||||
set ln0 [string trim $ln0]; set ln0 [string trim $ln0 \r] |
||||
if {![util::is_valid_tm_version $ln0]} { |
||||
puts stderr "ERROR: build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file" |
||||
exit 3 |
||||
} |
||||
set module_build_version $ln0 |
||||
} |
||||
|
||||
|
||||
if {[file exists $current_source_dir/#tarjar-$basename-$magicversion]} { |
||||
#TODO |
||||
file mkdir $buildfolder |
||||
|
||||
if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { |
||||
|
||||
} else { |
||||
|
||||
} |
||||
#REVIEW - should be in same structure/depth as $target_module_dir in _build? |
||||
set tmfile $basedir/_build/$basename-$module_build_version.tm |
||||
file mkdir $basedir/_build |
||||
file delete -force $basedir/_build/#tarjar-$basename-$module_build_version |
||||
file delete -force $tmfile |
||||
|
||||
|
||||
file copy -force $current_source_dir/#tarjar-$basename-$magicversion $basedir/_build/#tarjar-$basename-$module_build_version |
||||
# |
||||
#bsdtar doesn't seem to work.. or I haven't worked out the right options? |
||||
#exec tar -cvf $basedir/_build/$basename-$module_build_version.tm $basedir/_build/#tarjar-$basename-$module_build_version |
||||
package require tar |
||||
tar::create $tmfile $basedir/_build/#tarjar-$basename-$module_build_version |
||||
if {![file exists $tmfile]} { |
||||
puts stdout "ERROR: Failed to build tarjar file $tmfile" |
||||
exit 4 |
||||
} |
||||
#copy the file? |
||||
#set target $target_module_dir/$basename-$module_build_version.tm |
||||
#file copy -force $tmfile $target |
||||
|
||||
lappend module_list $tmfile |
||||
} else { |
||||
#assume that either the .tm is not a tarjar - or the tarjar dir is capped (trailing #) and the .tm has been manually tarred. |
||||
if {[file exists $current_source_dir/#tarjar-$basename-${magicversion}#]} { |
||||
puts stderr "\nWarning: found 'capped' folder #tarjar-$basename-${magicversion}# - No attempt being made to update version in description.txt" |
||||
} |
||||
|
||||
#------------------------------ |
||||
# |
||||
#set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$basename-$module_build_version.tm] |
||||
#set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] |
||||
$event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm |
||||
$event targetset_addsource $versionfile |
||||
$event targetset_addsource $current_source_dir/$m |
||||
|
||||
#set changed_list [list] |
||||
## -- --- --- --- --- --- |
||||
#set source_relpath [punkcheck::lib::path_relative $basedir $versionfile] |
||||
#set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] |
||||
## -- --- --- --- --- --- |
||||
#set source_relpath [punkcheck::lib::path_relative $basedir $current_source_dir/$m] |
||||
#set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] |
||||
## -- --- --- --- --- --- |
||||
#set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] |
||||
#set changed_list [dict get $changed_unchanged changed] |
||||
|
||||
|
||||
if {\ |
||||
[llength [dict get [$event targetset_source_changes] changed]]\ |
||||
|| [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ |
||||
} { |
||||
|
||||
#set file_record [punkcheck::installfile_started_install $basedir $file_record] |
||||
$event targetset_started |
||||
# -- --- --- --- --- --- |
||||
set target $target_module_dir/$basename-$module_build_version.tm |
||||
if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} |
||||
puts stdout "copying module $current_source_dir/$m to $target as version: $module_build_version ([file tail $target])" |
||||
set fd [open $current_source_dir/$m r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd |
||||
set data [string map [list $magicversion $module_build_version] $data] |
||||
set fdout [open $target w] |
||||
fconfigure $fdout -translation binary |
||||
puts -nonewline $fdout $data |
||||
close $fdout |
||||
#file copy -force $srcdir/$m $target |
||||
lappend module_list $target |
||||
# -- --- --- --- --- --- |
||||
#set file_record [punkcheck::installfile_finished_install $basedir $file_record] |
||||
$event targetset_end OK |
||||
} else { |
||||
#puts stdout "skipping module $current_source_dir/$m - no change in sources detected" |
||||
puts -nonewline stderr "." |
||||
set did_skip 1 |
||||
#set file_record [punkcheck::installfile_skipped_install $basedir $file_record] |
||||
$event targetset_end SKIPPED |
||||
} |
||||
|
||||
#------------------------------ |
||||
|
||||
} |
||||
|
||||
continue |
||||
} |
||||
|
||||
|
||||
if {![util::is_valid_tm_version $tmfile_versionsegment]} { |
||||
#last segment doesn't look even slightly versiony - fail. |
||||
puts stderr "ERROR: Unable to confirm file $current_source_dir/$m is a reasonably versioned .tm module - ABORTING." |
||||
exit 1 |
||||
} |
||||
|
||||
##------------------------------ |
||||
## |
||||
#set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$m] |
||||
#set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] |
||||
#set changed_list [list] |
||||
## -- --- --- --- --- --- |
||||
#set source_relpath [punkcheck::lib::path_relative $basedir $current_source_dir/$m] |
||||
#set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] |
||||
## -- --- --- --- --- --- |
||||
#set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] |
||||
#set changed_list [dict get $changed_unchanged changed] |
||||
|
||||
#---------- |
||||
$event targetset_init INSTALL $target_module_dir/$m |
||||
$event targetset_addsource $current_source_dir/$m |
||||
if {\ |
||||
[llength [dict get [$event targetset_source_changes] changed]]\ |
||||
|| [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ |
||||
} { |
||||
|
||||
#set file_record [punkcheck::installfile_started_install $basedir $file_record] |
||||
$event targetset_started |
||||
# -- --- --- --- --- --- |
||||
if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} |
||||
puts stderr "Copied already versioned module $current_source_dir/$m to $target_module_dir" |
||||
lappend module_list $current_source_dir/$m |
||||
file copy -force $current_source_dir/$m $target_module_dir |
||||
# -- --- --- --- --- --- |
||||
#set file_record [punkcheck::installfile_finished_install $basedir $file_record] |
||||
$event targetset_end OK -note "already versioned module" |
||||
} else { |
||||
puts -nonewline stderr "." |
||||
set did_skip 1 |
||||
#set file_record [punkcheck::installfile_skipped_install $basedir $file_record] |
||||
$event targetset_end SKIPPED |
||||
} |
||||
|
||||
} |
||||
if {$CALLDEPTH >= $max_depth} { |
||||
set subdirs [list] |
||||
} else { |
||||
set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] |
||||
} |
||||
#puts stderr "subdirs: $subdirs" |
||||
foreach d $subdirs { |
||||
set skipdir 0 |
||||
foreach dg $antidir { |
||||
if {[string match $dg $d]} { |
||||
set skipdir 1 |
||||
continue |
||||
} |
||||
} |
||||
if {$skipdir} { |
||||
continue |
||||
} |
||||
if {![file exists $target_module_dir/$d]} { |
||||
file mkdir $target_module_dir/$d |
||||
} |
||||
lappend module_list {*}[build_modules_from_source_to_base $srcdir $basedir\ |
||||
-call-depth-internal [expr {$CALLDEPTH +1}]\ |
||||
-subdirlist [list {*}$subdirlist $d]\ |
||||
-punkcheck_eventobj $event\ |
||||
-glob $fileglob\ |
||||
] |
||||
} |
||||
if {$did_skip} { |
||||
puts -nonewline stdout \n |
||||
} |
||||
if {$CALLDEPTH == 0} { |
||||
$event destroy |
||||
$installer destroy |
||||
} |
||||
return $module_list |
||||
} |
||||
|
||||
variable kettle_reset_bodies [dict create] |
||||
variable kettle_reset_args [dict create] |
||||
#We are abusing kettle to run in-process. |
||||
# when we change to another project we need recipes to be reloaded. |
||||
# Kettle rewrites some of it's own procs - stopping reloading of recipes when we change folders |
||||
#kettle_init stores the original proc bodies & args |
||||
proc kettle_init {} { |
||||
variable kettle_reset_bodies ;#dict |
||||
variable kettle_reset_args |
||||
set reset_procs [list\ |
||||
::kettle::benchmarks\ |
||||
::kettle::doc\ |
||||
::kettle::figures\ |
||||
::kettle::meta::scan\ |
||||
::kettle::testsuite\ |
||||
] |
||||
foreach p $reset_procs { |
||||
set b [info body $p] |
||||
if {[string match "*Overwrite self*" $b]} { |
||||
dict set kettle_reset_bodies $p $b |
||||
set argnames [info args $p] |
||||
set arglist [list] |
||||
foreach a $argnames { |
||||
if {[info default $p $a dval]} { |
||||
lappend arglist [list $a $dval] |
||||
} else { |
||||
lappend arglist $a |
||||
} |
||||
} |
||||
dict set kettle_reset_args $p $arglist |
||||
} |
||||
} |
||||
|
||||
} |
||||
#call kettle_reinit to ensure recipes point to current project |
||||
proc kettle_reinit {} { |
||||
variable kettle_reset_bodies |
||||
variable kettle_reset_args |
||||
foreach p [dict keys $kettle_reset_bodies] { |
||||
set b [dict get $kettle_reset_bodies $p] |
||||
set argl [dict get $kettle_reset_args $p] |
||||
uplevel 1 [list ::proc $p $argl $b] |
||||
} |
||||
#todo - determine standard recipes by examining standard.tcl instead of hard coding? |
||||
set standard_recipes [list\ |
||||
null\ |
||||
forever\ |
||||
list-recipes\ |
||||
help-recipes\ |
||||
help-dump\ |
||||
help-recipes\ |
||||
help\ |
||||
list\ |
||||
list-options\ |
||||
help-options\ |
||||
show-configuration\ |
||||
show-state\ |
||||
show\ |
||||
meta-status\ |
||||
gui\ |
||||
] |
||||
#set ::kettle::recipe::recipe [dict create] |
||||
foreach r [dict keys $::kettle::recipe::recipe] { |
||||
if {$r ni $standard_recipes} { |
||||
dict unset ::kettle::recipe::recipe $r |
||||
} |
||||
} |
||||
} |
||||
proc kettle_call {calltype args} { |
||||
variable kettle_reset_bodies |
||||
if {$calltype ni [list lib shell]} { |
||||
error "pmix kettle_call 1st argument must be one of: 'lib' for direct use of kettle module or 'shell' to call as separate process" |
||||
} |
||||
if {$calltype eq "shell"} { |
||||
set kettleappfile [file dirname [info nameofexecutable]]/kettle |
||||
set kettlebatfile [file dirname [info nameofexecutable]]/kettle.bat |
||||
|
||||
if {(![file exists $kettleappfile]) && (![file exists $kettlebatfile])} { |
||||
error "pmix kettle_call unable to find installed kettle application file '$kettleappfile' (or '$kettlebatfile' if on windows)" |
||||
} |
||||
if {[file exists $kettleappfile]} { |
||||
set kettlescript $kettleappfile |
||||
} |
||||
if {$::tcl_platform(platform) eq "windows"} { |
||||
if {[file exists $kettlebatfile]} { |
||||
set kettlescript $kettlebatfile |
||||
} |
||||
} |
||||
} |
||||
set startdir [pwd] |
||||
if {![file exists $startdir/build.tcl]} { |
||||
error "pmix kettle must be run from a folder containing build.tcl (cwd: [pwd])" |
||||
} |
||||
if {[package provide kettle] eq ""} { |
||||
puts stdout "Loading kettle package - may be delay on first load ..." |
||||
package require kettle |
||||
kettle_init ;#store original procs for those kettle procs that rewrite themselves |
||||
} else { |
||||
if {[dict size $kettle_reset_bodies] == 0} { |
||||
#presumably package require kettle was called without calling our kettle_init hack. |
||||
kettle_init |
||||
} else { |
||||
#undo proc rewrites |
||||
kettle_reinit |
||||
} |
||||
} |
||||
set first [lindex $args 0] |
||||
if {[string match @* $first]} { |
||||
error "pmix kettle doesn't support special operations - try calling tclsh kettle directly" |
||||
} |
||||
if {$first eq "-f"} { |
||||
set args [lassign $args __ path] |
||||
} else { |
||||
set path $startdir/build.tcl |
||||
} |
||||
set opts [list] |
||||
|
||||
if {[lindex $args 0] eq "-trace"} { |
||||
set args [lrange $args 1 end] |
||||
lappend opts --verbose on |
||||
} |
||||
set goals [list] |
||||
|
||||
if {$calltype eq "lib"} { |
||||
file mkdir ~/.kettle |
||||
set dotfile ~/.kettle/config |
||||
if {[file exists $dotfile] && |
||||
[file isfile $dotfile] && |
||||
[file readable $dotfile]} { |
||||
::kettle io trace {Loading dotfile $dotfile ...} |
||||
set args [list {*}[::kettle path cat $dotfile] {*}$args] |
||||
} |
||||
} |
||||
|
||||
#hardcoded kettle option names (::kettle option names) - retrieved using kettle::option names |
||||
#This is done so we don't have to load kettle lib for shell call (both loading as module and running shell are annoyingly SLOW) |
||||
#REVIEW - needs to be updated to keep in sync with kettle. |
||||
set knownopts [list\ |
||||
--exec-prefix --bin-dir --lib-dir --prefix --man-dir --html-dir --markdown-dir --include-dir \ |
||||
--ignore-glob --dry --verbose --machine --color --state --config --with-shell --log \ |
||||
--log-append --log-mode --with-dia --constraints --file --limitconstraints --tmatch --notfile --single --valgrind --tskip --repeats \ |
||||
--iters --collate --match --rmatch --with-doc-destination --with-git --target --test-include \ |
||||
] |
||||
|
||||
while {[llength $args]} { |
||||
set o [lindex $args 0] |
||||
switch -glob -- $o { |
||||
--* { |
||||
#instead of using: kettle option known |
||||
if {$o ni $knownopts} { |
||||
error "Unable to process unknown option $o." {} [list KETTLE (pmix)] |
||||
} |
||||
lappend opts $o [lindex $args 1] |
||||
#::kettle::option set $o [lindex $args 1] |
||||
set args [lrange $args 2 end] |
||||
} |
||||
default { |
||||
lappend goals $o |
||||
set args [lrange $args 1 end] |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {![llength $goals]} { |
||||
lappend goals help |
||||
} |
||||
if {"--prefix" ni [dict keys $opts]} { |
||||
dict set opts --prefix [file dirname $startdir] |
||||
} |
||||
if {$calltype eq "lib"} { |
||||
::kettle status clear |
||||
::kettle::option::set @kettle $startdir |
||||
foreach {o v} $opts { |
||||
::kettle option set $o $v |
||||
} |
||||
::kettle option set @srcscript $path |
||||
::kettle option set @srcdir [file dirname $path] |
||||
::kettle option set @goals $goals |
||||
::source $path |
||||
puts stderr "recipes: [::kettle recipe names]" |
||||
::kettle recipe run {*}[::kettle option get @goals] |
||||
|
||||
set state [::kettle option get --state] |
||||
if {$state ne {}} { |
||||
puts stderr "saving kettle state: $state" |
||||
::kettle status save $state |
||||
} |
||||
|
||||
} else { |
||||
#shell |
||||
puts stdout "Running external kettle process with args: $opts $goals" |
||||
run -n tclsh $kettlescript -f $path {*}$opts {*}$goals |
||||
} |
||||
|
||||
} |
||||
|
||||
} |
||||
} |
||||
|
||||
|
||||
namespace eval punk::mix::cli { |
||||
proc _cli {args} { |
||||
#don't use tailcall - base uses info level to determine caller |
||||
::punk::mix::base::_cli {*}$args |
||||
} |
||||
variable default_command help |
||||
package require punk::mix::base |
||||
package require punk::overlay |
||||
punk::overlay::custom_from_base [namespace current] ::punk::mix::base |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::cli [namespace eval punk::mix::cli { |
||||
variable version |
||||
set version 0.3 |
||||
}] |
||||
return |
||||
@ -0,0 +1,152 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::buildsuite 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::buildsuite { |
||||
namespace export * |
||||
proc projects {suite} { |
||||
set pathinfo [punk::repo::find_repos [pwd]] |
||||
set projectdir [dict get $pathinfo closest] |
||||
set suites_dir [file join $projectdir src buildsuites] |
||||
if {![file isdirectory [file join $suites_dir $suite]]} { |
||||
puts stderr "suite: $suite not found in buildsuites folder: $suites_dir" |
||||
return |
||||
} |
||||
set suite_dir [file join $suites_dir $suite] |
||||
set projects [glob -dir $suite_dir -type d -tails *] |
||||
|
||||
#use internal du which although breadth-first is generally faster |
||||
puts stdout "Examining source folders in $suite_dir." ;#A hint that something is happening in case sources are large |
||||
set du_info [punk::du::du -d 1 -b $suite_dir] |
||||
set du_sizes [dict create] |
||||
set suite_total_size "-" |
||||
foreach du_record $du_info { |
||||
if {[llength $du_record] != 2} { |
||||
#sanity precaution - punk::du::du should always output list of 2 element lists - at least with flags we're using |
||||
continue |
||||
} |
||||
set sz [lindex $du_record 0] |
||||
set path_parts [file split [lindex $du_record 1]] ;#should handle spaced-paths ok. |
||||
set s [lindex $path_parts end-1] |
||||
set p [lindex $path_parts end] |
||||
|
||||
#This handles case where a project folder is same name as suite e.g src/buildsuites/tcl/tcl |
||||
#so we can't just use tail as dict key. We could assume last record is always total - but |
||||
if {![string match -nocase $s $suite]} { |
||||
if {$s eq "buildsuites" && [string match -nocase $p $suite]} { |
||||
set suite_total_size $sz ;#this includes config files in suite base - so we don't really want to use this to report the total source size |
||||
} else { |
||||
#something else - shouldn't happen |
||||
puts stderr "Unexpected output from du in suite_dir: $suite_dir" |
||||
puts stderr "$du_record" |
||||
#try to continue anyway |
||||
} |
||||
} else { |
||||
dict set du_sizes $p $sz |
||||
} |
||||
} |
||||
|
||||
#build another dict for sizes where we ensure exactly one entry for each project exists and exclude total (don't blindly trust du output e.g in case weird filename/permission issue) |
||||
set psizes [list] |
||||
foreach p $projects { |
||||
if {[dict exists $du_sizes $p]} { |
||||
dict set psizes $p [dict get $du_sizes $p] |
||||
} else { |
||||
dict set psizes $p - |
||||
} |
||||
} |
||||
set total_source_size "-" |
||||
if {[catch { |
||||
set total_source_size [tcl::mathop::+ {*}[dict values $psizes]] |
||||
} errM]} { |
||||
puts stderr "Failed to calculate total source size. Errmsg: $errM" |
||||
} |
||||
package require overtype |
||||
|
||||
set title1 "Projects" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $projects] {punk::strlen $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
|
||||
set size_values [dict values $psizes] |
||||
# Title is probably widest - but go through the process anyway! |
||||
set title2 "Source Bytes" |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $size_values] {punk::strlen $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
|
||||
|
||||
set output "" |
||||
append output "[overtype::left $col1 $title1] [overtype::right $col2 $title2]" \n |
||||
foreach p [lsort $projects] { |
||||
#todo - provide some basic info for each - last build time? last time-to-build? |
||||
append output "[overtype::left $col1 $p] [overtype::right $col2 [dict get $psizes $p]]" \n |
||||
} |
||||
append output "Total Source size: $total_source_size bytes" \n |
||||
return $output |
||||
} |
||||
|
||||
|
||||
namespace eval collection { |
||||
namespace export * |
||||
proc _default {{glob {}}} { |
||||
if {![string length $glob]} { |
||||
set glob * |
||||
} |
||||
#todo - review - we want the furthest not the closest if we are potentially inside a buildsuite project |
||||
set pathinfo [punk::repo::find_repos [pwd]] |
||||
set projectdir [dict get $pathinfo closest] |
||||
set suites_dir [file join $projectdir src buildsuites] |
||||
if {![file exists $suites_dir]} { |
||||
puts stderr "No buildsuites folder found at $suites_dir" |
||||
return |
||||
} |
||||
set suites [lsort [glob -dir $suites_dir -type d -tails *]] |
||||
if {$glob ne "*"} { |
||||
set suites [lsearch -all -inline $suites $glob] |
||||
} |
||||
return $suites |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::buildsuite [namespace eval punk::mix::commandset::buildsuite { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,92 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::debug 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::debug { |
||||
namespace export get paths |
||||
namespace path ::punk::mix::cli |
||||
|
||||
#Except for 'get' - all debug commands should emit to stdout |
||||
proc paths {} { |
||||
set out "" |
||||
puts stdout "find_repos output:" |
||||
set pathinfo [punk::repo::find_repos [pwd]] |
||||
pdict $pathinfo |
||||
|
||||
set projectdir [dict get $pathinfo closest] |
||||
set modulefolders [lib::find_source_module_paths $projectdir] |
||||
puts stdout "modulefolders: $modulefolders" |
||||
|
||||
set template_base_dict [punk::mix::base::lib::get_template_basefolders] |
||||
puts stdout "get_template_basefolders output:" |
||||
pdict $template_base_dict |
||||
return |
||||
} |
||||
|
||||
#call other debug command - but capture stdout as return value |
||||
proc get {args} { |
||||
set nm [lindex $args 0] |
||||
if {$nm eq ""} { |
||||
set nscmds [info commands [namespace current]::*] |
||||
set cmds [lmap v $nscmds {namespace tail $v}] |
||||
error "debug.get missing debug command argument. Try one of: $cmds" |
||||
return |
||||
} |
||||
set nextargs [lrange $args 1 end] |
||||
set out "" |
||||
if {[info commands [namespace current]::$nm] ne ""} { |
||||
append out [runout -n -tcl [namespace current]::$nm {*}$nextargs] \n |
||||
} else { |
||||
set nscmds [info commands [namespace current]::*] |
||||
set cmds [lmap v $nscmds {namespace tail $v}] |
||||
error "debug.get invalid debug command '$nm' Try one of: $cmds" |
||||
} |
||||
return $out |
||||
} |
||||
namespace eval lib { |
||||
|
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::debug [namespace eval punk::mix::commandset::debug { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,181 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::doc 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::doc { |
||||
namespace export * |
||||
|
||||
proc _default {} { |
||||
puts "documentation subsystem" |
||||
puts "commands: doc.build" |
||||
puts " build documentation from src/doc to src/embedded using the kettle build tool" |
||||
} |
||||
|
||||
proc build {} { |
||||
puts "build docs" |
||||
set projectdir [punk::repo::find_project] |
||||
if {$projectdir eq ""} { |
||||
puts stderr "No current project dir - unable to build docs" |
||||
return |
||||
} |
||||
if {[file exists $projectdir/src/doc]} { |
||||
set original_wd [pwd] |
||||
cd $projectdir/src |
||||
#---------- |
||||
set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] |
||||
$installer set_source_target $projectdir/src/doc $projectdir/src/embedded |
||||
set event [$installer start_event {-install_step kettledoc}] |
||||
#use same virtual id "kettle_build_doc" as project.new - review best way to keep identifiers like this in sync. |
||||
$event targetset_init VIRTUAL kettle_build_doc ;#VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated |
||||
$event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source |
||||
#---------- |
||||
if {\ |
||||
[llength [dict get [$event targetset_source_changes] changed]]\ |
||||
} { |
||||
$event targetset_started |
||||
# -- --- --- --- --- --- |
||||
puts stdout "BUILDING DOCS at $projectdir/src/embedded from src/doc" |
||||
if {[catch { |
||||
|
||||
punk::mix::cli::lib::kettle_call lib doc |
||||
#Kettle doc |
||||
|
||||
} errM]} { |
||||
$event targetset_end FAILED -note "kettle_build_doc failed: $errM" |
||||
} else { |
||||
$event targetset_end OK |
||||
} |
||||
# -- --- --- --- --- --- |
||||
} else { |
||||
puts stderr "No change detected in src/doc" |
||||
$event targetset_end SKIPPED |
||||
} |
||||
$event end |
||||
$event destroy |
||||
$installer destroy |
||||
cd $original_wd |
||||
} else { |
||||
puts stderr "No doc folder found at $projectdir/src/doc" |
||||
} |
||||
} |
||||
proc status {} { |
||||
set projectdir [punk::repo::find_project] |
||||
if {$projectdir eq ""} { |
||||
puts stderr "No current project dir - unable to check doc status" |
||||
return |
||||
} |
||||
if {![file exists $projectdir/src/doc]} { |
||||
set result "No documentation source found. Expected .man files in doctools format at $projectdir/src/doc" |
||||
return $result |
||||
} |
||||
set original_wd [pwd] |
||||
cd $projectdir/src |
||||
puts stdout "Testing status of doctools source location $projectdir/src/doc ..." |
||||
flush stdout |
||||
#---------- |
||||
set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] |
||||
$installer set_source_target $projectdir/src/doc $projectdir/src/embedded |
||||
set event [$installer start_event {-install_step kettledoc}] |
||||
#use same virtual id "kettle_build_doc" as project.new - review best way to keep identifiers like this in sync. |
||||
$event targetset_init QUERY kettle_build_doc ;#usually VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated - but here we use QUERY to ensure no writes to .punkcheck |
||||
set last_completion [$event targetset_last_complete] |
||||
|
||||
if {[llength $last_completion]} { |
||||
#adding a source causes it to be checksummed |
||||
$event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source |
||||
#---------- |
||||
set changeinfo [$event targetset_source_changes] |
||||
if {\ |
||||
[llength [dict get $changeinfo changed]]\ |
||||
} { |
||||
puts stdout "changed" |
||||
puts stdout $changeinfo |
||||
} else { |
||||
puts stdout "No changes detected in $projectdir/src/doc tree" |
||||
} |
||||
} else { |
||||
#no previous completion-record for this target - must assume changed - no need to trigger checksumming |
||||
puts stdout "No existing record of doc build in .punkcheck. Assume it needs to be rebuilt." |
||||
} |
||||
|
||||
|
||||
$event destroy |
||||
$installer destroy |
||||
|
||||
cd $original_wd |
||||
} |
||||
proc validate {} { |
||||
set projectdir [punk::repo::find_project] |
||||
if {$projectdir eq ""} { |
||||
puts stderr "No current project dir - unable to check doc status" |
||||
return |
||||
} |
||||
if {![file exists $projectdir/src/doc]} { |
||||
set result "No documentation source found. Expected .man files in doctools format at $projectdir/src/doc" |
||||
return $result |
||||
} |
||||
set original_wd [pwd] |
||||
cd $projectdir/src |
||||
|
||||
punk::mix::cli::lib::kettle_call lib validate-doc |
||||
|
||||
cd $original_wd |
||||
} |
||||
|
||||
namespace eval collection { |
||||
variable pkg |
||||
set pkg punk::mix::commandset::doc |
||||
|
||||
namespace export * |
||||
namespace path [namespace parent] |
||||
|
||||
} |
||||
|
||||
namespace eval lib { |
||||
variable pkg |
||||
set pkg punk::mix::commandset::doc |
||||
|
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::doc [namespace eval punk::mix::commandset::doc { |
||||
variable pkg punk::mix::commandset::doc |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,185 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::layout 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
#sort of a circular dependency when commandset loaded by punk::mix::cli - that's ok, but this could theoretically be loaded by another cli and with another base |
||||
package require punk::mix |
||||
package require punk::mix::base |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::layout { |
||||
namespace export * |
||||
|
||||
#per layout functions |
||||
proc files {layout} { |
||||
set allfiles [lib::layout_all_files $layout] |
||||
return [join $allfiles \n] |
||||
} |
||||
proc templatefiles {layout} { |
||||
set templatefiles [lib::layout_scan_for_template_files $layout] |
||||
return [join $templatefiles \n] |
||||
} |
||||
proc templatefiles.relative {layout} { |
||||
set template_base_dict [punk::mix::base::lib::get_template_basefolders] |
||||
|
||||
set bases_containing_layout [list] |
||||
dict for {tbase folderinfo} $template_base_dict { |
||||
if {[file exists $tbase/layouts/$layout]} { |
||||
lappend bases_containing_layout $tbase |
||||
} |
||||
} |
||||
if {![llength $bases_containing_layout]} { |
||||
puts stderr "Unable to locate folder for layout '$layout'" |
||||
puts stderr "searched [dict size $template_base_dict] template folders" |
||||
return |
||||
} |
||||
set tpldir [lindex $bases_containing_layout end] |
||||
|
||||
set layout_base $tpldir/layouts |
||||
set layout_dir [file join $layout_base $layout] |
||||
|
||||
set stripprefix [file normalize $layout_dir] |
||||
set templatefiles [lib::layout_scan_for_template_files $layout] |
||||
set tails [list] |
||||
foreach templatefullpath $templatefiles { |
||||
lappend tails [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] |
||||
} |
||||
return [join $tails \n] |
||||
} |
||||
|
||||
#layout collection functions - to be imported with punk::overlay::import_commandset separately |
||||
namespace eval collection { |
||||
namespace export * |
||||
proc _default {{glob {}}} { |
||||
if {![string length $glob]} { |
||||
set glob * |
||||
} |
||||
set layouts [list] |
||||
#set tplfolderdict [punk::cap::templates::folders] |
||||
set tplfolderdict [punk::mix::base::lib::get_template_basefolders] |
||||
dict for {tdir folderinfo} $tplfolderdict { |
||||
set layout_base $tdir/layouts |
||||
#collect all layouts and use lsearch glob rather than the filesystem glob (avoid issues with dotted folder names) |
||||
set all_layouts [lsort [glob -nocomplain -dir $layout_base -type d -tail *]] |
||||
foreach match [lsearch -all -inline $all_layouts $glob] { |
||||
lappend layouts [list $match $folderinfo] |
||||
} |
||||
} |
||||
return [join [lsort -index 0 $layouts] \n] |
||||
} |
||||
|
||||
} |
||||
namespace eval lib { |
||||
proc layout_all_files {layout} { |
||||
set tplbasedict [punk::mix::base::lib::get_template_basefolders] |
||||
set layouts_found [list] |
||||
dict for {tplbase folderinfo} $tplbasedict { |
||||
if {[file isdirectory $tplbase/layouts/$layout]} { |
||||
lappend layouts_found $tplbase/layouts/$layout |
||||
} |
||||
} |
||||
if {![llength $layouts_found]} { |
||||
puts stderr "layout '$layout' not found." |
||||
puts stderr "searched [dict size $tplbasedict] template folders" |
||||
dict for {tplbase pkg} $tplbasedict { |
||||
puts stderr " - $tplbase $pkg" |
||||
} |
||||
return |
||||
} |
||||
set layoutfolder [lindex $layouts_found end] |
||||
|
||||
if {![file isdirectory $layoutfolder]} { |
||||
puts stderr "layout '$layout' not found in /layouts within one of template_folders. (get_template_folder returned: $tplbasedict)" |
||||
} |
||||
set file_list [list] |
||||
util::foreach-file $layoutfolder path { |
||||
lappend file_list $path |
||||
} |
||||
|
||||
return $file_list |
||||
} |
||||
|
||||
# |
||||
#todo - allow specifying which package the layout is from: e.g "punk::mix::templates project" ?? |
||||
proc layout_scan_for_template_files {layout {tags {}}} { |
||||
#equivalent for projects? punk::mix::commandset::module::lib::templates_dict -scriptpath "" |
||||
set tplbasedict [punk::mix::base::lib::get_template_basefolders] |
||||
set layouts_found [list] |
||||
dict for {tpldir pkg} $tplbasedict { |
||||
if {[file isdirectory $tpldir/layouts/$layout]} { |
||||
lappend layouts_found $tpldir/layouts/$layout |
||||
} |
||||
} |
||||
if {![llength $layouts_found]} { |
||||
puts stderr "layout '$layout' not found." |
||||
puts stderr "searched [dict size $tplbasedict] template folders" |
||||
dict for {tpldir pkg} $tplbasedict { |
||||
puts stderr " - $tpldir $pkg" |
||||
} |
||||
return |
||||
} |
||||
set layoutfolder [lindex $layouts_found end] |
||||
|
||||
#use last matching layout found. review silent if multiple? |
||||
if {![llength $tags]} { |
||||
#todo - get standard tags from somewhere |
||||
set tags [list %project%] |
||||
} |
||||
set file_list [list] |
||||
util::foreach-file $layoutfolder path { |
||||
set fd [open $path r] |
||||
fconfigure $fd -translation binary |
||||
set data [read $fd] |
||||
close $fd |
||||
foreach tag $tags { |
||||
if {[string match "*$tag*" $data]} { |
||||
lappend file_list $path |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $file_list |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::layout [namespace eval punk::mix::commandset::layout { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,529 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::loadedlib 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
package require punk::ns |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::loadedlib { |
||||
namespace export * |
||||
#search automatically wrapped in * * - can contain inner * ? globs |
||||
proc search {searchstring} { |
||||
catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything |
||||
if {[catch {package require natsort}]} { |
||||
set has_natsort 0 |
||||
} else { |
||||
set has_natsort 1 |
||||
} |
||||
if {[regexp {[?*]} $searchstring]} { |
||||
#caller has specified specific glob pattern - use it |
||||
#todo - respect supplied case only if uppers present? require another flag? |
||||
set matches [lsearch -all -inline -nocase [package names] $searchstring] |
||||
} else { |
||||
#make it easy to search for anything |
||||
set matches [lsearch -all -inline -nocase [package names] "*$searchstring*"] |
||||
} |
||||
|
||||
set matchinfo [list] |
||||
foreach m $matches { |
||||
set versions [package versions $m] |
||||
if {$has_natsort} { |
||||
set versions [natsort::sort $versions] |
||||
} else { |
||||
set versions [lsort $versions] |
||||
} |
||||
lappend matchinfo [list $m $versions] |
||||
} |
||||
return [join [lsort $matchinfo] \n] |
||||
} |
||||
proc loaded.search {searchstring} { |
||||
set search_result [search $searchstring] |
||||
set all_libs [split $search_result \n] |
||||
set col1items [list] |
||||
set col2items [list] |
||||
set col3items [list] |
||||
foreach libinfo $all_libs { |
||||
if {[string trim $libinfo] eq ""} { |
||||
continue |
||||
} |
||||
set versions [lassign $libinfo libname] |
||||
if {[set ver [package provide $libname]] ne ""} { |
||||
lappend col1items $libname |
||||
lappend col2items $versions |
||||
lappend col3items $ver |
||||
} |
||||
} |
||||
|
||||
package require overtype |
||||
set title1 "Library" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1items] {string length $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
set title2 "Versions Avail." |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {string length $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
set title3 "Loaded Version" |
||||
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {string length $v}]] |
||||
set col3 [string repeat " " $widest3] |
||||
|
||||
|
||||
set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3}] |
||||
|
||||
set table "" |
||||
append table [string repeat - $tablewidth] \n |
||||
append table "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]" \n |
||||
append table [string repeat - $tablewidth] \n |
||||
foreach c1 $col1items c2 $col2items c3 $col3items { |
||||
append table "[overtype::left $col1 $c1] [overtype::left $col2 $c2] [overtype::left $col3 $c3]" \n |
||||
} |
||||
|
||||
return $table |
||||
|
||||
|
||||
set loaded_libs [list] |
||||
foreach libinfo $all_libs { |
||||
if {[string trim $libinfo] eq ""} { |
||||
continue |
||||
} |
||||
set versions [lassign $libinfo libname] |
||||
if {[set ver [package provide $libname]] ne ""} { |
||||
lappend loaded_libs "$libname $versions (loaded $ver)" |
||||
} |
||||
} |
||||
return [join $loaded_libs \n] |
||||
} |
||||
|
||||
proc info {libname} { |
||||
if {[catch {package require natsort}]} { |
||||
set has_natsort 0 |
||||
} else { |
||||
set has_natsort 1 |
||||
} |
||||
catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything |
||||
set pkgsknown [package names] |
||||
if {[set posn [lsearch $pkgsknown $libname]] >= 0} { |
||||
puts stdout "Found package [lindex $pkgsknown $posn]" |
||||
} else { |
||||
puts stderr "Package not found as available library/module - check tcl::tm::list and \$auto_path" |
||||
} |
||||
set versions [package versions [lindex $libname 0]] |
||||
if {$has_natsort} { |
||||
set versions [natsort::sort $versions] |
||||
} else { |
||||
set versions [lsort $versions] |
||||
} |
||||
if {![llength $versions]} { |
||||
puts stderr "No version numbers found for library/module $libname" |
||||
return false |
||||
} |
||||
puts stdout "Versions of $libname found: $versions" |
||||
set alphaposn [lsearch $versions "999999.*"] |
||||
if {$alphaposn >= 0} { |
||||
set alpha [lindex $versions $alphaposn] |
||||
#remove and tack onto beginning.. |
||||
set versions [lreplace $versions $alphaposn $alphaposn] |
||||
set versions [list $alpha {*}$versions] |
||||
} |
||||
foreach ver $versions { |
||||
set loadinfo [package ifneeded $libname $ver] |
||||
puts stdout "$libname $ver" |
||||
puts stdout "--- 'package ifneeded' script ---" |
||||
puts stdout $loadinfo |
||||
puts stdout "---" |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc copyasmodule {library modulefoldername args} { |
||||
set defaults [list -askme 1] |
||||
set opts [dict merge $defaults $args] |
||||
set opt_askme [dict get $opts -askme] |
||||
|
||||
if {[catch {package require natsort}]} { |
||||
set has_natsort 0 |
||||
} else { |
||||
set has_natsort 1 |
||||
} |
||||
|
||||
catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything |
||||
|
||||
if {[file pathtype $modulefoldername] eq "absolute"} { |
||||
if {![file exists $modulefoldername]} { |
||||
error "Path '$modulefoldername' not found. Enter a fully qualified path, or just the tail such as 'modules' if you are within the project to use <projectdir>/src/modules" |
||||
} |
||||
#use the target folder as the source of projectdir info |
||||
set pathinfo [punk::repo::find_repos $modulefoldername] |
||||
set projectdir [dict get $pathinfo closest] |
||||
set modulefolder_path $modulefoldername |
||||
} else { |
||||
#use the current working directory as the source of projectdir info |
||||
set pathinfo [punk::repo::find_repos [pwd]] |
||||
set projectdir [dict get $pathinfo closest] |
||||
if {$projectdir ne ""} { |
||||
set modulefolders [punk::mix::cli::lib::find_source_module_paths $projectdir] |
||||
foreach k [list modules vendormodules] { |
||||
set knownfolder [file join $projectdir src $k] |
||||
if {$knownfolder ni $modulefolders} { |
||||
lappend modulefolders $knownfolder |
||||
} |
||||
} |
||||
set mtails [list] |
||||
foreach path $modulefolders { |
||||
lappend mtails [file tail $path] |
||||
} |
||||
|
||||
#special case bootsupport/modules so it can be referred to as just bootsupport or bootsupport/modules |
||||
lappend modulefolders [file join $projectdir src bootsupport/modules] |
||||
|
||||
if {$modulefoldername ni $mtails && $modulefoldername ni "bootsupport bootsupport/modules"} { |
||||
set msg "Suplied modulefoldername '$modulefoldername' doesn't appear to be a known module folder within the project at $projectdir\n" |
||||
append msg "Known module folders: [lsort $mtails]\n" |
||||
append msg "Use a name from the above list, or a fully qualified path\n" |
||||
error $msg |
||||
} |
||||
|
||||
if {$modulefoldername eq "bootsupport"} { |
||||
set modulefoldername "bootsupport/modules" |
||||
} |
||||
set modulefolder_path [file join $projectdir src $modulefoldername] |
||||
} else { |
||||
set msg "No current project found at or above current directory\n" |
||||
append msg "Supplied modulefoldername '$modulefoldername' is a name or relative path - cannot use when outside a project." \n |
||||
append msg "Supply an absolute path for the target modulefolder, or try again from within a project directory" \n |
||||
error $msg |
||||
} |
||||
} |
||||
puts stdout "-----------------------------" |
||||
if {$projectdir ne ""} { |
||||
puts stdout "Using projectdir: $projectdir for lib.copyasmodule" |
||||
} else { |
||||
puts stdout "No current project." |
||||
} |
||||
puts stdout "-----------------------------" |
||||
if {![file exists $modulefolder_path]} { |
||||
error "Selected module folder path '$modulefolder_path' doesn't exist. Required subdirectories for namespaced modules will be created automatically - but base selected folder must exist first" |
||||
} |
||||
|
||||
|
||||
set libfound [lsearch -all -inline [package names] $library] |
||||
if {[llength $libfound] != 1 || ![string length $libfound]} { |
||||
error "Library must match exactly one entry in the list of package names visible to the current interpretor: found '$libfound'" |
||||
} |
||||
|
||||
set versions [package versions [lindex $libfound 0]] |
||||
if {$has_natsort} { |
||||
set versions [natsort::sort $versions] |
||||
} else { |
||||
set versions [lsort $versions] |
||||
} |
||||
if {![llength $versions]} { |
||||
error "No version numbers found for library/module $libfound - sorry, you will need to copy it across manually" |
||||
} |
||||
puts stdout "Versions of $libfound found: $versions" |
||||
set alphaposn [lsearch $versions "999999.*"] |
||||
if {$alphaposn >= 0} { |
||||
set alpha [lindex $versions $alphaposn] |
||||
#remove and tack onto beginning.. |
||||
set versions [lreplace $versions $alphaposn $alphaposn] |
||||
set versions [list $alpha {*}$versions] |
||||
} |
||||
|
||||
set ver [lindex $versions end] ;# todo - make selectable! don't assume tail is latest?.. package vcompare? |
||||
if {[llength $versions] > 1} { |
||||
puts stdout "Version selected: $ver" |
||||
} |
||||
|
||||
set loadinfo [package ifneeded $libfound $ver] |
||||
set loadinfo [string map [list \r\n \n] $loadinfo] |
||||
set loadinfo_lines [split $loadinfo \n] |
||||
if {[catch {llength $loadinfo}]} { |
||||
set loadinfo_is_listshaped 0 |
||||
} else { |
||||
set loadinfo_is_listshaped 1 |
||||
} |
||||
|
||||
#check for redirection to differently cased version of self - this is only detected if this is the only command in the package ifneeded result |
||||
#- must have matching version. REVIEW this requirement. Is there a legitimate reason to divert to a differently cased other-version? |
||||
set is_package_require_self_recased 0 |
||||
set is_package_require_diversion 0 |
||||
set lib_diversion_name "" |
||||
if {[llength $loadinfo_lines] == 1} { |
||||
#e.g Thread 3.0b1 diverts to thread 3.0b1 |
||||
set line1 [lindex $loadinfo_lines 0] |
||||
#check if multiparted with semicolon |
||||
#We need to distinguish "package require <lib> <ver>; more stuff" from "package require <lib> ver> ;" possibly with trailing comment? |
||||
set parts [list] |
||||
if {[regexp {;} $line1]} { |
||||
foreach p [split $line1 {;}] { |
||||
set p [string trim $p] |
||||
if {[string length $p]} { |
||||
#only append parts with some content that doesn't look like a comment |
||||
if {![string match "#*" $p]} { |
||||
lappend parts $p |
||||
} |
||||
} |
||||
} |
||||
|
||||
} |
||||
if {[llength $parts] == 1} { |
||||
#seems like a lone package require statement. |
||||
#check if package require, package\trequire etc |
||||
if {[string match "package*require" [lrange $line1 0 1]]} { |
||||
set is_package_require_diversion 1 |
||||
if {[lindex $line1 2] eq "-exact"} { |
||||
#package require -exact <pkg> <ver> |
||||
set lib_diversion_name [lindex $line1 3] |
||||
#check not an exact match - but is a -nocase match - i.e differs in case only |
||||
if {($lib_diversion_name ne $libfound) && [string match -nocase $lib_diversion_name $libfound]} { |
||||
if {[lindex $line1 4] eq $ver} { |
||||
set is_package_require_self_recased 1 |
||||
} |
||||
} |
||||
} else { |
||||
#may be package require <pkg> <ver> |
||||
#or package require <pkg> <ver> ?<ver>?... |
||||
set lib_diversion_name [lindex $line1 2] |
||||
#check not an exact match - but is a -nocase match - i.e differs in case only |
||||
if {($lib_diversion_name ne $libfound) && [string match -nocase $lib_diversion_name $libfound]} { |
||||
set requiredversions [lrange $line1 3 end] |
||||
if {$ver in $requiredversions} { |
||||
set is_package_require_self_recased 1 |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {$is_package_require_self_recased && [string length $lib_diversion_name]} { |
||||
#we only follow one level of package require redirection - seems unlikely/imprudent to follow arbitrarily in a while loop(?) |
||||
set libfound $lib_diversion_name |
||||
set loadinfo [package ifneeded $libfound $ver] |
||||
set loadinfo [string map [list \r\n \n] $loadinfo] |
||||
set loadinfo_lines [split $loadinfo \n] |
||||
if {[catch {llength $loadinfo}]} { |
||||
set loadinfo_is_listshaped 0 |
||||
} else { |
||||
set loadinfo_is_listshaped 1 |
||||
} |
||||
|
||||
|
||||
} else { |
||||
if {$is_package_require_diversion} { |
||||
#single |
||||
#for now - we'll abort and tell the user to run again with specified pkg/version |
||||
#We could automate - but it seems likely to be surprising. |
||||
puts stderr "Loadinfo for $libfound seems to be diverting to another pkg/version: $loadinfo_lines" |
||||
puts stderr "Review and consider trying with the pkg/version described in the result above." |
||||
return |
||||
} |
||||
} |
||||
|
||||
|
||||
if {$loadinfo_is_listshaped && ([llength $loadinfo] == 2 && [lindex $loadinfo 0] eq "source")} { |
||||
set source_file [lindex $loadinfo 1] |
||||
} elseif {[string match "*source*" $loadinfo]} { |
||||
set parts [list] |
||||
foreach ln $loadinfo_lines { |
||||
if {![string length $ln]} {continue} |
||||
lappend parts {*}[split $ln ";"] |
||||
} |
||||
set sources_found [list] |
||||
set loads_found [list] |
||||
set dependencies [list] |
||||
set incomplete_lines [list] |
||||
foreach p $parts { |
||||
set p [string trim $p] |
||||
if {![string length $p]} { |
||||
continue ;#empty line or trailing colon |
||||
} |
||||
if {[string match "*tclPkgSetup*" $p]} { |
||||
puts stderr "Unable to process load script for library $libfound" |
||||
puts stderr "The library appears to use the deprecated tcl library support utility 'tclPkgSetup'" |
||||
return false |
||||
} |
||||
if {![::info complete $p]} { |
||||
# |
||||
#probably a perfectly valid script - but slightly more complicated than we can handle |
||||
#better to defer to manual processing |
||||
lappend incomplete_lines $p |
||||
continue |
||||
} |
||||
if {[lindex $p 0] eq "source"} { |
||||
#may have args.. e.g -encoding utf-8 |
||||
lappend sources_found [lindex $p end] |
||||
} |
||||
if {[lindex $p 0] eq "load"} { |
||||
lappend loads_found [lrange $p 1 end] |
||||
} |
||||
if {[lrange $p 0 1] eq "package require"} { |
||||
lappend dependencies [lrange $p 2 end] |
||||
} |
||||
} |
||||
if {[llength $incomplete_lines]} { |
||||
puts stderr "unable to interpret load script for library $libfound" |
||||
puts stderr "Load info: $loadinfo" |
||||
return false |
||||
} |
||||
if {[llength $loads_found]} { |
||||
puts stderr "package $libfound appears to have binary components" |
||||
foreach l $loads_found { |
||||
puts stderr " binary - $l" |
||||
} |
||||
foreach s $sources_found { |
||||
puts stderr " script - $s" |
||||
} |
||||
puts stderr "Unable to automatically copy binary libraries to your module folder." |
||||
return false |
||||
} |
||||
|
||||
if {[llength $sources_found] != 1} { |
||||
puts stderr "sorry - unable to interpret source library location" |
||||
puts stderr "Only 1 source supported for now" |
||||
puts stderr "Load info: $loadinfo" |
||||
return false |
||||
} |
||||
if {[llength $dependencies]} { |
||||
#todo - check/ignore if dependency is Tcl ? |
||||
puts stderr "WARNING the package appears to depend on at least one other. Review and copy dependencies if required." |
||||
foreach d $dependencies { |
||||
puts stderr " - $d" |
||||
} |
||||
} |
||||
|
||||
set source_file [lindex $sources_found 0] |
||||
} else { |
||||
puts stderr "sorry - unable to interpret source library location" |
||||
puts stderr "Load info: $loadinfo" |
||||
return false |
||||
} |
||||
|
||||
# -- --------------------------------------- |
||||
#Analyse source file |
||||
if {![file exists $source_file]} { |
||||
error "Unable to verify source file existence at: $source_file" |
||||
} |
||||
set source_data [fcat $source_file -translation binary] |
||||
if {![string match "*package provide*" $source_data]} { |
||||
puts stderr "Sorry - unable to verify source file contains 'package provide' statement of some sort - copy manually" |
||||
return false |
||||
} else { |
||||
if {![string match "*$libfound*" $source_data]} { |
||||
# as an exception - look for the specific 'package provide $pkg $version' as occurs in the auto-name auto-version modules |
||||
#e.g anyname-0.1.tm example |
||||
if {![string match "*package provide \$pkg \$version*" $source_data]} { |
||||
puts stderr "Sorry - unable to verify source file contains 'package provide' and '$libfound' - copy manually" |
||||
return false |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
if {[string match "*lappend ::auto_path*" $source_data] || [string match "*lappend auto_path*" $source_data] || [string match "*set ::auto_path*" $source_data]} { |
||||
puts stderr "Sorry - '$libfound' source file '$source_file' appears to rely on ::auto_path and can't be automatically copied as a .tm module" |
||||
puts stderr "Copy the library across to a lib folder instead" |
||||
return false |
||||
} |
||||
# -- --------------------------------------- |
||||
|
||||
set moduleprefix [punk::ns::nsprefix $libfound] |
||||
if {[string length $moduleprefix]} { |
||||
set moduleprefix_parts [punk::ns::nsparts $moduleprefix] |
||||
set relative_path [file join {*}$moduleprefix_parts] |
||||
} else { |
||||
set relative_path "" |
||||
} |
||||
set pkgtail [punk::ns::nstail $libfound] |
||||
set target_path [file join $modulefolder_path $relative_path ${pkgtail}-${ver}.tm] |
||||
|
||||
if {$opt_askme} { |
||||
puts stdout "WARNING - you should check that there aren't extra required files for the library/modules" |
||||
puts stdout "" |
||||
puts stdout "This is not intended for binary modules - use at own risk and check results" |
||||
puts stdout "" |
||||
puts stdout "Base module path: $modulefolder_path" |
||||
puts stdout "Target path : $target_path" |
||||
puts stdout "results of 'package ifneeded $libfound'" |
||||
puts stdout "---" |
||||
puts stdout "$loadinfo" |
||||
puts stdout "---" |
||||
puts stdout "Proceed to create ${pkgtail}-${ver}.tm module? Y|N" |
||||
set stdin_state [fconfigure stdin] |
||||
fconfigure stdin -blocking 1 |
||||
set answer [string tolower [gets stdin]] |
||||
fconfigure stdin -blocking [dict get $stdin_state -blocking] |
||||
if {$answer ne "y"} { |
||||
puts stderr "mix libcopy.asmodule aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
|
||||
if {![file exists $modulefolder_path]} { |
||||
puts stdout "Creating module base folder at $modulefolder_path" |
||||
file mkdir $modulefolder_path |
||||
} |
||||
if {![file exists [file dirname $target_path]]} { |
||||
puts stdout "Creating relative folder at [file dirname $target_path]" |
||||
file mkdir [file dirname $target_path] |
||||
} |
||||
|
||||
if {[file exists $target_path]} { |
||||
puts stdout "WARNING - module already exists at $target_path" |
||||
if {$opt_askme} { |
||||
puts stdout "Copy anyway? Y|N" |
||||
set stdin_state [fconfigure stdin] |
||||
fconfigure stdin -blocking 1 |
||||
set answer [string tolower [gets stdin]] |
||||
fconfigure stdin -blocking [dict get $stdin_state -blocking] |
||||
if {$answer ne "y"} { |
||||
puts stderr "mix libcopy.asmodule aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
} |
||||
|
||||
file copy -force $source_file $target_path |
||||
|
||||
return $target_path |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::loadedlib [namespace eval punk::mix::commandset::loadedlib { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,419 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::module 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::module { |
||||
namespace export * |
||||
|
||||
proc paths {} { |
||||
set roots [punk::repo::find_repos ""] |
||||
set project [lindex [dict get $roots project] 0] |
||||
if {$project ne ""} { |
||||
set is_project 1 |
||||
set searchbase $project |
||||
} else { |
||||
set is_project 0 |
||||
set searchbase [pwd] |
||||
} |
||||
|
||||
if {[catch { |
||||
set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $searchbase] |
||||
} errMsg]} { |
||||
set source_module_folderlist [list] |
||||
} |
||||
|
||||
set tm_folders [tcl::tm::list] |
||||
package require overtype |
||||
|
||||
set result "" |
||||
if {$is_project} { |
||||
append result "Project module source paths:" \n |
||||
foreach f $source_module_folderlist { |
||||
append result "$f" \n |
||||
} |
||||
} |
||||
append result \n |
||||
append result "tcl::tm::list" \n |
||||
foreach f $tm_folders { |
||||
if {$is_project} { |
||||
if {[punk::mix::cli::lib::path_a_aboveorat_b $project $f]} { |
||||
set pinfo "(within project)" |
||||
} else { |
||||
set pinfo "" |
||||
} |
||||
} else { |
||||
set pinfo "" |
||||
} |
||||
set warning "" |
||||
if {![file isdirectory $f]} { |
||||
set warning "(PATH NOT FOUND)" |
||||
} |
||||
append result "$f $pinfo $warning" \n |
||||
} |
||||
|
||||
|
||||
return $result |
||||
} |
||||
#require current dir when calling to be the projectdir, or |
||||
proc templates {args} { |
||||
set tdict [templates_dict {*}$args] |
||||
|
||||
package require overtype |
||||
set paths [dict values $tdict] |
||||
set names [dict keys $tdict] |
||||
|
||||
set title1 "Path" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $paths] {punk::strlen $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
|
||||
set title2 "Template Name" |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $names] {punk::strlen $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
|
||||
set tablewidth [expr {$widest1 + 1 + $widest2}] |
||||
set table "" |
||||
append table [string repeat - $tablewidth] \n |
||||
append table "[overtype::left $col1 $title1] [overtype::left $col2 $title2]" \n |
||||
append table [string repeat - $tablewidth] \n |
||||
|
||||
foreach p $paths n $names { |
||||
append table "[overtype::left $col1 $p] [overtype::left $col2 $n]" \n |
||||
} |
||||
|
||||
return $table |
||||
} |
||||
#return all module templates with repeated ones suffixed with .2 .3 etc |
||||
proc templates_dict {args} { |
||||
tailcall lib::templates_dict {*}$args |
||||
} |
||||
proc new {module args} { |
||||
set year [clock format [clock seconds] -format %Y] |
||||
set defaults [list\ |
||||
-project \uFFFF\ |
||||
-version \uFFFF\ |
||||
-license <unspecified>\ |
||||
-template module-0.0.1.tm\ |
||||
-type \uFFFF\ |
||||
-force 0\ |
||||
] |
||||
set opts [dict merge $defaults $args] |
||||
|
||||
#todo - review compatibility between -template and -type |
||||
#-type is the wrapping technology e.g 'plain' for none or tarjar/zipkit etc (consider also snappy/snappy-tcl) |
||||
#-template may be a folder - but only if the selected -type suports it |
||||
|
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
# option -version |
||||
# we need this value before looking at the named argument |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_version_supplied [dict get $opts -version] |
||||
if {$opt_version_supplied eq "\uFFFF"} { |
||||
set opt_version "0.1.0" |
||||
} else { |
||||
set opt_version $opt_version_supplied |
||||
if {![util::is_valid_tm_version $opt_version]} { |
||||
error "pmix module.new error - supplied -version $opt_version doesn't appear to be a valid Tcl module version" |
||||
} |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
#named argument |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set mversion_supplied "" ;#version supplied directly in module argument |
||||
if {[string first - $module]> 0} { |
||||
#if it has a dash then version is required to be valid |
||||
lassign [punk::mix::cli::lib::split_modulename_version $module] modulename mversion |
||||
if {![util::is_valid_tm_version $mversion]} { |
||||
error "pmix module.new error - unable to determine modulename-version from supplied value '$module'" |
||||
} |
||||
set mversion_supplied $mversion ;#record as may need to compare to version from templatefile name |
||||
set vcompare_is_mversion_bigger [package vcompare $mversion $opt_version] |
||||
if {$vcompare_is_mversion_bigger > 0} { |
||||
set opt_version $mversion; #module parameter has higher value than -version |
||||
set vmsg "from module argument: $module" |
||||
} else { |
||||
set vmsg "from -version option: $opt_version_supplied" |
||||
} |
||||
if {$opt_version_supplied ne "\uFFFF"} { |
||||
if {$vcompare_is_mversion_bigger != 0} { |
||||
#is bigger or smaller |
||||
puts stderr "module.new WARNING: version supplied in module argument as well as -version option. Using the higher version number $vmsg" |
||||
} |
||||
} |
||||
} else { |
||||
set modulename $module |
||||
} |
||||
punk::mix::cli::lib::validate_modulename $modulename -name_description "mix module.new name" |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
#options |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_project [dict get $opts -project] |
||||
set testdir [pwd] |
||||
if {![string length [set projectdir [punk::repo::find_project $testdir]]]} { |
||||
if {![string length [set projectdir [punk::repo::find_candidate $testdir]]]} { |
||||
set msg [punkc::repo::is_candidate_root_requirements_msg] |
||||
error "module.new unable to create module in projectdir:$projectdir - directory doesn't appear to meet basic standards $msg" |
||||
} |
||||
} |
||||
if {$opt_project == "\uFFFF"} { |
||||
set projectname [file tail $projectdir] |
||||
} else { |
||||
set projectname $opt_project |
||||
if {$projectname ne [file tail $projectdir]} { |
||||
error "module.new -project '$opt_project' doesn't match detected projectname '$projectname' at path: $projectdir" |
||||
} |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_license [dict get $opts -license] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_template [dict get $opts -template] |
||||
|
||||
set templates_dict [templates_dict] ;#possibly suffixed with .2 .3 etc |
||||
#todo - allow versionless name - pick latest which isn't suffixed with .2 etc |
||||
if {![dict exists $templates_dict $opt_template]} { |
||||
error "module.new unable to find template '$opt_template'. Known templates: [dict keys $templates_dict]" |
||||
} |
||||
set templatefile [dict get $templates_dict $opt_template] |
||||
set tpldir [file dirname $templatefile] ;#use same folder for modulename_buildversion.txt, modulename_description.txt if they exist |
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_type [dict get $opts -type] |
||||
if {$opt_type eq "\uFFFF"} { |
||||
set opt_type [lindex [punk::mix::cli::lib::module_types] 0] ;#default to plain |
||||
} |
||||
if {$opt_type ni [punk::mix::cli::lib::module_types]} { |
||||
error "module.new - error - unknown -type '$opt_type' known-types: [punk::mix::cli::lib::module_types]" |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
set subpath [punk::mix::cli::lib::module_subpath $modulename] ;#commonly empty string for simple modulename e.g "mymodule" but x::mymodule has subpath 'x' and x::y::mymodule has subpath 'x/y' |
||||
if {![string length $subpath]} { |
||||
set modulefolder $projectdir/src/modules |
||||
} else { |
||||
set modulefolder $projectdir/src/modules/$subpath |
||||
} |
||||
file mkdir $modulefolder |
||||
|
||||
set moduletail [namespace tail $modulename] |
||||
set magicversion [punk::mix::util::magic_tm_version] ;#deliberately large so given load-preference when testing |
||||
|
||||
|
||||
|
||||
|
||||
set template_tail [file tail $templatefile] ;#convert template_xxx-version.tm.x to {xxx version} |
||||
set template_tail [string range $template_tail [string length template_] end] |
||||
set ext [string tolower [file extension $template_tail]] |
||||
if {$ext eq ".tm"} { |
||||
set template_modulename_part [file rootname $template_tail] |
||||
} elseif {[string is integer -strict [string range $ext 1 end]]} { |
||||
#something like modulename-0.0.1.tm.2 |
||||
#strip of last 2 dotted parts |
||||
set shortened [file rootname $template_tail] |
||||
if {![string equal -nocase [file extension $shortened] ".tm"]} { |
||||
error "module.new error: Unable to interpret filename components of template file '$templatefile' (expected .tm as second-last or last component)" |
||||
} |
||||
set template_modulename_part [file rootname $shortened] |
||||
} else { |
||||
error "module.new error: Unable to interpret filename components of template file '$templatefile'" |
||||
} |
||||
lassign [punk::mix::cli::lib::split_modulename_version $template_modulename_part] t_mname t_version |
||||
#t_version may be empty string if template is unversioned e.g template_whatever.tm |
||||
|
||||
set fd [open $templatefile r]; set template_filedata [read $fd]; close $fd |
||||
if {[string match "*$magicversion*" $template_filedata]} { |
||||
set use_magic 1 |
||||
set build_version $opt_version |
||||
set infile_version $magicversion |
||||
} else { |
||||
set use_magic 0 |
||||
if {$opt_version_supplied ne "\uFFFF"} { |
||||
set build_version $opt_version |
||||
} else { |
||||
if {[util::is_valid_tm_version $t_version]} { |
||||
if {$mversion_supplied eq ""} { |
||||
set build_version $t_version |
||||
} else { |
||||
#we have a version from the named argument 'module' |
||||
if {[package vcompare $mversion_supplied $t_version] > 0} { |
||||
set build_version $mversion_supplied |
||||
} else { |
||||
set build_version $t_version |
||||
} |
||||
} |
||||
} else { |
||||
#probably an unversioned module template |
||||
#use opt_version default from above |
||||
set build_version $opt_version |
||||
} |
||||
} |
||||
set infile_version $build_version |
||||
} |
||||
|
||||
set template_filedata [string map [list %pkg% $modulename %year% $year %license% $opt_license %version% $infile_version] $template_filedata] |
||||
|
||||
set modulefile $modulefolder/${moduletail}-$infile_version.tm |
||||
if {[file exists $modulefile]} { |
||||
set errmsg "module.new error: module file $modulefile already exists - aborting" |
||||
if {[string match "*$magicversion*" $modulefile]} { |
||||
append errmsg \n "If you are attempting to create a module file with a specific version in the source-file name - you will need to use a template that doesn't contain the string '$magicversion' e.g the provided template moduleexactversion-0.0.1.tm" |
||||
} |
||||
error $errmsg |
||||
} |
||||
|
||||
|
||||
if {[file exists $tpldir/modulename_buildversion.txt]} { |
||||
set fd [open $tpldir/modulename_buildversion.txt r]; set buildversion_filedata [read $fd]; close $fd |
||||
} else { |
||||
#mix_templates_dir warns of deprecation - review |
||||
set lib_tpldir [file join [punk::mix::cli::lib::mix_templates_dir] modules];#fallback for modulename_buildversion.txt, modulename_description.txt |
||||
set fd [open $lib_tpldir/modulename_buildversion.txt r]; set buildversion_filedata [read $fd]; close $fd |
||||
} |
||||
set buildversionfile [file join $modulefolder ${moduletail}-buildversion.txt] |
||||
set existing_build_version "" |
||||
if {[file exists $buildversionfile]} { |
||||
set buildversiondata [punk::mix::util::fcat $buildversionfile] |
||||
set lines [split $buildversiondata \n] |
||||
set existing_build_version [string trim [lindex $lines 0]] |
||||
if {[package vcompare $existing_build_version $build_version] >= 0} { |
||||
#existing version in -buildversion.txt file is lower than the module version we are creating |
||||
error "module.new error: there is an existing buildversion file $buildversionfile with version $existing_build_version equal to or higher than $build_version - unable to continue" |
||||
} |
||||
} |
||||
|
||||
set existing_versions [glob -nocomplain -dir $modulefolder -tails ${moduletail}-*.tm] |
||||
#it shouldn't be possible to overmatch with the glob - because '-' is not valid in a Tcl module name |
||||
if {[llength $existing_versions]} { |
||||
set name_version_pairs [list] |
||||
lappend name_version_pairs [list $moduletail $infile_version] |
||||
foreach existing $existing_versions { |
||||
lappend name_version_pairs [punk::mix::cli::lib::split_modulename_version $existing] ;# .tm is stripped and ignored |
||||
} |
||||
set name_version_pairs [lsort -command {package vcompare} -index 1 $name_version_pairs] ;#while plain lsort will often work with versions - it can get order wrong with some - so use package vcompare |
||||
if {[lindex $name_version_pairs end] ne [list $moduletail $infile_version]} { |
||||
set thisposn [lsearch -index 1 $name_version_pairs $infile_version] |
||||
set name_version_pairs [lreplace $name_version_pairs $thisposn $thisposn] |
||||
set other_versions [lsearch -all -inline -index 1 -subindices $name_version_pairs *] |
||||
set errmsg "module.new error: There are existing modules in the target folder with higher versions than $infile_version." |
||||
append errmsg \n "Other versions found: $other_versions" |
||||
if {$magicversion in $other_versions} { |
||||
append errmsg \n "Existing build version for special source file name: '$magicversion' is: '$existing_build_version'" |
||||
append errmsg \n "If '$magicversion' file doesn't represent the latest source it should be removed or the filename and contents adjusted to be a specific version" |
||||
} |
||||
error $errmsg |
||||
} else { |
||||
puts stderr "module.new WARNING: There are existing modules in the target folder with lower versions than $infile_version - manual review recommended" |
||||
puts stderr "Other versions found: [lsearch -all -inline -index 1 -subindices [lrange $name_version_pairs 0 end-1] *]" |
||||
} |
||||
} |
||||
|
||||
|
||||
set fd [open $modulefile w] |
||||
fconfigure $fd -translation binary |
||||
puts -nonewline $fd $template_filedata |
||||
close $fd |
||||
|
||||
|
||||
set buildversion_filedata [string map [list %Major.Minor.Level% $build_version] $buildversion_filedata] |
||||
set fd [open $buildversionfile w] |
||||
fconfigure $fd -translation binary |
||||
puts -nonewline $fd $buildversion_filedata |
||||
close $fd |
||||
|
||||
return [list file $modulefile version $build_version] |
||||
} |
||||
|
||||
namespace eval lib { |
||||
proc templates_dict {args} { |
||||
set defaults [list -scriptpath ""] |
||||
set opts [dict merge $defaults $args] |
||||
set opt_scriptpath [dict get $opts -scriptpath] |
||||
|
||||
set module_template_bases [list] |
||||
set tbasedict [punk::mix::base::lib::get_template_basefolders $opt_scriptpath] |
||||
dict for {tbase folderinfo} $tbasedict { |
||||
lappend module_template_bases [file join $tbase modules] |
||||
} |
||||
|
||||
|
||||
|
||||
set template_files [list] |
||||
foreach basefld $module_template_bases { |
||||
set matched_files [glob -nocomplain -dir $basefld -type f template_*] |
||||
foreach tf $matched_files { |
||||
if {[string match ignore* $tf]} { |
||||
continue |
||||
} |
||||
set ext [file extension $tf] |
||||
if {$ext in [list ".tm"]} { |
||||
lappend template_files $tf |
||||
} |
||||
} |
||||
} |
||||
|
||||
set tdict [dict create] |
||||
set seen_dict [dict create] |
||||
foreach fullpath $template_files { |
||||
set ftail [file tail $fullpath] |
||||
set tname [string range $ftail [string length template_] end] |
||||
if {![dict exists $seen_dict $tname]} { |
||||
dict set seen_dict $tname 1 |
||||
dict set tdict $tname $fullpath ; #first seen of filename gets no number |
||||
} else { |
||||
set n [dict get $seen_dict $tname] |
||||
incr n |
||||
dict incr seen_dict $tname |
||||
dict set tdict ${tname}.$n $fullpath |
||||
} |
||||
} |
||||
return $tdict |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::module [namespace eval punk::mix::commandset::module { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,849 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::project 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::project { |
||||
namespace export * |
||||
|
||||
#new project structure - may be dedicated to one module, or contain many. |
||||
#create minimal folder structure only by specifying -modules {} |
||||
proc new {newprojectpath_or_name args} { |
||||
if {[file pathtype $newprojectpath_or_name] eq "absolute"} { |
||||
set projectfullpath [file normalize $newprojectpath_or_name] |
||||
set projectname [file tail $projectfullpath] |
||||
set projectparentdir [file dirname $newprojectpath_or_name] |
||||
} else { |
||||
set projectfullpath [file join [pwd] $newprojectpath_or_name] |
||||
set projectname [file tail $projectfullpath] |
||||
set projectparentdir [file dirname $projectfullpath] |
||||
} |
||||
if {[file type $projectparentdir] ne "directory"} { |
||||
error "punk::mix::cli::new error: unable to determine containing folder for '$newprojectpath_or_name'" |
||||
} |
||||
|
||||
punk::mix::cli::lib::validate_projectname $projectname -name_description "punk mix project.new" |
||||
|
||||
|
||||
set defaults [list\ |
||||
-type plain\ |
||||
-empty 0\ |
||||
-force 0\ |
||||
-update 0\ |
||||
-confirm 1\ |
||||
-modules \uFFFF\ |
||||
-layout project |
||||
] ;#todo |
||||
set known_opts [dict keys $defaults] |
||||
foreach {k v} $args { |
||||
if {$k ni $known_opts} { |
||||
error "project.new error: option '$k' not known. Known options: $known_opts" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_type [dict get $opts -type] |
||||
if {$opt_type ni [punk::mix::cli::lib::module_types]} { |
||||
error "pmix new error - unknown type '$opt_type' known types: [punk::mix::cli::lib::module_types]" |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_force [dict get $opts -force] |
||||
set opt_confirm [string tolower [dict get $opts -confirm]] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_modules [dict get $opts -modules] |
||||
if {[llength $opt_modules] == 1 && [lindex $opt_modules 0] eq "\uFFFF"} { |
||||
#if not specified - add a single module matching project name |
||||
set opt_modules [list $projectname] |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_layout [dict get $opts -layout] |
||||
set opt_update [dict get $opts -update] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
|
||||
|
||||
set fossil_prog [auto_execok fossil] |
||||
if {![string length $fossil_prog]} { |
||||
puts stderr "The fossil program was not found. A fossil executable is required to use most pmix features." |
||||
if {[string length [set scoop_prog [auto_execok scoop]]]} { |
||||
#restrict to windows? |
||||
set answer [util::askuser "scoop detected. Would you like pmix to install fossil now using scoop? Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." |
||||
return |
||||
} |
||||
#we don't assume 'unknown' is configured to run shell commands |
||||
if {[string length [package provide shellrun]]} { |
||||
set exitinfo [run {*}$scoop_prog install fossil] |
||||
#scoop tends to return successful exitcode (0) even when packages not found etc. - so exitinfo not much use. |
||||
puts stdout "scoop install fossil ran with result: $exitinfo" |
||||
} else { |
||||
puts stdout "Please wait while scoop runs - there may be a slight delay and then scoop output will be shown. (use punk shellrun package for )" |
||||
set result [exec {*}$scoop_prog install fossil] |
||||
puts stdout $result |
||||
} |
||||
catch {::auto_reset} ;#can be missing (unsure under what circumstances - but I've seen it raise error 'invalid command name "auto_reset"') |
||||
if {![string length [auto_execok fossil]]} { |
||||
puts stderr "Fossil still not detected. If it was successfully installed, try restarting your punk/tcl shell." |
||||
return |
||||
} |
||||
#todo - ask user if they want to configure fosssil first.. |
||||
set answer [util::askuser "Fossil command now appears to be available. You may wish to answer N to exit and customize it - but default config may be ok. Type the word 'continue' to proceed with default configuration."] |
||||
if {[string tolower $answer] ne "continue"} { |
||||
return |
||||
} |
||||
|
||||
} else { |
||||
puts stdout "See: https://fossil-scm.org/home/uv/download.html" |
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
puts stdout "Consider using a package manager such as scoop: https://scoop.sh" |
||||
puts stdout "(Then: scoop install fossil)" |
||||
} |
||||
return |
||||
} |
||||
} |
||||
set startdir [pwd] |
||||
if {[set in_project [punk::repo::find_project $startdir]] ne ""} { |
||||
# use this project as source of templates |
||||
puts stdout "-------------------------------------------" |
||||
puts stdout "Currently in a project directory '$in_project'" |
||||
puts stdout "This project will be searched for templates" |
||||
puts stdout "-------------------------------------------" |
||||
} |
||||
set template_base_dict [punk::mix::base::lib::get_template_basefolders] |
||||
set template_bases_containing_layout [list] |
||||
dict for {tbase folderinfo} $template_base_dict { |
||||
if {[file exists $tbase/layouts/$opt_layout]} { |
||||
lappend template_bases_containing_layout $tbase |
||||
} |
||||
} |
||||
if {![llength $template_bases_containing_layout]} { |
||||
puts stderr "layout '$opt_layout' was not found in template dirs" |
||||
puts stderr "searched [dict size $template_base_dict] template folders" |
||||
dict for {tbase folderinfo} $template_base_dict { |
||||
puts stderr " - $tbase $folderinfo" |
||||
} |
||||
return |
||||
} |
||||
#review: silently use last entry which had the layout (?) |
||||
set templatebase [lindex $template_bases_containing_layout end] |
||||
|
||||
|
||||
|
||||
#todo - detect whether inside cwd-project or inside a different project |
||||
set projectdir $projectparentdir/$projectname |
||||
if {[set target_in_project [punk::repo::find_project $projectparentdir]] ne ""} { |
||||
puts stderr "Target location for new project is already within a project: $target_in_project" |
||||
error "Nested projects not yet supported aborting" |
||||
} |
||||
|
||||
|
||||
|
||||
if {[punk::repo::is_git $projectparentdir]} { |
||||
puts stderr "mix new WARNING: target project location is within a git repo based at [punk::repo::find_git $projectparentdir]" |
||||
puts stderr "The new project will create a fossil repository (which you are free to ignore - but but will be used to confirm project base)" |
||||
puts stderr "If you intend to use both git and fossil in the same project space - you should research and understand the details and any possible interactions/issues" |
||||
set answer [util::askuser "Do you want to proceed to create a project based at: $projectdir? Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
set is_nested_fossil 0 ;#default assumption |
||||
if {[punk::repo::is_fossil $projectparentdir]} { |
||||
puts stderr "mix new WARNING: target project location is within an open fossil repo based at [punk::repo::find_fossil $projectparentdir] NESTED fossil repository" |
||||
if {$opt_confirm ni [list 0 no false]} { |
||||
puts stderr "If you proceed - the new project's fossil repo will be created using the --nested flag" |
||||
set answer [util::askuser "Do you want to proceed to create a NESTED project based at: $projectdir? Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." |
||||
return |
||||
} |
||||
set is_nested_fossil 1 |
||||
} |
||||
} |
||||
|
||||
|
||||
set project_dir_exists [file exists $projectdir] |
||||
if {$project_dir_exists && !($opt_force || $opt_update)} { |
||||
puts stderr "Unable to create new project at $projectdir - file/folder already exists use -update 1 to fill in missing items from template use -force 1 to overwrite from template" |
||||
return |
||||
} elseif {$project_dir_exists && $opt_force} { |
||||
puts stderr "mix new WARNING: -force 1 was supplied. Will copy layout $templatebase/layouts/$opt_layout using -force option to overwrite from template" |
||||
if {$opt_confirm ni [list 0 no false]} { |
||||
set answer [util::askuser "Do you want to proceed to possibly overwrite existing files in $projectdir? Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
} elseif {$project_dir_exists && $opt_update} { |
||||
puts stderr "mix new WARNING: -update 1 was supplied. Will copy layout $templatebase/layouts/$opt_layout using -update option to add missing items" |
||||
} |
||||
|
||||
set fossil_repo_file "" |
||||
set is_fossil_root 0 |
||||
if {$project_dir_exists && [punk::repo::is_fossil_root $projectdir]} { |
||||
set is_fossil_root 1 |
||||
set fossil_repo_file [punk::repo::fossil_get_repository_file $projectdir] |
||||
if {$fossil_repo_file ne ""} { |
||||
set repodb_folder [file dirname $fossil_repo_file] |
||||
} |
||||
} |
||||
|
||||
if {$fossil_repo_file eq ""} { |
||||
set repodb_folder [punk::repo::fossil_get_repository_folder_for_project $projectname -parentfolder $startdir] |
||||
if {![string length $repodb_folder]} { |
||||
puts stderr "No usable repository database folder selected for $projectname.fossil file" |
||||
return |
||||
} |
||||
} |
||||
if {[file exists $repodb_folder/$projectname.fossil]} { |
||||
puts stdout "NOTICE: $repodb_folder/$projectname.fossil already exists" |
||||
if {!($opt_force || $opt_update)} { |
||||
puts stderr "-force 1 or -update 1 not specified - aborting" |
||||
return |
||||
} |
||||
} |
||||
|
||||
if {$fossil_repo_file eq ""} { |
||||
puts stdout "Initialising fossil repo: $repodb_folder/$projectname.fossil" |
||||
set fossilinit [runx -n {*}$fossil_prog init $repodb_folder/$projectname.fossil -project-name $projectname] |
||||
if {[dict get $fossilinit exitcode] != 0} { |
||||
puts stderr "fossil init failed:" |
||||
puts stderr [dict get $fossilinit stderr] |
||||
return |
||||
} else { |
||||
puts stdout "fossil init result:" |
||||
puts stdout [dict get $fossilinit stdout] |
||||
} |
||||
} |
||||
|
||||
file mkdir $projectdir |
||||
|
||||
set layout_dir $templatebase/layouts/$opt_layout |
||||
puts stdout ">>> about to call punkcheck::install $layout_dir $projectdir" |
||||
set resultdict [dict create] |
||||
set unpublish [list\ |
||||
src/doc/*\ |
||||
src/doc/include/*\ |
||||
] |
||||
|
||||
#default antiglob_dir_core will stop .fossil* from being updated - which is generally desirable as these are likely to be customized |
||||
if {$opt_force} { |
||||
puts stdout "copying layout files - with force applied - overwrite all-targets" |
||||
set resultdict [punkcheck::install $layout_dir $projectdir -installer project.new -overwrite ALL-TARGETS -unpublish_paths $unpublish] |
||||
#file copy -force $layout_dir $projectdir |
||||
} else { |
||||
puts stdout "copying layout files - (if source file changed)" |
||||
set resultdict [punkcheck::install $layout_dir $projectdir -installer project.new -overwrite installedsourcechanged-targets -unpublish_paths $unpublish] |
||||
} |
||||
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
||||
|
||||
puts stdout "copying layout src/doc files (if target missing)" |
||||
set resultdict [punkcheck::install $layout_dir/src/doc $projectdir/src/doc -punkcheck_folder $projectdir -installer project.new -overwrite SYNCED-TARGETS] |
||||
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
||||
|
||||
#target folders .fossil-custom and .fossil-settings may not exist. use -createdir 1 to ensure existence. |
||||
#In this case we need to override the default dir antiglob - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized. |
||||
## default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"] |
||||
set override_antiglob_dir_core [list #* _aside .git] |
||||
puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)" |
||||
set resultdict [punkcheck::install $layout_dir/.fossil-custom $projectdir/.fossil-custom -createdir 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] |
||||
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
||||
|
||||
puts stdout "copying layout src/.fossil-settings files (if target missing or uncustomised)" |
||||
set resultdict [punkcheck::install $layout_dir/.fossil-settings $projectdir/.fossil-settings -createdir 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] |
||||
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
||||
|
||||
|
||||
|
||||
|
||||
#lappend substfiles $projectdir/README.md |
||||
#lappend substfiles $projectdir/src/README.md |
||||
#lappend substfiles $projectdir/src/doc/main.man |
||||
#expect this in all templates? - todo make these substitutions independent of specific paths and filenames? |
||||
#scan all files in template |
||||
# |
||||
#TODO - pmix command to substitute templates? |
||||
set templatefiles [punk::mix::commandset::layout::lib::layout_scan_for_template_files $opt_layout] |
||||
set stripprefix [file normalize $layout_dir] |
||||
|
||||
foreach templatefullpath $templatefiles { |
||||
set templatetail [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] |
||||
|
||||
set fpath [file join $projectdir $templatetail] |
||||
if {[file exists $fpath]} { |
||||
set fd [open $fpath r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd |
||||
set data2 [string map [list %project% $projectname] $data] |
||||
if {$data2 ne $data} { |
||||
puts stdout "updated template file: $fpath" |
||||
set fdout [open $fpath w]; fconfigure $fdout -translation binary; puts -nonewline $fdout $data2; close $fdout |
||||
} |
||||
} else { |
||||
puts stderr "warning: Missing template file $fpath" |
||||
} |
||||
} |
||||
#todo - tag substitutions in src/doc tree |
||||
|
||||
|
||||
cd $projectdir |
||||
|
||||
if {[file exists $projectdir/src/modules]} { |
||||
foreach m $opt_modules { |
||||
if {![file exists $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm]} { |
||||
punk::mix::commandset::module::new $m -project $projectname -type $opt_type |
||||
} else { |
||||
if {$opt_force} { |
||||
punk::mix::commandset::module::new $m -project $projectname -type $opt_type -force 1 |
||||
} |
||||
} |
||||
} |
||||
} else { |
||||
puts stderr "project.new WARNING template hasn't created src/modules - skipping creation of new module(s) for project" |
||||
} |
||||
|
||||
#generate www/man/md output in 'embedded' folder which should be checked into repo for online documentation |
||||
if {[file exists $projectdir/src]} { |
||||
cd $projectdir/src |
||||
#---------- |
||||
set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] |
||||
$installer set_source_target $projectdir/src/doc $projectdir/src/embedded |
||||
set event [$installer start_event {-install_step kettledoc}] |
||||
$event targetset_init VIRTUAL kettle_build_doc ;#VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated |
||||
$event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source |
||||
#---------- |
||||
if {\ |
||||
[llength [dict get [$event targetset_source_changes] changed]]\ |
||||
} { |
||||
$event targetset_started |
||||
# -- --- --- --- --- --- |
||||
puts stdout "BUILDING DOCS at src/embedded from src/doc" |
||||
if {[catch { |
||||
|
||||
punk::mix::cli::lib::kettle_call lib doc |
||||
#Kettle doc |
||||
|
||||
} errM]} { |
||||
$event targetset_end FAILED -note "kettle_build_doc failed: $errM" |
||||
} else { |
||||
$event targetset_end OK |
||||
} |
||||
# -- --- --- --- --- --- |
||||
} else { |
||||
puts stderr "No change detected in src/doc" |
||||
$event targetset_end SKIPPED |
||||
} |
||||
$event end |
||||
$event destroy |
||||
$installer destroy |
||||
} |
||||
|
||||
cd $projectdir |
||||
|
||||
if {![punk::repo::is_fossil_root $projectdir]} { |
||||
set first_fossil 1 |
||||
#-k = keep. (only modify the manifest file(s)) |
||||
if {$is_nested_fossil} { |
||||
set fossilopen [runx -n {*}$fossil_prog open --nested $repodb_folder/$projectname.fossil -k --workdir $projectdir] |
||||
} else { |
||||
set fossilopen [runx -n {*}$fossil_prog open $repodb_folder/$projectname.fossil -k --workdir $projectdir] |
||||
} |
||||
if {[file exists $projectdir/_FOSSIL_] && ![file exists $projectdir/.fslckout]} { |
||||
file rename $projectdir/_FOSSIL_ $projectdir/.fslckout |
||||
} |
||||
if {[dict get $fossilopen exitcode] != 0} { |
||||
puts stderr "fossil open in project workdir '$projectdir' FAILED:" |
||||
puts stderr [dict get $fossilopen stderr] |
||||
return |
||||
} else { |
||||
puts stdout "fossil open in project workdir '$projectdir' OK:" |
||||
puts stdout [dict get $fossilopen stdout] |
||||
} |
||||
} else { |
||||
set first_fossil 0 |
||||
} |
||||
set fossiladd [runx -n {*}$fossil_prog add --dotfiles $projectdir] |
||||
if {[dict get $fossiladd exitcode] != 0} { |
||||
puts stderr "fossil add workfiles in workdir '$projectdir' FAILED:" |
||||
puts stderr [dict get $fossiladd stderr] |
||||
return |
||||
} else { |
||||
puts stdout "fossil add workfiles in workdir '$projectdir' OK:" |
||||
puts stdout [dict get $fossiladd stdout] |
||||
} |
||||
if {$first_fossil} { |
||||
#fossil commit may prompt user for input.. runx runout etc will pause with no prompts |
||||
util::do_in_path $projectdir { |
||||
set fossilcommit [run -n {*}$fossil_prog commit -m "initial project commit"] |
||||
} |
||||
if {[dict get $fossilcommit exitcode] != 0} { |
||||
puts stderr "fossil commit in workdir '$projectdir' FAILED" |
||||
return |
||||
} else { |
||||
puts stdout "fossil commit in workdir '$projectdir' OK" |
||||
} |
||||
} |
||||
|
||||
puts stdout "-done- project:$projectname projectdir: $projectdir" |
||||
} |
||||
|
||||
|
||||
namespace eval collection { |
||||
namespace export * |
||||
namespace path [namespace parent] |
||||
|
||||
#e.g imported as 'projects' |
||||
proc _default {{glob {}} args} { |
||||
package require overtype |
||||
set db_projects [lib::get_projects $glob] |
||||
set col1items [lsearch -all -inline -index 0 -subindices $db_projects *] |
||||
set col2items [lsearch -all -inline -index 1 -subindices $db_projects *] |
||||
set checkouts [lsearch -all -inline -index 2 -subindices $db_projects *] |
||||
set col3items [lmap v $checkouts {llength $v}] |
||||
|
||||
set title1 "Fossil DB" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1items] {punk::strlen $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
set title2 "File Name" |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {punk::strlen $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
set title3 "Checkouts" |
||||
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {punk::strlen $v}]] |
||||
set col3 [string repeat " " $widest3] |
||||
set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3}] |
||||
|
||||
|
||||
append msg "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]" \n |
||||
append msg [string repeat "=" $tablewidth] \n |
||||
foreach p $col1items n $col2items c $col3items { |
||||
append msg "[overtype::left $col1 $p] [overtype::left $col2 $n] [overtype::right $col3 $c]" \n |
||||
} |
||||
return $msg |
||||
#return [list_as_lines [lib::get_projects $glob]] |
||||
} |
||||
proc detail {{glob {}} args} { |
||||
package require overtype |
||||
package require textutil |
||||
set defaults [dict create\ |
||||
-description 0\ |
||||
] |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- |
||||
set opt_description [dict get $opts -description] |
||||
# -- --- --- --- --- --- --- |
||||
|
||||
|
||||
set db_projects [lib::get_projects $glob] |
||||
set col1_dbfiles [lsearch -all -inline -index 0 -subindices $db_projects *] |
||||
set col2items [lsearch -all -inline -index 1 -subindices $db_projects *] |
||||
set checkouts [lsearch -all -inline -index 2 -subindices $db_projects *] |
||||
set col3items [lmap v $checkouts {llength $v}] |
||||
|
||||
set col4_pnames [list] |
||||
set col5_pcodes [list] |
||||
set col6_dupids [list] |
||||
set col7_pdescs [list] |
||||
set codes [dict create] |
||||
foreach dbfile $col1_dbfiles { |
||||
set project_name "" |
||||
set project_code "" |
||||
set project_desc "" |
||||
sqlite3 dbp $dbfile |
||||
dbp eval {select name,value from config where name like 'project-%';} r { |
||||
if {$r(name) eq "project-name"} { |
||||
set project_name $r(value) |
||||
} elseif {$r(name) eq "project-code"} { |
||||
set project_code $r(value) |
||||
} elseif {$r(name) eq "project-description"} { |
||||
set project_desc $r(value) |
||||
} |
||||
} |
||||
dbp close |
||||
lappend col4_pnames $project_name |
||||
lappend col5_pcodes $project_code |
||||
dict lappend codes $project_code $dbfile |
||||
lappend col7_pdescs $project_desc |
||||
} |
||||
|
||||
set setid 1 |
||||
set codeset [dict create] |
||||
dict for {code dbs} $codes { |
||||
if {[llength $dbs]>1} { |
||||
dict set codeset $code setid $setid |
||||
dict set codeset $code count [llength $dbs] |
||||
dict set codeset $code seen 0 |
||||
incr setid |
||||
} |
||||
} |
||||
set dupid 1 |
||||
foreach pc $col5_pcodes { |
||||
if {[dict exists $codeset $pc]} { |
||||
set seen [dict get $codeset $pc seen] |
||||
set this_seen [expr {$seen + 1}] |
||||
dict set codeset $pc seen $this_seen |
||||
lappend col6_dupids "[dict get $codeset $pc setid].${this_seen}/[dict get $codeset $pc count]" |
||||
} else { |
||||
lappend col6_dupids "" |
||||
} |
||||
} |
||||
|
||||
set title1 "Fossil DB" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1_dbfiles] {punk::strlen $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
set title2 "File Name" |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {punk::strlen $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
set title3 "Checkouts" |
||||
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {punk::strlen $v}]] |
||||
set col3 [string repeat " " $widest3] |
||||
set title4 "Project Name" |
||||
set widest4 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col4_pnames] {punk::strlen $v}]] |
||||
set col4 [string repeat " " $widest4] |
||||
set title5 "Project Code" |
||||
set widest5 [tcl::mathfunc::max {*}[lmap v [concat [list $title5] $col5_pcodes] {punk::strlen $v}]] |
||||
set col5 [string repeat " " $widest5] |
||||
set title6 "Dup" |
||||
set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col6_dupids] {punk::strlen $v}]] |
||||
set col6 [string repeat " " $widest6] |
||||
set title7 "Description" |
||||
#set widest7 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col7_pdescs] {punk::strlen $v}]] |
||||
set widest7 35 |
||||
set col7 [string repeat " " $widest7] |
||||
|
||||
|
||||
set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3 +1 + $widest4 + 1 + $widest5 + 1 + $widest6}] |
||||
|
||||
append msg "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]\ |
||||
[overtype::left $col4 $title4] [overtype::left $col5 $title5] [overtype::left $col6 $title6]" |
||||
if {!$opt_description} { |
||||
append msg \n |
||||
} else { |
||||
append msg "[overtype::left $col7 $title7]" \n |
||||
set tablewidth [expr {$tablewidth + 1 + $widest7}] |
||||
} |
||||
|
||||
append msg [string repeat "=" $tablewidth] \n |
||||
foreach p $col1_dbfiles n $col2items c $col3items pn $col4_pnames pc $col5_pcodes dup $col6_dupids desc $col7_pdescs { |
||||
set desclines [split [textutil::adjust $desc -length $widest7] \n] |
||||
set desc1 [lindex $desclines 0] |
||||
append msg "[overtype::left $col1 $p] [overtype::left $col2 $n] [overtype::right $col3 $c]\ |
||||
[overtype::left $col4 $pn] [overtype::left $col5 $pc] [overtype::left $col6 $dup]" |
||||
if {!$opt_description} { |
||||
append msg \n |
||||
} else { |
||||
append msg " [overtype::left $col7 $desc1]" \n |
||||
foreach dline [lrange $desclines 1 end] { |
||||
append msg "$col1 $col2 $col3 $col4 $col5 $col6 [overtype::left $col7 $dline]" \n |
||||
} |
||||
} |
||||
} |
||||
return $msg |
||||
#return [list_as_lines [lib::get_projects $glob]] |
||||
} |
||||
proc cd {{glob {}} args} { |
||||
dict set args -cd 1 |
||||
work $glob {*}$args |
||||
} |
||||
proc work {{glob {}} args} { |
||||
package require sqlite3 |
||||
set db_projects [lib::get_projects $glob] |
||||
#list of lists of the form: |
||||
#{fosdb fname workdirlist} |
||||
set defaults [dict create\ |
||||
-cd 0\ |
||||
] |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- |
||||
set opt_cd [dict get $opts -cd] |
||||
# -- --- --- --- --- --- --- |
||||
set workdir_dict [dict create] |
||||
set all_workdirs [list] |
||||
foreach pinfo $db_projects { |
||||
lassign $pinfo fosdb name workdirs |
||||
foreach wdir $workdirs { |
||||
dict set workdir_dict $wdir $pinfo |
||||
lappend all_workdirs $wdir |
||||
} |
||||
} |
||||
set col_rowids [list] |
||||
set workdirs [lsort -index 0 $all_workdirs] |
||||
set col_dupids [list] |
||||
set col_fnames [list] |
||||
set col_pnames [list] |
||||
set col_pcodes [list] |
||||
set col_dupids [list] |
||||
|
||||
set fosdb_count [dict create] |
||||
set fosdb_dupset [dict create] |
||||
set fosdb_cache [dict create] |
||||
set dupset 0 |
||||
set rowid 1 |
||||
foreach wd $workdirs { |
||||
set wdinfo [dict get $workdir_dict $wd] |
||||
lassign $wdinfo fosdb nm siblingworkdirs |
||||
dict incr fosdb_count $fosdb |
||||
set dbcount [dict get $fosdb_count $fosdb] |
||||
if {[llength $siblingworkdirs] > 1} { |
||||
if {![dict exists $fosdb_dupset $fosdb]} { |
||||
#first time this multi-checkout fosdb seen |
||||
dict set fosdb_dupset $fosdb [incr dupset] |
||||
} |
||||
set dupid "[dict get $fosdb_dupset $fosdb].$dbcount/[llength $siblingworkdirs]" |
||||
} else { |
||||
set dupid "" |
||||
} |
||||
if {$dbcount == 1} { |
||||
set pname "" |
||||
set pcode "" |
||||
if {[file exists $fosdb]} { |
||||
if {[catch { |
||||
sqlite3 fdb $fosdb |
||||
set pname [lindex [fdb eval {select value from config where name = 'project-name'}] 0] |
||||
set pcode [lindex [fdb eval {select value from config where name = 'project-code'}] 0] |
||||
fdb close |
||||
dict set fosdb_cache $fosdb [list name $pname code $pcode] |
||||
} errM]} { |
||||
puts stderr "!!! problem with fossil db: $fosdb when examining workdir $wd" |
||||
puts stderr "!!! error: $errM" |
||||
} |
||||
} else { |
||||
puts stderr "!!! missing fossil db $fosdb" |
||||
} |
||||
} else { |
||||
set info [dict get $fosdb_cache $fosdb] |
||||
lassign $info _name pname _code pcode |
||||
} |
||||
lappend col_rowids $rowid |
||||
lappend col_fnames $nm |
||||
lappend col_dupids $dupid |
||||
lappend col_pnames $pname |
||||
lappend col_pcodes [string range $pcode 0 9] |
||||
incr rowid |
||||
} |
||||
|
||||
set col_states [list] |
||||
set state_title "" |
||||
#if only one set of fossil checkouts in the resultset - retrieve workingdir state for each co |
||||
if {[llength [dict keys $fosdb_cache]] == 1} { |
||||
puts stderr "Result is a single project - gathering file state for each checkout folder" |
||||
set c_rev [list] |
||||
set c_unchanged [list] |
||||
set c_changed [list] |
||||
set c_new [list] |
||||
set c_missing [list] |
||||
set c_extra [list] |
||||
foreach wd $workdirs { |
||||
set wd_state [punk::repo::workingdir_state $wd] |
||||
set state_dict [punk::repo::workingdir_state_summary_dict $wd_state] |
||||
lappend c_rev [string range [dict get $state_dict revision] 0 9] |
||||
lappend c_unchanged [dict get $state_dict unchanged] |
||||
lappend c_changed [dict get $state_dict changed] |
||||
lappend c_new [dict get $state_dict new] |
||||
lappend c_missing [dict get $state_dict missing] |
||||
lappend c_extra [dict get $state_dict extra] |
||||
puts -nonewline stderr "." |
||||
} |
||||
puts -nonewline stderr \n |
||||
set t0 "Revision" |
||||
set w0 [tcl::mathfunc::max {*}[lmap v [concat [list $t0] $c_rev] {string length $v}]] |
||||
set c0 [string repeat " " $w0] |
||||
set t1 "Unch" |
||||
set w1 [tcl::mathfunc::max {*}[lmap v [concat [list $t1] $c_unchanged] {string length $v}]] |
||||
set c1 [string repeat " " $w1] |
||||
set t2 "Chgd" |
||||
set w2 [tcl::mathfunc::max {*}[lmap v [concat [list $t2] $c_changed] {string length $v}]] |
||||
set c2 [string repeat " " $w2] |
||||
set t3 "New" |
||||
set w3 [tcl::mathfunc::max {*}[lmap v [concat [list $t3] $c_new] {string length $v}]] |
||||
set c3 [string repeat " " $w3] |
||||
set t4 "Miss" |
||||
set w4 [tcl::mathfunc::max {*}[lmap v [concat [list $t4] $c_missing] {string length $v}]] |
||||
set c4 [string repeat " " $w4] |
||||
set t5 "Extr" |
||||
set w5 [tcl::mathfunc::max {*}[lmap v [concat [list $t5] $c_extra] {string length $v}]] |
||||
set c5 [string repeat " " $w5] |
||||
|
||||
set state_title "[overtype::left $c0 $t0] [overtype::right $c1 $t1] [overtype::right $c2 $t2] [overtype::right $c3 $t3] [overtype::right $c4 $t4] [overtype::right $c5 $t5]" |
||||
foreach r $c_rev u $c_unchanged c $c_changed n $c_new m $c_missing e $c_extra { |
||||
lappend col_states "[overtype::left $c0 $r] [overtype::right $c1 $u] [overtype::right $c2 $c] [overtype::right $c3 $n] [overtype::right $c4 $m] [overtype::right $c5 $e]" |
||||
} |
||||
} |
||||
|
||||
set msg "" |
||||
if {$opt_cd} { |
||||
set title0 "CD" |
||||
} else { |
||||
set title0 "" |
||||
} |
||||
set widest0 [tcl::mathfunc::max {*}[lmap v [concat [list $title0] $col_rowids] {punk::strlen $v}]] |
||||
set col0 [string repeat " " $widest0] |
||||
set title1 "Checkout dir" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $workdirs] {punk::strlen $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
set title2 "Db name" |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col_fnames] {string length $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
set title3 "CO dup" |
||||
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col_dupids] {string length $v}]] |
||||
set col3 [string repeat " " $widest3] |
||||
set title4 "Project Name" |
||||
set widest4 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col_pnames] {string length $v}]] |
||||
set col4 [string repeat " " $widest4] |
||||
set title5 "Project Code" |
||||
set widest5 [tcl::mathfunc::max {*}[lmap v [concat [list $title5] $col_pcodes] {string length $v}]] |
||||
set col5 [string repeat " " $widest5] |
||||
|
||||
set tablewidth [expr {$widest0 + 1 + $widest1 + 1 + $widest2 + 1 + $widest3 +1 + $widest4 + 1 + $widest5}] |
||||
append msg "[overtype::right $col0 $title0] [overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3] [overtype::left $col4 $title4] [overtype::left $col5 $title5]" |
||||
|
||||
if {[llength $col_states]} { |
||||
set title6 $state_title |
||||
set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col_states] {string length $v}]] |
||||
set col6 [string repeat " " $widest6] |
||||
incr tablewidth [expr {$widest6 + 1}] |
||||
append msg " [overtype::left $col6 $title6]" \n |
||||
} else { |
||||
append msg \n |
||||
} |
||||
append msg [string repeat "=" $tablewidth] \n |
||||
|
||||
if {[llength $col_states]} { |
||||
foreach row $col_rowids wd $workdirs db $col_fnames dup $col_dupids pname $col_pnames pcode $col_pcodes s $col_states { |
||||
append msg "[overtype::right $col0 $row] [overtype::left $col1 $wd] [overtype::left $col2 $db] [overtype::right $col3 $dup] [overtype::left $col4 $pname] [overtype::left $col5 $pcode] [overtype::left $col6 $s]" \n |
||||
} |
||||
} else { |
||||
foreach row $col_rowids wd $workdirs db $col_fnames dup $col_dupids pname $col_pnames pcode $col_pcodes { |
||||
append msg "[overtype::right $col0 $row] [overtype::left $col1 $wd] [overtype::left $col2 $db] [overtype::right $col3 $dup] [overtype::left $col4 $pname] [overtype::left $col5 $pcode]" \n |
||||
} |
||||
} |
||||
set numrows [llength $col_rowids] |
||||
if {$opt_cd && $numrows >= 1} { |
||||
puts stdout $msg |
||||
if {$numrows == 1} { |
||||
set workingdir [lindex $workdirs 0] |
||||
puts stdout "1 result. Changing dir to $workingdir" |
||||
if {[file exists $workingdir]} { |
||||
cd $workingdir |
||||
return $workingdir |
||||
} else { |
||||
puts stderr "path $workingdir doesn't appear to exist" |
||||
return [pwd] |
||||
} |
||||
} else { |
||||
set answer [util::askuser "Change directory to working folder - select a number from 1 to [llength $col_rowids] or any other key to cancel."] |
||||
if {[string trim $answer] in $col_rowids} { |
||||
set index [expr {$answer - 1}] |
||||
set workingdir [lindex $workdirs $index] |
||||
cd $workingdir |
||||
puts stdout [pmix stat] |
||||
return $workingdir |
||||
} |
||||
} |
||||
} |
||||
return $msg |
||||
} |
||||
} |
||||
|
||||
namespace eval lib { |
||||
#get project info only by opening the central confg-db |
||||
#(will not have proper project-name etc) |
||||
proc get_projects {{globlist {}} args} { |
||||
if {![llength $globlist]} { |
||||
set globlist [list *] |
||||
} |
||||
set fossil_prog [auto_execok fossil] |
||||
|
||||
set fossilinfo [exec {*}$fossil_prog info] ;#will give us the necessary config-db info whether in a project folder or not |
||||
set matching_lines [punk::repo::grep {config-db:*} $fossilinfo] |
||||
if {[llength $matching_lines] != 1} { |
||||
puts stderr "Unable to find config-db info from fossil. Check your fossil installation." |
||||
puts stderr "Fossil output was:" |
||||
puts stderr "-------------" |
||||
puts stderr "$fossilinfo" |
||||
puts stderr "-------------" |
||||
puts stderr "config-db info:" |
||||
puts stderr "$matching_lines" |
||||
return |
||||
} |
||||
set ln [lindex $matching_lines 0] |
||||
set configdb [string trim [string range $ln [string length "config-db: "] end]] |
||||
if {![file exists $configdb]} { |
||||
error "config-db not found at path $configdb" |
||||
} |
||||
package require sqlite3 |
||||
::sqlite3 fosconf $configdb |
||||
#set testresult [fosconf eval {select name,value from global_config;}] |
||||
#puts stderr $testresult |
||||
set project_repos [fosconf eval {select name from global_config where name like 'repo:%';}] |
||||
set paths_and_names [list] |
||||
foreach pr $project_repos { |
||||
set path [string trim [string range $pr 5 end]] |
||||
set nm [file rootname [file tail $path]] |
||||
set ckouts [fosconf eval {select name from global_config where value = $path;}] |
||||
set checkout_paths [list] |
||||
#strip "ckout:" |
||||
foreach ck $ckouts { |
||||
lappend checkout_paths [string trim [string range $ck 6 end]] |
||||
} |
||||
lappend paths_and_names [list $path $nm $checkout_paths] |
||||
} |
||||
set filtered_list [list] |
||||
foreach glob $globlist { |
||||
set matches [lsearch -all -inline -index 1 $paths_and_names $glob] |
||||
foreach m $matches { |
||||
if {$m ni $filtered_list} { |
||||
lappend filtered_list $m |
||||
} |
||||
} |
||||
} |
||||
set projects [lsort -index 1 $filtered_list] |
||||
return $projects |
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::project [namespace eval punk::mix::commandset::project { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,92 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::repo 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::repo { |
||||
namespace export * |
||||
proc tickets {{project ""}} { |
||||
set result "" |
||||
if {[string length $project]} { |
||||
puts stderr "project status unimplemented" |
||||
return |
||||
} |
||||
set active_dir [pwd] |
||||
append result "Retrieving top 10 tickets only (for more, use fossil timeline -n <int> -t t)" \n |
||||
append result [exec fossil timeline -n 10 -t t] |
||||
|
||||
return $result |
||||
} |
||||
|
||||
proc fossilize { args} { |
||||
#check if project already managed by fossil.. initialise and check in if not. |
||||
puts stderr "unimplemented" |
||||
} |
||||
|
||||
proc unfossilize {projectname args} { |
||||
#remove/archive .fossil |
||||
puts stderr "unimplemented" |
||||
} |
||||
proc state {} { |
||||
set result "" |
||||
set repopaths [punk::repo::find_repos [pwd]] |
||||
set repos [dict get $repopaths repos] |
||||
if {![llength $repos]} { |
||||
append result [dict get $repopaths warnings] |
||||
} else { |
||||
append result [dict get $repopaths warnings] |
||||
lassign [lindex $repos 0] repopath repotypes |
||||
if {"fossil" in $repotypes} { |
||||
append result \n "Fossil repo based at $repopath" |
||||
set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes fossil] |
||||
append result \n [punk::repo::workingdir_state_summary $repostate] |
||||
} |
||||
if {"git" in $repotypes} { |
||||
append result \n "Git repo based at $repopath" |
||||
set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes git] |
||||
append result \n [punk::repo::workingdir_state_summary $repostate] |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::repo [namespace eval punk::mix::commandset::repo { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,634 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::scriptwrap 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
package require punk::mix |
||||
package require punk::mix::base |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::scriptwrap { |
||||
namespace export * |
||||
|
||||
|
||||
#scriptpath allows templates command to use same custom template set as when multishell pointed to a filepath |
||||
#it may or may not be within a project |
||||
#by using the same folder or path, the same project root will be discovered. REVIEW. |
||||
proc templates_dict {args} { |
||||
set defaults [list -scriptpath ""] |
||||
set opts [dict merge $defaults $args] |
||||
set opt_scriptpath [dict get $opts -scriptpath] |
||||
|
||||
set wrapper_folders [lib::get_wrapper_folders $opt_scriptpath] |
||||
|
||||
set wrapper_templates [list] |
||||
foreach fld $wrapper_folders { |
||||
set templates [glob -nocomplain -dir $fld -type f *] |
||||
foreach tf $templates { |
||||
if {[string match ignore* $tf]} { |
||||
continue |
||||
} |
||||
set ext [file extension $tf] |
||||
if {$ext in [list "" ".bat" ".cmd" ".sh"]} { |
||||
lappend wrapper_templates $tf |
||||
} |
||||
} |
||||
} |
||||
|
||||
set tdict [dict create] |
||||
set seen_dict [dict create] |
||||
foreach fullpath $wrapper_templates { |
||||
set ftail [file tail $fullpath] |
||||
if {![dict exists $seen_dict $ftail]} { |
||||
dict set seen_dict $ftail 1 |
||||
dict set tdict $ftail $fullpath ; #first seen of filename gets no number |
||||
} else { |
||||
set n [dict get $seen_dict $ftail] |
||||
incr n |
||||
dict incr seen_dict $ftail |
||||
dict set tdict ${ftail}.$n $fullpath |
||||
} |
||||
} |
||||
return $tdict |
||||
} |
||||
proc templates {args} { |
||||
package require overtype |
||||
set tdict [templates_dict {*}$args] |
||||
|
||||
|
||||
set paths [dict values $tdict] |
||||
set names [dict keys $tdict] |
||||
|
||||
set title1 "Path" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $paths] {punk::strlen $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
|
||||
set title2 "Template Name" |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $names] {punk::strlen $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
|
||||
set tablewidth [expr {$widest1 + 1 + $widest2}] |
||||
set table "" |
||||
append table [string repeat - $tablewidth] \n |
||||
append table "[overtype::left $col1 $title1] [overtype::left $col2 $title2]" \n |
||||
append table [string repeat - $tablewidth] \n |
||||
|
||||
foreach p $paths n $names { |
||||
append table "[overtype::left $col1 $p] [overtype::left $col2 $n]" \n |
||||
} |
||||
|
||||
|
||||
return $table |
||||
} |
||||
#specific filepath to just wrap one script at the tcl-payload or xxx-payload-pre-tcl site |
||||
#scriptset name to substiture multiple scriptset.xxx files at the default locations - or as specified in scriptset.wrapconf |
||||
proc multishell {filepath_or_scriptset args} { |
||||
set defaults [list -askme 1 -template \uFFFF] |
||||
set opts [dict merge $defaults $args] |
||||
set opt_askme [dict get $opts -askme] |
||||
set opt_template [dict get $opts -template] |
||||
set ext [file extension $filepath_or_scriptset] |
||||
set startdir [pwd] |
||||
|
||||
set usage "" |
||||
append usage "Use directly with the script file to wrap, or supply the name of a scriptset" \n |
||||
append usage "The scriptset name will be used to search for yourname.sh|tcl|ps1 or names as you specify in yourname.wrapconfig if it exists" \n |
||||
append usage "If no template is specified in a .wrapconfig and no -template argument is supplied, it will default to punk-multishell.cmd" \n |
||||
if {![string length $filepath_or_scriptset]} { |
||||
puts stderr "No filepath_or_scriptset specified" |
||||
puts stderr $usage |
||||
return false |
||||
} |
||||
|
||||
|
||||
#first check if relative or absolute path matches a file |
||||
if {[file pathtype $filepath_or_scriptset] eq "absolute"} { |
||||
set specified_path $filepath_or_scriptset |
||||
} else { |
||||
set specified_path [file join $startdir $filepath_or_scriptset] |
||||
} |
||||
|
||||
set ext [string trim [file extension $filepath_or_scriptset] .] |
||||
set allowed_extensions [list wrapconfig tcl ps1 sh bash] |
||||
#set allowed_extensions [list tcl] |
||||
set found_script 0 |
||||
if {[file exists $specified_path]} { |
||||
set found_script 1 |
||||
} else { |
||||
foreach e $allowed_extensions { |
||||
if {[file exists $filepath_or_scriptset.$e]} { |
||||
set found_script 1 |
||||
break |
||||
} |
||||
} |
||||
} |
||||
|
||||
#TODO! - use get_wrapper_folders - multishell should use same available templates as the 'templates' function |
||||
set scriptset [file rootname [file tail $specified_path]] |
||||
if {$found_script} { |
||||
if {[file type $specified_path] eq "file"} { |
||||
set specified_root [file dirname $specified_path] |
||||
set pathinfo [punk::repo::find_repos [file dirname $specified_path]] |
||||
set projectroot [dict get $pathinfo closest] |
||||
if {[string length $projectroot]} { |
||||
#use the specified files folder - but use the main scriptapps/wrappers folder if specified one has no wrappers subfolder |
||||
set scriptroot [file dirname $specified_path] |
||||
if {[file exists $scriptroot/wrappers]} { |
||||
set customwrapper_folder $scriptroot/wrappers |
||||
} else { |
||||
set customwrapper_folder $projectroot/src/scriptapps/wrappers |
||||
} |
||||
} else { |
||||
#outside of any project |
||||
set scriptroot [file dirname $specified_path] |
||||
if {[file exists $scriptroot/wrappers]} { |
||||
set customwrapper_folder $scriptroot/wrappers |
||||
} else { |
||||
#no customwrapper folder available |
||||
set customwrapper_folder "" |
||||
} |
||||
} |
||||
} else { |
||||
puts stderr "wrap_in_multishell doesn't currently support a directory as the path." |
||||
puts stderr $usage |
||||
return false |
||||
} |
||||
} else { |
||||
set pathinfo [punk::repo::find_repos $startdir] |
||||
set projectroot [dict get $pathinfo closest] |
||||
if {[string length $projectroot]} { |
||||
if {[llength [file split $filepath_or_scriptset]] > 1} { |
||||
puts stderr "filepath_or_scriptset looks like a path - but doesn't seem to point to a file" |
||||
puts stderr "Ensure you are within a project and use just the name of the scriptset, or pass in the full correct path or relative path to current directory" |
||||
puts stderr $usage |
||||
return false |
||||
} else { |
||||
#we've already ruled out empty string - so must have a single element representing scriptset - possibly with file extension |
||||
set scriptroot $projectroot/src/scriptapps |
||||
set customwrapper_folder $projectroot/src/scriptapps/wrappers |
||||
#check something matches the scriptset.. |
||||
set something_found "" |
||||
if {[file exists $scriptroot/$scriptset]} { |
||||
set found_script 1 |
||||
set something_found $scriptroot/$scriptset ;#extensionless file - that's ok too |
||||
} else { |
||||
foreach e $allowed_extensions { |
||||
if {[file exists $scriptroot/$scriptset.$e]} { |
||||
set found_script 1 |
||||
set something_found $scriptroot/$scriptset.$e |
||||
break |
||||
} |
||||
} |
||||
} |
||||
if {!$found_script} { |
||||
puts stderr "Searched within $scriptroot" |
||||
puts stderr "Unable to find a file matching $scriptset or one of the extensions: $allowed_extensions" |
||||
puts stderr $usage |
||||
return false |
||||
} else { |
||||
if {[file pathtype $something_found] ne "file"} { |
||||
puts stderr "wrap_in_multishell doesn't currently support a directory as the path." |
||||
puts stderr $usage |
||||
return false |
||||
} |
||||
} |
||||
} |
||||
|
||||
} else { |
||||
puts stderr "filepath_or_scriptset parameter doesn't seem to refer to a file, and you are not within a directory where projectroot and src/scriptapps/wrappers can be determined" |
||||
puts stderr $usage |
||||
return false |
||||
} |
||||
} |
||||
#assert - customwrapper_folder var exists - but might be empty |
||||
|
||||
|
||||
if {[string length $ext]} { |
||||
#If there was an explicitly supplied extension - then that file should exist |
||||
if {![file exists $scriptroot/$scriptset.$ext]} { |
||||
puts stderr "Explicit extension .$ext was supplied - but matching file not found." |
||||
puts stderr $usage |
||||
return false |
||||
} else { |
||||
if {$ext eq "wrapconfig"} { |
||||
set process_extensions ALLFOUNDORCONFIGURED |
||||
} else { |
||||
set process_extensions $ext |
||||
} |
||||
} |
||||
} else { |
||||
#no explicit extension - process all for scriptset |
||||
set process_extensions ALLFOUNDORCONFIGURED |
||||
} |
||||
#process_extensions - either a single one - or all found or as per .wrapconfig |
||||
|
||||
if {$opt_template eq "\uFFFF"} { |
||||
set templatename punk-multishell.cmd |
||||
} else { |
||||
set templatename $opt_template |
||||
} |
||||
|
||||
|
||||
|
||||
set template_base_dict [punk::mix::base::lib::get_template_basefolders] |
||||
set tpldirs [list] |
||||
dict for {tdir tsourceinfo} $template_base_dict { |
||||
if {[file exists $tdir/utility/scriptappwrappers/$templatename]} { |
||||
lappend tpldirs $tdir |
||||
} |
||||
} |
||||
|
||||
if {[string length $customwrapper_folder] && [file exists [file join $customwrapper_folder $templatename] ]} { |
||||
set wrapper_template [file join $customwrapper_folder $templatename] |
||||
} else { |
||||
if {![llength $tpldirs]} { |
||||
set msg "No template named '$templatename' found in src/scriptapps/wrappers or in template dirs from packages" |
||||
append msg \n "Searched [dict size $template_base_dict] template dirs" |
||||
error $msg |
||||
} |
||||
|
||||
#last pkg with templates cap which was loaded has highest precedence |
||||
set wrapper_template "" |
||||
foreach tdir [lreverse $tpldirs] { |
||||
set ftest [file join $tdir utility scriptappwrappers $templatename] |
||||
if {[file exists $ftest]} { |
||||
set wrapper_template $ftest |
||||
break |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {$wrapper_template eq "" || ![file exists $wrapper_template]} { |
||||
error "wrap_in_multishell: unable to find multishell template $templatename in template folders [concat $tpldirs $customwrapper_folder]" |
||||
} |
||||
|
||||
|
||||
#todo |
||||
#output_file extension depends on the template being used.. |
||||
|
||||
|
||||
set output_file $scriptset.cmd |
||||
if {[file exists $output_file]} { |
||||
error "wrap_in_multishell: target file $output_file already exists.. aborting" |
||||
} |
||||
|
||||
|
||||
set fdt [open $wrapper_template r] |
||||
fconfigure $fdt -translation binary |
||||
set template_data [read $fdt] |
||||
close $fdt |
||||
puts stdout "Read [string length $template_data] bytes of template data.." |
||||
set template_lines [split $template_data \n] |
||||
puts stdout "Displaying first 3 lines of template between dashed lines..." |
||||
puts stdout "-----------------------------------------------" |
||||
foreach ln [lrange $template_lines 0 3] { |
||||
puts stdout $ln |
||||
} |
||||
puts stdout "-----------------------------------------------\n" |
||||
#foreach ln $template_lines { |
||||
#} |
||||
|
||||
set list_input_files [list] |
||||
if {$process_extensions eq "ALLFOUNDORCONFIGURED"} { |
||||
#todo - look for .wrapconfig or all extensions for the scriptset |
||||
puts stderr "Sorry - only single input file supported - implementation incomplete" |
||||
return false |
||||
} else { |
||||
lappend list_input_files $scriptroot/$scriptset.$ext |
||||
} |
||||
|
||||
#todo - split template at each <ext-payload> etc marker and build a dict of parts |
||||
|
||||
|
||||
#hack - process one input |
||||
set filepath [lindex $list_input_files 0] |
||||
|
||||
set fdscript [open $filepath r] |
||||
fconfigure $fdscript -translation binary |
||||
set script_data [read $fdscript] |
||||
close $fdscript |
||||
puts stdout "Read [string length $script_data] bytes of template data.." |
||||
set script_lines [split $script_data \n] |
||||
puts stdout "Displaying first 3 lines of your script between dashed lines..." |
||||
puts stdout "-----------------------------------------------" |
||||
foreach ln [lrange $script_lines 0 3] { |
||||
puts stdout $ln |
||||
} |
||||
puts stdout "-----------------------------------------------\n" |
||||
if {$opt_askme} { |
||||
puts stdout "Target for above data is '$output_file'" |
||||
set answer [util::askuser "Does this look correct? Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y or y to proceed) use -askme 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
|
||||
set start_idx 0 |
||||
set end_idx 0 |
||||
set line_idx 0 |
||||
set existing_payload [list] |
||||
foreach ln $template_lines { |
||||
|
||||
if {[string match "#<tcl-payload>*" $ln]} { |
||||
set start_idx $line_idx |
||||
} elseif {[string match "#</tcl-payload>*" $ln]} { |
||||
set end_idx $line_idx |
||||
break |
||||
} elseif {$start_idx > 0} { |
||||
if {$end_idx > 0} { |
||||
lappend existing_payload [string trim $ln] |
||||
} |
||||
} else { |
||||
|
||||
} |
||||
incr line_idx |
||||
} |
||||
if {($start_idx == 0) || ($end_idx == 0)} { |
||||
error "wrap_in_multishell was unable to find payload area in template marked with #<tcl-payload> and #</tcl-payload> on separate lines" |
||||
} |
||||
set existing_string [join $existing_payload \n] |
||||
if {[string length [string trim $existing_string]]} { |
||||
puts stdout "EXISTING PAYLOAD!!" |
||||
puts stdout "-----------------------------------------------\n" |
||||
puts stdout $existing_string |
||||
puts stdout "-----------------------------------------------\n" |
||||
error "wrap_in_multishell found existing payload.. aborting." |
||||
#todo - allow overwrite only in files outside of punkshell distribution? |
||||
if 0 { |
||||
puts stderr "Found existing payload.. overwrite?" |
||||
if {$opt_askme} { |
||||
set answer [util::askuser "Are you sure you want to replace the tcl payload shown above? Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
set tpl_head_lines [lrange $template_lines 0 $start_idx] ;#include tag line |
||||
set tpl_tail_lines [lrange $template_lines $end_idx end] |
||||
set newscript [join $tpl_head_lines \n]\n[join $script_lines \n]\n[join $tpl_tail_lines \n] |
||||
puts stdout "New script is [string length $newscript] bytes" |
||||
puts stdout $newscript |
||||
set fdtarget [open $output_file w] |
||||
fconfigure $fdtarget -translation binary |
||||
puts -nonewline $fdtarget $newscript |
||||
close $fdtarget |
||||
puts stdout "Wrote script file at $output_file" |
||||
puts stdout "-done-" |
||||
return $output_file |
||||
} |
||||
|
||||
namespace eval lib { |
||||
|
||||
#get_wrapper_folders |
||||
# scriptpath - file or folder |
||||
# It represents the base point from which to search for /wrapper folders either directly above the scriptpath or in the containing project if any |
||||
# The cwd will also be searched for /wrapper folder and project - but with lower precedence in the resultset (later in list) |
||||
proc get_wrapper_folders {{scriptpath ""}} { |
||||
set wrapper_folders [list] |
||||
if {$scriptpath ne ""} { |
||||
if {[file type $scriptpath] eq "file"} { |
||||
set searchbase [file dirname $scriptpath] |
||||
} else { |
||||
set searchbase $scriptpath |
||||
} |
||||
if {[file isdirectory [file join $searchbase wrappers]]} { |
||||
lappend wrapper_folders [file join $searchbase wrappers] |
||||
} |
||||
set pathinfo [punk::repo::find_repos $searchbase] |
||||
set scriptpath_projectroot [dict get $pathinfo closest] |
||||
if {$scriptpath_projectroot ne ""} { |
||||
set fld [file join $scriptpath_projectroot src/scriptapps/wrappers] |
||||
if {[file isdirectory $fld]} { |
||||
if {$fld ni $wrapper_folders} { |
||||
lappend wrapper_folders $fld |
||||
} |
||||
} |
||||
} |
||||
} |
||||
set searchbase [pwd] |
||||
set fld [file join $searchbase wrappers] |
||||
if {[file isdirectory $fld]} { |
||||
if {$fld ni $wrapper_folders} { |
||||
lappend wrapper_folders $fld |
||||
} |
||||
} |
||||
set pathinfo [punk::repo::find_repos $searchbase] |
||||
set pwd_projectroot [dict get $pathinfo closest] |
||||
if {$pwd_projectroot ne ""} { |
||||
set fld [file join $pwd_projectroot src/scriptapps/wrappers] |
||||
if {[file isdirectory $fld]} { |
||||
if {$fld ni $wrapper_folders} { |
||||
lappend wrapper_folders $fld |
||||
} |
||||
} |
||||
} |
||||
|
||||
set template_base_dict [punk::mix::base::lib::get_template_basefolders] |
||||
set tpldirs [list] |
||||
dict for {tdir tsourceinfo} $template_base_dict { |
||||
if {[file exists $tdir/utility/scriptappwrappers]} { |
||||
lappend tpldirs $tdir |
||||
} |
||||
} |
||||
foreach tpldir $tpldirs { |
||||
set fld [file join $tpldir utility scriptappwrappers] |
||||
if {[file isdirectory $fld]} { |
||||
if {$fld ni $wrapper_folders} { |
||||
lappend wrapper_folders $fld |
||||
} |
||||
} |
||||
} |
||||
return $wrapper_folders |
||||
} |
||||
proc _scriptapp_tag_from_line {line} { |
||||
set result [list istag 0 raw ""] ;#default assumption. All |
||||
#---- |
||||
set startc [string first "#" $line] ;#tags must be commented |
||||
#todo - review. next line is valid - note # doesn't have to be the only one before <tagname> |
||||
# @REM # etc < blah # <tagname> etc |
||||
#--- |
||||
#fix - we should use a regexp on at least <tagname> </tagname> <tagname/> and only catch tagname without whitespace |
||||
regexp {(\s*).*} $line _ln indent ;#will match on empty line, whitespace only line - or anything really. |
||||
set indent [string map [list \t " "] $indent] ;#opinionated I guess - but need to normalize to something. The spec is that spaces should be used anyway. |
||||
dict set result indent [string length $indent] |
||||
set starttag [string first "<" $line] |
||||
set pretag [string range $line $startc $starttag-1] |
||||
if {[string match "*>*" $pretag]} { |
||||
return [list istag 0 raw $line reason pretag_contents] |
||||
} |
||||
set closetag [string first ">" $line] |
||||
set inelement [string range $line $starttag+1 $closetag-1] |
||||
if {[string match "*<*" $inelement]} { |
||||
return [list istag 0 raw $line reason tag_malformed_angles] |
||||
} |
||||
set elementchars [split $inelement ""] |
||||
set numslashes [llength [lsearch -all $elementchars "/"]] |
||||
if {$numslashes == 0} { |
||||
dict set result type "open" |
||||
} elseif {$numslashes == 1} { |
||||
if {[lindex $elementchars 0] eq "/"} { |
||||
dict set result type "close" |
||||
} elseif {[lindex $elementchars end] eq "/"} { |
||||
dict set result type "openclose" |
||||
} else { |
||||
return [list istag 0 raw $line reason tag_malformed_slashes] |
||||
} |
||||
} else { |
||||
return [list istag 0 raw $line reason tag_malformed_extraslashes] |
||||
} |
||||
if {[dict get $result type] eq "open"} { |
||||
dict set result name $inelement |
||||
} elseif {[dict get $result type] eq "close"} { |
||||
dict set result name [string range $inelement 1 end] |
||||
} else { |
||||
dict set result name [string range $inelement 0 end-1] |
||||
} |
||||
dict set result istag 1 |
||||
dict set result raw $line |
||||
return $result |
||||
} |
||||
|
||||
#get all \n#<something>\n ...\n#</something> data - where number of intervening newlines is at least one (and whitespace and/or other data can precede #) |
||||
#we don't verify 'something' against known tags - as custom templates can have own tags |
||||
#An openclose tag #<xxx/> is used to substitute a specific line in its entirety - but the tag *must* remain in the line |
||||
# |
||||
#e.g for the line: |
||||
# @set "nextshell=pwsh" & :: #<batch-nextshell-line/> |
||||
#The .wrapconfig might contain |
||||
# tag <batch-nextshell-line> line {@set "nextshell=tclsh" & :: @<batch-nextshell-line/>} |
||||
# |
||||
proc scriptapp_wrapper_get_tags {wrapperdata} { |
||||
set wrapperdata [string map [list \r\n \n] $wrapperdata] |
||||
set lines [split $wrapperdata \n] |
||||
#set tags_in_data [dict create];#active tags - list of lines accumulating. supports nested tags |
||||
set status 0 |
||||
set tags [dict create] |
||||
set errors [list] |
||||
set errortags [dict create] ;#mark names invalid on first error so that more than 2 tags can't obscure config problem |
||||
set linenum 1 ;#editors and other utils use 1-based indexing when referencing files - we should too to avoid confusion, despite it being less natural for lindex operations on the result. |
||||
foreach ln $lines { |
||||
set lntrim [string trim $ln] |
||||
if {![string length $lntrim]} { |
||||
incr linenum |
||||
continue |
||||
} |
||||
if {[string match "*#*<*>*" $lntrim]} { |
||||
set taginfo [_scriptapp_tag_from_line $ln] ;#use untrimmed line - to get indent |
||||
if {[dict get $taginfo istag]} { |
||||
set nm [dict get $taginfo name] |
||||
if {[dict exists $errortags $nm]} { |
||||
#tag is already in error condition - |
||||
} else { |
||||
set tp [dict get $taginfo type] ;# type singular - related to just one line |
||||
#set raw [dict get $taginfo raw] #equivalent to $ln |
||||
if {[dict exists $tags $nm]} { |
||||
#already seen tag name |
||||
#tags dict has types key *plural* - need to track whether we have type open and type close (or openclose for self-closing tags) |
||||
if {[dict get $tags $nm types] ne "open"} { |
||||
lappend errors "line: $linenum tag $nm encountered type $tp after existing type [dict get $tags $nm types]" |
||||
dict incr errortags $nm |
||||
} else { |
||||
#we already have open - expect only close |
||||
if {$tp ne "close"} { |
||||
lappend errors "line: $linenum tag $nm encountered type $tp after existing type [dict get $tags $nm types]" |
||||
dict incr errortags $nm |
||||
} else { |
||||
#close after open |
||||
dict set tags $nm types [list open close] |
||||
dict set tags $nm end $linenum |
||||
set taglines [dict get $tags $nm taglines] |
||||
if {[llength $taglines] != 1} { |
||||
error "Unexpected result when closing tag $nm. Existing taglines length not 1." |
||||
} |
||||
dict set tags $nm taglines [concat $taglines $ln] |
||||
} |
||||
} |
||||
} else { |
||||
#first seen of tag name |
||||
if {$tp eq "close"} { |
||||
lappend errors "line: $linenum tag $nm encountered type $p close first" |
||||
dict incr errortags $nm |
||||
} else { |
||||
dict set tags $nm types $tp |
||||
dict set tags $nm indent [dict get $taginfo indent] |
||||
if {$tp eq "open"} { |
||||
dict set tags $nm start $linenum |
||||
dict set tags $nm taglines [list $ln] ;#first entry - another will be added on encountering matching closing tag |
||||
} elseif {$tp eq "openclose"} { |
||||
dict set tags $nm start $linenum |
||||
dict set tags $nm end $linenum |
||||
dict set tags $nm taglines [list $ln] ;#single entry is final result for self-closing tag |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} else { |
||||
#looks like it should be a tag.. but failed to even parse for some reason.. just add to errorlist |
||||
lappend errors "line: $linenum tag parse failure reason: [dict get $taginfo reason] raw line: [dict get $taginfo raw]" |
||||
} |
||||
} |
||||
#whether the line is tag or not append to any tags_in_data |
||||
#foreach t [dict keys $tags_in_data] { |
||||
# dict lappend tags_in_data $t $ln ;#accumulate raw lines - written to the tag entry in tags only on encountering a closing tag, then removed from tags_in_data |
||||
#} |
||||
incr linenum |
||||
} |
||||
#assert [expr {$linenum -1 == [llength $lines]}] |
||||
if {[llength $errors]} { |
||||
set status 0 |
||||
} else { |
||||
set status 1 |
||||
} |
||||
if {$linenum == 0} { |
||||
|
||||
} |
||||
return [dict create ok $status linecount [llength $lines] data $tags errors $errors] |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::scriptwrap [namespace eval punk::mix::commandset::scriptwrap { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,49 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::templates 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
package require punk::cap |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::templates { |
||||
punk::cap::register_package punk::mix::templates [list\ |
||||
{templates {relpath ../templates}}\ |
||||
] |
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::templates [namespace eval punk::mix::templates { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,427 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::util 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
namespace eval punk::mix::util { |
||||
variable has_winpath 0 |
||||
} |
||||
|
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
if {![catch {package require punk::winpath}]} { |
||||
set punk::mix::util::has_winpath 1 |
||||
} |
||||
} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::util { |
||||
variable tmpfile_counter 0 ;#additional tmpfile collision avoidance |
||||
|
||||
namespace export * |
||||
|
||||
|
||||
proc fcat {args} { |
||||
variable has_winpath |
||||
|
||||
if {$::tcl_platform(platform) ne "windows"} { |
||||
return [fileutil::cat {*}$args] |
||||
} |
||||
|
||||
set knownopts [list -eofchar -translation -encoding --] |
||||
set last_opt 0 |
||||
for {set i 0} {$i < [llength $args]} {incr i} { |
||||
set ival [lindex $args $i] |
||||
#puts stdout "i:$i a: $ival known: [expr {$ival in $knownopts}]" |
||||
if {$ival eq "--"} { |
||||
set last_opt $i |
||||
break |
||||
} else { |
||||
if {$ival in $knownopts} { |
||||
#puts ">known at $i : [lindex $args $i]" |
||||
if {($i % 2) != 0} { |
||||
error "unexpected option at index $i. known options: $knownopts must come in -opt val pairs." |
||||
} |
||||
incr i |
||||
set last_opt $i |
||||
} else { |
||||
set last_opt [expr {$i - 1}] |
||||
break |
||||
} |
||||
} |
||||
} |
||||
set first_non_opt [expr {$last_opt + 1}] |
||||
|
||||
#puts stderr "first_non_opt: $first_non_opt" |
||||
set opts [lrange $args -1 $first_non_opt-1] |
||||
set paths [lrange $args $first_non_opt end] |
||||
if {![llength $paths]} { |
||||
error "Unable to find file in the supplied arguments: $args. Ensure options are all -opt val pairs and that file name(s) follow" |
||||
} |
||||
#puts stderr "opts: $opts paths: $paths" |
||||
set finalpaths [list] |
||||
foreach p $paths { |
||||
if {$has_winpath && [punk::winpath::illegalname_test $p]} { |
||||
lappend finalpaths [punk::winpath::illegalname_fix $p] |
||||
} else { |
||||
lappend finalpaths $p |
||||
} |
||||
} |
||||
fileutil::cat {*}$opts {*}$finalpaths |
||||
} |
||||
|
||||
#---------------------------------------- |
||||
namespace eval internal { |
||||
proc path_common_prefix_pop {varname} { |
||||
upvar 1 $varname var |
||||
set var [lassign $var head] |
||||
return $head |
||||
} |
||||
} |
||||
proc path_common_prefix {args} { |
||||
set dirs $args |
||||
set parts [file split [internal::path_common_prefix_pop dirs]] |
||||
while {[llength $dirs]} { |
||||
set r {} |
||||
foreach cmp $parts elt [file split [internal::path_common_prefix_pop dirs]] { |
||||
if {$cmp ne $elt} break |
||||
lappend r $cmp |
||||
} |
||||
set parts $r |
||||
} |
||||
if {[llength $parts]} { |
||||
return [file join {*}$parts] |
||||
} else { |
||||
return "" |
||||
} |
||||
} |
||||
|
||||
#retains case from first argument only - caseless comparison |
||||
proc path_common_prefix_nocase {args} { |
||||
set dirs $args |
||||
set parts [file split [internal::path_common_prefix_pop dirs]] |
||||
while {[llength $dirs]} { |
||||
set r {} |
||||
foreach cmp $parts elt [file split [internal::path_common_prefix_pop dirs]] { |
||||
if {![string equal -nocase $cmp $elt]} break |
||||
lappend r $cmp |
||||
} |
||||
set parts $r |
||||
} |
||||
if {[llength $parts]} { |
||||
return [file join {*}$parts] |
||||
} else { |
||||
return "" |
||||
} |
||||
} |
||||
#---------------------------------------- |
||||
|
||||
#maint warning - also in punkcheck |
||||
proc path_relative {base dst} { |
||||
#see also kettle |
||||
# Modified copy of ::fileutil::relative (tcllib) |
||||
# Adapted to 8.5 ({*}). |
||||
# |
||||
# Taking two _directory_ paths, a base and a destination, computes the path |
||||
# of the destination relative to the base. |
||||
# |
||||
# Arguments: |
||||
# base The path to make the destination relative to. |
||||
# dst The destination path |
||||
# |
||||
# Results: |
||||
# The path of the destination, relative to the base. |
||||
|
||||
# Ensure that the link to directory 'dst' is properly done relative to |
||||
# the directory 'base'. |
||||
|
||||
#review - check volume info on windows.. UNC paths? |
||||
if {[file pathtype $base] ne [file pathtype $dst]} { |
||||
return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)" |
||||
} |
||||
|
||||
#avoid normalizing if possible (file normalize *very* expensive on windows) |
||||
set do_normalize 0 |
||||
if {[file pathtype $base] eq "relative"} { |
||||
#if base is relative so is dst |
||||
if {[regexp {[.]{2}} [list $base $dst]]} { |
||||
set do_normalize 1 |
||||
} |
||||
if {[regexp {[.]/} [list $base $dst]]} { |
||||
set do_normalize 1 |
||||
} |
||||
} else { |
||||
set do_normalize 1 |
||||
} |
||||
if {$do_normalize} { |
||||
set base [file normalize $base] |
||||
set dst [file normalize $dst] |
||||
} |
||||
|
||||
set save $dst |
||||
set base [file split $base] |
||||
set dst [file split $dst] |
||||
|
||||
while {[lindex $dst 0] eq [lindex $base 0]} { |
||||
set dst [lrange $dst 1 end] |
||||
set base [lrange $base 1 end] |
||||
if {![llength $dst]} {break} |
||||
} |
||||
|
||||
set dstlen [llength $dst] |
||||
set baselen [llength $base] |
||||
|
||||
if {($dstlen == 0) && ($baselen == 0)} { |
||||
# Cases: |
||||
# (a) base == dst |
||||
|
||||
set dst . |
||||
} else { |
||||
# Cases: |
||||
# (b) base is: base/sub = sub |
||||
# dst is: base = {} |
||||
|
||||
# (c) base is: base = {} |
||||
# dst is: base/sub = sub |
||||
|
||||
while {$baselen > 0} { |
||||
set dst [linsert $dst 0 ..] |
||||
incr baselen -1 |
||||
} |
||||
set dst [file join {*}$dst] |
||||
} |
||||
|
||||
return $dst |
||||
} |
||||
#namespace import ::punk::ns::nsimport_noclobber |
||||
|
||||
proc namespace_import_pattern_to_namespace_noclobber {pattern ns} { |
||||
set source_ns [namespace qualifiers $pattern] |
||||
if {![namespace exists $source_ns]} { |
||||
error "namespace_import_pattern_to_namespace_noclobber error namespace $source_ns not found" |
||||
} |
||||
if {![string match ::* $ns]} { |
||||
set nscaller [uplevel 1 {namespace current}] |
||||
set ns [punk::nsjoin $nscaller $ns] |
||||
} |
||||
set a_export_patterns [namespace eval $source_ns {namespace export}] |
||||
set a_commands [info commands $pattern] |
||||
set a_tails [lmap v $a_commands {namespace tail $v}] |
||||
set a_exported_tails [list] |
||||
foreach pattern $a_export_patterns { |
||||
set matches [lsearch -all -inline $a_tails $pattern] |
||||
foreach m $matches { |
||||
if {$m ni $a_exported_tails} { |
||||
lappend a_exported_tails $m |
||||
} |
||||
} |
||||
} |
||||
set imported_commands [list] |
||||
foreach e $a_exported_tails { |
||||
set imported [namespace eval $ns [string map [list <func> $e <a> $source_ns] { |
||||
set cmd "" |
||||
if {![catch {namespace import <a>::<func>}]} { |
||||
set cmd <func> |
||||
} |
||||
set cmd |
||||
}]] |
||||
if {[string length $imported]} { |
||||
lappend imported_commands $imported |
||||
} |
||||
} |
||||
return $imported_commands |
||||
} |
||||
|
||||
proc askuser {question} { |
||||
puts stdout $question |
||||
flush stdout |
||||
set stdin_state [fconfigure stdin] |
||||
fconfigure stdin -blocking 1 |
||||
set answer [gets stdin] |
||||
fconfigure stdin -blocking [dict get $stdin_state -blocking] |
||||
return $answer |
||||
} |
||||
|
||||
proc do_in_path {path script} { |
||||
#from ::kettle::path::in |
||||
set here [pwd] |
||||
try { |
||||
cd $path |
||||
uplevel 1 $script |
||||
} finally { |
||||
cd $here |
||||
} |
||||
} |
||||
|
||||
proc foreach-file {path script_pathvariable script} { |
||||
upvar 1 $script_pathvariable thepath |
||||
|
||||
set known {} |
||||
lappend waiting $path |
||||
while {[llength $waiting]} { |
||||
set pending $waiting |
||||
set waiting {} |
||||
set at 0 |
||||
while {$at < [llength $pending]} { |
||||
set current [lindex $pending $at] |
||||
incr at |
||||
|
||||
# Do not follow into parent. |
||||
if {[string match *.. $current]} continue |
||||
|
||||
# Ignore what we have visited already. |
||||
set c [file dirname [file normalize $current/___]] |
||||
if {[dict exists $known $c]} continue |
||||
dict set known $c . |
||||
|
||||
if {[file tail $c] eq ".git"} { |
||||
continue |
||||
} |
||||
|
||||
# Expand directories. |
||||
if {[file isdirectory $c]} { |
||||
lappend waiting {*}[lsort -unique [glob -directory $c * .*]] |
||||
continue |
||||
} |
||||
|
||||
# Handle files as per the user's will. |
||||
set thepath $current |
||||
switch -exact -- [catch { uplevel 1 $script } result] { |
||||
0 - 4 { |
||||
# ok, continue - nothing |
||||
} |
||||
2 { |
||||
# return, abort, rethrow |
||||
return -code return |
||||
} |
||||
3 { |
||||
# break, abort |
||||
return |
||||
} |
||||
1 - default { |
||||
# error, any thing else - rethrow |
||||
return -code error $result |
||||
} |
||||
} |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc is_valid_tm_version {versionpart} { |
||||
#Needs to be suitable for use with Tcl's 'package vcompare' |
||||
if {![catch [list package vcompare $versionpart $versionpart]]} { |
||||
return 1 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
#Note that semver only has a small overlap with tcl tm versions. |
||||
#todo - work out what overlap and whether it's even useful |
||||
#see also TIP #439: Semantic Versioning (tcl 9??) |
||||
proc semver {versionstring} { |
||||
set re {^(0|[1-9]\d*)\.(0|[1-9]\d*)\.(0|[1-9]\d*)(?:-((?:0|[1-9]\d*|\d*[a-zA-Z-][0-9a-zA-Z-]*)(?:\.(?:0|[1-9]\d*|\d*[a-zA-Z-][0-9a-zA-Z-]*))*))?(?:\+([0-9a-zA-Z-]+(?:\.[0-9a-zA-Z-]+)*))?$} |
||||
} |
||||
#todo - semver conversion/validation for other systems? |
||||
proc magic_tm_version {} { |
||||
set magicbase 999999 ;#deliberately large so given load-preference when testing! |
||||
#we split the literal to avoid the literal appearing here - reduce risk of accidentally converting to a release version |
||||
return ${magicbase}.0a1.0 |
||||
} |
||||
|
||||
|
||||
|
||||
proc tmpfile {{prefix tmp_}} { |
||||
#note risk of collision if pregenerating a list of tmpfile names |
||||
#we will maintain an icrementing id so the caller doesn't have to bear that in mind |
||||
variable tmpfile_counter |
||||
global tcl_platform |
||||
return .punkutil_$prefix[pid]_[clock microseconds]_[incr tmpfile_counter]_[info hostname]_$tcl_platform(user) |
||||
} |
||||
|
||||
proc tmpdir {} { |
||||
# Taken from tcllib fileutil. |
||||
global tcl_platform env |
||||
|
||||
set attempdirs [list] |
||||
set problems {} |
||||
|
||||
foreach tmp {TEMP TMP TMPDIR} { |
||||
if { [info exists env($tmp)] } { |
||||
lappend attempdirs $env($tmp) |
||||
} else { |
||||
lappend problems "No environment variable $tmp" |
||||
} |
||||
} |
||||
|
||||
switch $tcl_platform(platform) { |
||||
windows { |
||||
lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP" |
||||
} |
||||
macintosh { |
||||
lappend attempdirs $env(TRASH_FOLDER) ;# a better place? |
||||
} |
||||
default { |
||||
lappend attempdirs \ |
||||
[file join / tmp] \ |
||||
[file join / var tmp] \ |
||||
[file join / usr tmp] |
||||
} |
||||
} |
||||
|
||||
lappend attempdirs [pwd] |
||||
|
||||
foreach tmp $attempdirs { |
||||
if { [file isdirectory $tmp] && |
||||
[file writable $tmp] } { |
||||
return [file normalize $tmp] |
||||
} elseif { ![file isdirectory $tmp] } { |
||||
lappend problems "Not a directory: $tmp" |
||||
} else { |
||||
lappend problems "Not writable: $tmp" |
||||
} |
||||
} |
||||
|
||||
# Fail if nothing worked. |
||||
return -code error "Unable to determine a proper directory for temporary files\n[join $problems \n]" |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::util [namespace eval punk::mix::util { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,158 @@
|
||||
|
||||
|
||||
package require punk::mix::util |
||||
|
||||
namespace eval ::punk::overlay { |
||||
#based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend |
||||
# extend an ensemble-like routine with the routines in some namespace |
||||
# |
||||
# e.g custom_from_base ::punk::mix::cli ::punk::mix::base |
||||
# |
||||
proc custom_from_base {routine base} { |
||||
if {![string match ::* $routine]} { |
||||
set resolved [uplevel 1 [list ::namespace which $routine]] |
||||
if {$resolved eq {}} { |
||||
error [list {no such routine} $routine] |
||||
} |
||||
set routine $resolved |
||||
} |
||||
set routinens [namespace qualifiers $routine] |
||||
if {$routinens eq {::}} { |
||||
set routinens {} |
||||
} |
||||
set routinetail [namespace tail $routine] |
||||
|
||||
if {![string match ::* $base]} { |
||||
set base [uplevel 1 [ |
||||
list [namespace which namespace] current]]::$base |
||||
} |
||||
|
||||
if {![namespace exists $base]} { |
||||
error [list {no such namespace} $base] |
||||
} |
||||
|
||||
set base [namespace eval $base [ |
||||
list [namespace which namespace] current]] |
||||
|
||||
|
||||
#while 1 { |
||||
# set renamed ${routinens}::${routinetail}_[info cmdcount] |
||||
# if {[namespace which $renamed] eq {}} break |
||||
#} |
||||
|
||||
namespace eval $routine [ |
||||
list namespace ensemble configure $routine -unknown [ |
||||
list apply {{base ensemble subcommand args} { |
||||
list ${base}::_redirected $ensemble $subcommand |
||||
}} $base |
||||
] |
||||
] |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${routine}::util |
||||
#namespace eval ${routine}::util { |
||||
#namespace import ::punk::mix::util::* |
||||
#} |
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ${base}::lib::* ${routine}::lib |
||||
#namespace eval ${routine}::lib [string map [list <base> $base] { |
||||
# namespace import <base>::lib::* |
||||
#}] |
||||
|
||||
namespace eval ${routine}::lib [string map [list <base> $base <routine> $routine] { |
||||
if {[namespace exists <base>::lib]} { |
||||
set current_paths [namespace path] |
||||
if {"<routine>" ni $current_paths} { |
||||
lappend current_paths <routine> |
||||
} |
||||
namespace path $current_paths |
||||
} |
||||
}] |
||||
|
||||
namespace eval $routine { |
||||
set exportlist [list] |
||||
foreach cmd [info commands [namespace current]::*] { |
||||
set c [namespace tail $cmd] |
||||
if {![string match _* $c]} { |
||||
lappend exportlist $c |
||||
} |
||||
} |
||||
namespace export {*}$exportlist |
||||
} |
||||
|
||||
return $routine |
||||
} |
||||
#load *exported* commands from cmdnamespace into caller's namespace - prefixing each command with $prefix |
||||
#Note: commandset may be imported by different CLIs with different bases *at the same time* |
||||
#so we don't make commands from the cli or its base available automatically (will generally require fully-qualified commands to use code from cli/base) |
||||
#we do load punk::mix::util::* into the util subnamespace even though the commandset might not be loaded in a cli using punk::mix::base i.e punk::mix::util is a common dependency for CLIs. |
||||
#commandsets designed to be used with a specific cli/base may choose to do their own import e.g with util::namespace_import_pattern_to_namespace_noclobber and/or set namespace path if they |
||||
#want the convenience of using lib:xxx with commands coming from those packages. |
||||
#This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. |
||||
#The basic principle is that the commandset is loaded into the caller(s) with a prefix |
||||
#- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) |
||||
proc import_commandset {prefix separator cmdnamespace} { |
||||
set bad_seps [list "::"] |
||||
if {$separator in $bad_seps} { |
||||
error "import_commandset invalid separator '$separator'" |
||||
} |
||||
#namespace may or may not be a package |
||||
# allow with or without leading :: |
||||
if {[string range $cmdnamespace 0 1] eq "::"} { |
||||
set cmdpackage [string range $cmdnamespace 2 end] |
||||
} else { |
||||
set cmdpackage $cmdnamespace |
||||
set cmdnamespace ::$cmdnamespace |
||||
} |
||||
|
||||
if {![namespace exists $cmdnamespace]} { |
||||
#only do package require if the namespace not already present |
||||
catch {package require $cmdpackage} pkg_load_info |
||||
#recheck |
||||
if {![namespace exists $cmdnamespace]} { |
||||
set prov [package provide $cmdpackage] |
||||
if {[string length $prov]} { |
||||
set provinfo "(package $cmdpackage is present with version $prov)" |
||||
} else { |
||||
set provinfo "(package $cmdpackage not present)" |
||||
} |
||||
error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Pkg_load_result: $pkg_load_info Usage: import_commandset prefix separator namespace" |
||||
} |
||||
} |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util |
||||
|
||||
#let child namespace 'lib' resolve parent namespace and thus util::xxx |
||||
namespace eval ${cmdnamespace}::lib [string map [list <cmdns> $cmdnamespace] { |
||||
set nspaths [namespace path] |
||||
if {"<cmdns>" ni $nspaths} { |
||||
lappend nspaths <cmdns> |
||||
} |
||||
namespace path $nspaths |
||||
}] |
||||
|
||||
set imported_commands [list] |
||||
set nscaller [uplevel 1 [list namespace current]] |
||||
if {[catch { |
||||
namespace eval ${nscaller}::temp_import [list namespace import ${cmdnamespace}::*] |
||||
foreach cmd [info commands ${nscaller}::temp_import::*] { |
||||
set cmdtail [namespace tail $cmd] |
||||
if {$cmdtail eq "_default"} { |
||||
set import_as ${nscaller}::${prefix} |
||||
} else { |
||||
set import_as ${nscaller}::${prefix}${separator}${cmdtail} |
||||
} |
||||
rename $cmd $import_as |
||||
lappend imported_commands $import_as |
||||
} |
||||
} errM]} { |
||||
puts stderr "Error loading commandset $prefix $separator $cmdnamespace" |
||||
puts stderr "err: $errM" |
||||
} |
||||
return $imported_commands |
||||
} |
||||
} |
||||
|
||||
|
||||
package provide punk::overlay [namespace eval punk::overlay { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
@ -0,0 +1,104 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::tdl 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::tdl { |
||||
# https://wiki.tcl-lang.org/page/Config+file+using+slave+interp |
||||
|
||||
variable sample_script { |
||||
server -name bsd1 -os FreeBSD |
||||
server -name p1 -os linux |
||||
server -name trillion -os windows |
||||
|
||||
server -name vmhost1 -os FreeBSD { |
||||
guest -name bsd1 -vmmanager iocage |
||||
guest -name p1 -vmmanager bhyve |
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
proc prettyparse {script} { |
||||
set i [interp create -safe] |
||||
try { |
||||
# $i eval {unset {*}[info vars]} |
||||
# foreach command [$i eval {info commands}] {$i hide $command} |
||||
# $i invokehidden namespace delete {*}[$i invokehidden namespace children] |
||||
$i alias unknown apply {{i tag args} { |
||||
upvar 1 result result |
||||
set e [concat [list tag $tag]\ |
||||
[lrange $args 0 [expr {([llength $args] & ~1) - 1}]]] |
||||
if {[llength $args] % 2} { |
||||
set saved $result |
||||
set result {} |
||||
$i eval [lindex $args end] |
||||
lappend e body $result |
||||
set result $saved |
||||
} |
||||
lappend result $e |
||||
list |
||||
}} $i |
||||
set result {} |
||||
$i eval $script |
||||
return $result |
||||
} finally { |
||||
interp delete $i |
||||
} |
||||
} |
||||
proc prettyprint {data {level 0}} { |
||||
set ind [string repeat " " $level] |
||||
incr level |
||||
set result {} |
||||
foreach e $data { |
||||
set line $ind[concat [list [dict get $e tag]] [dict remove $e tag body]] |
||||
if {[dict exists $e body] && [llength [dict get $e body]]} { |
||||
append line " {\n[prettyprint [dict get $e body] $level]\n$ind}" |
||||
} |
||||
lappend result $line |
||||
} |
||||
join $result \n |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::tdl [namespace eval punk::tdl { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1 @@
|
||||
bootsupport libs and modules |
||||
@ -0,0 +1,200 @@
|
||||
# cksum.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||
# |
||||
# Provides a Tcl only implementation of the unix cksum(1) command. This is |
||||
# similar to the sum(1) command but the algorithm is better defined and |
||||
# standardized across multiple platforms by POSIX 1003.2/D11.2 |
||||
# |
||||
# This command has been verified against the cksum command from the GNU |
||||
# textutils package version 2.0 |
||||
# |
||||
# ------------------------------------------------------------------------- |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# ------------------------------------------------------------------------- |
||||
|
||||
package require Tcl 8.5-; # tcl minimum version |
||||
|
||||
namespace eval ::crc { |
||||
namespace export cksum |
||||
|
||||
variable cksum_tbl [list 0x0 \ |
||||
0x04C11DB7 0x09823B6E 0x0D4326D9 0x130476DC 0x17C56B6B \ |
||||
0x1A864DB2 0x1E475005 0x2608EDB8 0x22C9F00F 0x2F8AD6D6 \ |
||||
0x2B4BCB61 0x350C9B64 0x31CD86D3 0x3C8EA00A 0x384FBDBD \ |
||||
0x4C11DB70 0x48D0C6C7 0x4593E01E 0x4152FDA9 0x5F15ADAC \ |
||||
0x5BD4B01B 0x569796C2 0x52568B75 0x6A1936C8 0x6ED82B7F \ |
||||
0x639B0DA6 0x675A1011 0x791D4014 0x7DDC5DA3 0x709F7B7A \ |
||||
0x745E66CD 0x9823B6E0 0x9CE2AB57 0x91A18D8E 0x95609039 \ |
||||
0x8B27C03C 0x8FE6DD8B 0x82A5FB52 0x8664E6E5 0xBE2B5B58 \ |
||||
0xBAEA46EF 0xB7A96036 0xB3687D81 0xAD2F2D84 0xA9EE3033 \ |
||||
0xA4AD16EA 0xA06C0B5D 0xD4326D90 0xD0F37027 0xDDB056FE \ |
||||
0xD9714B49 0xC7361B4C 0xC3F706FB 0xCEB42022 0xCA753D95 \ |
||||
0xF23A8028 0xF6FB9D9F 0xFBB8BB46 0xFF79A6F1 0xE13EF6F4 \ |
||||
0xE5FFEB43 0xE8BCCD9A 0xEC7DD02D 0x34867077 0x30476DC0 \ |
||||
0x3D044B19 0x39C556AE 0x278206AB 0x23431B1C 0x2E003DC5 \ |
||||
0x2AC12072 0x128E9DCF 0x164F8078 0x1B0CA6A1 0x1FCDBB16 \ |
||||
0x018AEB13 0x054BF6A4 0x0808D07D 0x0CC9CDCA 0x7897AB07 \ |
||||
0x7C56B6B0 0x71159069 0x75D48DDE 0x6B93DDDB 0x6F52C06C \ |
||||
0x6211E6B5 0x66D0FB02 0x5E9F46BF 0x5A5E5B08 0x571D7DD1 \ |
||||
0x53DC6066 0x4D9B3063 0x495A2DD4 0x44190B0D 0x40D816BA \ |
||||
0xACA5C697 0xA864DB20 0xA527FDF9 0xA1E6E04E 0xBFA1B04B \ |
||||
0xBB60ADFC 0xB6238B25 0xB2E29692 0x8AAD2B2F 0x8E6C3698 \ |
||||
0x832F1041 0x87EE0DF6 0x99A95DF3 0x9D684044 0x902B669D \ |
||||
0x94EA7B2A 0xE0B41DE7 0xE4750050 0xE9362689 0xEDF73B3E \ |
||||
0xF3B06B3B 0xF771768C 0xFA325055 0xFEF34DE2 0xC6BCF05F \ |
||||
0xC27DEDE8 0xCF3ECB31 0xCBFFD686 0xD5B88683 0xD1799B34 \ |
||||
0xDC3ABDED 0xD8FBA05A 0x690CE0EE 0x6DCDFD59 0x608EDB80 \ |
||||
0x644FC637 0x7A089632 0x7EC98B85 0x738AAD5C 0x774BB0EB \ |
||||
0x4F040D56 0x4BC510E1 0x46863638 0x42472B8F 0x5C007B8A \ |
||||
0x58C1663D 0x558240E4 0x51435D53 0x251D3B9E 0x21DC2629 \ |
||||
0x2C9F00F0 0x285E1D47 0x36194D42 0x32D850F5 0x3F9B762C \ |
||||
0x3B5A6B9B 0x0315D626 0x07D4CB91 0x0A97ED48 0x0E56F0FF \ |
||||
0x1011A0FA 0x14D0BD4D 0x19939B94 0x1D528623 0xF12F560E \ |
||||
0xF5EE4BB9 0xF8AD6D60 0xFC6C70D7 0xE22B20D2 0xE6EA3D65 \ |
||||
0xEBA91BBC 0xEF68060B 0xD727BBB6 0xD3E6A601 0xDEA580D8 \ |
||||
0xDA649D6F 0xC423CD6A 0xC0E2D0DD 0xCDA1F604 0xC960EBB3 \ |
||||
0xBD3E8D7E 0xB9FF90C9 0xB4BCB610 0xB07DABA7 0xAE3AFBA2 \ |
||||
0xAAFBE615 0xA7B8C0CC 0xA379DD7B 0x9B3660C6 0x9FF77D71 \ |
||||
0x92B45BA8 0x9675461F 0x8832161A 0x8CF30BAD 0x81B02D74 \ |
||||
0x857130C3 0x5D8A9099 0x594B8D2E 0x5408ABF7 0x50C9B640 \ |
||||
0x4E8EE645 0x4A4FFBF2 0x470CDD2B 0x43CDC09C 0x7B827D21 \ |
||||
0x7F436096 0x7200464F 0x76C15BF8 0x68860BFD 0x6C47164A \ |
||||
0x61043093 0x65C52D24 0x119B4BE9 0x155A565E 0x18197087 \ |
||||
0x1CD86D30 0x029F3D35 0x065E2082 0x0B1D065B 0x0FDC1BEC \ |
||||
0x3793A651 0x3352BBE6 0x3E119D3F 0x3AD08088 0x2497D08D \ |
||||
0x2056CD3A 0x2D15EBE3 0x29D4F654 0xC5A92679 0xC1683BCE \ |
||||
0xCC2B1D17 0xC8EA00A0 0xD6AD50A5 0xD26C4D12 0xDF2F6BCB \ |
||||
0xDBEE767C 0xE3A1CBC1 0xE760D676 0xEA23F0AF 0xEEE2ED18 \ |
||||
0xF0A5BD1D 0xF464A0AA 0xF9278673 0xFDE69BC4 0x89B8FD09 \ |
||||
0x8D79E0BE 0x803AC667 0x84FBDBD0 0x9ABC8BD5 0x9E7D9662 \ |
||||
0x933EB0BB 0x97FFAD0C 0xAFB010B1 0xAB710D06 0xA6322BDF \ |
||||
0xA2F33668 0xBCB4666D 0xB8757BDA 0xB5365D03 0xB1F740B4 ] |
||||
|
||||
variable uid |
||||
if {![info exists uid]} {set uid 0} |
||||
} |
||||
|
||||
# crc::CksumInit -- |
||||
# |
||||
# Create and initialize a cksum context. This is cleaned up when we |
||||
# call CksumFinal to obtain the result. |
||||
# |
||||
proc ::crc::CksumInit {} { |
||||
variable uid |
||||
set token [namespace current]::[incr uid] |
||||
upvar #0 $token state |
||||
array set state {t 0 l 0} |
||||
return $token |
||||
} |
||||
|
||||
proc ::crc::CksumUpdate {token data} { |
||||
variable cksum_tbl |
||||
upvar #0 $token state |
||||
set t $state(t) |
||||
binary scan $data c* r |
||||
foreach {n} $r { |
||||
set index [expr { (($t >> 24) ^ ($n & 0xFF)) & 0xFF }] |
||||
# Since the introduction of built-in bigInt support with Tcl |
||||
# 8.5, bit-shifting $t to the left no longer overflows, |
||||
# keeping it 32 bits long. The value grows bigger and bigger |
||||
# instead - a severe hit on performance. For this reason we |
||||
# do a bitwise AND against 0xFFFFFFFF at each step to keep the |
||||
# value within limits. |
||||
set t [expr {0xFFFFFFFF & (($t << 8) ^ [lindex $cksum_tbl $index])}] |
||||
incr state(l) |
||||
} |
||||
set state(t) $t |
||||
return |
||||
} |
||||
|
||||
proc ::crc::CksumFinal {token} { |
||||
variable cksum_tbl |
||||
upvar #0 $token state |
||||
set t $state(t) |
||||
for {set i $state(l)} {$i > 0} {set i [expr {$i>>8}]} { |
||||
set index [expr {(($t >> 24) ^ $i) & 0xFF}] |
||||
set t [expr {0xFFFFFFFF & (($t << 8) ^ [lindex $cksum_tbl $index])}] |
||||
} |
||||
unset state |
||||
return [expr {~$t & 0xFFFFFFFF}] |
||||
} |
||||
|
||||
# crc::Pop -- |
||||
# |
||||
# Pop the nth element off a list. Used in options processing. |
||||
# |
||||
proc ::crc::Pop {varname {nth 0}} { |
||||
upvar $varname args |
||||
set r [lindex $args $nth] |
||||
set args [lreplace $args $nth $nth] |
||||
return $r |
||||
} |
||||
|
||||
# Description: |
||||
# Provide a Tcl equivalent of the unix cksum(1) command. |
||||
# Options: |
||||
# -filename name - return a checksum for the specified file. |
||||
# -format string - return the checksum using this format string. |
||||
# -chunksize size - set the chunking read size |
||||
# |
||||
proc ::crc::cksum {args} { |
||||
array set opts [list -filename {} -channel {} -chunksize 4096 \ |
||||
-format %u -command {}] |
||||
while {[string match -* [set option [lindex $args 0]]]} { |
||||
switch -glob -- $option { |
||||
-file* { set opts(-filename) [Pop args 1] } |
||||
-chan* { set opts(-channel) [Pop args 1] } |
||||
-chunk* { set opts(-chunksize) [Pop args 1] } |
||||
-for* { set opts(-format) [Pop args 1] } |
||||
-command { set opts(-command) [Pop args 1] } |
||||
default { |
||||
if {[llength $args] == 1} { break } |
||||
if {[string compare $option "--"] == 0} { Pop args ; break } |
||||
set err [join [lsort [array names opts -*]] ", "] |
||||
return -code error "bad option \"option\": must be $err" |
||||
} |
||||
} |
||||
Pop args |
||||
} |
||||
|
||||
if {$opts(-filename) != {}} { |
||||
set opts(-channel) [open $opts(-filename) r] |
||||
fconfigure $opts(-channel) -translation binary |
||||
} |
||||
|
||||
if {$opts(-channel) == {}} { |
||||
|
||||
if {[llength $args] != 1} { |
||||
return -code error "wrong # args: should be\ |
||||
cksum ?-format string?\ |
||||
-channel chan | -filename file | string" |
||||
} |
||||
set tok [CksumInit] |
||||
CksumUpdate $tok [lindex $args 0] |
||||
set r [CksumFinal $tok] |
||||
|
||||
} else { |
||||
|
||||
set tok [CksumInit] |
||||
while {![eof $opts(-channel)]} { |
||||
CksumUpdate $tok [read $opts(-channel) $opts(-chunksize)] |
||||
} |
||||
set r [CksumFinal $tok] |
||||
|
||||
if {$opts(-filename) != {}} { |
||||
close $opts(-channel) |
||||
} |
||||
} |
||||
|
||||
return [format $opts(-format) $r] |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
package provide cksum 1.1.4 |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Local variables: |
||||
# mode: tcl |
||||
# indent-tabs-mode: nil |
||||
# End: |
||||
@ -0,0 +1,933 @@
|
||||
# cmdline.tcl -- |
||||
# |
||||
# This package provides a utility for parsing command line |
||||
# arguments that are processed by our various applications. |
||||
# It also includes a utility routine to determine the |
||||
# application name for use in command line errors. |
||||
# |
||||
# Copyright (c) 1998-2000 by Ajuba Solutions. |
||||
# Copyright (c) 2001-2015 by Andreas Kupries <andreas_kupries@users.sf.net>. |
||||
# Copyright (c) 2003 by David N. Welton <davidw@dedasys.com> |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
|
||||
package require Tcl 8.5- |
||||
package provide cmdline 1.5.2 |
||||
|
||||
namespace eval ::cmdline { |
||||
namespace export getArgv0 getopt getKnownOpt getfiles getoptions \ |
||||
getKnownOptions usage |
||||
} |
||||
|
||||
# ::cmdline::getopt -- |
||||
# |
||||
# The cmdline::getopt works in a fashion like the standard |
||||
# C based getopt function. Given an option string and a |
||||
# pointer to an array or args this command will process the |
||||
# first argument and return info on how to proceed. |
||||
# |
||||
# Arguments: |
||||
# argvVar Name of the argv list that you |
||||
# want to process. If options are found the |
||||
# arg list is modified and the processed arguments |
||||
# are removed from the start of the list. |
||||
# optstring A list of command options that the application |
||||
# will accept. If the option ends in ".arg" the |
||||
# getopt routine will use the next argument as |
||||
# an argument to the option. Otherwise the option |
||||
# is a boolean that is set to 1 if present. |
||||
# optVar The variable pointed to by optVar |
||||
# contains the option that was found (without the |
||||
# leading '-' and without the .arg extension). |
||||
# valVar Upon success, the variable pointed to by valVar |
||||
# contains the value for the specified option. |
||||
# This value comes from the command line for .arg |
||||
# options, otherwise the value is 1. |
||||
# If getopt fails, the valVar is filled with an |
||||
# error message. |
||||
# |
||||
# Results: |
||||
# The getopt function returns 1 if an option was found, 0 if no more |
||||
# options were found, and -1 if an error occurred. |
||||
|
||||
proc ::cmdline::getopt {argvVar optstring optVar valVar} { |
||||
upvar 1 $argvVar argsList |
||||
upvar 1 $optVar option |
||||
upvar 1 $valVar value |
||||
|
||||
set result [getKnownOpt argsList $optstring option value] |
||||
|
||||
if {$result < 0} { |
||||
# Collapse unknown-option error into any-other-error result. |
||||
set result -1 |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
# ::cmdline::getKnownOpt -- |
||||
# |
||||
# The cmdline::getKnownOpt works in a fashion like the standard |
||||
# C based getopt function. Given an option string and a |
||||
# pointer to an array or args this command will process the |
||||
# first argument and return info on how to proceed. |
||||
# |
||||
# Arguments: |
||||
# argvVar Name of the argv list that you |
||||
# want to process. If options are found the |
||||
# arg list is modified and the processed arguments |
||||
# are removed from the start of the list. Note that |
||||
# unknown options and the args that follow them are |
||||
# left in this list. |
||||
# optstring A list of command options that the application |
||||
# will accept. If the option ends in ".arg" the |
||||
# getopt routine will use the next argument as |
||||
# an argument to the option. Otherwise the option |
||||
# is a boolean that is set to 1 if present. |
||||
# optVar The variable pointed to by optVar |
||||
# contains the option that was found (without the |
||||
# leading '-' and without the .arg extension). |
||||
# valVar Upon success, the variable pointed to by valVar |
||||
# contains the value for the specified option. |
||||
# This value comes from the command line for .arg |
||||
# options, otherwise the value is 1. |
||||
# If getopt fails, the valVar is filled with an |
||||
# error message. |
||||
# |
||||
# Results: |
||||
# The getKnownOpt function returns 1 if an option was found, |
||||
# 0 if no more options were found, -1 if an unknown option was |
||||
# encountered, and -2 if any other error occurred. |
||||
|
||||
proc ::cmdline::getKnownOpt {argvVar optstring optVar valVar} { |
||||
upvar 1 $argvVar argsList |
||||
upvar 1 $optVar option |
||||
upvar 1 $valVar value |
||||
|
||||
# default settings for a normal return |
||||
set value "" |
||||
set option "" |
||||
set result 0 |
||||
|
||||
# check if we're past the end of the args list |
||||
if {[llength $argsList] != 0} { |
||||
|
||||
# if we got -- or an option that doesn't begin with -, return (skipping |
||||
# the --). otherwise process the option arg. |
||||
switch -glob -- [set arg [lindex $argsList 0]] { |
||||
"--" { |
||||
set argsList [lrange $argsList 1 end] |
||||
} |
||||
"--*" - |
||||
"-*" { |
||||
set option [string range $arg 1 end] |
||||
if {[string equal [string range $option 0 0] "-"]} { |
||||
set option [string range $arg 2 end] |
||||
} |
||||
|
||||
# support for format: [-]-option=value |
||||
set idx [string first "=" $option 1] |
||||
if {$idx != -1} { |
||||
set _val [string range $option [expr {$idx+1}] end] |
||||
set option [string range $option 0 [expr {$idx-1}]] |
||||
} |
||||
|
||||
if {[lsearch -exact $optstring $option] != -1} { |
||||
# Booleans are set to 1 when present |
||||
set value 1 |
||||
set result 1 |
||||
set argsList [lrange $argsList 1 end] |
||||
} elseif {[lsearch -exact $optstring "$option.arg"] != -1} { |
||||
set result 1 |
||||
set argsList [lrange $argsList 1 end] |
||||
|
||||
if {[info exists _val]} { |
||||
set value $_val |
||||
} elseif {[llength $argsList]} { |
||||
set value [lindex $argsList 0] |
||||
set argsList [lrange $argsList 1 end] |
||||
} else { |
||||
set value "Option \"$option\" requires an argument" |
||||
set result -2 |
||||
} |
||||
} else { |
||||
# Unknown option. |
||||
set value "Illegal option \"-$option\"" |
||||
set result -1 |
||||
} |
||||
} |
||||
default { |
||||
# Skip ahead |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
# ::cmdline::getoptions -- |
||||
# |
||||
# Process a set of command line options, filling in defaults |
||||
# for those not specified. This also generates an error message |
||||
# that lists the allowed flags if an incorrect flag is specified. |
||||
# |
||||
# Arguments: |
||||
# argvVar The name of the argument list, typically argv. |
||||
# We remove all known options and their args from it. |
||||
# In other words, after the call to this command the |
||||
# referenced variable contains only the non-options, |
||||
# and unknown options. |
||||
# optlist A list-of-lists where each element specifies an option |
||||
# in the form: |
||||
# (where flag takes no argument) |
||||
# flag comment |
||||
# |
||||
# (or where flag takes an argument) |
||||
# flag default comment |
||||
# |
||||
# If flag ends in ".arg" then the value is taken from the |
||||
# command line. Otherwise it is a boolean and appears in |
||||
# the result if present on the command line. If flag ends |
||||
# in ".secret", it will not be displayed in the usage. |
||||
# usage Text to include in the usage display. Defaults to |
||||
# "options:" |
||||
# |
||||
# Results |
||||
# Name value pairs suitable for using with array set. |
||||
# A modified `argvVar`. |
||||
|
||||
proc ::cmdline::getoptions {argvVar optlist {usage options:}} { |
||||
upvar 1 $argvVar argv |
||||
|
||||
set opts [GetOptionDefaults $optlist result] |
||||
|
||||
set argc [llength $argv] |
||||
while {[set err [getopt argv $opts opt arg]]} { |
||||
if {$err < 0} { |
||||
set result(?) "" |
||||
break |
||||
} |
||||
set result($opt) $arg |
||||
} |
||||
if {[info exist result(?)] || [info exists result(help)]} { |
||||
Error [usage $optlist $usage] USAGE |
||||
} |
||||
return [array get result] |
||||
} |
||||
|
||||
# ::cmdline::getKnownOptions -- |
||||
# |
||||
# Process a set of command line options, filling in defaults |
||||
# for those not specified. This ignores unknown flags, but generates |
||||
# an error message that lists the correct usage if a known option |
||||
# is used incorrectly. |
||||
# |
||||
# Arguments: |
||||
# argvVar The name of the argument list, typically argv. This |
||||
# We remove all known options and their args from it. |
||||
# In other words, after the call to this command the |
||||
# referenced variable contains only the non-options, |
||||
# and unknown options. |
||||
# optlist A list-of-lists where each element specifies an option |
||||
# in the form: |
||||
# flag default comment |
||||
# If flag ends in ".arg" then the value is taken from the |
||||
# command line. Otherwise it is a boolean and appears in |
||||
# the result if present on the command line. If flag ends |
||||
# in ".secret", it will not be displayed in the usage. |
||||
# usage Text to include in the usage display. Defaults to |
||||
# "options:" |
||||
# |
||||
# Results |
||||
# Name value pairs suitable for using with array set. |
||||
# A modified `argvVar`. |
||||
|
||||
proc ::cmdline::getKnownOptions {argvVar optlist {usage options:}} { |
||||
upvar 1 $argvVar argv |
||||
|
||||
set opts [GetOptionDefaults $optlist result] |
||||
|
||||
# As we encounter them, keep the unknown options and their |
||||
# arguments in this list. Before we return from this procedure, |
||||
# we'll prepend these args to the argList so that the application |
||||
# doesn't lose them. |
||||
|
||||
set unknownOptions [list] |
||||
|
||||
set argc [llength $argv] |
||||
while {[set err [getKnownOpt argv $opts opt arg]]} { |
||||
if {$err == -1} { |
||||
# Unknown option. |
||||
|
||||
# Skip over any non-option items that follow it. |
||||
# For now, add them to the list of unknownOptions. |
||||
lappend unknownOptions [lindex $argv 0] |
||||
set argv [lrange $argv 1 end] |
||||
while {([llength $argv] != 0) \ |
||||
&& ![string match "-*" [lindex $argv 0]]} { |
||||
lappend unknownOptions [lindex $argv 0] |
||||
set argv [lrange $argv 1 end] |
||||
} |
||||
} elseif {$err == -2} { |
||||
set result(?) "" |
||||
break |
||||
} else { |
||||
set result($opt) $arg |
||||
} |
||||
} |
||||
|
||||
# Before returning, prepend the any unknown args back onto the |
||||
# argList so that the application doesn't lose them. |
||||
set argv [concat $unknownOptions $argv] |
||||
|
||||
if {[info exist result(?)] || [info exists result(help)]} { |
||||
Error [usage $optlist $usage] USAGE |
||||
} |
||||
return [array get result] |
||||
} |
||||
|
||||
# ::cmdline::GetOptionDefaults -- |
||||
# |
||||
# This internal procedure processes the option list (that was passed to |
||||
# the getopt or getKnownOpt procedure). The defaultArray gets an index |
||||
# for each option in the option list, the value of which is the option's |
||||
# default value. |
||||
# |
||||
# Arguments: |
||||
# optlist A list-of-lists where each element specifies an option |
||||
# in the form: |
||||
# flag default comment |
||||
# If flag ends in ".arg" then the value is taken from the |
||||
# command line. Otherwise it is a boolean and appears in |
||||
# the result if present on the command line. If flag ends |
||||
# in ".secret", it will not be displayed in the usage. |
||||
# defaultArrayVar The name of the array in which to put argument defaults. |
||||
# |
||||
# Results |
||||
# Name value pairs suitable for using with array set. |
||||
|
||||
proc ::cmdline::GetOptionDefaults {optlist defaultArrayVar} { |
||||
upvar 1 $defaultArrayVar result |
||||
|
||||
set opts {? help} |
||||
foreach opt $optlist { |
||||
set name [lindex $opt 0] |
||||
if {[regsub -- {\.secret$} $name {} name] == 1} { |
||||
# Need to hide this from the usage display and getopt |
||||
} |
||||
lappend opts $name |
||||
if {[regsub -- {\.arg$} $name {} name] == 1} { |
||||
|
||||
# Set defaults for those that take values. |
||||
|
||||
set default [lindex $opt 1] |
||||
set result($name) $default |
||||
} else { |
||||
# The default for booleans is false |
||||
set result($name) 0 |
||||
} |
||||
} |
||||
return $opts |
||||
} |
||||
|
||||
# ::cmdline::usage -- |
||||
# |
||||
# Generate an error message that lists the allowed flags. |
||||
# |
||||
# Arguments: |
||||
# optlist As for cmdline::getoptions |
||||
# usage Text to include in the usage display. Defaults to |
||||
# "options:" |
||||
# |
||||
# Results |
||||
# A formatted usage message |
||||
|
||||
proc ::cmdline::usage {optlist {usage {options:}}} { |
||||
set str "[getArgv0] $usage\n" |
||||
set longest 20 |
||||
set lines {} |
||||
foreach opt [concat $optlist \ |
||||
{{- "Forcibly stop option processing"} {help "Print this message"} {? "Print this message"}}] { |
||||
set name "-[lindex $opt 0]" |
||||
if {[regsub -- {\.secret$} $name {} name] == 1} { |
||||
# Hidden option |
||||
continue |
||||
} |
||||
if {[regsub -- {\.arg$} $name {} name] == 1} { |
||||
append name " value" |
||||
set desc "[lindex $opt 2] <[lindex $opt 1]>" |
||||
} else { |
||||
set desc "[lindex $opt 1]" |
||||
} |
||||
set n [string length $name] |
||||
if {$n > $longest} { set longest $n } |
||||
# max not available before 8.5 - set longest [expr {max($longest, )}] |
||||
lappend lines $name $desc |
||||
} |
||||
foreach {name desc} $lines { |
||||
append str "[string trimright [format " %-*s %s" $longest $name $desc]]\n" |
||||
} |
||||
|
||||
return $str |
||||
} |
||||
|
||||
# ::cmdline::getfiles -- |
||||
# |
||||
# Given a list of file arguments from the command line, compute |
||||
# the set of valid files. On windows, file globbing is performed |
||||
# on each argument. On Unix, only file existence is tested. If |
||||
# a file argument produces no valid files, a warning is optionally |
||||
# generated. |
||||
# |
||||
# This code also uses the full path for each file. If not |
||||
# given it prepends [pwd] to the filename. This ensures that |
||||
# these files will never conflict with files in our zip file. |
||||
# |
||||
# Arguments: |
||||
# patterns The file patterns specified by the user. |
||||
# quiet If this flag is set, no warnings will be generated. |
||||
# |
||||
# Results: |
||||
# Returns the list of files that match the input patterns. |
||||
|
||||
proc ::cmdline::getfiles {patterns quiet} { |
||||
set result {} |
||||
if {$::tcl_platform(platform) == "windows"} { |
||||
foreach pattern $patterns { |
||||
set pat [file join $pattern] |
||||
set files [glob -nocomplain -- $pat] |
||||
if {$files == {}} { |
||||
if {! $quiet} { |
||||
puts stdout "warning: no files match \"$pattern\"" |
||||
} |
||||
} else { |
||||
foreach file $files { |
||||
lappend result $file |
||||
} |
||||
} |
||||
} |
||||
} else { |
||||
set result $patterns |
||||
} |
||||
set files {} |
||||
foreach file $result { |
||||
# Make file an absolute path so that we will never conflict |
||||
# with files that might be contained in our zip file. |
||||
set fullPath [file join [pwd] $file] |
||||
|
||||
if {[file isfile $fullPath]} { |
||||
lappend files $fullPath |
||||
} elseif {! $quiet} { |
||||
puts stdout "warning: no files match \"$file\"" |
||||
} |
||||
} |
||||
return $files |
||||
} |
||||
|
||||
# ::cmdline::getArgv0 -- |
||||
# |
||||
# This command returns the "sanitized" version of argv0. It will strip |
||||
# off the leading path and remove the ".bin" extensions that our apps |
||||
# use because they must be wrapped by a shell script. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# The application name that can be used in error messages. |
||||
|
||||
proc ::cmdline::getArgv0 {} { |
||||
global argv0 |
||||
|
||||
set name [file tail $argv0] |
||||
return [file rootname $name] |
||||
} |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
# Now the typed versions of the above commands. |
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
# typedCmdline.tcl -- |
||||
# |
||||
# This package provides a utility for parsing typed command |
||||
# line arguments that may be processed by various applications. |
||||
# |
||||
# Copyright (c) 2000 by Ross Palmer Mohn. |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: cmdline.tcl,v 1.28 2011/02/23 17:41:52 andreas_kupries Exp $ |
||||
|
||||
namespace eval ::cmdline { |
||||
namespace export typedGetopt typedGetoptions typedUsage |
||||
|
||||
# variable cmdline::charclasses -- |
||||
# |
||||
# Create regexp list of allowable character classes |
||||
# from "string is" error message. |
||||
# |
||||
# Results: |
||||
# String of character class names separated by "|" characters. |
||||
|
||||
variable charclasses |
||||
#checker exclude badKey |
||||
catch {string is . .} charclasses |
||||
variable dummy |
||||
regexp -- {must be (.+)$} $charclasses dummy charclasses |
||||
regsub -all -- {, (or )?} $charclasses {|} charclasses |
||||
unset dummy |
||||
} |
||||
|
||||
# ::cmdline::typedGetopt -- |
||||
# |
||||
# The cmdline::typedGetopt works in a fashion like the standard |
||||
# C based getopt function. Given an option string and a |
||||
# pointer to a list of args this command will process the |
||||
# first argument and return info on how to proceed. In addition, |
||||
# you may specify a type for the argument to each option. |
||||
# |
||||
# Arguments: |
||||
# argvVar Name of the argv list that you want to process. |
||||
# If options are found, the arg list is modified |
||||
# and the processed arguments are removed from the |
||||
# start of the list. |
||||
# |
||||
# optstring A list of command options that the application |
||||
# will accept. If the option ends in ".xxx", where |
||||
# xxx is any valid character class to the tcl |
||||
# command "string is", then typedGetopt routine will |
||||
# use the next argument as a typed argument to the |
||||
# option. The argument must match the specified |
||||
# character classes (e.g. integer, double, boolean, |
||||
# xdigit, etc.). Alternatively, you may specify |
||||
# ".arg" for an untyped argument. |
||||
# |
||||
# optVar Upon success, the variable pointed to by optVar |
||||
# contains the option that was found (without the |
||||
# leading '-' and without the .xxx extension). If |
||||
# typedGetopt fails the variable is set to the empty |
||||
# string. SOMETIMES! Different for each -value! |
||||
# |
||||
# argVar Upon success, the variable pointed to by argVar |
||||
# contains the argument for the specified option. |
||||
# If typedGetopt fails, the variable is filled with |
||||
# an error message. |
||||
# |
||||
# Argument type syntax: |
||||
# Option that takes no argument. |
||||
# foo |
||||
# |
||||
# Option that takes a typeless argument. |
||||
# foo.arg |
||||
# |
||||
# Option that takes a typed argument. Allowable types are all |
||||
# valid character classes to the tcl command "string is". |
||||
# Currently must be one of alnum, alpha, ascii, control, |
||||
# boolean, digit, double, false, graph, integer, lower, print, |
||||
# punct, space, true, upper, wordchar, or xdigit. |
||||
# foo.double |
||||
# |
||||
# Option that takes an argument from a list. |
||||
# foo.(bar|blat) |
||||
# |
||||
# Argument quantifier syntax: |
||||
# Option that takes an optional argument. |
||||
# foo.arg? |
||||
# |
||||
# Option that takes a list of arguments terminated by "--". |
||||
# foo.arg+ |
||||
# |
||||
# Option that takes an optional list of arguments terminated by "--". |
||||
# foo.arg* |
||||
# |
||||
# Argument quantifiers work on all argument types, so, for |
||||
# example, the following is a valid option specification. |
||||
# foo.(bar|blat|blah)? |
||||
# |
||||
# Argument syntax miscellany: |
||||
# Options may be specified on the command line using a unique, |
||||
# shortened version of the option name. Given that program foo |
||||
# has an option list of {bar.alpha blah.arg blat.double}, |
||||
# "foo -b fob" returns an error, but "foo -ba fob" |
||||
# successfully returns {bar fob} |
||||
# |
||||
# Results: |
||||
# The typedGetopt function returns one of the following: |
||||
# 1 a valid option was found |
||||
# 0 no more options found to process |
||||
# -1 invalid option |
||||
# -2 missing argument to a valid option |
||||
# -3 argument to a valid option does not match type |
||||
# |
||||
# Known Bugs: |
||||
# When using options which include special glob characters, |
||||
# you must use the exact option. Abbreviating it can cause |
||||
# an error in the "cmdline::prefixSearch" procedure. |
||||
|
||||
proc ::cmdline::typedGetopt {argvVar optstring optVar argVar} { |
||||
variable charclasses |
||||
|
||||
upvar $argvVar argsList |
||||
|
||||
upvar $optVar retvar |
||||
upvar $argVar optarg |
||||
|
||||
# default settings for a normal return |
||||
set optarg "" |
||||
set retvar "" |
||||
set retval 0 |
||||
|
||||
# check if we're past the end of the args list |
||||
if {[llength $argsList] != 0} { |
||||
|
||||
# if we got -- or an option that doesn't begin with -, return (skipping |
||||
# the --). otherwise process the option arg. |
||||
switch -glob -- [set arg [lindex $argsList 0]] { |
||||
"--" { |
||||
set argsList [lrange $argsList 1 end] |
||||
} |
||||
|
||||
"-*" { |
||||
# Create list of options without their argument extensions |
||||
|
||||
set optstr "" |
||||
foreach str $optstring { |
||||
lappend optstr [file rootname $str] |
||||
} |
||||
|
||||
set _opt [string range $arg 1 end] |
||||
|
||||
set i [prefixSearch $optstr [file rootname $_opt]] |
||||
if {$i != -1} { |
||||
set opt [lindex $optstring $i] |
||||
|
||||
set quantifier "none" |
||||
if {[regexp -- {\.[^.]+([?+*])$} $opt dummy quantifier]} { |
||||
set opt [string range $opt 0 end-1] |
||||
} |
||||
|
||||
if {[string first . $opt] == -1} { |
||||
set retval 1 |
||||
set retvar $opt |
||||
set argsList [lrange $argsList 1 end] |
||||
|
||||
} elseif {[regexp -- "\\.(arg|$charclasses)\$" $opt dummy charclass] |
||||
|| [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} { |
||||
if {[string equal arg $charclass]} { |
||||
set type arg |
||||
} elseif {[regexp -- "^($charclasses)\$" $charclass]} { |
||||
set type class |
||||
} else { |
||||
set type oneof |
||||
} |
||||
|
||||
set argsList [lrange $argsList 1 end] |
||||
set opt [file rootname $opt] |
||||
|
||||
while {1} { |
||||
if {[llength $argsList] == 0 |
||||
|| [string equal "--" [lindex $argsList 0]]} { |
||||
if {[string equal "--" [lindex $argsList 0]]} { |
||||
set argsList [lrange $argsList 1 end] |
||||
} |
||||
|
||||
set oneof "" |
||||
if {$type == "arg"} { |
||||
set charclass an |
||||
} elseif {$type == "oneof"} { |
||||
set oneof ", one of $charclass" |
||||
set charclass an |
||||
} |
||||
|
||||
if {$quantifier == "?"} { |
||||
set retval 1 |
||||
set retvar $opt |
||||
set optarg "" |
||||
} elseif {$quantifier == "+"} { |
||||
set retvar $opt |
||||
if {[llength $optarg] < 1} { |
||||
set retval -2 |
||||
set optarg "Option requires at least one $charclass argument$oneof -- $opt" |
||||
} else { |
||||
set retval 1 |
||||
} |
||||
} elseif {$quantifier == "*"} { |
||||
set retval 1 |
||||
set retvar $opt |
||||
} else { |
||||
set optarg "Option requires $charclass argument$oneof -- $opt" |
||||
set retvar $opt |
||||
set retval -2 |
||||
} |
||||
set quantifier "" |
||||
} elseif {($type == "arg") |
||||
|| (($type == "oneof") |
||||
&& [string first "|[lindex $argsList 0]|" "|$charclass|"] != -1) |
||||
|| (($type == "class") |
||||
&& [string is $charclass [lindex $argsList 0]])} { |
||||
set retval 1 |
||||
set retvar $opt |
||||
lappend optarg [lindex $argsList 0] |
||||
set argsList [lrange $argsList 1 end] |
||||
} else { |
||||
set oneof "" |
||||
if {$type == "arg"} { |
||||
set charclass an |
||||
} elseif {$type == "oneof"} { |
||||
set oneof ", one of $charclass" |
||||
set charclass an |
||||
} |
||||
set optarg "Option requires $charclass argument$oneof -- $opt" |
||||
set retvar $opt |
||||
set retval -3 |
||||
|
||||
if {$quantifier == "?"} { |
||||
set retval 1 |
||||
set optarg "" |
||||
} |
||||
set quantifier "" |
||||
} |
||||
if {![regexp -- {[+*]} $quantifier]} { |
||||
break; |
||||
} |
||||
} |
||||
} else { |
||||
Error \ |
||||
"Illegal option type specification: must be one of $charclasses" \ |
||||
BAD OPTION TYPE |
||||
} |
||||
} else { |
||||
set optarg "Illegal option -- $_opt" |
||||
set retvar $_opt |
||||
set retval -1 |
||||
} |
||||
} |
||||
default { |
||||
# Skip ahead |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $retval |
||||
} |
||||
|
||||
# ::cmdline::typedGetoptions -- |
||||
# |
||||
# Process a set of command line options, filling in defaults |
||||
# for those not specified. This also generates an error message |
||||
# that lists the allowed options if an incorrect option is |
||||
# specified. |
||||
# |
||||
# Arguments: |
||||
# argvVar The name of the argument list, typically argv |
||||
# optlist A list-of-lists where each element specifies an option |
||||
# in the form: |
||||
# |
||||
# option default comment |
||||
# |
||||
# Options formatting is as described for the optstring |
||||
# argument of typedGetopt. Default is for optionally |
||||
# specifying a default value. Comment is for optionally |
||||
# specifying a comment for the usage display. The |
||||
# options "--", "-help", and "-?" are automatically included |
||||
# in optlist. |
||||
# |
||||
# Argument syntax miscellany: |
||||
# Options formatting and syntax is as described in typedGetopt. |
||||
# There are two additional suffixes that may be applied when |
||||
# passing options to typedGetoptions. |
||||
# |
||||
# You may add ".multi" as a suffix to any option. For options |
||||
# that take an argument, this means that the option may be used |
||||
# more than once on the command line and that each additional |
||||
# argument will be appended to a list, which is then returned |
||||
# to the application. |
||||
# foo.double.multi |
||||
# |
||||
# If a non-argument option is specified as ".multi", it is |
||||
# toggled on and off for each time it is used on the command |
||||
# line. |
||||
# foo.multi |
||||
# |
||||
# If an option specification does not contain the ".multi" |
||||
# suffix, it is not an error to use an option more than once. |
||||
# In this case, the behavior for options with arguments is that |
||||
# the last argument is the one that will be returned. For |
||||
# options that do not take arguments, using them more than once |
||||
# has no additional effect. |
||||
# |
||||
# Options may also be hidden from the usage display by |
||||
# appending the suffix ".secret" to any option specification. |
||||
# Please note that the ".secret" suffix must be the last suffix, |
||||
# after any argument type specification and ".multi" suffix. |
||||
# foo.xdigit.multi.secret |
||||
# |
||||
# Results |
||||
# Name value pairs suitable for using with array set. |
||||
|
||||
proc ::cmdline::typedGetoptions {argvVar optlist {usage options:}} { |
||||
variable charclasses |
||||
|
||||
upvar 1 $argvVar argv |
||||
|
||||
set opts {? help} |
||||
foreach opt $optlist { |
||||
set name [lindex $opt 0] |
||||
if {[regsub -- {\.secret$} $name {} name] == 1} { |
||||
# Remove this extension before passing to typedGetopt. |
||||
} |
||||
if {[regsub -- {\.multi$} $name {} name] == 1} { |
||||
# Remove this extension before passing to typedGetopt. |
||||
|
||||
regsub -- {\..*$} $name {} temp |
||||
set multi($temp) 1 |
||||
} |
||||
lappend opts $name |
||||
if {[regsub -- "\\.(arg|$charclasses|\\(.+).?\$" $name {} name] == 1} { |
||||
# Set defaults for those that take values. |
||||
# Booleans are set just by being present, or not |
||||
|
||||
set dflt [lindex $opt 1] |
||||
if {$dflt != {}} { |
||||
set defaults($name) $dflt |
||||
} |
||||
} |
||||
} |
||||
set argc [llength $argv] |
||||
while {[set err [typedGetopt argv $opts opt arg]]} { |
||||
if {$err == 1} { |
||||
if {[info exists result($opt)] |
||||
&& [info exists multi($opt)]} { |
||||
# Toggle boolean options or append new arguments |
||||
|
||||
if {$arg == ""} { |
||||
unset result($opt) |
||||
} else { |
||||
set result($opt) "$result($opt) $arg" |
||||
} |
||||
} else { |
||||
set result($opt) "$arg" |
||||
} |
||||
} elseif {($err == -1) || ($err == -3)} { |
||||
Error [typedUsage $optlist $usage] USAGE |
||||
} elseif {$err == -2 && ![info exists defaults($opt)]} { |
||||
Error [typedUsage $optlist $usage] USAGE |
||||
} |
||||
} |
||||
if {[info exists result(?)] || [info exists result(help)]} { |
||||
Error [typedUsage $optlist $usage] USAGE |
||||
} |
||||
foreach {opt dflt} [array get defaults] { |
||||
if {![info exists result($opt)]} { |
||||
set result($opt) $dflt |
||||
} |
||||
} |
||||
return [array get result] |
||||
} |
||||
|
||||
# ::cmdline::typedUsage -- |
||||
# |
||||
# Generate an error message that lists the allowed flags, |
||||
# type of argument taken (if any), default value (if any), |
||||
# and an optional description. |
||||
# |
||||
# Arguments: |
||||
# optlist As for cmdline::typedGetoptions |
||||
# |
||||
# Results |
||||
# A formatted usage message |
||||
|
||||
proc ::cmdline::typedUsage {optlist {usage {options:}}} { |
||||
variable charclasses |
||||
|
||||
set str "[getArgv0] $usage\n" |
||||
set longest 20 |
||||
set lines {} |
||||
foreach opt [concat $optlist \ |
||||
{{help "Print this message"} {? "Print this message"}}] { |
||||
set name "-[lindex $opt 0]" |
||||
if {[regsub -- {\.secret$} $name {} name] == 1} { |
||||
# Hidden option |
||||
continue |
||||
} |
||||
|
||||
if {[regsub -- {\.multi$} $name {} name] == 1} { |
||||
# Display something about multiple options |
||||
} |
||||
|
||||
if {[regexp -- "\\.(arg|$charclasses)\$" $name dummy charclass] || |
||||
[regexp -- {\.\(([^)]+)\)} $opt dummy charclass] |
||||
} { |
||||
regsub -- "\\..+\$" $name {} name |
||||
append name " $charclass" |
||||
set desc [lindex $opt 2] |
||||
set default [lindex $opt 1] |
||||
if {$default != ""} { |
||||
append desc " <$default>" |
||||
} |
||||
} else { |
||||
set desc [lindex $opt 1] |
||||
} |
||||
lappend accum $name $desc |
||||
set n [string length $name] |
||||
if {$n > $longest} { set longest $n } |
||||
# max not available before 8.5 - set longest [expr {max($longest, [string length $name])}] |
||||
} |
||||
foreach {name desc} $accum { |
||||
append str "[string trimright [format " %-*s %s" $longest $name $desc]]\n" |
||||
} |
||||
return $str |
||||
} |
||||
|
||||
# ::cmdline::prefixSearch -- |
||||
# |
||||
# Search a Tcl list for a pattern; searches first for an exact match, |
||||
# and if that fails, for a unique prefix that matches the pattern |
||||
# (i.e, first "lsearch -exact", then "lsearch -glob $pattern*" |
||||
# |
||||
# Arguments: |
||||
# list list of words |
||||
# pattern word to search for |
||||
# |
||||
# Results: |
||||
# Index of found word is returned. If no exact match or |
||||
# unique short version is found then -1 is returned. |
||||
|
||||
proc ::cmdline::prefixSearch {list pattern} { |
||||
# Check for an exact match |
||||
|
||||
if {[set pos [::lsearch -exact $list $pattern]] > -1} { |
||||
return $pos |
||||
} |
||||
|
||||
# Check for a unique short version |
||||
|
||||
set slist [lsort $list] |
||||
if {[set pos [::lsearch -glob $slist $pattern*]] > -1} { |
||||
# What if there is nothing for the check variable? |
||||
|
||||
set check [lindex $slist [expr {$pos + 1}]] |
||||
if {[string first $pattern $check] != 0} { |
||||
return [::lsearch -exact $list [lindex $slist $pos]] |
||||
} |
||||
} |
||||
return -1 |
||||
} |
||||
# ::cmdline::Error -- |
||||
# |
||||
# Internal helper to throw errors with a proper error-code attached. |
||||
# |
||||
# Arguments: |
||||
# message text of the error message to throw. |
||||
# args additional parts of the error code to use, |
||||
# with CMDLINE as basic prefix added by this command. |
||||
# |
||||
# Results: |
||||
# An error is thrown, always. |
||||
|
||||
proc ::cmdline::Error {message args} { |
||||
return -code error -errorcode [linsert $args 0 CMDLINE] $message |
||||
} |
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,195 @@
|
||||
#JMN - api should be kept in sync with package patternlib where possible |
||||
# |
||||
package provide oolib [namespace eval oolib { |
||||
variable version |
||||
set version 0.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]} { |
||||
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 [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 {} { |
||||
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
@ -0,0 +1,218 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::cap 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta description pkg capability register |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::cap { |
||||
variable pkgcap [dict create] |
||||
variable caps [dict create] |
||||
proc register_package {pkg capabilitylist} { |
||||
variable pkgcap |
||||
variable caps |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
#for each capability |
||||
# - ensure 1st element is a single word |
||||
# - ensure that if 2nd element (capdict) is present - it is dict shaped |
||||
foreach c $capabilitylist { |
||||
lassign $c capname capdict |
||||
if {[llength $capname] !=1} { |
||||
error "register_package error. pkg: '$pkg' An entry in the capability list doesn't appear to have a single-word name. Problematic entry:'$c'" |
||||
} |
||||
if {[expr {[llength $capdict] %2 != 0}]} { |
||||
error "register_package error. pkg:'$pkg' The second element for capname:'$capname' doesn't appear to be a valid dict. Problematic entry: '$c'" |
||||
} |
||||
if {[dict exists $caps $capname]} { |
||||
set cap_pkgs [dict get $caps $capname] |
||||
} else { |
||||
set cap_pkgs [list] |
||||
} |
||||
if {$pkg ni $cap_pkgs} { |
||||
dict lappend caps $capname $pkg |
||||
} |
||||
} |
||||
dict set pkgcap $pkg $capabilitylist |
||||
} |
||||
proc promote_package {pkg} { |
||||
variable pkgcap |
||||
variable caps |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
if {![dict exists $pkgcap $pkg]} { |
||||
error "punk::cap::promote_package error pkg'$pkg' not registered. Use register_package \$pkg first" |
||||
} |
||||
if {[dict size $pkgcap] > 1} { |
||||
set pkginfo [dict get $pkgcap $pkg] |
||||
#remove and re-add at end of dict |
||||
dict unset pkgcap $pkg |
||||
dict set pkgcap $pkg $pkginfo |
||||
foreach {cap cap_pkgs} $caps { |
||||
if {$pkg in $cap_pkgs} { |
||||
set posn [lsearch $cap_pkgs $pkg] |
||||
if {$posn >=0} { |
||||
#rewrite package list with pkg at tail of list for this capability |
||||
set cap_pkgs [lreplace $cap_pkgs $posn $posn] |
||||
lappend cap_pkgs $pkg |
||||
dict set caps $cap $cap_pkgs |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
proc demote_package {pkg} { |
||||
variable pkgcap |
||||
variable caps |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
if {![dict exists $pkgcap $pkg]} { |
||||
error "punk::cap::promote_package error pkg'$pkg' not registered. Use register_package \$pkg first" |
||||
} |
||||
if {[dict size $pkgcap] > 1} { |
||||
set pkginfo [dict get $pkgcap $pkg] |
||||
#remove and re-add at start of dict |
||||
dict unset pkgcap $pkg |
||||
dict set pkgcap $pkg $pkginfo |
||||
set pkgcap [dict merge [dict create $pkg $pkginfo] $pkgcap] |
||||
foreach {cap cap_pkgs} $caps { |
||||
if {$pkg in $cap_pkgs} { |
||||
set posn [lsearch $cap_pkgs $pkg] |
||||
if {$posn >=0} { |
||||
#rewrite package list with pkg at head of list for this capability |
||||
set cap_pkgs [lreplace $cap_pkgs $posn $posn] |
||||
set cap_pkgs [list $pkg {*}$cap_pkgs] |
||||
dict set caps $cap $cap_pkgs |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
proc unregister_package {pkg} { |
||||
variable pkgcap |
||||
variable caps |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
if {[dict exists $pkgcap $pkg]} { |
||||
#remove corresponding entries in caps |
||||
set capabilitylist [dict get $pkgcap $pkg] |
||||
foreach c $capabilitylist { |
||||
lassign $c capname _capdict |
||||
set pkglist [dict get $caps $capname] |
||||
set posn [lsearch $pkglist $pkg] |
||||
if {$posn >= 0} { |
||||
set pkglist [lreplace $pkglist $posn $posn] |
||||
dict set caps $capname $pkglist |
||||
} |
||||
} |
||||
#delete the main registration record |
||||
dict unset pkgcap $pkg |
||||
} |
||||
} |
||||
proc registered_package {pkg} { |
||||
variable pkgcap |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
if {[dict exists $pkgcap $pkg]} { |
||||
return [dict get $pkgcap $pkg] |
||||
} else { |
||||
return |
||||
} |
||||
} |
||||
proc registered_packages {} { |
||||
variable pkgcap |
||||
return $pkgcap |
||||
} |
||||
|
||||
proc capabilities {{glob *}} { |
||||
variable caps |
||||
set keys [lsort [dict keys $caps $glob]] |
||||
set cap_list [list] |
||||
foreach k $keys { |
||||
lappend cap_list [list $k [dict get $caps $k]] |
||||
} |
||||
return $cap_list |
||||
} |
||||
|
||||
namespace eval templates { |
||||
#return a dict keyed on folder with source pkg as value |
||||
proc folders {} { |
||||
package require punk::cap |
||||
set caplist [punk::cap::capabilities templates] |
||||
# e.g {templates {punk::mix::templates ::somepkg}} |
||||
set templates_record [lindex $caplist 0] |
||||
set pkgs [lindex $templates_record 1] |
||||
|
||||
set folderdict [dict create] |
||||
foreach pkg $pkgs { |
||||
set caplist [punk::cap::registered_package $pkg] |
||||
set templates_entries [lsearch -all -inline -index 0 $caplist templates] ;#we generally expect only one - but if multiple exist - use them |
||||
foreach templates_info $templates_entries { |
||||
lassign $templates_info _templates templates_dict |
||||
if {[dict exists $templates_dict relpath]} { |
||||
set provide_statement [package ifneeded $pkg [package require $pkg]] |
||||
set tmfile [lindex $provide_statement end] |
||||
#set tmdir [file dirname [lindex $provide_statement end]] |
||||
set tpath [file normalize [file join $tmfile [dict get $templates_dict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder |
||||
#relpath relative to file is important for tm files that are zip/tar based containers |
||||
if {[file isdirectory $tpath]} { |
||||
dict set folderdict $tpath [list source $pkg sourcetype package] |
||||
} else { |
||||
puts stderr "punk::cap::templates::folders WARNING - unable to determine base folder for package '$pkg' which is registered with punk::mix as a provider of 'templates' capability" |
||||
} |
||||
} else { |
||||
puts stderr "punk::cap::templates::folders WARNING - registered pkg 'pkg' has capability 'templates' but no 'relpath' key - unable to use as source of templates" |
||||
} |
||||
} |
||||
} |
||||
return $folderdict |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::cap [namespace eval punk::cap { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,15 @@
|
||||
|
||||
package require punk::cap |
||||
package require punk::mix::templates ;#registers 'templates' capability with punk::cap |
||||
package require punk::mix::base |
||||
package require punk::mix::cli |
||||
|
||||
namespace eval punk::mix { |
||||
|
||||
} |
||||
|
||||
package provide punk::mix [namespace eval punk::mix { |
||||
variable version |
||||
set version 0.2 |
||||
|
||||
}] |
||||
@ -0,0 +1,904 @@
|
||||
package provide punk::mix::base [namespace eval punk::mix::base { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
||||
|
||||
#base internal plumbing functions |
||||
namespace eval punk::mix::base { |
||||
proc set_alias {cmdname args} { |
||||
#--------- |
||||
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||
lassign [_split_args $args] _opts opts _args args |
||||
if {[dict exists $opts -extension]} { |
||||
set extension [dict get $opts -extension] |
||||
} else { |
||||
set extension "" |
||||
} |
||||
#--------- |
||||
|
||||
uplevel #0 [list interp alias {} $cmdname {} punk::mix::base::_cli -extension $extension] |
||||
} |
||||
proc _cli {args} { |
||||
#--------- |
||||
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||
lassign [_split_args $args] _opts opts _args args |
||||
if {[dict exists $opts -extension]} { |
||||
set extension [dict get $opts -extension] |
||||
} else { |
||||
set extension "" |
||||
} |
||||
#--------- |
||||
if {![string length $extension]} { |
||||
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||
} |
||||
#puts stderr "punk::mix::base extension: [string trimleft $extension :]" |
||||
if {![string length $extension]} { |
||||
#if still no extension - must have been called dirctly as punk::mix::base::_cli |
||||
if {![llength $args]} { |
||||
set args "help" |
||||
} |
||||
set extension [namespace current] |
||||
} |
||||
if {![llength $args]} { |
||||
if {[info exists ${extension}::default_command]} { |
||||
tailcall $extension [set ${extension}::default_command] |
||||
} |
||||
tailcall $extension |
||||
} else { |
||||
tailcall $extension {*}$args |
||||
} |
||||
} |
||||
proc _unknown {ns args} { |
||||
#--------- |
||||
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||
lassign [_split_args $args] _opts opts _args args |
||||
if {[dict exists $opts -extension]} { |
||||
set extension [dict get $opts -extension] |
||||
} else { |
||||
set extension "" |
||||
} |
||||
#--------- |
||||
|
||||
if {![string length $extension]} { |
||||
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||
} |
||||
#puts stderr "arglen:[llength $args]" |
||||
#puts stdout "_unknown '$ns' '$args'" |
||||
|
||||
set d_commands [get_commands -extension $extension] |
||||
set all_commands [list {*}[dict get $d_commands main] {*}[dict get $d_commands base]] |
||||
error "Unknown subcommand \"[lindex $args 0]\": must be one of: $all_commands" "punk::mix::base _unknown $ns $args" [list unknown_ensemble_subcommand ensemble punk::mix::base] |
||||
} |
||||
proc _redirected {from_ns subcommand args} { |
||||
#puts stderr "_redirected from_ns: $from_ns subcommand:$subcommand args:$args" |
||||
set pname [namespace current]::$subcommand |
||||
if {$pname in [info procs $pname]} { |
||||
set argnames [info args $pname] |
||||
#puts stderr "_redirected $subcommand argnames: $argnames" |
||||
if {[lindex $argnames end] eq "args"} { |
||||
set pos_argnames [lrange $argnames 0 end-1] |
||||
} else { |
||||
set pos_argnames $argnames |
||||
} |
||||
set argvals [list] |
||||
set numargs [llength $pos_argnames] |
||||
if {$numargs > 0} { |
||||
set argvals [lrange $args 0 $numargs-1] |
||||
set args [lrange $args $numargs end] |
||||
} |
||||
if {[llength $argvals] < $numargs} { |
||||
error "wrong # args: $from_ns $subcommand requires args: $pos_argnames" |
||||
} |
||||
tailcall [namespace current] $subcommand {*}$argvals {*}$args -extension $from_ns |
||||
} else { |
||||
tailcall [namespace current] $subcommand {*}$args -extension $from_ns |
||||
} |
||||
} |
||||
proc _split_args {arglist} { |
||||
#don't assume arglist is fully paired. |
||||
set posn [lsearch $arglist -extension] |
||||
set opts [list] |
||||
if {$posn >= 0} { |
||||
if {$posn+2 <= [llength $arglist]} { |
||||
set opts [list -extension [lindex $arglist $posn+1]] |
||||
set argsremaining [lreplace $arglist $posn $posn+1] |
||||
} else { |
||||
#no value supplied to -extension |
||||
error "punk::mix::base::_split_args - no value found for option '-extension'. Supply a value or omit the option." |
||||
} |
||||
} else { |
||||
set argsremaining $arglist |
||||
} |
||||
|
||||
return [list opts $opts args $argsremaining] |
||||
} |
||||
} |
||||
|
||||
|
||||
#base API (potentially overridden functions - may also be called from overriding namespace) |
||||
#commands should either handle or silently ignore -extension <namespace/ensemble> |
||||
namespace eval punk::mix::base { |
||||
namespace ensemble create |
||||
namespace export help dostuff get_commands set_alias |
||||
namespace ensemble configure [namespace current] -unknown punk::mix::base::_unknown |
||||
proc get_commands {args} { |
||||
#--------- |
||||
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||
lassign [_split_args $args] _opts opts _args args |
||||
if {[dict exists $opts -extension]} { |
||||
set extension [dict get $opts -extension] |
||||
} else { |
||||
set extension "" |
||||
} |
||||
#--------- |
||||
if {![string length $extension]} { |
||||
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||
} |
||||
|
||||
set maincommands [list] |
||||
#extension may still be blank e.g if punk::mix::base::get_commands called directly |
||||
if {[string length $extension]} { |
||||
set nsmain $extension |
||||
#puts stdout "get_commands nsmain: $nsmain" |
||||
set parentpatterns [namespace eval $nsmain [list namespace export]] |
||||
set nscommands [list] |
||||
foreach p $parentpatterns { |
||||
lappend nscommands {*}[info commands ${nsmain}::$p] |
||||
} |
||||
foreach c $nscommands { |
||||
set cmd [namespace tail $c] |
||||
lappend maincommands $cmd |
||||
} |
||||
set maincommands [lsort $maincommands] |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
set nsbase [namespace current] |
||||
set basepatterns [namespace export] |
||||
#puts stdout "basepatterns:$basepatterns" |
||||
set nscommands [list] |
||||
foreach p $basepatterns { |
||||
lappend nscommands {*}[info commands ${nsbase}::$p] |
||||
} |
||||
|
||||
set basecommands [list] |
||||
foreach c $nscommands { |
||||
set cmd [namespace tail $c] |
||||
if {$cmd ni $maincommands} { |
||||
lappend basecommands $cmd |
||||
} |
||||
} |
||||
set basecommands [lsort $basecommands] |
||||
|
||||
|
||||
return [list main $maincommands base $basecommands] |
||||
} |
||||
proc help {args} { |
||||
#' **%ensemblecommand% help** *args* |
||||
#' |
||||
#' Help for ensemble commands in the command line interface |
||||
#' |
||||
#' |
||||
#' Arguments: |
||||
#' |
||||
#' * args - first word of args is the helptopic requested - usually a command name |
||||
#' - calling help with no arguments will list available commands |
||||
#' |
||||
#' Returns: help text (text) |
||||
#' |
||||
#' Examples: |
||||
#' |
||||
#' ``` |
||||
#' %ensemblecommand% help <commandname> |
||||
#' ``` |
||||
#' |
||||
#' |
||||
|
||||
|
||||
#extension.= @@opts/@?@-extension,args@@args=>. [_split_args $args] {| |
||||
# >} inspect -label a {| |
||||
# >} .=e>end,data>end pipeswitch { |
||||
# pipecase ,0/1/#= $switchargs {| |
||||
# e/0 |
||||
# >} .=>. {set e} |
||||
# pipecase /1,1/1/#= $switchargs |
||||
#} |@@ok/result> <e/0| [namespace qualifiers [lindex [info level -1] 0]] |
||||
|
||||
|
||||
#--------- |
||||
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||
lassign [_split_args $args] _opts opts _args args |
||||
if {[dict exists $opts -extension]} { |
||||
set extension [dict get $opts -extension] |
||||
} else { |
||||
set extension "" |
||||
} |
||||
#--------- |
||||
|
||||
|
||||
|
||||
if {![string length $extension]} { |
||||
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||
} |
||||
#puts stderr "-1:[info level -1]" |
||||
|
||||
set command_info [punk::mix::base::get_commands -extension $extension] |
||||
set subhelp1 [lindex $args 0] |
||||
if {[string length $subhelp1]} { |
||||
if {[regexp {[*?]} $subhelp1]} { |
||||
set helpstr "" |
||||
append helpstr "matched commands:\n" |
||||
dict for {source cmdlist} $command_info { |
||||
set matches [lsearch -all -inline -glob $cmdlist $subhelp1] |
||||
if {[llength $matches]} { |
||||
append helpstr \n " $source" |
||||
foreach cmd $matches { |
||||
append helpstr \n " - $cmd" |
||||
} |
||||
} |
||||
} |
||||
return $helpstr |
||||
} else { |
||||
dict for {source cmdlist} $command_info { |
||||
if {$subhelp1 in $cmdlist} { |
||||
if {$source eq "base"} { |
||||
set ns [namespace current] |
||||
} else { |
||||
set ns $extension |
||||
} |
||||
set procname ${ns}::$subhelp1 |
||||
if {$procname in [info procs $procname]} { |
||||
return "proc: $subhelp1 arguments: [info args $procname]" |
||||
} else { |
||||
set a [interp alias {} ${ns}::$subhelp1] |
||||
if {[string length $a]} { |
||||
return "alias: $subhelp1 target: $a" |
||||
} else { |
||||
return "command: $subhelp1 (No info available)" |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
return "No info found" |
||||
} |
||||
|
||||
} |
||||
#result for just 'pmix help' |
||||
set helpstr "" |
||||
append helpstr "commands:\n" |
||||
|
||||
foreach {source cmdlist} $command_info { |
||||
append helpstr \n " $source" |
||||
foreach cmd $cmdlist { |
||||
append helpstr \n " - $cmd" |
||||
} |
||||
} |
||||
return $helpstr |
||||
} |
||||
#proc dostuff {args} { |
||||
# extension@@opts/@?@-extension,args@@args= [_split_args $args] |
||||
# puts stdout "base doingstuff-with-args:'$args'-in-namespace:'[namespace current]'" |
||||
#} |
||||
namespace eval lib { |
||||
variable sha3_implementation "" ;#set by cksum_algorithms (which is called by cksum_path) It looks for fossil or sqlite3. Todo - add proper Tcl implementation. |
||||
namespace export * |
||||
|
||||
#----------------------------------------------------- |
||||
#literate-programming style naming for some path tests |
||||
#Note the naming of the operator portion of a_op_b is consistent in that it is the higher side of the filesystem tree first. |
||||
#hence aboveorat vs atorbelow |
||||
#These names also sort in the logical order of higher to lower in the filesystem (when considering the root as 'higher' in the filesystem) |
||||
proc path_a_above_b {path_a path_b} { |
||||
#stripPath prefix path |
||||
return [expr {[fileutil::stripPath $path_a $path_b] ni [list . $path_b]}] |
||||
} |
||||
proc path_a_aboveorat_b {path_a path_b} { |
||||
return [expr {[fileutil::stripPath $path_a $path_b] ne $path_b}] |
||||
} |
||||
proc path_a_at_b {path_a path_b} { |
||||
return [expr {[fileutil::stripPath $path_a $path_b] eq "." }] |
||||
} |
||||
proc path_a_atorbelow_b {path_a path_b} { |
||||
return [expr {[fileutil::stripPath $path_b $path_a] ne $path_a}] |
||||
} |
||||
proc path_a_below_b {path_a path_b} { |
||||
return [expr {[fileutil::stripPath $path_b $path_a] ni [list . $path_a]}] |
||||
} |
||||
proc path_a_inlinewith_b {path_a path_b} { |
||||
return [expr {[path_a_aboveorat_b $path_a $path_b] || [path_a_below_b $path_a $path_b]}] |
||||
} |
||||
#----------------------------------------------------- |
||||
|
||||
|
||||
|
||||
#find src/something folders which are not certain known folders with other purposes, (such as: bootsupport .vfs folders or vendor folders etc) and contain .tm file(s) |
||||
proc find_source_module_paths {{path {}}} { |
||||
if {![string length [set candidate [punk::repo::find_candidate $path]]]} { |
||||
error "find_source_module_paths cannot determine a suitable project root at or above path '$path' - path supplied should be within a project" |
||||
} |
||||
#we can return module paths even if the project isn't yet under revision control |
||||
set src_subs [glob -nocomplain -dir [file join $candidate src] -type d -tail *] |
||||
set antipatterns [list *.vfs vendor* lib _build doc embedded runtime bootsupport] |
||||
set tm_folders [list] |
||||
foreach sub $src_subs { |
||||
set is_ok 1 |
||||
foreach anti $antipatterns { |
||||
if {[string match $anti $sub]} { |
||||
set is_ok 0 |
||||
break |
||||
} |
||||
} |
||||
if {!$is_ok} { |
||||
continue |
||||
} |
||||
set testfolder [file join $candidate src $sub] |
||||
set tmfiles [glob -nocomplain -dir $testfolder -type f -tail *.tm] |
||||
if {[llength $tmfiles]} { |
||||
lappend tm_folders $testfolder |
||||
} |
||||
} |
||||
return $tm_folders |
||||
} |
||||
|
||||
proc mix_templates_dir {} { |
||||
puts stderr "mix_templates_dir WARNING: deprecated - use get_template_basefolders instead" |
||||
set provide_statement [package ifneeded punk::mix [package require punk::mix]] |
||||
set tmdir [file dirname [lindex $provide_statement end]] |
||||
set tpldir $tmdir/mix/templates |
||||
if {![file exists $tpldir]} { |
||||
error "punk::mix::lib::mix_templates_dir unable to locate mix templates folder at '$tpldir'" |
||||
} |
||||
return $tpldir |
||||
} |
||||
|
||||
#get_template_basefolders |
||||
# scriptpath - file or folder |
||||
# It represents the base point from which to search for mixtemplates folders either directly related to the scriptpath (../) or in the containing project if any |
||||
# The cwd will also be searched for project root - but with lower precedence in the resultset (later in list) |
||||
proc get_template_basefolders {{scriptpath ""}} { |
||||
#1 lowest precedence - templates from packages (ordered by order in which packages registered with punk::cap) |
||||
set folderdict [dict create] |
||||
set template_folder_dict [punk::cap::templates::folders] |
||||
dict for {dir folderinfo} $template_folder_dict { |
||||
dict set folderdict $dir $folderinfo |
||||
} |
||||
|
||||
#2 middle precedence - mixtemplates folder relative to cwd |
||||
set searchbase [pwd] |
||||
set fld [file join $searchbase mixtemplates] |
||||
if {[file isdirectory $fld]} { |
||||
if {![dict exists $folderdict $fld]} { |
||||
dict set folderdict $fld [list source $searchbase sourcetype cwd] |
||||
} |
||||
} |
||||
set pathinfo [punk::repo::find_repos $searchbase] |
||||
set pwd_projectroot [dict get $pathinfo closest] |
||||
if {$pwd_projectroot ne ""} { |
||||
set fld [file join $pwd_projectroot src/mixtemplates] |
||||
if {![dict exists $folderdict $fld]} { |
||||
dict set folderdict $fld [list source $pwd_projectroot sourcetype project] |
||||
} |
||||
} |
||||
|
||||
#3 highest precedence - mixtemplates relative to scriptpath argument |
||||
if {$scriptpath ne ""} { |
||||
if {[file type $scriptpath] eq "file"} { |
||||
set searchbase [file dirname $scriptpath] |
||||
} else { |
||||
set searchbase $scriptpath |
||||
} |
||||
if {[file isdirectory [file join $searchbase mixtemplates]]} { |
||||
dict set folderdict [file join $searchbase mixtemplates] [list source $searchbase sourcetype pathsearch] |
||||
} |
||||
set pathinfo [punk::repo::find_repos $searchbase] |
||||
set scriptpath_projectroot [dict get $pathinfo closest] |
||||
if {$scriptpath_projectroot ne ""} { |
||||
set fld [file join $scriptpath_projectroot src/mixtemplates] |
||||
if {[file isdirectory $fld]} { |
||||
dict set folderdict $fld [list source $scriptpath_projectroot sourcetype project] |
||||
} |
||||
} |
||||
} |
||||
#don't sort - order in which encountered defines the precedence - with later overriding earlier |
||||
return $folderdict |
||||
} |
||||
|
||||
proc module_subpath {modulename} { |
||||
set modulename [string trim $modulename :] |
||||
set nsq [namespace qualifiers $modulename] |
||||
return [string map [list :: /] $nsq] |
||||
} |
||||
|
||||
proc get_build_workdir {path} { |
||||
set repo_info [punk::repo::find_repos $path] |
||||
set base [lindex [dict get $repo_info project] 0] |
||||
if {![string length $base]} { |
||||
error "get_build_workdir unable to determine project base for path '$path'" |
||||
} |
||||
if {![file exists $base/src] || ![file writable $base/src]} { |
||||
error "get_build_workdir unable to access $base/src" |
||||
} |
||||
file mkdir $base/src/_build |
||||
return $base/src/_build |
||||
} |
||||
|
||||
|
||||
|
||||
#todo - move cksum stuff to punkcheck - more logical home |
||||
proc cksum_path_content {path args} { |
||||
dict set args -cksum_content 1 |
||||
dict set args -cksum_meta 0 |
||||
tailcall cksum_path $path {*}$args |
||||
} |
||||
|
||||
#not just used by cksum_path. used by caller (e.g fill_relativecksums_from_base_and_relativepathdict via cksum_filter_opts) to determine what opt names passed through |
||||
proc cksum_default_opts {} { |
||||
return [dict create -cksum_content 1 -cksum_meta auto -cksum_acls 0 -cksum_usetar auto -cksum_algorithm sha1] |
||||
} |
||||
|
||||
#crc::cksum is extremely slow in tcllib as at 2023 e.g 20x slower (no c implementation?) |
||||
#sha1 is performant - and this is not being used in a cryptographic or adversarial context - so performance and practical unlikelihood of accidental collisions should be the main consideration. |
||||
#adler32 is fastest for some larger files of a few MB but slower on small files (possibly due to Tcl-based file load?) |
||||
#sha1 as at 2023 seems a good default |
||||
proc cksum_algorithms {} { |
||||
variable sha3_implementation |
||||
#sha2 is an alias for sha256 |
||||
#2023 - no sha3 available in tcllib - we can exec fossil for now - which will be very slow |
||||
set algs [list md5 sha1 sha2 sha256 cksum adler32] |
||||
set sha3_algs [list sha3 sha3-224 sha3-256 sha3-384 sha3-512] |
||||
if {[auto_execok sqlite3] ne ""} { |
||||
lappend algs {*}$sha3_algs |
||||
set sha3_implementation sqlite3_sha3 |
||||
} else { |
||||
if {[auto_execok fossil] ne ""} { |
||||
lappend algs {*}$sha3_algs |
||||
set sha3_implementation fossil_sha3 |
||||
} |
||||
} |
||||
return $algs |
||||
} |
||||
|
||||
proc sqlite3_sha3 {bits filename} { |
||||
return [exec sqlite3 :memory: "select lower(hex(sha3(readfile('$filename'),$bits)))"] |
||||
} |
||||
proc fossil_sha3 {bits filename} { |
||||
return [lindex [exec fossil sha3sum -$bits $filename] 0] |
||||
} |
||||
|
||||
#adler32 via file-slurp |
||||
proc cksum_adler32_file {filename} { |
||||
package require zlib; #should be builtin anyway |
||||
set data [punk::mix::util::fcat -translation binary $filename] |
||||
#set data [fileutil::cat -translation binary $filename] ;#no significant performance diff on windows - and doesn't handle win-illegal names |
||||
zlib adler32 $data |
||||
} |
||||
|
||||
|
||||
#required to be able to accept relative paths |
||||
#for full cksum - using tar could reduce number of hashes to be made.. |
||||
#but as it stores metadata such as permission - we don't know if/how the archive will vary based on platform/filesystem |
||||
#-noperms only available on extraction - so that doesn't help |
||||
#Needs to operate on non-existant paths and return empty string in cksum field |
||||
proc cksum_path {path args} { |
||||
variable sha3_implementation |
||||
if {$path eq {}} { set path [pwd] } |
||||
if {[file pathtype $path] eq "relative"} { |
||||
set path [file normalize $path] |
||||
} |
||||
set base [file dirname $path] |
||||
set startdir [pwd] |
||||
|
||||
set defaults [cksum_default_opts] |
||||
set known_opts [dict keys $defaults] |
||||
foreach {k v} $args { |
||||
if {$k ni $known_opts} { |
||||
error "cksum_path unknown option '$k' known_options: $known_opts" |
||||
} |
||||
} |
||||
|
||||
set opts [dict merge $defaults $args] |
||||
set opts_actual $opts ;#default - auto updated to 0 or 1 later |
||||
|
||||
#if {![file exists $path]} { |
||||
# return [list cksum "" opts $opts] |
||||
#} |
||||
|
||||
if {[catch {file type $path} ftype]} { |
||||
return [list cksum "<PATHNOTFOUND>" opts $opts] |
||||
} |
||||
if {$ftype ni [list file directory]} { |
||||
#review - links? |
||||
error "cksum_path error file type '$ftype' not supported" |
||||
} |
||||
|
||||
|
||||
set opt_cksum_algorithm [dict get $opts -cksum_algorithm] |
||||
if {$opt_cksum_algorithm ni [cksum_algorithms]} { |
||||
return [list error unsupported_cksum_algorithm cksum "<ERR>" opts $opts] |
||||
} |
||||
set opt_cksum_acls [dict get $opts -cksum_acls] |
||||
if {$opt_cksum_acls} { |
||||
puts stderr "cksum_path is not yet able to cksum ACLs" |
||||
return |
||||
} |
||||
|
||||
set opt_cksum_meta [dict get $opts -cksum_meta] |
||||
set opt_use_tar [dict get $opts -cksum_usetar] |
||||
if {$ftype eq "file"} { |
||||
if {$opt_use_tar eq "auto"} { |
||||
if {$opt_cksum_meta eq "1"} { |
||||
set opt_use_tar 1 |
||||
} else { |
||||
#prefer no tar if meta not required - faster/simpler |
||||
#meta == auto or 0 |
||||
set opt_cksum_meta 0 |
||||
set opt_use_tar 0 |
||||
} |
||||
} elseif {$opt_use_tar eq "0"} { |
||||
if {$opt_cksum_meta eq "1"} { |
||||
puts stderr "cksum_path doesn't yet support a non-tar cksum with metadata for a file" |
||||
return [list error unsupported_meta_without_tar cksum "<ERR>" opts $opts] |
||||
} else { |
||||
#meta == auto or 0 |
||||
set opt_cksum_meta 0 |
||||
} |
||||
} else { |
||||
#tar == 1 |
||||
if {$opt_cksum_meta eq "0"} { |
||||
puts stderr "cksum_path doesn't yet support a tar cksum without metadata for a file" |
||||
return [list error unsupported_tar_without_meta cksum "<ERR>" opts $opts] |
||||
} else { |
||||
#meta == auto or 1 |
||||
set opt_cksum_meta 1 |
||||
} |
||||
} |
||||
} elseif {$ftype eq "directory"} { |
||||
if {$opt_use_tar eq "auto"} { |
||||
if {$opt_cksum_meta in [list "auto" "1"]} { |
||||
set opt_use_tar 1 |
||||
set opt_cksum_meta 1 |
||||
} else { |
||||
puts stderr "cksum_path doesn't yet support a content-only cksum of a folder structure. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto" |
||||
return [list error unsupported_directory_cksum_without_meta cksum "<ERR>" opts $opts] |
||||
} |
||||
} elseif {$opt_use_tar eq "0"} { |
||||
puts stderr "cksum_path doesn't yet support a cksum of a folder structure without tar. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" |
||||
return [list error unsupported_directory_cksum_without_tar cksum "<ERR>" opts $opts] |
||||
} else { |
||||
#tar 1 |
||||
if {$opt_cksum_meta eq "0"} { |
||||
puts stderr "cksum_path doesn't yet support a tar checksum of a folder structure without metadat. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" |
||||
return [list error unsupported_without_meta cksum "<ERR>" opts $opts] |
||||
} else { |
||||
#meta == auto or 1 |
||||
set opt_cksum_meta 1 |
||||
} |
||||
} |
||||
} |
||||
|
||||
dict set opts_actual -cksum_meta $opt_cksum_meta |
||||
dict set opts_actual -cksum_usetar $opt_use_tar |
||||
|
||||
|
||||
if {$opt_use_tar} { |
||||
package require tar ;#from tcllib |
||||
} |
||||
|
||||
if {$path eq $base} { |
||||
#attempting to cksum at root/volume level of a filesystem.. extra work |
||||
#This needs fixing for general use.. not necessarily just for project repos |
||||
puts stderr "cksum_path doesn't yet support cksum of entire volume. (todo)" |
||||
return [list error unsupported_path opts $opts] |
||||
} |
||||
|
||||
if {$opt_cksum_algorithm eq "sha1"} { |
||||
package require sha1 |
||||
set cksum_command [list sha1::sha1 -hex -file] |
||||
} elseif {$opt_cksum_algorithm in [list "sha2" "sha256"]} { |
||||
package require sha256 |
||||
set cksum_command [list sha2::sha256 -hex -file] |
||||
} elseif {$opt_cksum_algorithm eq "md5"} { |
||||
package require md5 |
||||
set cksum_command [list md5::md5 -hex -file] |
||||
} elseif {$opt_cksum_algorithm eq "cksum"} { |
||||
package require cksum ;#tcllib |
||||
set cksum_command [list crc::cksum -format 0x%X -file] |
||||
} elseif {$opt_cksum_algorithm eq "adler32"} { |
||||
set cksum_command [list cksum_adler32_file] |
||||
} elseif {$opt_cksum_algorithm in [list "sha3" "sha3-256"]} { |
||||
#todo - replace with something that doesn't call another process |
||||
#set cksum_command [list apply {{file} {lindex [exec fossil sha3sum -256 $file] 0}}] |
||||
set cksum_command [list $sha3_implementation 256] |
||||
} elseif {$opt_cksum_algorithm in [list "sha3-224" "sha3-384" "sha3-512"]} { |
||||
set bits [lindex [split $opt_cksum_algorithm -] 1] |
||||
#set cksum_command [list apply {{bits file} {lindex [exec fossil sha3sum -$bits $file] 0}} $bits] |
||||
set cksum_command [list $sha3_implementation $bits] |
||||
} |
||||
|
||||
set cksum "" |
||||
if {$opt_use_tar != 0} { |
||||
set target [file tail $path] |
||||
set tmplocation [punk::mix::util::tmpdir] |
||||
set archivename $tmplocation/[punk::mix::util::tmpfile].tar |
||||
|
||||
cd $base ;#cd is process-wide.. keep cd in effect for as small a scope as possible. (review for thread issues) |
||||
|
||||
#temp emission to stdout.. todo - repl telemetry channel |
||||
puts stdout "cksum_path: creating temporary tar archive at: $archivename .." |
||||
tar::create $archivename $target |
||||
if {$ftype eq "file"} { |
||||
set sizeinfo "(size [file size $target])" |
||||
} else { |
||||
set sizeinfo "(file type $ftype - size unknown)" |
||||
} |
||||
puts stdout "cksum_path: calculating cksum for $target $sizeinfo..." |
||||
set cksum [{*}$cksum_command $archivename] |
||||
#puts stdout "cksum_path: cleaning up.. " |
||||
file delete -force $archivename |
||||
cd $startdir |
||||
|
||||
} else { |
||||
#todo |
||||
if {$ftype eq "file"} { |
||||
if {$opt_cksum_meta} { |
||||
return [list error unsupported_opts_combo cksum "<ERR>" opts $opts] |
||||
} else { |
||||
set cksum [{*}$cksum_command $path] |
||||
} |
||||
} else { |
||||
error "cksum_path unsupported $opts for path type [file type $path]" |
||||
} |
||||
} |
||||
set result [dict create] |
||||
dict set result cksum $cksum |
||||
dict set result opts $opts_actual |
||||
return $result |
||||
} |
||||
|
||||
#dict_path_cksum keyed on path - with value as a dict that must contain cksum key - but can contain other keys |
||||
#e.g -cksum_usetar which is one of the keys understood by the punk::mix::base::lib::cksum_path function - or unrelated keys which will also be passed through |
||||
#cksum only calculated for keys in dict where cksum is empty - ie return same dict but with empty cksums filled out. |
||||
#base can be empty string in which case paths must be absolute |
||||
proc fill_relativecksums_from_base_and_relativepathdict {base {dict_path_cksum {}}} { |
||||
if {$base eq ""} { |
||||
set error_paths [list] |
||||
dict for {path pathinfo} $dict_path_cksum { |
||||
if {[file pathtype $path] ne "absolute"} { |
||||
lappend error_paths $path |
||||
} |
||||
} |
||||
if {[llength $error_paths]} { |
||||
puts stderr "get_relativecksums_from_base_and_relativepathdict has empty base - and non-absolute paths in the supplied checksum dict - aborting" |
||||
puts stderr "error_paths: $error_paths" |
||||
error "fill_relativecksums_from_base_and_relativepathdict error: non-absolute paths when base empty. $error_paths" |
||||
} |
||||
} else { |
||||
if {[file pathtype $base] ne "absolute"} { |
||||
error "fill_relativecksums_from_base_and_relativepathdict error: base supplied but was not absolute path. $base" |
||||
} |
||||
#conversely now we have a base - so we require all paths are relative. |
||||
#We will ignore/disallow volume-relative - as these shouldn't be used here either |
||||
set error_paths [list] |
||||
dict for {path pathinfo} $dict_path_cksum { |
||||
if {[file pathtype $path] ne "relative"} { |
||||
lappend error_paths $path |
||||
} |
||||
} |
||||
if {[llength $error_paths]} { |
||||
puts stderr "fill_relativecksums_from_base_and_relativepathdict has a supplied absolute base path, but some of the paths in the supplied dict are not relative - aborting" |
||||
error "fill_relativecksums_from_base_and_relativepathdict error: non-relative paths when base supplied. $error_paths" |
||||
} |
||||
} |
||||
|
||||
|
||||
dict for {path pathinfo} $dict_path_cksum { |
||||
if {![dict exists $pathinfo cksum]} { |
||||
dict set pathinfo cksum "" |
||||
} else { |
||||
if {[dict get $pathinfo cksum] ne "" && ![cksum_is_tag [dict get $pathinfo cksum]]} { |
||||
continue ;#already filled with non-tag value |
||||
} |
||||
} |
||||
if {$base ne ""} { |
||||
set fullpath [file join $base $path] |
||||
} else { |
||||
set fullpath $path |
||||
} |
||||
|
||||
set ckopts [cksum_filter_opts {*}$pathinfo] |
||||
|
||||
if {![file exists $fullpath]} { |
||||
dict set dict_path_cksum $path cksum "<PATHNOTFOUND>" |
||||
} else { |
||||
set ckinfo [cksum_path $fullpath {*}$ckopts] |
||||
dict set dict_path_cksum $path cksum [dict get $ckinfo cksum] |
||||
dict set dict_path_cksum $path cksum_all_opts [dict get $ckinfo opts] |
||||
if {[dict exists $ckinfo error]} { |
||||
dict set dict_path_cksum $path cksum_error [dict get $ckinfo error] |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $dict_path_cksum |
||||
} |
||||
#whether cksum is <XXX> e.g <ERR> <PATHNOTFOUND> |
||||
proc cksum_is_tag {cksum} { |
||||
expr {[string index $cksum 0] eq "<" && [string index $cksum end] eq ">"} |
||||
} |
||||
proc cksum_filter_opts {args} { |
||||
set ck_opt_names [dict keys [cksum_default_opts]] |
||||
set ck_opts [dict create] |
||||
dict for {k v} $args { |
||||
if {$k in $ck_opt_names} { |
||||
dict set ck_opts $k $v |
||||
} |
||||
} |
||||
return $ck_opts |
||||
} |
||||
|
||||
#convenience so caller doesn't have to pre-calculate the relative path from the base |
||||
#Note semantic difference from fill_relativecksums_from_base_and_relativepathdict (hence get_ vs fill_) |
||||
#Here we will raise an error if cksum exists and is not empty or a tag - whereas the multiple path version will ignore valid-looking prefilled cksum values |
||||
#base is the presumed location to store the checksum file. The caller should retain (normalize if relative) |
||||
proc get_relativecksum_from_base {base specifiedpath args} { |
||||
if {$base ne ""} { |
||||
#targetpath ideally should be within same project tree as base if base supplied - but not necessarily below it |
||||
#we don't necessarily want to restrict this to use in punk projects though - so we'll allow anything with a common prefix |
||||
if {[file pathtype $specifiedpath] eq "relative"} { |
||||
if {[file pathtype $base] eq "relative"} { |
||||
set normbase [file normalize $base] |
||||
set normtarg [file normalize [file join $normbase $specifiedpath]] |
||||
set targetpath $normtarg |
||||
set storedpath [punk::mix::util::path_relative $normbase $normtarg] |
||||
} else { |
||||
set targetpath [file join $base $specifiedpath] |
||||
set storedpath $specifiedpath |
||||
} |
||||
} else { |
||||
#specifed absolute |
||||
if {[file pathtype $base] eq "relative"} { |
||||
#relative to cwd or to specifiedpath? For consistency it should arguably be cwd but a case could be made that when one path is relative it is in reference to the other |
||||
#there is a strong possibility that allowing this combination will cause confusion - better to disallow |
||||
error "get_relativecksum_from_base error: disallowed pathtype combination. Base must be empty or absolute when specified path is absolute" |
||||
} |
||||
#both absolute - compute relative path if they share a common prefix |
||||
set commonprefix [punk::mix::util::path_common_prefix $base $specifiedpath] |
||||
if {$commonprefix eq ""} { |
||||
#absolute base with no shared prefix doesn't make sense - we could ignore it - but better to error-out and require the caller specify an empty base |
||||
error "get_relativecksum_from_base error: base '$base' and specifiedpath '$specifiedpath' don't share a common root. Use empty-string for base if independent absolute path is required" |
||||
} |
||||
set targetpath $specifiedpath |
||||
set storedpath [punk::mix::util::path_relative $base $specifiedpath] |
||||
|
||||
} |
||||
} else { |
||||
if {[file type $specifiedpath] eq "relative"} { |
||||
#if specifiedpath is relative - and we don't have a base, we now need to convert relative to cwd to an absolute path for storage |
||||
set targetpath [file normalize $specifiedpath] |
||||
set storedpath $targetpath |
||||
} else { |
||||
set targetpath $specifiedpath |
||||
set storedpath $targetpath |
||||
} |
||||
} |
||||
|
||||
# |
||||
#NOTE: specifiedpath can be a relative path (to cwd) when base is empty |
||||
#OR - a relative path when base itself is relative e.g base: somewhere targetpath somewhere/etc |
||||
#possibly also: base: somewhere targetpath: ../elsewhere/etc |
||||
# |
||||
#todo - write tests |
||||
|
||||
|
||||
if {([llength $args] % 2) != 0} { |
||||
error "get_relativecksum_from_base error. args supplied must be in the form of key-value pairs. received '$args' " |
||||
} |
||||
if {[dict exists $args cksum]} { |
||||
if {[dict get $args cksum] ne "" && ![cksum_is_tag [dict get $args cksum]]} { |
||||
error "get_relativecksum_from_base called with existing cksum value (and is not a tag or empty-value to be replaced) cksum: [dict get $args cksum] Set cksum to be empty, any tag such as <REPLACE> or remove the key and try again." |
||||
} |
||||
} |
||||
|
||||
|
||||
set ckopts [cksum_filter_opts {*}$args] |
||||
set ckinfo [cksum_path $targetpath {*}$ckopts] |
||||
|
||||
set keyvals $args |
||||
dict set keyvals cksum [dict get $ckinfo cksum] |
||||
dict set keyvals cksum_all_opts [dict get $ckinfo opts] |
||||
if {[dict exists $ckinfo error]} { |
||||
dict set keyvals cksum_error [dict get $ckinfo error] |
||||
} |
||||
|
||||
#set relpath [punk::repo::path_strip_alreadynormalized_prefixdepth $fullpath $base] ;#empty base ok noop |
||||
#storedpath is relative if possible |
||||
return [dict create $storedpath $keyvals] |
||||
} |
||||
|
||||
#calculate the runtime checksum and vfs checksums |
||||
proc get_all_vfs_build_cksums {path} { |
||||
set buildfolder [get_build_workdir $path] |
||||
set cksum_base_folder [file dirname $buildfolder] ;#this is the <project>/src folder - a reasonable base for our vfs cksums |
||||
set dict_cksums [dict create] |
||||
|
||||
set buildrelpath [punk::repo::path_strip_alreadynormalized_prefixdepth $buildfolder $cksum_base_folder] |
||||
set vfs_tail_list [glob -nocomplain -dir $cksum_base_folder -type d -tails *.vfs] |
||||
|
||||
foreach vfstail $vfs_tail_list { |
||||
set vname [file rootname $vfstail] |
||||
dict set dict_cksums $vfstail [list cksum ""] |
||||
dict set dict_cksums [file join $buildrelpath $vname.exe] [list cksum ""] |
||||
} |
||||
|
||||
set fullpath_buildruntime $buildfolder/buildruntime.exe |
||||
|
||||
set ckinfo_buildruntime [cksum_path $fullpath_buildruntime] |
||||
set ck [dict get $ckinfo_buildruntime cksum] |
||||
|
||||
|
||||
set relpath [file join $buildrelpath "buildruntime.exe"] |
||||
dict set dict_cksums $relpath [list cksum $ck] |
||||
|
||||
set dict_cksums [fill_relativecksums_from_base_and_relativepathdict $cksum_base_folder $dict_cksums] |
||||
|
||||
return $dict_cksums |
||||
} |
||||
|
||||
proc get_vfs_build_cksums_stored {vfsfolder} { |
||||
set vfscontainer [file dirname $vfsfolder] |
||||
set buildfolder $vfscontainer/_build |
||||
set vfs [file tail $vfsfolder] |
||||
set vname [file rootname $vfs] |
||||
set dict_vfs [list $vname.vfs "" $vname.exe "" buildruntime.exe ""] |
||||
set ckfile $buildfolder/$vname.cksums |
||||
if {[file exists $ckfile]} { |
||||
set data [punk::mix::util::fcat -translation binary $ckfile] |
||||
foreach ln [split $data \n] { |
||||
if {[string trim $ln] eq ""} {continue} |
||||
lassign $ln path cksum |
||||
dict set dict_vfs $path $cksum |
||||
} |
||||
} |
||||
return $dict_vfs |
||||
} |
||||
proc get_all_build_cksums_stored {path} { |
||||
set buildfolder [get_build_workdir $path] |
||||
|
||||
set vfscontainer [file dirname $buildfolder] |
||||
set vfslist [glob -nocomplain -dir $vfscontainer -type d -tail *.vfs] |
||||
set dict_cksums [dict create] |
||||
foreach vfs $vfslist { |
||||
set vname [file rootname $vfs] |
||||
set dict_vfs [get_vfs_build_cksums_stored $vfscontainer/$vfs] |
||||
|
||||
dict set dict_cksums $vname $dict_vfs |
||||
} |
||||
return $dict_cksums |
||||
} |
||||
|
||||
proc store_vfs_build_cksums {vfsfolder} { |
||||
if {![file isdirectory $vfsfolder]} { |
||||
error "Unable to find supplied vfsfolder: $vfsfolder" |
||||
} |
||||
set vfscontainer [file dirname $vfsfolder] |
||||
set buildfolder $vfscontainer/_build |
||||
set dict_vfs [get_vfs_build_cksums $vfsfolder] |
||||
set data "" |
||||
dict for {path cksum} $dict_vfs { |
||||
append data "$path $cksum" \n |
||||
} |
||||
set fd [open $buildfolder/$vname.cksums w] |
||||
chan configure $fd -translation binary |
||||
puts $fd $data |
||||
close $fd |
||||
return $dict_vfs |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
} |
||||
@ -0,0 +1,909 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::cli 0.3 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
package require punk::repo |
||||
package require punkcheck ;#checksum and/or timestamp records |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
namespace eval punk::mix::cli { |
||||
namespace eval temp_import { |
||||
} |
||||
namespace ensemble create |
||||
|
||||
package require punk::overlay |
||||
catch { |
||||
punk::overlay::import_commandset module . ::punk::mix::commandset::module |
||||
} |
||||
punk::overlay::import_commandset debug . ::punk::mix::commandset::debug |
||||
punk::overlay::import_commandset repo . ::punk::mix::commandset::repo |
||||
punk::overlay::import_commandset lib . ::punk::mix::commandset::loadedlib |
||||
|
||||
catch { |
||||
package require punk::mix::commandset::project |
||||
punk::overlay::import_commandset project . ::punk::mix::commandset::project |
||||
punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection |
||||
} |
||||
if {[catch { |
||||
package require punk::mix::commandset::layout |
||||
punk::overlay::import_commandset project.layout . ::punk::mix::commandset::layout |
||||
punk::overlay::import_commandset project.layouts . ::punk::mix::commandset::layout::collection |
||||
} errM]} { |
||||
puts stderr "error loading punk::mix::commandset::layout" |
||||
puts stderr $errM |
||||
} |
||||
if {[catch { |
||||
package require punk::mix::commandset::buildsuite |
||||
punk::overlay::import_commandset buildsuite . ::punk::mix::commandset::buildsuite |
||||
punk::overlay::import_commandset buildsuites . ::punk::mix::commandset::buildsuite::collection |
||||
} errM]} { |
||||
puts stderr "error loading punk::mix::commandset::buildsuite" |
||||
puts stderr $errM |
||||
} |
||||
punk::overlay::import_commandset scriptwrap . ::punk::mix::commandset::scriptwrap |
||||
if {[catch { |
||||
package require punk::mix::commandset::doc |
||||
punk::overlay::import_commandset doc . ::punk::mix::commandset::doc |
||||
punk::overlay::import_commandset "" "" ::punk::mix::commandset::doc::collection |
||||
} errM]} { |
||||
puts stderr "error loading punk::mix::commandset::doc" |
||||
puts stderr $errM |
||||
} |
||||
|
||||
|
||||
proc help {args} { |
||||
#set basehelp [punk::mix::base::help -extension [namespace current] {*}$args] |
||||
set basehelp [punk::mix::base help {*}$args] |
||||
#puts stdout "punk::mix help" |
||||
return $basehelp |
||||
} |
||||
|
||||
proc stat {{workingdir ""} args} { |
||||
dict set args -v 0 |
||||
punk::mix::cli::lib::get_status $workingdir {*}$args |
||||
} |
||||
proc status {{workingdir ""} args} { |
||||
dict set args -v 1 |
||||
punk::mix::cli::lib::get_status $workingdir {*}$args |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
namespace eval punk::mix::cli { |
||||
|
||||
|
||||
#interp alias {} ::punk::mix::cli::project.new {} ::punk::mix::cli::new |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
proc make {args} { |
||||
set startdir [pwd] |
||||
set project_base "" ;#empty for unknown |
||||
if {[punk::repo::is_git $startdir]} { |
||||
set project_base [punk::repo::find_git] |
||||
set sourcefolder $project_base/src |
||||
} elseif {[punk::repo::is_fossil $startdir]} { |
||||
set project_base [punk::repo::find_fossil] |
||||
set sourcefolder $project_base/src |
||||
} else { |
||||
if {[punk::repo::is_candidate $startdir]} { |
||||
set project_base [punk::repo::find_candidate] |
||||
set sourcefolder $project_base/src |
||||
puts stderr "WARNING - project not under git or fossil control" |
||||
puts stderr "Using base folder $project_base" |
||||
} else { |
||||
set sourcefolder $startdir |
||||
} |
||||
} |
||||
|
||||
#review - why can't we be anywhere in the project? |
||||
if {([file tail $sourcefolder] ne "src") || (![file exists $sourcefolder/make.tcl])} { |
||||
puts stderr "pmix make must be run from src folder containing make.tcl - unable to proceed (cwd: [pwd])" |
||||
if {[string length $project_base]} { |
||||
if {[file exists $project_base/src] && [string tolower [pwd]] ne [string tolower $project_base/src]} { |
||||
puts stderr "Try cd to $project_base/src" |
||||
} |
||||
} else { |
||||
if {[file exists $startdir/Makefile]} { |
||||
puts stdout "A Makefile exists at $startdir/Makefile." |
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
puts stdout "Try running: msys2 -ucrt64 -here -c \"make build\" or bash -c \"make build\"" |
||||
} else { |
||||
puts stdout "Try runing: make build" |
||||
} |
||||
} |
||||
} |
||||
return false |
||||
} |
||||
|
||||
if {![string length $project_base]} { |
||||
puts stderr "WARNING no git or fossil repository detected." |
||||
puts stderr "Using base folder $startdir" |
||||
set project_base $startdir |
||||
} |
||||
|
||||
set lc_this_exe [string tolower [info nameofexecutable]] |
||||
set lc_proj_bin [string tolower $project_base/bin] |
||||
set lc_build_bin [string tolower $project_base/src/_build] |
||||
|
||||
if {"project" in $args} { |
||||
set is_own_exe 0 |
||||
if {[string match "${lc_proj_bin}*" $lc_this_exe] || [string match "${lc_build_bin}" $lc_this_exe]} { |
||||
set is_own_exe 1 |
||||
puts stderr "WARNING - running make using executable that may be created by the project being built" |
||||
set answer [util::askuser "Do you want to proceed using this executable? (build will probably stop when it is unable to update the executable) Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
} |
||||
cd $sourcefolder |
||||
#use run so that stdout visible as it goes |
||||
if {![catch {run --timeout=5000 -debug [info nameofexecutable] $sourcefolder/make.tcl {*}$args} exitinfo]} { |
||||
puts stderr "exitinfo: $exitinfo" |
||||
set exitcode [dict get $exitinfo exitcode] |
||||
} else { |
||||
puts stderr "Error unable to determine exitcode. err: $exitinfo" |
||||
cd $startdir |
||||
return false |
||||
} |
||||
|
||||
cd $startdir |
||||
if {$exitcode != 0} { |
||||
puts stderr "FAILED with exitcode $exitcode" |
||||
return false |
||||
} else { |
||||
puts stdout "OK make finished " |
||||
return true |
||||
} |
||||
} |
||||
|
||||
proc Kettle {args} { |
||||
tailcall lib::kettle_call lib {*}$args |
||||
} |
||||
proc KettleShell {args} { |
||||
tailcall lib::kettle_call shell {*}$args |
||||
} |
||||
|
||||
|
||||
|
||||
namespace eval lib { |
||||
namespace path ::punk::mix::util |
||||
|
||||
|
||||
proc module_types {} { |
||||
#first in list is default for unspecified -type when creating new module |
||||
return [list plain tarjar zipkit] |
||||
} |
||||
|
||||
proc validate_modulename {modulename args} { |
||||
set defaults [list\ |
||||
-name_description modulename\ |
||||
] |
||||
if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"} |
||||
set known_opts [dict keys $defaults] |
||||
foreach k [dict keys $args] { |
||||
if {$k ni $known_opts} { |
||||
error "validate_modulename error: unknown option $k. known options: $known_opts" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_name_description [dict get $opts -name_description] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
|
||||
validate_name_not_empty_or_spaced $modulename -name_description $opt_name_description |
||||
set testname [string map [list :: ""] $modulename] |
||||
if {[string first : $testname] >=0} { |
||||
error "$opt_name_description '$modulename' can only contain paired colons" |
||||
} |
||||
set badchars [list - "$" "?" "*"] |
||||
foreach bc $badchars { |
||||
if {[string first $bc $modulename] >= 0} { |
||||
error "$opt_name_description '$modulename' can not contain character '$bc'" |
||||
} |
||||
} |
||||
return $modulename |
||||
} |
||||
|
||||
proc validate_projectname {projectname args} { |
||||
set defaults [list\ |
||||
-name_description projectname\ |
||||
] |
||||
if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"} |
||||
set known_opts [dict keys $defaults] |
||||
foreach k [dict keys $args] { |
||||
if {$k ni $known_opts} { |
||||
error "validate_modulename error: unknown option $k. known options: $known_opts" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_name_description [dict get $opts -name_description] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
validate_name_not_empty_or_spaced $projectname -name_description $opt_name_description |
||||
set reserved_words [list etc lib bin modules src doc vendorlib vendormodules embedded runtime _aside _build] |
||||
if {$projectname in $reserved_words } { |
||||
error "$opt_name_description '$projectname' cannot be one of reserved_words: $reserved_words" |
||||
} |
||||
if {[string first "::" $projectname] >= 0} { |
||||
error "$opt_name_description '$projectname' cannot contain namespace separator '::'" |
||||
} |
||||
return $projectname |
||||
} |
||||
proc validate_name_not_empty_or_spaced {name args} { |
||||
set defaults [list\ |
||||
-name_description projectname\ |
||||
] |
||||
if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"} |
||||
set known_opts [dict keys $defaults] |
||||
foreach k [dict keys $args] { |
||||
if {$k ni $known_opts} { |
||||
error "validate_modulename error: unknown option $k. known options: $known_opts" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_name_description [dict get $opts -name_description] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
if {![string length $name]} { |
||||
error "$opt_name_description cannot be empty" |
||||
} |
||||
if {[string length [string map [list " " "" \n "" \r "" \t ""] $name]] != [string length $name]} { |
||||
error "$opt_name_description cannot contain whitespace" |
||||
} |
||||
return $name |
||||
} |
||||
|
||||
#split modulename (as present in a filename or namespaced name) into name/version ignoring leading namespace path |
||||
#ignore trailing .tm .TM if present |
||||
#if version doesn't pass validation - treat it as part of the modulename and return empty version string without error |
||||
#Up to caller to validate. |
||||
proc split_modulename_version {modulename} { |
||||
set lastpart [namespace tail $modulename] |
||||
set lastpart [file tail $lastpart] ;# should be ok to use file tail now that we've ensured no namespace components |
||||
if {[string equal -nocase [file extension $modulename] ".tm"]} { |
||||
set fileparts [split [file rootname $lastpart] -] |
||||
} else { |
||||
set fileparts [split $lastpart -] |
||||
} |
||||
if {[punk::mix::util::is_valid_tm_version [lindex $fileparts end]]} { |
||||
set versionsegment [lindex $fileparts end] |
||||
set namesegment [join [lrange $fileparts 0 end-1] -];#re-stitch |
||||
} else { |
||||
# |
||||
set namesegment [join $fileparts -] |
||||
set versionsegment "" |
||||
} |
||||
return [list $namesegment $versionsegment] |
||||
} |
||||
|
||||
proc get_status {{workingdir ""} args} { |
||||
set result "" |
||||
if {$workingdir ne ""} { |
||||
if {[file pathtype $workingdir] ne "absolute"} { |
||||
set workingdir [file normalize $workingdir] |
||||
} |
||||
set active_dir $workingdir |
||||
} else { |
||||
set active_dir [pwd] |
||||
} |
||||
set defaults [dict create\ |
||||
-v 1\ |
||||
] |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- --- --- |
||||
set opt_v [dict get $opts -v] |
||||
# -- --- --- --- --- --- --- --- --- |
||||
|
||||
|
||||
set repopaths [punk::repo::find_repos [pwd]] |
||||
set repos [dict get $repopaths repos] |
||||
if {![llength $repos]} { |
||||
append result [dict get $repopaths warnings] |
||||
} else { |
||||
append result [dict get $repopaths warnings] |
||||
lassign [lindex $repos 0] repopath repotypes |
||||
if {"fossil" in $repotypes} { |
||||
#review - multiple process launches to fossil a bit slow on windows.. |
||||
#could we query global db in one go instead? |
||||
# |
||||
set fossil_prog [auto_execok fossil] |
||||
append result "FOSSIL project based at $repopath with revision: [punk::repo::fossil_revision $repopath]" \n |
||||
set fosinfo [exec {*}$fossil_prog info] |
||||
append result [join [punk::repo::grep {repository:*} $fosinfo] \n] \n |
||||
|
||||
set fosrem [exec {*}$fossil_prog remote ls] |
||||
if {[string length $fosrem]} { |
||||
append result "Remotes:\n" |
||||
append result " " $fosrem \n |
||||
} |
||||
|
||||
|
||||
append result [join [punk::repo::grep {tags:*} $fosinfo] \n] \n |
||||
|
||||
set dbinfo [exec {*}$fossil_prog dbstat] |
||||
append result [join [punk::repo::grep {project-name:*} $dbinfo] \n] \n |
||||
append result [join [punk::repo::grep {tickets:*} $dbinfo] \n] \n |
||||
append result [join [punk::repo::grep {project-age:*} $dbinfo] \n] \n |
||||
append result [join [punk::repo::grep {latest-change:*} $dbinfo] \n] \n |
||||
append result [join [punk::repo::grep {files:*} $dbinfo] \n] \n |
||||
append result [join [punk::repo::grep {check-ins:*} $dbinfo] \n] \n |
||||
if {"project" in $repotypes} { |
||||
#punk project |
||||
if {![catch {package require textblock; package require patternpunk}]} { |
||||
set result [textblock::join [textblock::join [>punk . logo] " "] $result] |
||||
append result \n |
||||
} |
||||
} |
||||
|
||||
set timeline [exec fossil timeline -n 5 -t ci] |
||||
set timeline [string map [list \r\n \n] $timeline] |
||||
append result $timeline |
||||
if {$opt_v} { |
||||
set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes fossil] |
||||
append result \n [punk::repo::workingdir_state_summary $repostate] |
||||
} |
||||
|
||||
} |
||||
#repotypes *could* be both git and fossil - so report both if so |
||||
if {"git" in $repotypes} { |
||||
append result "GIT project based at $repopath with revision: [punk::repo::git_revision $repopath]" \n |
||||
if {[string length [set git_prog [auto_execok git]]]} { |
||||
set git_remotes [exec {*}$git_prog remote -v] |
||||
append result $git_remotes |
||||
if {$opt_v} { |
||||
set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes git] |
||||
append result \n [punk::repo::workingdir_state_summary $repostate] |
||||
} |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
|
||||
proc build_modules_from_source_to_base {srcdir basedir args} { |
||||
set antidir [list "#*" "_aside" ".git" ".fossil*"] ;#exact or glob patterns for folders we don't want to search in. |
||||
set defaults [list\ |
||||
-installer punk::mix::cli::build_modules_from_source_to_base\ |
||||
-call-depth-internal 0\ |
||||
-max_depth 1000\ |
||||
-subdirlist {}\ |
||||
-punkcheck_eventobj "\uFFFF"\ |
||||
-glob *.tm\ |
||||
] |
||||
set opts [dict merge $defaults $args] |
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set installername [dict get $opts -installer] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set CALLDEPTH [dict get $opts -call-depth-internal] |
||||
set max_depth [dict get $opts -max_depth] |
||||
set subdirlist [dict get $opts -subdirlist] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set fileglob [dict get $opts -glob] |
||||
if {![string match "*.tm" $fileglob]} { |
||||
error "build_modules_from_source_to_base -glob '$fileglob' doesn't seem to target tcl modules." |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_punkcheck_eventobj [dict get $opts -punkcheck_eventobj] |
||||
|
||||
set magicversion [punk::mix::util::magic_tm_version] ;#deliberately large so given load-preference when testing |
||||
set module_list [list] |
||||
|
||||
if {[file tail [file dirname $srcdir]] ne "src"} { |
||||
puts stderr "ERROR build_modules_from_source_to_base can only be called with a srcdir that is a subfolder of your 'src' directory" |
||||
puts stderr "The .tm modules are namespaced based on their directory depth - so we need to start at the root" |
||||
puts stderr "To build a subtree of your modules - use an appropriate src/modules folder and pass in the -subdirlist." |
||||
puts stderr "e.g if your modules are based at /x/src/modules2 and you wish to build only the .tm files at /x/src/modules2/skunkworks/lib" |
||||
puts stderr "Use: >build_modules_from_source_to_base /x/src/modules2 /x/modules2 -subdirlist {skunkworks lib}" |
||||
exit 2 |
||||
} |
||||
set srcdirname [file tail $srcdir] |
||||
|
||||
set build [file dirname $srcdir]/_build/$srcdirname ;#relative to *original* srcdir - not current_source_dir |
||||
if {[llength $subdirlist] == 0} { |
||||
set target_module_dir $basedir |
||||
set current_source_dir $srcdir |
||||
} else { |
||||
set target_module_dir $basedir/[file join {*}$subdirlist] |
||||
set current_source_dir $srcdir/[file join {*}$subdirlist] |
||||
} |
||||
if {![file exists $target_module_dir]} { |
||||
error "build_modules_from_source_to_base from current source dir: '$current_source_dir'. Basedir:'$current_module_dir' doesn't exist or is empty" |
||||
} |
||||
if {![file exists $current_source_dir]} { |
||||
error "build_modules_from_source_to_base from current source dir:'$current_source_dir' doesn't exist or is empty" |
||||
} |
||||
|
||||
#---------------------------------------- |
||||
set punkcheck_file [file join $basedir/.punkcheck] |
||||
if {$CALLDEPTH == 0} { |
||||
|
||||
set config [dict create\ |
||||
-glob $fileglob\ |
||||
-max_depth 0\ |
||||
] |
||||
#lassign [punkcheck::start_installer_event $punkcheck_file $installername $srcdir $basedir $config] _eventid punkcheck_eventid _recordset record_list |
||||
# -- --- |
||||
set installer [punkcheck::installtrack new $installername $punkcheck_file] |
||||
$installer set_source_target $srcdir $basedir |
||||
set event [$installer start_event $config] |
||||
# -- --- |
||||
|
||||
} else { |
||||
set event $opt_punkcheck_eventobj |
||||
} |
||||
#---------------------------------------- |
||||
|
||||
|
||||
|
||||
set src_modules [glob -nocomplain -dir $current_source_dir -type f -tail $fileglob] |
||||
|
||||
set did_skip 0 ;#flag for stdout/stderr formatting only |
||||
foreach m $src_modules { |
||||
#puts "build_modules_from_source_to_base >>> module $m" |
||||
set fileparts [split [file rootname $m] -] |
||||
set tmfile_versionsegment [lindex $fileparts end] |
||||
if {$tmfile_versionsegment eq $magicversion} { |
||||
#rebuild the .tm from the #tarjar |
||||
set basename [join [lrange $fileparts 0 end-1] -] |
||||
set versionfile $current_source_dir/$basename-buildversion.txt |
||||
set versionfiledata "" |
||||
if {![file exists $versionfile]} { |
||||
puts stderr "\nWARNING: Missing buildversion text file: $versionfile" |
||||
puts stderr "Using version 0.1 - create $versionfile containing the desired version number as the top line to avoid this warning\n" |
||||
set module_build_version "0.1" |
||||
} else { |
||||
set fd [open $versionfile r] |
||||
set versionfiledata [read $fd]; close $fd |
||||
set ln0 [lindex [split $versionfiledata \n] 0] |
||||
set ln0 [string trim $ln0]; set ln0 [string trim $ln0 \r] |
||||
if {![util::is_valid_tm_version $ln0]} { |
||||
puts stderr "ERROR: build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file" |
||||
exit 3 |
||||
} |
||||
set module_build_version $ln0 |
||||
} |
||||
|
||||
|
||||
if {[file exists $current_source_dir/#tarjar-$basename-$magicversion]} { |
||||
#TODO |
||||
file mkdir $buildfolder |
||||
|
||||
if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { |
||||
|
||||
} else { |
||||
|
||||
} |
||||
#REVIEW - should be in same structure/depth as $target_module_dir in _build? |
||||
set tmfile $basedir/_build/$basename-$module_build_version.tm |
||||
file mkdir $basedir/_build |
||||
file delete -force $basedir/_build/#tarjar-$basename-$module_build_version |
||||
file delete -force $tmfile |
||||
|
||||
|
||||
file copy -force $current_source_dir/#tarjar-$basename-$magicversion $basedir/_build/#tarjar-$basename-$module_build_version |
||||
# |
||||
#bsdtar doesn't seem to work.. or I haven't worked out the right options? |
||||
#exec tar -cvf $basedir/_build/$basename-$module_build_version.tm $basedir/_build/#tarjar-$basename-$module_build_version |
||||
package require tar |
||||
tar::create $tmfile $basedir/_build/#tarjar-$basename-$module_build_version |
||||
if {![file exists $tmfile]} { |
||||
puts stdout "ERROR: Failed to build tarjar file $tmfile" |
||||
exit 4 |
||||
} |
||||
#copy the file? |
||||
#set target $target_module_dir/$basename-$module_build_version.tm |
||||
#file copy -force $tmfile $target |
||||
|
||||
lappend module_list $tmfile |
||||
} else { |
||||
#assume that either the .tm is not a tarjar - or the tarjar dir is capped (trailing #) and the .tm has been manually tarred. |
||||
if {[file exists $current_source_dir/#tarjar-$basename-${magicversion}#]} { |
||||
puts stderr "\nWarning: found 'capped' folder #tarjar-$basename-${magicversion}# - No attempt being made to update version in description.txt" |
||||
} |
||||
|
||||
#------------------------------ |
||||
# |
||||
#set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$basename-$module_build_version.tm] |
||||
#set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] |
||||
$event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm |
||||
$event targetset_addsource $versionfile |
||||
$event targetset_addsource $current_source_dir/$m |
||||
|
||||
#set changed_list [list] |
||||
## -- --- --- --- --- --- |
||||
#set source_relpath [punkcheck::lib::path_relative $basedir $versionfile] |
||||
#set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] |
||||
## -- --- --- --- --- --- |
||||
#set source_relpath [punkcheck::lib::path_relative $basedir $current_source_dir/$m] |
||||
#set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] |
||||
## -- --- --- --- --- --- |
||||
#set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] |
||||
#set changed_list [dict get $changed_unchanged changed] |
||||
|
||||
|
||||
if {\ |
||||
[llength [dict get [$event targetset_source_changes] changed]]\ |
||||
|| [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ |
||||
} { |
||||
|
||||
#set file_record [punkcheck::installfile_started_install $basedir $file_record] |
||||
$event targetset_started |
||||
# -- --- --- --- --- --- |
||||
set target $target_module_dir/$basename-$module_build_version.tm |
||||
if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} |
||||
puts stdout "copying module $current_source_dir/$m to $target as version: $module_build_version ([file tail $target])" |
||||
set fd [open $current_source_dir/$m r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd |
||||
set data [string map [list $magicversion $module_build_version] $data] |
||||
set fdout [open $target w] |
||||
fconfigure $fdout -translation binary |
||||
puts -nonewline $fdout $data |
||||
close $fdout |
||||
#file copy -force $srcdir/$m $target |
||||
lappend module_list $target |
||||
# -- --- --- --- --- --- |
||||
#set file_record [punkcheck::installfile_finished_install $basedir $file_record] |
||||
$event targetset_end OK |
||||
} else { |
||||
#puts stdout "skipping module $current_source_dir/$m - no change in sources detected" |
||||
puts -nonewline stderr "." |
||||
set did_skip 1 |
||||
#set file_record [punkcheck::installfile_skipped_install $basedir $file_record] |
||||
$event targetset_end SKIPPED |
||||
} |
||||
|
||||
#------------------------------ |
||||
|
||||
} |
||||
|
||||
continue |
||||
} |
||||
|
||||
|
||||
if {![util::is_valid_tm_version $tmfile_versionsegment]} { |
||||
#last segment doesn't look even slightly versiony - fail. |
||||
puts stderr "ERROR: Unable to confirm file $current_source_dir/$m is a reasonably versioned .tm module - ABORTING." |
||||
exit 1 |
||||
} |
||||
|
||||
##------------------------------ |
||||
## |
||||
#set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$m] |
||||
#set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] |
||||
#set changed_list [list] |
||||
## -- --- --- --- --- --- |
||||
#set source_relpath [punkcheck::lib::path_relative $basedir $current_source_dir/$m] |
||||
#set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] |
||||
## -- --- --- --- --- --- |
||||
#set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] |
||||
#set changed_list [dict get $changed_unchanged changed] |
||||
|
||||
#---------- |
||||
$event targetset_init INSTALL $target_module_dir/$m |
||||
$event targetset_addsource $current_source_dir/$m |
||||
if {\ |
||||
[llength [dict get [$event targetset_source_changes] changed]]\ |
||||
|| [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ |
||||
} { |
||||
|
||||
#set file_record [punkcheck::installfile_started_install $basedir $file_record] |
||||
$event targetset_started |
||||
# -- --- --- --- --- --- |
||||
if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} |
||||
puts stderr "Copied already versioned module $current_source_dir/$m to $target_module_dir" |
||||
lappend module_list $current_source_dir/$m |
||||
file copy -force $current_source_dir/$m $target_module_dir |
||||
# -- --- --- --- --- --- |
||||
#set file_record [punkcheck::installfile_finished_install $basedir $file_record] |
||||
$event targetset_end OK -note "already versioned module" |
||||
} else { |
||||
puts -nonewline stderr "." |
||||
set did_skip 1 |
||||
#set file_record [punkcheck::installfile_skipped_install $basedir $file_record] |
||||
$event targetset_end SKIPPED |
||||
} |
||||
|
||||
} |
||||
if {$CALLDEPTH >= $max_depth} { |
||||
set subdirs [list] |
||||
} else { |
||||
set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] |
||||
} |
||||
#puts stderr "subdirs: $subdirs" |
||||
foreach d $subdirs { |
||||
set skipdir 0 |
||||
foreach dg $antidir { |
||||
if {[string match $dg $d]} { |
||||
set skipdir 1 |
||||
continue |
||||
} |
||||
} |
||||
if {$skipdir} { |
||||
continue |
||||
} |
||||
if {![file exists $target_module_dir/$d]} { |
||||
file mkdir $target_module_dir/$d |
||||
} |
||||
lappend module_list {*}[build_modules_from_source_to_base $srcdir $basedir\ |
||||
-call-depth-internal [expr {$CALLDEPTH +1}]\ |
||||
-subdirlist [list {*}$subdirlist $d]\ |
||||
-punkcheck_eventobj $event\ |
||||
-glob $fileglob\ |
||||
] |
||||
} |
||||
if {$did_skip} { |
||||
puts -nonewline stdout \n |
||||
} |
||||
if {$CALLDEPTH == 0} { |
||||
$event destroy |
||||
$installer destroy |
||||
} |
||||
return $module_list |
||||
} |
||||
|
||||
variable kettle_reset_bodies [dict create] |
||||
variable kettle_reset_args [dict create] |
||||
#We are abusing kettle to run in-process. |
||||
# when we change to another project we need recipes to be reloaded. |
||||
# Kettle rewrites some of it's own procs - stopping reloading of recipes when we change folders |
||||
#kettle_init stores the original proc bodies & args |
||||
proc kettle_init {} { |
||||
variable kettle_reset_bodies ;#dict |
||||
variable kettle_reset_args |
||||
set reset_procs [list\ |
||||
::kettle::benchmarks\ |
||||
::kettle::doc\ |
||||
::kettle::figures\ |
||||
::kettle::meta::scan\ |
||||
::kettle::testsuite\ |
||||
] |
||||
foreach p $reset_procs { |
||||
set b [info body $p] |
||||
if {[string match "*Overwrite self*" $b]} { |
||||
dict set kettle_reset_bodies $p $b |
||||
set argnames [info args $p] |
||||
set arglist [list] |
||||
foreach a $argnames { |
||||
if {[info default $p $a dval]} { |
||||
lappend arglist [list $a $dval] |
||||
} else { |
||||
lappend arglist $a |
||||
} |
||||
} |
||||
dict set kettle_reset_args $p $arglist |
||||
} |
||||
} |
||||
|
||||
} |
||||
#call kettle_reinit to ensure recipes point to current project |
||||
proc kettle_reinit {} { |
||||
variable kettle_reset_bodies |
||||
variable kettle_reset_args |
||||
foreach p [dict keys $kettle_reset_bodies] { |
||||
set b [dict get $kettle_reset_bodies $p] |
||||
set argl [dict get $kettle_reset_args $p] |
||||
uplevel 1 [list ::proc $p $argl $b] |
||||
} |
||||
#todo - determine standard recipes by examining standard.tcl instead of hard coding? |
||||
set standard_recipes [list\ |
||||
null\ |
||||
forever\ |
||||
list-recipes\ |
||||
help-recipes\ |
||||
help-dump\ |
||||
help-recipes\ |
||||
help\ |
||||
list\ |
||||
list-options\ |
||||
help-options\ |
||||
show-configuration\ |
||||
show-state\ |
||||
show\ |
||||
meta-status\ |
||||
gui\ |
||||
] |
||||
#set ::kettle::recipe::recipe [dict create] |
||||
foreach r [dict keys $::kettle::recipe::recipe] { |
||||
if {$r ni $standard_recipes} { |
||||
dict unset ::kettle::recipe::recipe $r |
||||
} |
||||
} |
||||
} |
||||
proc kettle_call {calltype args} { |
||||
variable kettle_reset_bodies |
||||
if {$calltype ni [list lib shell]} { |
||||
error "pmix kettle_call 1st argument must be one of: 'lib' for direct use of kettle module or 'shell' to call as separate process" |
||||
} |
||||
if {$calltype eq "shell"} { |
||||
set kettleappfile [file dirname [info nameofexecutable]]/kettle |
||||
set kettlebatfile [file dirname [info nameofexecutable]]/kettle.bat |
||||
|
||||
if {(![file exists $kettleappfile]) && (![file exists $kettlebatfile])} { |
||||
error "pmix kettle_call unable to find installed kettle application file '$kettleappfile' (or '$kettlebatfile' if on windows)" |
||||
} |
||||
if {[file exists $kettleappfile]} { |
||||
set kettlescript $kettleappfile |
||||
} |
||||
if {$::tcl_platform(platform) eq "windows"} { |
||||
if {[file exists $kettlebatfile]} { |
||||
set kettlescript $kettlebatfile |
||||
} |
||||
} |
||||
} |
||||
set startdir [pwd] |
||||
if {![file exists $startdir/build.tcl]} { |
||||
error "pmix kettle must be run from a folder containing build.tcl (cwd: [pwd])" |
||||
} |
||||
if {[package provide kettle] eq ""} { |
||||
puts stdout "Loading kettle package - may be delay on first load ..." |
||||
package require kettle |
||||
kettle_init ;#store original procs for those kettle procs that rewrite themselves |
||||
} else { |
||||
if {[dict size $kettle_reset_bodies] == 0} { |
||||
#presumably package require kettle was called without calling our kettle_init hack. |
||||
kettle_init |
||||
} else { |
||||
#undo proc rewrites |
||||
kettle_reinit |
||||
} |
||||
} |
||||
set first [lindex $args 0] |
||||
if {[string match @* $first]} { |
||||
error "pmix kettle doesn't support special operations - try calling tclsh kettle directly" |
||||
} |
||||
if {$first eq "-f"} { |
||||
set args [lassign $args __ path] |
||||
} else { |
||||
set path $startdir/build.tcl |
||||
} |
||||
set opts [list] |
||||
|
||||
if {[lindex $args 0] eq "-trace"} { |
||||
set args [lrange $args 1 end] |
||||
lappend opts --verbose on |
||||
} |
||||
set goals [list] |
||||
|
||||
if {$calltype eq "lib"} { |
||||
file mkdir ~/.kettle |
||||
set dotfile ~/.kettle/config |
||||
if {[file exists $dotfile] && |
||||
[file isfile $dotfile] && |
||||
[file readable $dotfile]} { |
||||
::kettle io trace {Loading dotfile $dotfile ...} |
||||
set args [list {*}[::kettle path cat $dotfile] {*}$args] |
||||
} |
||||
} |
||||
|
||||
#hardcoded kettle option names (::kettle option names) - retrieved using kettle::option names |
||||
#This is done so we don't have to load kettle lib for shell call (both loading as module and running shell are annoyingly SLOW) |
||||
#REVIEW - needs to be updated to keep in sync with kettle. |
||||
set knownopts [list\ |
||||
--exec-prefix --bin-dir --lib-dir --prefix --man-dir --html-dir --markdown-dir --include-dir \ |
||||
--ignore-glob --dry --verbose --machine --color --state --config --with-shell --log \ |
||||
--log-append --log-mode --with-dia --constraints --file --limitconstraints --tmatch --notfile --single --valgrind --tskip --repeats \ |
||||
--iters --collate --match --rmatch --with-doc-destination --with-git --target --test-include \ |
||||
] |
||||
|
||||
while {[llength $args]} { |
||||
set o [lindex $args 0] |
||||
switch -glob -- $o { |
||||
--* { |
||||
#instead of using: kettle option known |
||||
if {$o ni $knownopts} { |
||||
error "Unable to process unknown option $o." {} [list KETTLE (pmix)] |
||||
} |
||||
lappend opts $o [lindex $args 1] |
||||
#::kettle::option set $o [lindex $args 1] |
||||
set args [lrange $args 2 end] |
||||
} |
||||
default { |
||||
lappend goals $o |
||||
set args [lrange $args 1 end] |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {![llength $goals]} { |
||||
lappend goals help |
||||
} |
||||
if {"--prefix" ni [dict keys $opts]} { |
||||
dict set opts --prefix [file dirname $startdir] |
||||
} |
||||
if {$calltype eq "lib"} { |
||||
::kettle status clear |
||||
::kettle::option::set @kettle $startdir |
||||
foreach {o v} $opts { |
||||
::kettle option set $o $v |
||||
} |
||||
::kettle option set @srcscript $path |
||||
::kettle option set @srcdir [file dirname $path] |
||||
::kettle option set @goals $goals |
||||
::source $path |
||||
puts stderr "recipes: [::kettle recipe names]" |
||||
::kettle recipe run {*}[::kettle option get @goals] |
||||
|
||||
set state [::kettle option get --state] |
||||
if {$state ne {}} { |
||||
puts stderr "saving kettle state: $state" |
||||
::kettle status save $state |
||||
} |
||||
|
||||
} else { |
||||
#shell |
||||
puts stdout "Running external kettle process with args: $opts $goals" |
||||
run -n tclsh $kettlescript -f $path {*}$opts {*}$goals |
||||
} |
||||
|
||||
} |
||||
|
||||
} |
||||
} |
||||
|
||||
|
||||
namespace eval punk::mix::cli { |
||||
proc _cli {args} { |
||||
#don't use tailcall - base uses info level to determine caller |
||||
::punk::mix::base::_cli {*}$args |
||||
} |
||||
variable default_command help |
||||
package require punk::mix::base |
||||
package require punk::overlay |
||||
punk::overlay::custom_from_base [namespace current] ::punk::mix::base |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::cli [namespace eval punk::mix::cli { |
||||
variable version |
||||
set version 0.3 |
||||
}] |
||||
return |
||||
@ -0,0 +1,152 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::buildsuite 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::buildsuite { |
||||
namespace export * |
||||
proc projects {suite} { |
||||
set pathinfo [punk::repo::find_repos [pwd]] |
||||
set projectdir [dict get $pathinfo closest] |
||||
set suites_dir [file join $projectdir src buildsuites] |
||||
if {![file isdirectory [file join $suites_dir $suite]]} { |
||||
puts stderr "suite: $suite not found in buildsuites folder: $suites_dir" |
||||
return |
||||
} |
||||
set suite_dir [file join $suites_dir $suite] |
||||
set projects [glob -dir $suite_dir -type d -tails *] |
||||
|
||||
#use internal du which although breadth-first is generally faster |
||||
puts stdout "Examining source folders in $suite_dir." ;#A hint that something is happening in case sources are large |
||||
set du_info [punk::du::du -d 1 -b $suite_dir] |
||||
set du_sizes [dict create] |
||||
set suite_total_size "-" |
||||
foreach du_record $du_info { |
||||
if {[llength $du_record] != 2} { |
||||
#sanity precaution - punk::du::du should always output list of 2 element lists - at least with flags we're using |
||||
continue |
||||
} |
||||
set sz [lindex $du_record 0] |
||||
set path_parts [file split [lindex $du_record 1]] ;#should handle spaced-paths ok. |
||||
set s [lindex $path_parts end-1] |
||||
set p [lindex $path_parts end] |
||||
|
||||
#This handles case where a project folder is same name as suite e.g src/buildsuites/tcl/tcl |
||||
#so we can't just use tail as dict key. We could assume last record is always total - but |
||||
if {![string match -nocase $s $suite]} { |
||||
if {$s eq "buildsuites" && [string match -nocase $p $suite]} { |
||||
set suite_total_size $sz ;#this includes config files in suite base - so we don't really want to use this to report the total source size |
||||
} else { |
||||
#something else - shouldn't happen |
||||
puts stderr "Unexpected output from du in suite_dir: $suite_dir" |
||||
puts stderr "$du_record" |
||||
#try to continue anyway |
||||
} |
||||
} else { |
||||
dict set du_sizes $p $sz |
||||
} |
||||
} |
||||
|
||||
#build another dict for sizes where we ensure exactly one entry for each project exists and exclude total (don't blindly trust du output e.g in case weird filename/permission issue) |
||||
set psizes [list] |
||||
foreach p $projects { |
||||
if {[dict exists $du_sizes $p]} { |
||||
dict set psizes $p [dict get $du_sizes $p] |
||||
} else { |
||||
dict set psizes $p - |
||||
} |
||||
} |
||||
set total_source_size "-" |
||||
if {[catch { |
||||
set total_source_size [tcl::mathop::+ {*}[dict values $psizes]] |
||||
} errM]} { |
||||
puts stderr "Failed to calculate total source size. Errmsg: $errM" |
||||
} |
||||
package require overtype |
||||
|
||||
set title1 "Projects" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $projects] {punk::strlen $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
|
||||
set size_values [dict values $psizes] |
||||
# Title is probably widest - but go through the process anyway! |
||||
set title2 "Source Bytes" |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $size_values] {punk::strlen $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
|
||||
|
||||
set output "" |
||||
append output "[overtype::left $col1 $title1] [overtype::right $col2 $title2]" \n |
||||
foreach p [lsort $projects] { |
||||
#todo - provide some basic info for each - last build time? last time-to-build? |
||||
append output "[overtype::left $col1 $p] [overtype::right $col2 [dict get $psizes $p]]" \n |
||||
} |
||||
append output "Total Source size: $total_source_size bytes" \n |
||||
return $output |
||||
} |
||||
|
||||
|
||||
namespace eval collection { |
||||
namespace export * |
||||
proc _default {{glob {}}} { |
||||
if {![string length $glob]} { |
||||
set glob * |
||||
} |
||||
#todo - review - we want the furthest not the closest if we are potentially inside a buildsuite project |
||||
set pathinfo [punk::repo::find_repos [pwd]] |
||||
set projectdir [dict get $pathinfo closest] |
||||
set suites_dir [file join $projectdir src buildsuites] |
||||
if {![file exists $suites_dir]} { |
||||
puts stderr "No buildsuites folder found at $suites_dir" |
||||
return |
||||
} |
||||
set suites [lsort [glob -dir $suites_dir -type d -tails *]] |
||||
if {$glob ne "*"} { |
||||
set suites [lsearch -all -inline $suites $glob] |
||||
} |
||||
return $suites |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::buildsuite [namespace eval punk::mix::commandset::buildsuite { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,92 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::debug 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::debug { |
||||
namespace export get paths |
||||
namespace path ::punk::mix::cli |
||||
|
||||
#Except for 'get' - all debug commands should emit to stdout |
||||
proc paths {} { |
||||
set out "" |
||||
puts stdout "find_repos output:" |
||||
set pathinfo [punk::repo::find_repos [pwd]] |
||||
pdict $pathinfo |
||||
|
||||
set projectdir [dict get $pathinfo closest] |
||||
set modulefolders [lib::find_source_module_paths $projectdir] |
||||
puts stdout "modulefolders: $modulefolders" |
||||
|
||||
set template_base_dict [punk::mix::base::lib::get_template_basefolders] |
||||
puts stdout "get_template_basefolders output:" |
||||
pdict $template_base_dict |
||||
return |
||||
} |
||||
|
||||
#call other debug command - but capture stdout as return value |
||||
proc get {args} { |
||||
set nm [lindex $args 0] |
||||
if {$nm eq ""} { |
||||
set nscmds [info commands [namespace current]::*] |
||||
set cmds [lmap v $nscmds {namespace tail $v}] |
||||
error "debug.get missing debug command argument. Try one of: $cmds" |
||||
return |
||||
} |
||||
set nextargs [lrange $args 1 end] |
||||
set out "" |
||||
if {[info commands [namespace current]::$nm] ne ""} { |
||||
append out [runout -n -tcl [namespace current]::$nm {*}$nextargs] \n |
||||
} else { |
||||
set nscmds [info commands [namespace current]::*] |
||||
set cmds [lmap v $nscmds {namespace tail $v}] |
||||
error "debug.get invalid debug command '$nm' Try one of: $cmds" |
||||
} |
||||
return $out |
||||
} |
||||
namespace eval lib { |
||||
|
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::debug [namespace eval punk::mix::commandset::debug { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,181 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::doc 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::doc { |
||||
namespace export * |
||||
|
||||
proc _default {} { |
||||
puts "documentation subsystem" |
||||
puts "commands: doc.build" |
||||
puts " build documentation from src/doc to src/embedded using the kettle build tool" |
||||
} |
||||
|
||||
proc build {} { |
||||
puts "build docs" |
||||
set projectdir [punk::repo::find_project] |
||||
if {$projectdir eq ""} { |
||||
puts stderr "No current project dir - unable to build docs" |
||||
return |
||||
} |
||||
if {[file exists $projectdir/src/doc]} { |
||||
set original_wd [pwd] |
||||
cd $projectdir/src |
||||
#---------- |
||||
set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] |
||||
$installer set_source_target $projectdir/src/doc $projectdir/src/embedded |
||||
set event [$installer start_event {-install_step kettledoc}] |
||||
#use same virtual id "kettle_build_doc" as project.new - review best way to keep identifiers like this in sync. |
||||
$event targetset_init VIRTUAL kettle_build_doc ;#VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated |
||||
$event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source |
||||
#---------- |
||||
if {\ |
||||
[llength [dict get [$event targetset_source_changes] changed]]\ |
||||
} { |
||||
$event targetset_started |
||||
# -- --- --- --- --- --- |
||||
puts stdout "BUILDING DOCS at $projectdir/src/embedded from src/doc" |
||||
if {[catch { |
||||
|
||||
punk::mix::cli::lib::kettle_call lib doc |
||||
#Kettle doc |
||||
|
||||
} errM]} { |
||||
$event targetset_end FAILED -note "kettle_build_doc failed: $errM" |
||||
} else { |
||||
$event targetset_end OK |
||||
} |
||||
# -- --- --- --- --- --- |
||||
} else { |
||||
puts stderr "No change detected in src/doc" |
||||
$event targetset_end SKIPPED |
||||
} |
||||
$event end |
||||
$event destroy |
||||
$installer destroy |
||||
cd $original_wd |
||||
} else { |
||||
puts stderr "No doc folder found at $projectdir/src/doc" |
||||
} |
||||
} |
||||
proc status {} { |
||||
set projectdir [punk::repo::find_project] |
||||
if {$projectdir eq ""} { |
||||
puts stderr "No current project dir - unable to check doc status" |
||||
return |
||||
} |
||||
if {![file exists $projectdir/src/doc]} { |
||||
set result "No documentation source found. Expected .man files in doctools format at $projectdir/src/doc" |
||||
return $result |
||||
} |
||||
set original_wd [pwd] |
||||
cd $projectdir/src |
||||
puts stdout "Testing status of doctools source location $projectdir/src/doc ..." |
||||
flush stdout |
||||
#---------- |
||||
set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] |
||||
$installer set_source_target $projectdir/src/doc $projectdir/src/embedded |
||||
set event [$installer start_event {-install_step kettledoc}] |
||||
#use same virtual id "kettle_build_doc" as project.new - review best way to keep identifiers like this in sync. |
||||
$event targetset_init QUERY kettle_build_doc ;#usually VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated - but here we use QUERY to ensure no writes to .punkcheck |
||||
set last_completion [$event targetset_last_complete] |
||||
|
||||
if {[llength $last_completion]} { |
||||
#adding a source causes it to be checksummed |
||||
$event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source |
||||
#---------- |
||||
set changeinfo [$event targetset_source_changes] |
||||
if {\ |
||||
[llength [dict get $changeinfo changed]]\ |
||||
} { |
||||
puts stdout "changed" |
||||
puts stdout $changeinfo |
||||
} else { |
||||
puts stdout "No changes detected in $projectdir/src/doc tree" |
||||
} |
||||
} else { |
||||
#no previous completion-record for this target - must assume changed - no need to trigger checksumming |
||||
puts stdout "No existing record of doc build in .punkcheck. Assume it needs to be rebuilt." |
||||
} |
||||
|
||||
|
||||
$event destroy |
||||
$installer destroy |
||||
|
||||
cd $original_wd |
||||
} |
||||
proc validate {} { |
||||
set projectdir [punk::repo::find_project] |
||||
if {$projectdir eq ""} { |
||||
puts stderr "No current project dir - unable to check doc status" |
||||
return |
||||
} |
||||
if {![file exists $projectdir/src/doc]} { |
||||
set result "No documentation source found. Expected .man files in doctools format at $projectdir/src/doc" |
||||
return $result |
||||
} |
||||
set original_wd [pwd] |
||||
cd $projectdir/src |
||||
|
||||
punk::mix::cli::lib::kettle_call lib validate-doc |
||||
|
||||
cd $original_wd |
||||
} |
||||
|
||||
namespace eval collection { |
||||
variable pkg |
||||
set pkg punk::mix::commandset::doc |
||||
|
||||
namespace export * |
||||
namespace path [namespace parent] |
||||
|
||||
} |
||||
|
||||
namespace eval lib { |
||||
variable pkg |
||||
set pkg punk::mix::commandset::doc |
||||
|
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::doc [namespace eval punk::mix::commandset::doc { |
||||
variable pkg punk::mix::commandset::doc |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,185 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::layout 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
#sort of a circular dependency when commandset loaded by punk::mix::cli - that's ok, but this could theoretically be loaded by another cli and with another base |
||||
package require punk::mix |
||||
package require punk::mix::base |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::layout { |
||||
namespace export * |
||||
|
||||
#per layout functions |
||||
proc files {layout} { |
||||
set allfiles [lib::layout_all_files $layout] |
||||
return [join $allfiles \n] |
||||
} |
||||
proc templatefiles {layout} { |
||||
set templatefiles [lib::layout_scan_for_template_files $layout] |
||||
return [join $templatefiles \n] |
||||
} |
||||
proc templatefiles.relative {layout} { |
||||
set template_base_dict [punk::mix::base::lib::get_template_basefolders] |
||||
|
||||
set bases_containing_layout [list] |
||||
dict for {tbase folderinfo} $template_base_dict { |
||||
if {[file exists $tbase/layouts/$layout]} { |
||||
lappend bases_containing_layout $tbase |
||||
} |
||||
} |
||||
if {![llength $bases_containing_layout]} { |
||||
puts stderr "Unable to locate folder for layout '$layout'" |
||||
puts stderr "searched [dict size $template_base_dict] template folders" |
||||
return |
||||
} |
||||
set tpldir [lindex $bases_containing_layout end] |
||||
|
||||
set layout_base $tpldir/layouts |
||||
set layout_dir [file join $layout_base $layout] |
||||
|
||||
set stripprefix [file normalize $layout_dir] |
||||
set templatefiles [lib::layout_scan_for_template_files $layout] |
||||
set tails [list] |
||||
foreach templatefullpath $templatefiles { |
||||
lappend tails [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] |
||||
} |
||||
return [join $tails \n] |
||||
} |
||||
|
||||
#layout collection functions - to be imported with punk::overlay::import_commandset separately |
||||
namespace eval collection { |
||||
namespace export * |
||||
proc _default {{glob {}}} { |
||||
if {![string length $glob]} { |
||||
set glob * |
||||
} |
||||
set layouts [list] |
||||
#set tplfolderdict [punk::cap::templates::folders] |
||||
set tplfolderdict [punk::mix::base::lib::get_template_basefolders] |
||||
dict for {tdir folderinfo} $tplfolderdict { |
||||
set layout_base $tdir/layouts |
||||
#collect all layouts and use lsearch glob rather than the filesystem glob (avoid issues with dotted folder names) |
||||
set all_layouts [lsort [glob -nocomplain -dir $layout_base -type d -tail *]] |
||||
foreach match [lsearch -all -inline $all_layouts $glob] { |
||||
lappend layouts [list $match $folderinfo] |
||||
} |
||||
} |
||||
return [join [lsort -index 0 $layouts] \n] |
||||
} |
||||
|
||||
} |
||||
namespace eval lib { |
||||
proc layout_all_files {layout} { |
||||
set tplbasedict [punk::mix::base::lib::get_template_basefolders] |
||||
set layouts_found [list] |
||||
dict for {tplbase folderinfo} $tplbasedict { |
||||
if {[file isdirectory $tplbase/layouts/$layout]} { |
||||
lappend layouts_found $tplbase/layouts/$layout |
||||
} |
||||
} |
||||
if {![llength $layouts_found]} { |
||||
puts stderr "layout '$layout' not found." |
||||
puts stderr "searched [dict size $tplbasedict] template folders" |
||||
dict for {tplbase pkg} $tplbasedict { |
||||
puts stderr " - $tplbase $pkg" |
||||
} |
||||
return |
||||
} |
||||
set layoutfolder [lindex $layouts_found end] |
||||
|
||||
if {![file isdirectory $layoutfolder]} { |
||||
puts stderr "layout '$layout' not found in /layouts within one of template_folders. (get_template_folder returned: $tplbasedict)" |
||||
} |
||||
set file_list [list] |
||||
util::foreach-file $layoutfolder path { |
||||
lappend file_list $path |
||||
} |
||||
|
||||
return $file_list |
||||
} |
||||
|
||||
# |
||||
#todo - allow specifying which package the layout is from: e.g "punk::mix::templates project" ?? |
||||
proc layout_scan_for_template_files {layout {tags {}}} { |
||||
#equivalent for projects? punk::mix::commandset::module::lib::templates_dict -scriptpath "" |
||||
set tplbasedict [punk::mix::base::lib::get_template_basefolders] |
||||
set layouts_found [list] |
||||
dict for {tpldir pkg} $tplbasedict { |
||||
if {[file isdirectory $tpldir/layouts/$layout]} { |
||||
lappend layouts_found $tpldir/layouts/$layout |
||||
} |
||||
} |
||||
if {![llength $layouts_found]} { |
||||
puts stderr "layout '$layout' not found." |
||||
puts stderr "searched [dict size $tplbasedict] template folders" |
||||
dict for {tpldir pkg} $tplbasedict { |
||||
puts stderr " - $tpldir $pkg" |
||||
} |
||||
return |
||||
} |
||||
set layoutfolder [lindex $layouts_found end] |
||||
|
||||
#use last matching layout found. review silent if multiple? |
||||
if {![llength $tags]} { |
||||
#todo - get standard tags from somewhere |
||||
set tags [list %project%] |
||||
} |
||||
set file_list [list] |
||||
util::foreach-file $layoutfolder path { |
||||
set fd [open $path r] |
||||
fconfigure $fd -translation binary |
||||
set data [read $fd] |
||||
close $fd |
||||
foreach tag $tags { |
||||
if {[string match "*$tag*" $data]} { |
||||
lappend file_list $path |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $file_list |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::layout [namespace eval punk::mix::commandset::layout { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,529 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::loadedlib 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
package require punk::ns |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::loadedlib { |
||||
namespace export * |
||||
#search automatically wrapped in * * - can contain inner * ? globs |
||||
proc search {searchstring} { |
||||
catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything |
||||
if {[catch {package require natsort}]} { |
||||
set has_natsort 0 |
||||
} else { |
||||
set has_natsort 1 |
||||
} |
||||
if {[regexp {[?*]} $searchstring]} { |
||||
#caller has specified specific glob pattern - use it |
||||
#todo - respect supplied case only if uppers present? require another flag? |
||||
set matches [lsearch -all -inline -nocase [package names] $searchstring] |
||||
} else { |
||||
#make it easy to search for anything |
||||
set matches [lsearch -all -inline -nocase [package names] "*$searchstring*"] |
||||
} |
||||
|
||||
set matchinfo [list] |
||||
foreach m $matches { |
||||
set versions [package versions $m] |
||||
if {$has_natsort} { |
||||
set versions [natsort::sort $versions] |
||||
} else { |
||||
set versions [lsort $versions] |
||||
} |
||||
lappend matchinfo [list $m $versions] |
||||
} |
||||
return [join [lsort $matchinfo] \n] |
||||
} |
||||
proc loaded.search {searchstring} { |
||||
set search_result [search $searchstring] |
||||
set all_libs [split $search_result \n] |
||||
set col1items [list] |
||||
set col2items [list] |
||||
set col3items [list] |
||||
foreach libinfo $all_libs { |
||||
if {[string trim $libinfo] eq ""} { |
||||
continue |
||||
} |
||||
set versions [lassign $libinfo libname] |
||||
if {[set ver [package provide $libname]] ne ""} { |
||||
lappend col1items $libname |
||||
lappend col2items $versions |
||||
lappend col3items $ver |
||||
} |
||||
} |
||||
|
||||
package require overtype |
||||
set title1 "Library" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1items] {string length $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
set title2 "Versions Avail." |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {string length $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
set title3 "Loaded Version" |
||||
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {string length $v}]] |
||||
set col3 [string repeat " " $widest3] |
||||
|
||||
|
||||
set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3}] |
||||
|
||||
set table "" |
||||
append table [string repeat - $tablewidth] \n |
||||
append table "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]" \n |
||||
append table [string repeat - $tablewidth] \n |
||||
foreach c1 $col1items c2 $col2items c3 $col3items { |
||||
append table "[overtype::left $col1 $c1] [overtype::left $col2 $c2] [overtype::left $col3 $c3]" \n |
||||
} |
||||
|
||||
return $table |
||||
|
||||
|
||||
set loaded_libs [list] |
||||
foreach libinfo $all_libs { |
||||
if {[string trim $libinfo] eq ""} { |
||||
continue |
||||
} |
||||
set versions [lassign $libinfo libname] |
||||
if {[set ver [package provide $libname]] ne ""} { |
||||
lappend loaded_libs "$libname $versions (loaded $ver)" |
||||
} |
||||
} |
||||
return [join $loaded_libs \n] |
||||
} |
||||
|
||||
proc info {libname} { |
||||
if {[catch {package require natsort}]} { |
||||
set has_natsort 0 |
||||
} else { |
||||
set has_natsort 1 |
||||
} |
||||
catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything |
||||
set pkgsknown [package names] |
||||
if {[set posn [lsearch $pkgsknown $libname]] >= 0} { |
||||
puts stdout "Found package [lindex $pkgsknown $posn]" |
||||
} else { |
||||
puts stderr "Package not found as available library/module - check tcl::tm::list and \$auto_path" |
||||
} |
||||
set versions [package versions [lindex $libname 0]] |
||||
if {$has_natsort} { |
||||
set versions [natsort::sort $versions] |
||||
} else { |
||||
set versions [lsort $versions] |
||||
} |
||||
if {![llength $versions]} { |
||||
puts stderr "No version numbers found for library/module $libname" |
||||
return false |
||||
} |
||||
puts stdout "Versions of $libname found: $versions" |
||||
set alphaposn [lsearch $versions "999999.*"] |
||||
if {$alphaposn >= 0} { |
||||
set alpha [lindex $versions $alphaposn] |
||||
#remove and tack onto beginning.. |
||||
set versions [lreplace $versions $alphaposn $alphaposn] |
||||
set versions [list $alpha {*}$versions] |
||||
} |
||||
foreach ver $versions { |
||||
set loadinfo [package ifneeded $libname $ver] |
||||
puts stdout "$libname $ver" |
||||
puts stdout "--- 'package ifneeded' script ---" |
||||
puts stdout $loadinfo |
||||
puts stdout "---" |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc copyasmodule {library modulefoldername args} { |
||||
set defaults [list -askme 1] |
||||
set opts [dict merge $defaults $args] |
||||
set opt_askme [dict get $opts -askme] |
||||
|
||||
if {[catch {package require natsort}]} { |
||||
set has_natsort 0 |
||||
} else { |
||||
set has_natsort 1 |
||||
} |
||||
|
||||
catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything |
||||
|
||||
if {[file pathtype $modulefoldername] eq "absolute"} { |
||||
if {![file exists $modulefoldername]} { |
||||
error "Path '$modulefoldername' not found. Enter a fully qualified path, or just the tail such as 'modules' if you are within the project to use <projectdir>/src/modules" |
||||
} |
||||
#use the target folder as the source of projectdir info |
||||
set pathinfo [punk::repo::find_repos $modulefoldername] |
||||
set projectdir [dict get $pathinfo closest] |
||||
set modulefolder_path $modulefoldername |
||||
} else { |
||||
#use the current working directory as the source of projectdir info |
||||
set pathinfo [punk::repo::find_repos [pwd]] |
||||
set projectdir [dict get $pathinfo closest] |
||||
if {$projectdir ne ""} { |
||||
set modulefolders [punk::mix::cli::lib::find_source_module_paths $projectdir] |
||||
foreach k [list modules vendormodules] { |
||||
set knownfolder [file join $projectdir src $k] |
||||
if {$knownfolder ni $modulefolders} { |
||||
lappend modulefolders $knownfolder |
||||
} |
||||
} |
||||
set mtails [list] |
||||
foreach path $modulefolders { |
||||
lappend mtails [file tail $path] |
||||
} |
||||
|
||||
#special case bootsupport/modules so it can be referred to as just bootsupport or bootsupport/modules |
||||
lappend modulefolders [file join $projectdir src bootsupport/modules] |
||||
|
||||
if {$modulefoldername ni $mtails && $modulefoldername ni "bootsupport bootsupport/modules"} { |
||||
set msg "Suplied modulefoldername '$modulefoldername' doesn't appear to be a known module folder within the project at $projectdir\n" |
||||
append msg "Known module folders: [lsort $mtails]\n" |
||||
append msg "Use a name from the above list, or a fully qualified path\n" |
||||
error $msg |
||||
} |
||||
|
||||
if {$modulefoldername eq "bootsupport"} { |
||||
set modulefoldername "bootsupport/modules" |
||||
} |
||||
set modulefolder_path [file join $projectdir src $modulefoldername] |
||||
} else { |
||||
set msg "No current project found at or above current directory\n" |
||||
append msg "Supplied modulefoldername '$modulefoldername' is a name or relative path - cannot use when outside a project." \n |
||||
append msg "Supply an absolute path for the target modulefolder, or try again from within a project directory" \n |
||||
error $msg |
||||
} |
||||
} |
||||
puts stdout "-----------------------------" |
||||
if {$projectdir ne ""} { |
||||
puts stdout "Using projectdir: $projectdir for lib.copyasmodule" |
||||
} else { |
||||
puts stdout "No current project." |
||||
} |
||||
puts stdout "-----------------------------" |
||||
if {![file exists $modulefolder_path]} { |
||||
error "Selected module folder path '$modulefolder_path' doesn't exist. Required subdirectories for namespaced modules will be created automatically - but base selected folder must exist first" |
||||
} |
||||
|
||||
|
||||
set libfound [lsearch -all -inline [package names] $library] |
||||
if {[llength $libfound] != 1 || ![string length $libfound]} { |
||||
error "Library must match exactly one entry in the list of package names visible to the current interpretor: found '$libfound'" |
||||
} |
||||
|
||||
set versions [package versions [lindex $libfound 0]] |
||||
if {$has_natsort} { |
||||
set versions [natsort::sort $versions] |
||||
} else { |
||||
set versions [lsort $versions] |
||||
} |
||||
if {![llength $versions]} { |
||||
error "No version numbers found for library/module $libfound - sorry, you will need to copy it across manually" |
||||
} |
||||
puts stdout "Versions of $libfound found: $versions" |
||||
set alphaposn [lsearch $versions "999999.*"] |
||||
if {$alphaposn >= 0} { |
||||
set alpha [lindex $versions $alphaposn] |
||||
#remove and tack onto beginning.. |
||||
set versions [lreplace $versions $alphaposn $alphaposn] |
||||
set versions [list $alpha {*}$versions] |
||||
} |
||||
|
||||
set ver [lindex $versions end] ;# todo - make selectable! don't assume tail is latest?.. package vcompare? |
||||
if {[llength $versions] > 1} { |
||||
puts stdout "Version selected: $ver" |
||||
} |
||||
|
||||
set loadinfo [package ifneeded $libfound $ver] |
||||
set loadinfo [string map [list \r\n \n] $loadinfo] |
||||
set loadinfo_lines [split $loadinfo \n] |
||||
if {[catch {llength $loadinfo}]} { |
||||
set loadinfo_is_listshaped 0 |
||||
} else { |
||||
set loadinfo_is_listshaped 1 |
||||
} |
||||
|
||||
#check for redirection to differently cased version of self - this is only detected if this is the only command in the package ifneeded result |
||||
#- must have matching version. REVIEW this requirement. Is there a legitimate reason to divert to a differently cased other-version? |
||||
set is_package_require_self_recased 0 |
||||
set is_package_require_diversion 0 |
||||
set lib_diversion_name "" |
||||
if {[llength $loadinfo_lines] == 1} { |
||||
#e.g Thread 3.0b1 diverts to thread 3.0b1 |
||||
set line1 [lindex $loadinfo_lines 0] |
||||
#check if multiparted with semicolon |
||||
#We need to distinguish "package require <lib> <ver>; more stuff" from "package require <lib> ver> ;" possibly with trailing comment? |
||||
set parts [list] |
||||
if {[regexp {;} $line1]} { |
||||
foreach p [split $line1 {;}] { |
||||
set p [string trim $p] |
||||
if {[string length $p]} { |
||||
#only append parts with some content that doesn't look like a comment |
||||
if {![string match "#*" $p]} { |
||||
lappend parts $p |
||||
} |
||||
} |
||||
} |
||||
|
||||
} |
||||
if {[llength $parts] == 1} { |
||||
#seems like a lone package require statement. |
||||
#check if package require, package\trequire etc |
||||
if {[string match "package*require" [lrange $line1 0 1]]} { |
||||
set is_package_require_diversion 1 |
||||
if {[lindex $line1 2] eq "-exact"} { |
||||
#package require -exact <pkg> <ver> |
||||
set lib_diversion_name [lindex $line1 3] |
||||
#check not an exact match - but is a -nocase match - i.e differs in case only |
||||
if {($lib_diversion_name ne $libfound) && [string match -nocase $lib_diversion_name $libfound]} { |
||||
if {[lindex $line1 4] eq $ver} { |
||||
set is_package_require_self_recased 1 |
||||
} |
||||
} |
||||
} else { |
||||
#may be package require <pkg> <ver> |
||||
#or package require <pkg> <ver> ?<ver>?... |
||||
set lib_diversion_name [lindex $line1 2] |
||||
#check not an exact match - but is a -nocase match - i.e differs in case only |
||||
if {($lib_diversion_name ne $libfound) && [string match -nocase $lib_diversion_name $libfound]} { |
||||
set requiredversions [lrange $line1 3 end] |
||||
if {$ver in $requiredversions} { |
||||
set is_package_require_self_recased 1 |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {$is_package_require_self_recased && [string length $lib_diversion_name]} { |
||||
#we only follow one level of package require redirection - seems unlikely/imprudent to follow arbitrarily in a while loop(?) |
||||
set libfound $lib_diversion_name |
||||
set loadinfo [package ifneeded $libfound $ver] |
||||
set loadinfo [string map [list \r\n \n] $loadinfo] |
||||
set loadinfo_lines [split $loadinfo \n] |
||||
if {[catch {llength $loadinfo}]} { |
||||
set loadinfo_is_listshaped 0 |
||||
} else { |
||||
set loadinfo_is_listshaped 1 |
||||
} |
||||
|
||||
|
||||
} else { |
||||
if {$is_package_require_diversion} { |
||||
#single |
||||
#for now - we'll abort and tell the user to run again with specified pkg/version |
||||
#We could automate - but it seems likely to be surprising. |
||||
puts stderr "Loadinfo for $libfound seems to be diverting to another pkg/version: $loadinfo_lines" |
||||
puts stderr "Review and consider trying with the pkg/version described in the result above." |
||||
return |
||||
} |
||||
} |
||||
|
||||
|
||||
if {$loadinfo_is_listshaped && ([llength $loadinfo] == 2 && [lindex $loadinfo 0] eq "source")} { |
||||
set source_file [lindex $loadinfo 1] |
||||
} elseif {[string match "*source*" $loadinfo]} { |
||||
set parts [list] |
||||
foreach ln $loadinfo_lines { |
||||
if {![string length $ln]} {continue} |
||||
lappend parts {*}[split $ln ";"] |
||||
} |
||||
set sources_found [list] |
||||
set loads_found [list] |
||||
set dependencies [list] |
||||
set incomplete_lines [list] |
||||
foreach p $parts { |
||||
set p [string trim $p] |
||||
if {![string length $p]} { |
||||
continue ;#empty line or trailing colon |
||||
} |
||||
if {[string match "*tclPkgSetup*" $p]} { |
||||
puts stderr "Unable to process load script for library $libfound" |
||||
puts stderr "The library appears to use the deprecated tcl library support utility 'tclPkgSetup'" |
||||
return false |
||||
} |
||||
if {![::info complete $p]} { |
||||
# |
||||
#probably a perfectly valid script - but slightly more complicated than we can handle |
||||
#better to defer to manual processing |
||||
lappend incomplete_lines $p |
||||
continue |
||||
} |
||||
if {[lindex $p 0] eq "source"} { |
||||
#may have args.. e.g -encoding utf-8 |
||||
lappend sources_found [lindex $p end] |
||||
} |
||||
if {[lindex $p 0] eq "load"} { |
||||
lappend loads_found [lrange $p 1 end] |
||||
} |
||||
if {[lrange $p 0 1] eq "package require"} { |
||||
lappend dependencies [lrange $p 2 end] |
||||
} |
||||
} |
||||
if {[llength $incomplete_lines]} { |
||||
puts stderr "unable to interpret load script for library $libfound" |
||||
puts stderr "Load info: $loadinfo" |
||||
return false |
||||
} |
||||
if {[llength $loads_found]} { |
||||
puts stderr "package $libfound appears to have binary components" |
||||
foreach l $loads_found { |
||||
puts stderr " binary - $l" |
||||
} |
||||
foreach s $sources_found { |
||||
puts stderr " script - $s" |
||||
} |
||||
puts stderr "Unable to automatically copy binary libraries to your module folder." |
||||
return false |
||||
} |
||||
|
||||
if {[llength $sources_found] != 1} { |
||||
puts stderr "sorry - unable to interpret source library location" |
||||
puts stderr "Only 1 source supported for now" |
||||
puts stderr "Load info: $loadinfo" |
||||
return false |
||||
} |
||||
if {[llength $dependencies]} { |
||||
#todo - check/ignore if dependency is Tcl ? |
||||
puts stderr "WARNING the package appears to depend on at least one other. Review and copy dependencies if required." |
||||
foreach d $dependencies { |
||||
puts stderr " - $d" |
||||
} |
||||
} |
||||
|
||||
set source_file [lindex $sources_found 0] |
||||
} else { |
||||
puts stderr "sorry - unable to interpret source library location" |
||||
puts stderr "Load info: $loadinfo" |
||||
return false |
||||
} |
||||
|
||||
# -- --------------------------------------- |
||||
#Analyse source file |
||||
if {![file exists $source_file]} { |
||||
error "Unable to verify source file existence at: $source_file" |
||||
} |
||||
set source_data [fcat $source_file -translation binary] |
||||
if {![string match "*package provide*" $source_data]} { |
||||
puts stderr "Sorry - unable to verify source file contains 'package provide' statement of some sort - copy manually" |
||||
return false |
||||
} else { |
||||
if {![string match "*$libfound*" $source_data]} { |
||||
# as an exception - look for the specific 'package provide $pkg $version' as occurs in the auto-name auto-version modules |
||||
#e.g anyname-0.1.tm example |
||||
if {![string match "*package provide \$pkg \$version*" $source_data]} { |
||||
puts stderr "Sorry - unable to verify source file contains 'package provide' and '$libfound' - copy manually" |
||||
return false |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
if {[string match "*lappend ::auto_path*" $source_data] || [string match "*lappend auto_path*" $source_data] || [string match "*set ::auto_path*" $source_data]} { |
||||
puts stderr "Sorry - '$libfound' source file '$source_file' appears to rely on ::auto_path and can't be automatically copied as a .tm module" |
||||
puts stderr "Copy the library across to a lib folder instead" |
||||
return false |
||||
} |
||||
# -- --------------------------------------- |
||||
|
||||
set moduleprefix [punk::ns::nsprefix $libfound] |
||||
if {[string length $moduleprefix]} { |
||||
set moduleprefix_parts [punk::ns::nsparts $moduleprefix] |
||||
set relative_path [file join {*}$moduleprefix_parts] |
||||
} else { |
||||
set relative_path "" |
||||
} |
||||
set pkgtail [punk::ns::nstail $libfound] |
||||
set target_path [file join $modulefolder_path $relative_path ${pkgtail}-${ver}.tm] |
||||
|
||||
if {$opt_askme} { |
||||
puts stdout "WARNING - you should check that there aren't extra required files for the library/modules" |
||||
puts stdout "" |
||||
puts stdout "This is not intended for binary modules - use at own risk and check results" |
||||
puts stdout "" |
||||
puts stdout "Base module path: $modulefolder_path" |
||||
puts stdout "Target path : $target_path" |
||||
puts stdout "results of 'package ifneeded $libfound'" |
||||
puts stdout "---" |
||||
puts stdout "$loadinfo" |
||||
puts stdout "---" |
||||
puts stdout "Proceed to create ${pkgtail}-${ver}.tm module? Y|N" |
||||
set stdin_state [fconfigure stdin] |
||||
fconfigure stdin -blocking 1 |
||||
set answer [string tolower [gets stdin]] |
||||
fconfigure stdin -blocking [dict get $stdin_state -blocking] |
||||
if {$answer ne "y"} { |
||||
puts stderr "mix libcopy.asmodule aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
|
||||
if {![file exists $modulefolder_path]} { |
||||
puts stdout "Creating module base folder at $modulefolder_path" |
||||
file mkdir $modulefolder_path |
||||
} |
||||
if {![file exists [file dirname $target_path]]} { |
||||
puts stdout "Creating relative folder at [file dirname $target_path]" |
||||
file mkdir [file dirname $target_path] |
||||
} |
||||
|
||||
if {[file exists $target_path]} { |
||||
puts stdout "WARNING - module already exists at $target_path" |
||||
if {$opt_askme} { |
||||
puts stdout "Copy anyway? Y|N" |
||||
set stdin_state [fconfigure stdin] |
||||
fconfigure stdin -blocking 1 |
||||
set answer [string tolower [gets stdin]] |
||||
fconfigure stdin -blocking [dict get $stdin_state -blocking] |
||||
if {$answer ne "y"} { |
||||
puts stderr "mix libcopy.asmodule aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
} |
||||
|
||||
file copy -force $source_file $target_path |
||||
|
||||
return $target_path |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::loadedlib [namespace eval punk::mix::commandset::loadedlib { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,419 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::module 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::module { |
||||
namespace export * |
||||
|
||||
proc paths {} { |
||||
set roots [punk::repo::find_repos ""] |
||||
set project [lindex [dict get $roots project] 0] |
||||
if {$project ne ""} { |
||||
set is_project 1 |
||||
set searchbase $project |
||||
} else { |
||||
set is_project 0 |
||||
set searchbase [pwd] |
||||
} |
||||
|
||||
if {[catch { |
||||
set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $searchbase] |
||||
} errMsg]} { |
||||
set source_module_folderlist [list] |
||||
} |
||||
|
||||
set tm_folders [tcl::tm::list] |
||||
package require overtype |
||||
|
||||
set result "" |
||||
if {$is_project} { |
||||
append result "Project module source paths:" \n |
||||
foreach f $source_module_folderlist { |
||||
append result "$f" \n |
||||
} |
||||
} |
||||
append result \n |
||||
append result "tcl::tm::list" \n |
||||
foreach f $tm_folders { |
||||
if {$is_project} { |
||||
if {[punk::mix::cli::lib::path_a_aboveorat_b $project $f]} { |
||||
set pinfo "(within project)" |
||||
} else { |
||||
set pinfo "" |
||||
} |
||||
} else { |
||||
set pinfo "" |
||||
} |
||||
set warning "" |
||||
if {![file isdirectory $f]} { |
||||
set warning "(PATH NOT FOUND)" |
||||
} |
||||
append result "$f $pinfo $warning" \n |
||||
} |
||||
|
||||
|
||||
return $result |
||||
} |
||||
#require current dir when calling to be the projectdir, or |
||||
proc templates {args} { |
||||
set tdict [templates_dict {*}$args] |
||||
|
||||
package require overtype |
||||
set paths [dict values $tdict] |
||||
set names [dict keys $tdict] |
||||
|
||||
set title1 "Path" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $paths] {punk::strlen $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
|
||||
set title2 "Template Name" |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $names] {punk::strlen $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
|
||||
set tablewidth [expr {$widest1 + 1 + $widest2}] |
||||
set table "" |
||||
append table [string repeat - $tablewidth] \n |
||||
append table "[overtype::left $col1 $title1] [overtype::left $col2 $title2]" \n |
||||
append table [string repeat - $tablewidth] \n |
||||
|
||||
foreach p $paths n $names { |
||||
append table "[overtype::left $col1 $p] [overtype::left $col2 $n]" \n |
||||
} |
||||
|
||||
return $table |
||||
} |
||||
#return all module templates with repeated ones suffixed with .2 .3 etc |
||||
proc templates_dict {args} { |
||||
tailcall lib::templates_dict {*}$args |
||||
} |
||||
proc new {module args} { |
||||
set year [clock format [clock seconds] -format %Y] |
||||
set defaults [list\ |
||||
-project \uFFFF\ |
||||
-version \uFFFF\ |
||||
-license <unspecified>\ |
||||
-template module-0.0.1.tm\ |
||||
-type \uFFFF\ |
||||
-force 0\ |
||||
] |
||||
set opts [dict merge $defaults $args] |
||||
|
||||
#todo - review compatibility between -template and -type |
||||
#-type is the wrapping technology e.g 'plain' for none or tarjar/zipkit etc (consider also snappy/snappy-tcl) |
||||
#-template may be a folder - but only if the selected -type suports it |
||||
|
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
# option -version |
||||
# we need this value before looking at the named argument |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_version_supplied [dict get $opts -version] |
||||
if {$opt_version_supplied eq "\uFFFF"} { |
||||
set opt_version "0.1.0" |
||||
} else { |
||||
set opt_version $opt_version_supplied |
||||
if {![util::is_valid_tm_version $opt_version]} { |
||||
error "pmix module.new error - supplied -version $opt_version doesn't appear to be a valid Tcl module version" |
||||
} |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
#named argument |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set mversion_supplied "" ;#version supplied directly in module argument |
||||
if {[string first - $module]> 0} { |
||||
#if it has a dash then version is required to be valid |
||||
lassign [punk::mix::cli::lib::split_modulename_version $module] modulename mversion |
||||
if {![util::is_valid_tm_version $mversion]} { |
||||
error "pmix module.new error - unable to determine modulename-version from supplied value '$module'" |
||||
} |
||||
set mversion_supplied $mversion ;#record as may need to compare to version from templatefile name |
||||
set vcompare_is_mversion_bigger [package vcompare $mversion $opt_version] |
||||
if {$vcompare_is_mversion_bigger > 0} { |
||||
set opt_version $mversion; #module parameter has higher value than -version |
||||
set vmsg "from module argument: $module" |
||||
} else { |
||||
set vmsg "from -version option: $opt_version_supplied" |
||||
} |
||||
if {$opt_version_supplied ne "\uFFFF"} { |
||||
if {$vcompare_is_mversion_bigger != 0} { |
||||
#is bigger or smaller |
||||
puts stderr "module.new WARNING: version supplied in module argument as well as -version option. Using the higher version number $vmsg" |
||||
} |
||||
} |
||||
} else { |
||||
set modulename $module |
||||
} |
||||
punk::mix::cli::lib::validate_modulename $modulename -name_description "mix module.new name" |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
#options |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_project [dict get $opts -project] |
||||
set testdir [pwd] |
||||
if {![string length [set projectdir [punk::repo::find_project $testdir]]]} { |
||||
if {![string length [set projectdir [punk::repo::find_candidate $testdir]]]} { |
||||
set msg [punkc::repo::is_candidate_root_requirements_msg] |
||||
error "module.new unable to create module in projectdir:$projectdir - directory doesn't appear to meet basic standards $msg" |
||||
} |
||||
} |
||||
if {$opt_project == "\uFFFF"} { |
||||
set projectname [file tail $projectdir] |
||||
} else { |
||||
set projectname $opt_project |
||||
if {$projectname ne [file tail $projectdir]} { |
||||
error "module.new -project '$opt_project' doesn't match detected projectname '$projectname' at path: $projectdir" |
||||
} |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_license [dict get $opts -license] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_template [dict get $opts -template] |
||||
|
||||
set templates_dict [templates_dict] ;#possibly suffixed with .2 .3 etc |
||||
#todo - allow versionless name - pick latest which isn't suffixed with .2 etc |
||||
if {![dict exists $templates_dict $opt_template]} { |
||||
error "module.new unable to find template '$opt_template'. Known templates: [dict keys $templates_dict]" |
||||
} |
||||
set templatefile [dict get $templates_dict $opt_template] |
||||
set tpldir [file dirname $templatefile] ;#use same folder for modulename_buildversion.txt, modulename_description.txt if they exist |
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_type [dict get $opts -type] |
||||
if {$opt_type eq "\uFFFF"} { |
||||
set opt_type [lindex [punk::mix::cli::lib::module_types] 0] ;#default to plain |
||||
} |
||||
if {$opt_type ni [punk::mix::cli::lib::module_types]} { |
||||
error "module.new - error - unknown -type '$opt_type' known-types: [punk::mix::cli::lib::module_types]" |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
set subpath [punk::mix::cli::lib::module_subpath $modulename] ;#commonly empty string for simple modulename e.g "mymodule" but x::mymodule has subpath 'x' and x::y::mymodule has subpath 'x/y' |
||||
if {![string length $subpath]} { |
||||
set modulefolder $projectdir/src/modules |
||||
} else { |
||||
set modulefolder $projectdir/src/modules/$subpath |
||||
} |
||||
file mkdir $modulefolder |
||||
|
||||
set moduletail [namespace tail $modulename] |
||||
set magicversion [punk::mix::util::magic_tm_version] ;#deliberately large so given load-preference when testing |
||||
|
||||
|
||||
|
||||
|
||||
set template_tail [file tail $templatefile] ;#convert template_xxx-version.tm.x to {xxx version} |
||||
set template_tail [string range $template_tail [string length template_] end] |
||||
set ext [string tolower [file extension $template_tail]] |
||||
if {$ext eq ".tm"} { |
||||
set template_modulename_part [file rootname $template_tail] |
||||
} elseif {[string is integer -strict [string range $ext 1 end]]} { |
||||
#something like modulename-0.0.1.tm.2 |
||||
#strip of last 2 dotted parts |
||||
set shortened [file rootname $template_tail] |
||||
if {![string equal -nocase [file extension $shortened] ".tm"]} { |
||||
error "module.new error: Unable to interpret filename components of template file '$templatefile' (expected .tm as second-last or last component)" |
||||
} |
||||
set template_modulename_part [file rootname $shortened] |
||||
} else { |
||||
error "module.new error: Unable to interpret filename components of template file '$templatefile'" |
||||
} |
||||
lassign [punk::mix::cli::lib::split_modulename_version $template_modulename_part] t_mname t_version |
||||
#t_version may be empty string if template is unversioned e.g template_whatever.tm |
||||
|
||||
set fd [open $templatefile r]; set template_filedata [read $fd]; close $fd |
||||
if {[string match "*$magicversion*" $template_filedata]} { |
||||
set use_magic 1 |
||||
set build_version $opt_version |
||||
set infile_version $magicversion |
||||
} else { |
||||
set use_magic 0 |
||||
if {$opt_version_supplied ne "\uFFFF"} { |
||||
set build_version $opt_version |
||||
} else { |
||||
if {[util::is_valid_tm_version $t_version]} { |
||||
if {$mversion_supplied eq ""} { |
||||
set build_version $t_version |
||||
} else { |
||||
#we have a version from the named argument 'module' |
||||
if {[package vcompare $mversion_supplied $t_version] > 0} { |
||||
set build_version $mversion_supplied |
||||
} else { |
||||
set build_version $t_version |
||||
} |
||||
} |
||||
} else { |
||||
#probably an unversioned module template |
||||
#use opt_version default from above |
||||
set build_version $opt_version |
||||
} |
||||
} |
||||
set infile_version $build_version |
||||
} |
||||
|
||||
set template_filedata [string map [list %pkg% $modulename %year% $year %license% $opt_license %version% $infile_version] $template_filedata] |
||||
|
||||
set modulefile $modulefolder/${moduletail}-$infile_version.tm |
||||
if {[file exists $modulefile]} { |
||||
set errmsg "module.new error: module file $modulefile already exists - aborting" |
||||
if {[string match "*$magicversion*" $modulefile]} { |
||||
append errmsg \n "If you are attempting to create a module file with a specific version in the source-file name - you will need to use a template that doesn't contain the string '$magicversion' e.g the provided template moduleexactversion-0.0.1.tm" |
||||
} |
||||
error $errmsg |
||||
} |
||||
|
||||
|
||||
if {[file exists $tpldir/modulename_buildversion.txt]} { |
||||
set fd [open $tpldir/modulename_buildversion.txt r]; set buildversion_filedata [read $fd]; close $fd |
||||
} else { |
||||
#mix_templates_dir warns of deprecation - review |
||||
set lib_tpldir [file join [punk::mix::cli::lib::mix_templates_dir] modules];#fallback for modulename_buildversion.txt, modulename_description.txt |
||||
set fd [open $lib_tpldir/modulename_buildversion.txt r]; set buildversion_filedata [read $fd]; close $fd |
||||
} |
||||
set buildversionfile [file join $modulefolder ${moduletail}-buildversion.txt] |
||||
set existing_build_version "" |
||||
if {[file exists $buildversionfile]} { |
||||
set buildversiondata [punk::mix::util::fcat $buildversionfile] |
||||
set lines [split $buildversiondata \n] |
||||
set existing_build_version [string trim [lindex $lines 0]] |
||||
if {[package vcompare $existing_build_version $build_version] >= 0} { |
||||
#existing version in -buildversion.txt file is lower than the module version we are creating |
||||
error "module.new error: there is an existing buildversion file $buildversionfile with version $existing_build_version equal to or higher than $build_version - unable to continue" |
||||
} |
||||
} |
||||
|
||||
set existing_versions [glob -nocomplain -dir $modulefolder -tails ${moduletail}-*.tm] |
||||
#it shouldn't be possible to overmatch with the glob - because '-' is not valid in a Tcl module name |
||||
if {[llength $existing_versions]} { |
||||
set name_version_pairs [list] |
||||
lappend name_version_pairs [list $moduletail $infile_version] |
||||
foreach existing $existing_versions { |
||||
lappend name_version_pairs [punk::mix::cli::lib::split_modulename_version $existing] ;# .tm is stripped and ignored |
||||
} |
||||
set name_version_pairs [lsort -command {package vcompare} -index 1 $name_version_pairs] ;#while plain lsort will often work with versions - it can get order wrong with some - so use package vcompare |
||||
if {[lindex $name_version_pairs end] ne [list $moduletail $infile_version]} { |
||||
set thisposn [lsearch -index 1 $name_version_pairs $infile_version] |
||||
set name_version_pairs [lreplace $name_version_pairs $thisposn $thisposn] |
||||
set other_versions [lsearch -all -inline -index 1 -subindices $name_version_pairs *] |
||||
set errmsg "module.new error: There are existing modules in the target folder with higher versions than $infile_version." |
||||
append errmsg \n "Other versions found: $other_versions" |
||||
if {$magicversion in $other_versions} { |
||||
append errmsg \n "Existing build version for special source file name: '$magicversion' is: '$existing_build_version'" |
||||
append errmsg \n "If '$magicversion' file doesn't represent the latest source it should be removed or the filename and contents adjusted to be a specific version" |
||||
} |
||||
error $errmsg |
||||
} else { |
||||
puts stderr "module.new WARNING: There are existing modules in the target folder with lower versions than $infile_version - manual review recommended" |
||||
puts stderr "Other versions found: [lsearch -all -inline -index 1 -subindices [lrange $name_version_pairs 0 end-1] *]" |
||||
} |
||||
} |
||||
|
||||
|
||||
set fd [open $modulefile w] |
||||
fconfigure $fd -translation binary |
||||
puts -nonewline $fd $template_filedata |
||||
close $fd |
||||
|
||||
|
||||
set buildversion_filedata [string map [list %Major.Minor.Level% $build_version] $buildversion_filedata] |
||||
set fd [open $buildversionfile w] |
||||
fconfigure $fd -translation binary |
||||
puts -nonewline $fd $buildversion_filedata |
||||
close $fd |
||||
|
||||
return [list file $modulefile version $build_version] |
||||
} |
||||
|
||||
namespace eval lib { |
||||
proc templates_dict {args} { |
||||
set defaults [list -scriptpath ""] |
||||
set opts [dict merge $defaults $args] |
||||
set opt_scriptpath [dict get $opts -scriptpath] |
||||
|
||||
set module_template_bases [list] |
||||
set tbasedict [punk::mix::base::lib::get_template_basefolders $opt_scriptpath] |
||||
dict for {tbase folderinfo} $tbasedict { |
||||
lappend module_template_bases [file join $tbase modules] |
||||
} |
||||
|
||||
|
||||
|
||||
set template_files [list] |
||||
foreach basefld $module_template_bases { |
||||
set matched_files [glob -nocomplain -dir $basefld -type f template_*] |
||||
foreach tf $matched_files { |
||||
if {[string match ignore* $tf]} { |
||||
continue |
||||
} |
||||
set ext [file extension $tf] |
||||
if {$ext in [list ".tm"]} { |
||||
lappend template_files $tf |
||||
} |
||||
} |
||||
} |
||||
|
||||
set tdict [dict create] |
||||
set seen_dict [dict create] |
||||
foreach fullpath $template_files { |
||||
set ftail [file tail $fullpath] |
||||
set tname [string range $ftail [string length template_] end] |
||||
if {![dict exists $seen_dict $tname]} { |
||||
dict set seen_dict $tname 1 |
||||
dict set tdict $tname $fullpath ; #first seen of filename gets no number |
||||
} else { |
||||
set n [dict get $seen_dict $tname] |
||||
incr n |
||||
dict incr seen_dict $tname |
||||
dict set tdict ${tname}.$n $fullpath |
||||
} |
||||
} |
||||
return $tdict |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::module [namespace eval punk::mix::commandset::module { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,849 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::project 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::project { |
||||
namespace export * |
||||
|
||||
#new project structure - may be dedicated to one module, or contain many. |
||||
#create minimal folder structure only by specifying -modules {} |
||||
proc new {newprojectpath_or_name args} { |
||||
if {[file pathtype $newprojectpath_or_name] eq "absolute"} { |
||||
set projectfullpath [file normalize $newprojectpath_or_name] |
||||
set projectname [file tail $projectfullpath] |
||||
set projectparentdir [file dirname $newprojectpath_or_name] |
||||
} else { |
||||
set projectfullpath [file join [pwd] $newprojectpath_or_name] |
||||
set projectname [file tail $projectfullpath] |
||||
set projectparentdir [file dirname $projectfullpath] |
||||
} |
||||
if {[file type $projectparentdir] ne "directory"} { |
||||
error "punk::mix::cli::new error: unable to determine containing folder for '$newprojectpath_or_name'" |
||||
} |
||||
|
||||
punk::mix::cli::lib::validate_projectname $projectname -name_description "punk mix project.new" |
||||
|
||||
|
||||
set defaults [list\ |
||||
-type plain\ |
||||
-empty 0\ |
||||
-force 0\ |
||||
-update 0\ |
||||
-confirm 1\ |
||||
-modules \uFFFF\ |
||||
-layout project |
||||
] ;#todo |
||||
set known_opts [dict keys $defaults] |
||||
foreach {k v} $args { |
||||
if {$k ni $known_opts} { |
||||
error "project.new error: option '$k' not known. Known options: $known_opts" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_type [dict get $opts -type] |
||||
if {$opt_type ni [punk::mix::cli::lib::module_types]} { |
||||
error "pmix new error - unknown type '$opt_type' known types: [punk::mix::cli::lib::module_types]" |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_force [dict get $opts -force] |
||||
set opt_confirm [string tolower [dict get $opts -confirm]] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_modules [dict get $opts -modules] |
||||
if {[llength $opt_modules] == 1 && [lindex $opt_modules 0] eq "\uFFFF"} { |
||||
#if not specified - add a single module matching project name |
||||
set opt_modules [list $projectname] |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_layout [dict get $opts -layout] |
||||
set opt_update [dict get $opts -update] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
|
||||
|
||||
set fossil_prog [auto_execok fossil] |
||||
if {![string length $fossil_prog]} { |
||||
puts stderr "The fossil program was not found. A fossil executable is required to use most pmix features." |
||||
if {[string length [set scoop_prog [auto_execok scoop]]]} { |
||||
#restrict to windows? |
||||
set answer [util::askuser "scoop detected. Would you like pmix to install fossil now using scoop? Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." |
||||
return |
||||
} |
||||
#we don't assume 'unknown' is configured to run shell commands |
||||
if {[string length [package provide shellrun]]} { |
||||
set exitinfo [run {*}$scoop_prog install fossil] |
||||
#scoop tends to return successful exitcode (0) even when packages not found etc. - so exitinfo not much use. |
||||
puts stdout "scoop install fossil ran with result: $exitinfo" |
||||
} else { |
||||
puts stdout "Please wait while scoop runs - there may be a slight delay and then scoop output will be shown. (use punk shellrun package for )" |
||||
set result [exec {*}$scoop_prog install fossil] |
||||
puts stdout $result |
||||
} |
||||
catch {::auto_reset} ;#can be missing (unsure under what circumstances - but I've seen it raise error 'invalid command name "auto_reset"') |
||||
if {![string length [auto_execok fossil]]} { |
||||
puts stderr "Fossil still not detected. If it was successfully installed, try restarting your punk/tcl shell." |
||||
return |
||||
} |
||||
#todo - ask user if they want to configure fosssil first.. |
||||
set answer [util::askuser "Fossil command now appears to be available. You may wish to answer N to exit and customize it - but default config may be ok. Type the word 'continue' to proceed with default configuration."] |
||||
if {[string tolower $answer] ne "continue"} { |
||||
return |
||||
} |
||||
|
||||
} else { |
||||
puts stdout "See: https://fossil-scm.org/home/uv/download.html" |
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
puts stdout "Consider using a package manager such as scoop: https://scoop.sh" |
||||
puts stdout "(Then: scoop install fossil)" |
||||
} |
||||
return |
||||
} |
||||
} |
||||
set startdir [pwd] |
||||
if {[set in_project [punk::repo::find_project $startdir]] ne ""} { |
||||
# use this project as source of templates |
||||
puts stdout "-------------------------------------------" |
||||
puts stdout "Currently in a project directory '$in_project'" |
||||
puts stdout "This project will be searched for templates" |
||||
puts stdout "-------------------------------------------" |
||||
} |
||||
set template_base_dict [punk::mix::base::lib::get_template_basefolders] |
||||
set template_bases_containing_layout [list] |
||||
dict for {tbase folderinfo} $template_base_dict { |
||||
if {[file exists $tbase/layouts/$opt_layout]} { |
||||
lappend template_bases_containing_layout $tbase |
||||
} |
||||
} |
||||
if {![llength $template_bases_containing_layout]} { |
||||
puts stderr "layout '$opt_layout' was not found in template dirs" |
||||
puts stderr "searched [dict size $template_base_dict] template folders" |
||||
dict for {tbase folderinfo} $template_base_dict { |
||||
puts stderr " - $tbase $folderinfo" |
||||
} |
||||
return |
||||
} |
||||
#review: silently use last entry which had the layout (?) |
||||
set templatebase [lindex $template_bases_containing_layout end] |
||||
|
||||
|
||||
|
||||
#todo - detect whether inside cwd-project or inside a different project |
||||
set projectdir $projectparentdir/$projectname |
||||
if {[set target_in_project [punk::repo::find_project $projectparentdir]] ne ""} { |
||||
puts stderr "Target location for new project is already within a project: $target_in_project" |
||||
error "Nested projects not yet supported aborting" |
||||
} |
||||
|
||||
|
||||
|
||||
if {[punk::repo::is_git $projectparentdir]} { |
||||
puts stderr "mix new WARNING: target project location is within a git repo based at [punk::repo::find_git $projectparentdir]" |
||||
puts stderr "The new project will create a fossil repository (which you are free to ignore - but but will be used to confirm project base)" |
||||
puts stderr "If you intend to use both git and fossil in the same project space - you should research and understand the details and any possible interactions/issues" |
||||
set answer [util::askuser "Do you want to proceed to create a project based at: $projectdir? Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
set is_nested_fossil 0 ;#default assumption |
||||
if {[punk::repo::is_fossil $projectparentdir]} { |
||||
puts stderr "mix new WARNING: target project location is within an open fossil repo based at [punk::repo::find_fossil $projectparentdir] NESTED fossil repository" |
||||
if {$opt_confirm ni [list 0 no false]} { |
||||
puts stderr "If you proceed - the new project's fossil repo will be created using the --nested flag" |
||||
set answer [util::askuser "Do you want to proceed to create a NESTED project based at: $projectdir? Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." |
||||
return |
||||
} |
||||
set is_nested_fossil 1 |
||||
} |
||||
} |
||||
|
||||
|
||||
set project_dir_exists [file exists $projectdir] |
||||
if {$project_dir_exists && !($opt_force || $opt_update)} { |
||||
puts stderr "Unable to create new project at $projectdir - file/folder already exists use -update 1 to fill in missing items from template use -force 1 to overwrite from template" |
||||
return |
||||
} elseif {$project_dir_exists && $opt_force} { |
||||
puts stderr "mix new WARNING: -force 1 was supplied. Will copy layout $templatebase/layouts/$opt_layout using -force option to overwrite from template" |
||||
if {$opt_confirm ni [list 0 no false]} { |
||||
set answer [util::askuser "Do you want to proceed to possibly overwrite existing files in $projectdir? Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
} elseif {$project_dir_exists && $opt_update} { |
||||
puts stderr "mix new WARNING: -update 1 was supplied. Will copy layout $templatebase/layouts/$opt_layout using -update option to add missing items" |
||||
} |
||||
|
||||
set fossil_repo_file "" |
||||
set is_fossil_root 0 |
||||
if {$project_dir_exists && [punk::repo::is_fossil_root $projectdir]} { |
||||
set is_fossil_root 1 |
||||
set fossil_repo_file [punk::repo::fossil_get_repository_file $projectdir] |
||||
if {$fossil_repo_file ne ""} { |
||||
set repodb_folder [file dirname $fossil_repo_file] |
||||
} |
||||
} |
||||
|
||||
if {$fossil_repo_file eq ""} { |
||||
set repodb_folder [punk::repo::fossil_get_repository_folder_for_project $projectname -parentfolder $startdir] |
||||
if {![string length $repodb_folder]} { |
||||
puts stderr "No usable repository database folder selected for $projectname.fossil file" |
||||
return |
||||
} |
||||
} |
||||
if {[file exists $repodb_folder/$projectname.fossil]} { |
||||
puts stdout "NOTICE: $repodb_folder/$projectname.fossil already exists" |
||||
if {!($opt_force || $opt_update)} { |
||||
puts stderr "-force 1 or -update 1 not specified - aborting" |
||||
return |
||||
} |
||||
} |
||||
|
||||
if {$fossil_repo_file eq ""} { |
||||
puts stdout "Initialising fossil repo: $repodb_folder/$projectname.fossil" |
||||
set fossilinit [runx -n {*}$fossil_prog init $repodb_folder/$projectname.fossil -project-name $projectname] |
||||
if {[dict get $fossilinit exitcode] != 0} { |
||||
puts stderr "fossil init failed:" |
||||
puts stderr [dict get $fossilinit stderr] |
||||
return |
||||
} else { |
||||
puts stdout "fossil init result:" |
||||
puts stdout [dict get $fossilinit stdout] |
||||
} |
||||
} |
||||
|
||||
file mkdir $projectdir |
||||
|
||||
set layout_dir $templatebase/layouts/$opt_layout |
||||
puts stdout ">>> about to call punkcheck::install $layout_dir $projectdir" |
||||
set resultdict [dict create] |
||||
set unpublish [list\ |
||||
src/doc/*\ |
||||
src/doc/include/*\ |
||||
] |
||||
|
||||
#default antiglob_dir_core will stop .fossil* from being updated - which is generally desirable as these are likely to be customized |
||||
if {$opt_force} { |
||||
puts stdout "copying layout files - with force applied - overwrite all-targets" |
||||
set resultdict [punkcheck::install $layout_dir $projectdir -installer project.new -overwrite ALL-TARGETS -unpublish_paths $unpublish] |
||||
#file copy -force $layout_dir $projectdir |
||||
} else { |
||||
puts stdout "copying layout files - (if source file changed)" |
||||
set resultdict [punkcheck::install $layout_dir $projectdir -installer project.new -overwrite installedsourcechanged-targets -unpublish_paths $unpublish] |
||||
} |
||||
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
||||
|
||||
puts stdout "copying layout src/doc files (if target missing)" |
||||
set resultdict [punkcheck::install $layout_dir/src/doc $projectdir/src/doc -punkcheck_folder $projectdir -installer project.new -overwrite SYNCED-TARGETS] |
||||
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
||||
|
||||
#target folders .fossil-custom and .fossil-settings may not exist. use -createdir 1 to ensure existence. |
||||
#In this case we need to override the default dir antiglob - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized. |
||||
## default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"] |
||||
set override_antiglob_dir_core [list #* _aside .git] |
||||
puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)" |
||||
set resultdict [punkcheck::install $layout_dir/.fossil-custom $projectdir/.fossil-custom -createdir 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] |
||||
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
||||
|
||||
puts stdout "copying layout src/.fossil-settings files (if target missing or uncustomised)" |
||||
set resultdict [punkcheck::install $layout_dir/.fossil-settings $projectdir/.fossil-settings -createdir 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] |
||||
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
||||
|
||||
|
||||
|
||||
|
||||
#lappend substfiles $projectdir/README.md |
||||
#lappend substfiles $projectdir/src/README.md |
||||
#lappend substfiles $projectdir/src/doc/main.man |
||||
#expect this in all templates? - todo make these substitutions independent of specific paths and filenames? |
||||
#scan all files in template |
||||
# |
||||
#TODO - pmix command to substitute templates? |
||||
set templatefiles [punk::mix::commandset::layout::lib::layout_scan_for_template_files $opt_layout] |
||||
set stripprefix [file normalize $layout_dir] |
||||
|
||||
foreach templatefullpath $templatefiles { |
||||
set templatetail [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] |
||||
|
||||
set fpath [file join $projectdir $templatetail] |
||||
if {[file exists $fpath]} { |
||||
set fd [open $fpath r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd |
||||
set data2 [string map [list %project% $projectname] $data] |
||||
if {$data2 ne $data} { |
||||
puts stdout "updated template file: $fpath" |
||||
set fdout [open $fpath w]; fconfigure $fdout -translation binary; puts -nonewline $fdout $data2; close $fdout |
||||
} |
||||
} else { |
||||
puts stderr "warning: Missing template file $fpath" |
||||
} |
||||
} |
||||
#todo - tag substitutions in src/doc tree |
||||
|
||||
|
||||
cd $projectdir |
||||
|
||||
if {[file exists $projectdir/src/modules]} { |
||||
foreach m $opt_modules { |
||||
if {![file exists $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm]} { |
||||
punk::mix::commandset::module::new $m -project $projectname -type $opt_type |
||||
} else { |
||||
if {$opt_force} { |
||||
punk::mix::commandset::module::new $m -project $projectname -type $opt_type -force 1 |
||||
} |
||||
} |
||||
} |
||||
} else { |
||||
puts stderr "project.new WARNING template hasn't created src/modules - skipping creation of new module(s) for project" |
||||
} |
||||
|
||||
#generate www/man/md output in 'embedded' folder which should be checked into repo for online documentation |
||||
if {[file exists $projectdir/src]} { |
||||
cd $projectdir/src |
||||
#---------- |
||||
set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] |
||||
$installer set_source_target $projectdir/src/doc $projectdir/src/embedded |
||||
set event [$installer start_event {-install_step kettledoc}] |
||||
$event targetset_init VIRTUAL kettle_build_doc ;#VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated |
||||
$event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source |
||||
#---------- |
||||
if {\ |
||||
[llength [dict get [$event targetset_source_changes] changed]]\ |
||||
} { |
||||
$event targetset_started |
||||
# -- --- --- --- --- --- |
||||
puts stdout "BUILDING DOCS at src/embedded from src/doc" |
||||
if {[catch { |
||||
|
||||
punk::mix::cli::lib::kettle_call lib doc |
||||
#Kettle doc |
||||
|
||||
} errM]} { |
||||
$event targetset_end FAILED -note "kettle_build_doc failed: $errM" |
||||
} else { |
||||
$event targetset_end OK |
||||
} |
||||
# -- --- --- --- --- --- |
||||
} else { |
||||
puts stderr "No change detected in src/doc" |
||||
$event targetset_end SKIPPED |
||||
} |
||||
$event end |
||||
$event destroy |
||||
$installer destroy |
||||
} |
||||
|
||||
cd $projectdir |
||||
|
||||
if {![punk::repo::is_fossil_root $projectdir]} { |
||||
set first_fossil 1 |
||||
#-k = keep. (only modify the manifest file(s)) |
||||
if {$is_nested_fossil} { |
||||
set fossilopen [runx -n {*}$fossil_prog open --nested $repodb_folder/$projectname.fossil -k --workdir $projectdir] |
||||
} else { |
||||
set fossilopen [runx -n {*}$fossil_prog open $repodb_folder/$projectname.fossil -k --workdir $projectdir] |
||||
} |
||||
if {[file exists $projectdir/_FOSSIL_] && ![file exists $projectdir/.fslckout]} { |
||||
file rename $projectdir/_FOSSIL_ $projectdir/.fslckout |
||||
} |
||||
if {[dict get $fossilopen exitcode] != 0} { |
||||
puts stderr "fossil open in project workdir '$projectdir' FAILED:" |
||||
puts stderr [dict get $fossilopen stderr] |
||||
return |
||||
} else { |
||||
puts stdout "fossil open in project workdir '$projectdir' OK:" |
||||
puts stdout [dict get $fossilopen stdout] |
||||
} |
||||
} else { |
||||
set first_fossil 0 |
||||
} |
||||
set fossiladd [runx -n {*}$fossil_prog add --dotfiles $projectdir] |
||||
if {[dict get $fossiladd exitcode] != 0} { |
||||
puts stderr "fossil add workfiles in workdir '$projectdir' FAILED:" |
||||
puts stderr [dict get $fossiladd stderr] |
||||
return |
||||
} else { |
||||
puts stdout "fossil add workfiles in workdir '$projectdir' OK:" |
||||
puts stdout [dict get $fossiladd stdout] |
||||
} |
||||
if {$first_fossil} { |
||||
#fossil commit may prompt user for input.. runx runout etc will pause with no prompts |
||||
util::do_in_path $projectdir { |
||||
set fossilcommit [run -n {*}$fossil_prog commit -m "initial project commit"] |
||||
} |
||||
if {[dict get $fossilcommit exitcode] != 0} { |
||||
puts stderr "fossil commit in workdir '$projectdir' FAILED" |
||||
return |
||||
} else { |
||||
puts stdout "fossil commit in workdir '$projectdir' OK" |
||||
} |
||||
} |
||||
|
||||
puts stdout "-done- project:$projectname projectdir: $projectdir" |
||||
} |
||||
|
||||
|
||||
namespace eval collection { |
||||
namespace export * |
||||
namespace path [namespace parent] |
||||
|
||||
#e.g imported as 'projects' |
||||
proc _default {{glob {}} args} { |
||||
package require overtype |
||||
set db_projects [lib::get_projects $glob] |
||||
set col1items [lsearch -all -inline -index 0 -subindices $db_projects *] |
||||
set col2items [lsearch -all -inline -index 1 -subindices $db_projects *] |
||||
set checkouts [lsearch -all -inline -index 2 -subindices $db_projects *] |
||||
set col3items [lmap v $checkouts {llength $v}] |
||||
|
||||
set title1 "Fossil DB" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1items] {punk::strlen $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
set title2 "File Name" |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {punk::strlen $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
set title3 "Checkouts" |
||||
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {punk::strlen $v}]] |
||||
set col3 [string repeat " " $widest3] |
||||
set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3}] |
||||
|
||||
|
||||
append msg "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]" \n |
||||
append msg [string repeat "=" $tablewidth] \n |
||||
foreach p $col1items n $col2items c $col3items { |
||||
append msg "[overtype::left $col1 $p] [overtype::left $col2 $n] [overtype::right $col3 $c]" \n |
||||
} |
||||
return $msg |
||||
#return [list_as_lines [lib::get_projects $glob]] |
||||
} |
||||
proc detail {{glob {}} args} { |
||||
package require overtype |
||||
package require textutil |
||||
set defaults [dict create\ |
||||
-description 0\ |
||||
] |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- |
||||
set opt_description [dict get $opts -description] |
||||
# -- --- --- --- --- --- --- |
||||
|
||||
|
||||
set db_projects [lib::get_projects $glob] |
||||
set col1_dbfiles [lsearch -all -inline -index 0 -subindices $db_projects *] |
||||
set col2items [lsearch -all -inline -index 1 -subindices $db_projects *] |
||||
set checkouts [lsearch -all -inline -index 2 -subindices $db_projects *] |
||||
set col3items [lmap v $checkouts {llength $v}] |
||||
|
||||
set col4_pnames [list] |
||||
set col5_pcodes [list] |
||||
set col6_dupids [list] |
||||
set col7_pdescs [list] |
||||
set codes [dict create] |
||||
foreach dbfile $col1_dbfiles { |
||||
set project_name "" |
||||
set project_code "" |
||||
set project_desc "" |
||||
sqlite3 dbp $dbfile |
||||
dbp eval {select name,value from config where name like 'project-%';} r { |
||||
if {$r(name) eq "project-name"} { |
||||
set project_name $r(value) |
||||
} elseif {$r(name) eq "project-code"} { |
||||
set project_code $r(value) |
||||
} elseif {$r(name) eq "project-description"} { |
||||
set project_desc $r(value) |
||||
} |
||||
} |
||||
dbp close |
||||
lappend col4_pnames $project_name |
||||
lappend col5_pcodes $project_code |
||||
dict lappend codes $project_code $dbfile |
||||
lappend col7_pdescs $project_desc |
||||
} |
||||
|
||||
set setid 1 |
||||
set codeset [dict create] |
||||
dict for {code dbs} $codes { |
||||
if {[llength $dbs]>1} { |
||||
dict set codeset $code setid $setid |
||||
dict set codeset $code count [llength $dbs] |
||||
dict set codeset $code seen 0 |
||||
incr setid |
||||
} |
||||
} |
||||
set dupid 1 |
||||
foreach pc $col5_pcodes { |
||||
if {[dict exists $codeset $pc]} { |
||||
set seen [dict get $codeset $pc seen] |
||||
set this_seen [expr {$seen + 1}] |
||||
dict set codeset $pc seen $this_seen |
||||
lappend col6_dupids "[dict get $codeset $pc setid].${this_seen}/[dict get $codeset $pc count]" |
||||
} else { |
||||
lappend col6_dupids "" |
||||
} |
||||
} |
||||
|
||||
set title1 "Fossil DB" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1_dbfiles] {punk::strlen $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
set title2 "File Name" |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {punk::strlen $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
set title3 "Checkouts" |
||||
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {punk::strlen $v}]] |
||||
set col3 [string repeat " " $widest3] |
||||
set title4 "Project Name" |
||||
set widest4 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col4_pnames] {punk::strlen $v}]] |
||||
set col4 [string repeat " " $widest4] |
||||
set title5 "Project Code" |
||||
set widest5 [tcl::mathfunc::max {*}[lmap v [concat [list $title5] $col5_pcodes] {punk::strlen $v}]] |
||||
set col5 [string repeat " " $widest5] |
||||
set title6 "Dup" |
||||
set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col6_dupids] {punk::strlen $v}]] |
||||
set col6 [string repeat " " $widest6] |
||||
set title7 "Description" |
||||
#set widest7 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col7_pdescs] {punk::strlen $v}]] |
||||
set widest7 35 |
||||
set col7 [string repeat " " $widest7] |
||||
|
||||
|
||||
set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3 +1 + $widest4 + 1 + $widest5 + 1 + $widest6}] |
||||
|
||||
append msg "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]\ |
||||
[overtype::left $col4 $title4] [overtype::left $col5 $title5] [overtype::left $col6 $title6]" |
||||
if {!$opt_description} { |
||||
append msg \n |
||||
} else { |
||||
append msg "[overtype::left $col7 $title7]" \n |
||||
set tablewidth [expr {$tablewidth + 1 + $widest7}] |
||||
} |
||||
|
||||
append msg [string repeat "=" $tablewidth] \n |
||||
foreach p $col1_dbfiles n $col2items c $col3items pn $col4_pnames pc $col5_pcodes dup $col6_dupids desc $col7_pdescs { |
||||
set desclines [split [textutil::adjust $desc -length $widest7] \n] |
||||
set desc1 [lindex $desclines 0] |
||||
append msg "[overtype::left $col1 $p] [overtype::left $col2 $n] [overtype::right $col3 $c]\ |
||||
[overtype::left $col4 $pn] [overtype::left $col5 $pc] [overtype::left $col6 $dup]" |
||||
if {!$opt_description} { |
||||
append msg \n |
||||
} else { |
||||
append msg " [overtype::left $col7 $desc1]" \n |
||||
foreach dline [lrange $desclines 1 end] { |
||||
append msg "$col1 $col2 $col3 $col4 $col5 $col6 [overtype::left $col7 $dline]" \n |
||||
} |
||||
} |
||||
} |
||||
return $msg |
||||
#return [list_as_lines [lib::get_projects $glob]] |
||||
} |
||||
proc cd {{glob {}} args} { |
||||
dict set args -cd 1 |
||||
work $glob {*}$args |
||||
} |
||||
proc work {{glob {}} args} { |
||||
package require sqlite3 |
||||
set db_projects [lib::get_projects $glob] |
||||
#list of lists of the form: |
||||
#{fosdb fname workdirlist} |
||||
set defaults [dict create\ |
||||
-cd 0\ |
||||
] |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- |
||||
set opt_cd [dict get $opts -cd] |
||||
# -- --- --- --- --- --- --- |
||||
set workdir_dict [dict create] |
||||
set all_workdirs [list] |
||||
foreach pinfo $db_projects { |
||||
lassign $pinfo fosdb name workdirs |
||||
foreach wdir $workdirs { |
||||
dict set workdir_dict $wdir $pinfo |
||||
lappend all_workdirs $wdir |
||||
} |
||||
} |
||||
set col_rowids [list] |
||||
set workdirs [lsort -index 0 $all_workdirs] |
||||
set col_dupids [list] |
||||
set col_fnames [list] |
||||
set col_pnames [list] |
||||
set col_pcodes [list] |
||||
set col_dupids [list] |
||||
|
||||
set fosdb_count [dict create] |
||||
set fosdb_dupset [dict create] |
||||
set fosdb_cache [dict create] |
||||
set dupset 0 |
||||
set rowid 1 |
||||
foreach wd $workdirs { |
||||
set wdinfo [dict get $workdir_dict $wd] |
||||
lassign $wdinfo fosdb nm siblingworkdirs |
||||
dict incr fosdb_count $fosdb |
||||
set dbcount [dict get $fosdb_count $fosdb] |
||||
if {[llength $siblingworkdirs] > 1} { |
||||
if {![dict exists $fosdb_dupset $fosdb]} { |
||||
#first time this multi-checkout fosdb seen |
||||
dict set fosdb_dupset $fosdb [incr dupset] |
||||
} |
||||
set dupid "[dict get $fosdb_dupset $fosdb].$dbcount/[llength $siblingworkdirs]" |
||||
} else { |
||||
set dupid "" |
||||
} |
||||
if {$dbcount == 1} { |
||||
set pname "" |
||||
set pcode "" |
||||
if {[file exists $fosdb]} { |
||||
if {[catch { |
||||
sqlite3 fdb $fosdb |
||||
set pname [lindex [fdb eval {select value from config where name = 'project-name'}] 0] |
||||
set pcode [lindex [fdb eval {select value from config where name = 'project-code'}] 0] |
||||
fdb close |
||||
dict set fosdb_cache $fosdb [list name $pname code $pcode] |
||||
} errM]} { |
||||
puts stderr "!!! problem with fossil db: $fosdb when examining workdir $wd" |
||||
puts stderr "!!! error: $errM" |
||||
} |
||||
} else { |
||||
puts stderr "!!! missing fossil db $fosdb" |
||||
} |
||||
} else { |
||||
set info [dict get $fosdb_cache $fosdb] |
||||
lassign $info _name pname _code pcode |
||||
} |
||||
lappend col_rowids $rowid |
||||
lappend col_fnames $nm |
||||
lappend col_dupids $dupid |
||||
lappend col_pnames $pname |
||||
lappend col_pcodes [string range $pcode 0 9] |
||||
incr rowid |
||||
} |
||||
|
||||
set col_states [list] |
||||
set state_title "" |
||||
#if only one set of fossil checkouts in the resultset - retrieve workingdir state for each co |
||||
if {[llength [dict keys $fosdb_cache]] == 1} { |
||||
puts stderr "Result is a single project - gathering file state for each checkout folder" |
||||
set c_rev [list] |
||||
set c_unchanged [list] |
||||
set c_changed [list] |
||||
set c_new [list] |
||||
set c_missing [list] |
||||
set c_extra [list] |
||||
foreach wd $workdirs { |
||||
set wd_state [punk::repo::workingdir_state $wd] |
||||
set state_dict [punk::repo::workingdir_state_summary_dict $wd_state] |
||||
lappend c_rev [string range [dict get $state_dict revision] 0 9] |
||||
lappend c_unchanged [dict get $state_dict unchanged] |
||||
lappend c_changed [dict get $state_dict changed] |
||||
lappend c_new [dict get $state_dict new] |
||||
lappend c_missing [dict get $state_dict missing] |
||||
lappend c_extra [dict get $state_dict extra] |
||||
puts -nonewline stderr "." |
||||
} |
||||
puts -nonewline stderr \n |
||||
set t0 "Revision" |
||||
set w0 [tcl::mathfunc::max {*}[lmap v [concat [list $t0] $c_rev] {string length $v}]] |
||||
set c0 [string repeat " " $w0] |
||||
set t1 "Unch" |
||||
set w1 [tcl::mathfunc::max {*}[lmap v [concat [list $t1] $c_unchanged] {string length $v}]] |
||||
set c1 [string repeat " " $w1] |
||||
set t2 "Chgd" |
||||
set w2 [tcl::mathfunc::max {*}[lmap v [concat [list $t2] $c_changed] {string length $v}]] |
||||
set c2 [string repeat " " $w2] |
||||
set t3 "New" |
||||
set w3 [tcl::mathfunc::max {*}[lmap v [concat [list $t3] $c_new] {string length $v}]] |
||||
set c3 [string repeat " " $w3] |
||||
set t4 "Miss" |
||||
set w4 [tcl::mathfunc::max {*}[lmap v [concat [list $t4] $c_missing] {string length $v}]] |
||||
set c4 [string repeat " " $w4] |
||||
set t5 "Extr" |
||||
set w5 [tcl::mathfunc::max {*}[lmap v [concat [list $t5] $c_extra] {string length $v}]] |
||||
set c5 [string repeat " " $w5] |
||||
|
||||
set state_title "[overtype::left $c0 $t0] [overtype::right $c1 $t1] [overtype::right $c2 $t2] [overtype::right $c3 $t3] [overtype::right $c4 $t4] [overtype::right $c5 $t5]" |
||||
foreach r $c_rev u $c_unchanged c $c_changed n $c_new m $c_missing e $c_extra { |
||||
lappend col_states "[overtype::left $c0 $r] [overtype::right $c1 $u] [overtype::right $c2 $c] [overtype::right $c3 $n] [overtype::right $c4 $m] [overtype::right $c5 $e]" |
||||
} |
||||
} |
||||
|
||||
set msg "" |
||||
if {$opt_cd} { |
||||
set title0 "CD" |
||||
} else { |
||||
set title0 "" |
||||
} |
||||
set widest0 [tcl::mathfunc::max {*}[lmap v [concat [list $title0] $col_rowids] {punk::strlen $v}]] |
||||
set col0 [string repeat " " $widest0] |
||||
set title1 "Checkout dir" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $workdirs] {punk::strlen $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
set title2 "Db name" |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col_fnames] {string length $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
set title3 "CO dup" |
||||
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col_dupids] {string length $v}]] |
||||
set col3 [string repeat " " $widest3] |
||||
set title4 "Project Name" |
||||
set widest4 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col_pnames] {string length $v}]] |
||||
set col4 [string repeat " " $widest4] |
||||
set title5 "Project Code" |
||||
set widest5 [tcl::mathfunc::max {*}[lmap v [concat [list $title5] $col_pcodes] {string length $v}]] |
||||
set col5 [string repeat " " $widest5] |
||||
|
||||
set tablewidth [expr {$widest0 + 1 + $widest1 + 1 + $widest2 + 1 + $widest3 +1 + $widest4 + 1 + $widest5}] |
||||
append msg "[overtype::right $col0 $title0] [overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3] [overtype::left $col4 $title4] [overtype::left $col5 $title5]" |
||||
|
||||
if {[llength $col_states]} { |
||||
set title6 $state_title |
||||
set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col_states] {string length $v}]] |
||||
set col6 [string repeat " " $widest6] |
||||
incr tablewidth [expr {$widest6 + 1}] |
||||
append msg " [overtype::left $col6 $title6]" \n |
||||
} else { |
||||
append msg \n |
||||
} |
||||
append msg [string repeat "=" $tablewidth] \n |
||||
|
||||
if {[llength $col_states]} { |
||||
foreach row $col_rowids wd $workdirs db $col_fnames dup $col_dupids pname $col_pnames pcode $col_pcodes s $col_states { |
||||
append msg "[overtype::right $col0 $row] [overtype::left $col1 $wd] [overtype::left $col2 $db] [overtype::right $col3 $dup] [overtype::left $col4 $pname] [overtype::left $col5 $pcode] [overtype::left $col6 $s]" \n |
||||
} |
||||
} else { |
||||
foreach row $col_rowids wd $workdirs db $col_fnames dup $col_dupids pname $col_pnames pcode $col_pcodes { |
||||
append msg "[overtype::right $col0 $row] [overtype::left $col1 $wd] [overtype::left $col2 $db] [overtype::right $col3 $dup] [overtype::left $col4 $pname] [overtype::left $col5 $pcode]" \n |
||||
} |
||||
} |
||||
set numrows [llength $col_rowids] |
||||
if {$opt_cd && $numrows >= 1} { |
||||
puts stdout $msg |
||||
if {$numrows == 1} { |
||||
set workingdir [lindex $workdirs 0] |
||||
puts stdout "1 result. Changing dir to $workingdir" |
||||
if {[file exists $workingdir]} { |
||||
cd $workingdir |
||||
return $workingdir |
||||
} else { |
||||
puts stderr "path $workingdir doesn't appear to exist" |
||||
return [pwd] |
||||
} |
||||
} else { |
||||
set answer [util::askuser "Change directory to working folder - select a number from 1 to [llength $col_rowids] or any other key to cancel."] |
||||
if {[string trim $answer] in $col_rowids} { |
||||
set index [expr {$answer - 1}] |
||||
set workingdir [lindex $workdirs $index] |
||||
cd $workingdir |
||||
puts stdout [pmix stat] |
||||
return $workingdir |
||||
} |
||||
} |
||||
} |
||||
return $msg |
||||
} |
||||
} |
||||
|
||||
namespace eval lib { |
||||
#get project info only by opening the central confg-db |
||||
#(will not have proper project-name etc) |
||||
proc get_projects {{globlist {}} args} { |
||||
if {![llength $globlist]} { |
||||
set globlist [list *] |
||||
} |
||||
set fossil_prog [auto_execok fossil] |
||||
|
||||
set fossilinfo [exec {*}$fossil_prog info] ;#will give us the necessary config-db info whether in a project folder or not |
||||
set matching_lines [punk::repo::grep {config-db:*} $fossilinfo] |
||||
if {[llength $matching_lines] != 1} { |
||||
puts stderr "Unable to find config-db info from fossil. Check your fossil installation." |
||||
puts stderr "Fossil output was:" |
||||
puts stderr "-------------" |
||||
puts stderr "$fossilinfo" |
||||
puts stderr "-------------" |
||||
puts stderr "config-db info:" |
||||
puts stderr "$matching_lines" |
||||
return |
||||
} |
||||
set ln [lindex $matching_lines 0] |
||||
set configdb [string trim [string range $ln [string length "config-db: "] end]] |
||||
if {![file exists $configdb]} { |
||||
error "config-db not found at path $configdb" |
||||
} |
||||
package require sqlite3 |
||||
::sqlite3 fosconf $configdb |
||||
#set testresult [fosconf eval {select name,value from global_config;}] |
||||
#puts stderr $testresult |
||||
set project_repos [fosconf eval {select name from global_config where name like 'repo:%';}] |
||||
set paths_and_names [list] |
||||
foreach pr $project_repos { |
||||
set path [string trim [string range $pr 5 end]] |
||||
set nm [file rootname [file tail $path]] |
||||
set ckouts [fosconf eval {select name from global_config where value = $path;}] |
||||
set checkout_paths [list] |
||||
#strip "ckout:" |
||||
foreach ck $ckouts { |
||||
lappend checkout_paths [string trim [string range $ck 6 end]] |
||||
} |
||||
lappend paths_and_names [list $path $nm $checkout_paths] |
||||
} |
||||
set filtered_list [list] |
||||
foreach glob $globlist { |
||||
set matches [lsearch -all -inline -index 1 $paths_and_names $glob] |
||||
foreach m $matches { |
||||
if {$m ni $filtered_list} { |
||||
lappend filtered_list $m |
||||
} |
||||
} |
||||
} |
||||
set projects [lsort -index 1 $filtered_list] |
||||
return $projects |
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::project [namespace eval punk::mix::commandset::project { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,92 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::repo 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::repo { |
||||
namespace export * |
||||
proc tickets {{project ""}} { |
||||
set result "" |
||||
if {[string length $project]} { |
||||
puts stderr "project status unimplemented" |
||||
return |
||||
} |
||||
set active_dir [pwd] |
||||
append result "Retrieving top 10 tickets only (for more, use fossil timeline -n <int> -t t)" \n |
||||
append result [exec fossil timeline -n 10 -t t] |
||||
|
||||
return $result |
||||
} |
||||
|
||||
proc fossilize { args} { |
||||
#check if project already managed by fossil.. initialise and check in if not. |
||||
puts stderr "unimplemented" |
||||
} |
||||
|
||||
proc unfossilize {projectname args} { |
||||
#remove/archive .fossil |
||||
puts stderr "unimplemented" |
||||
} |
||||
proc state {} { |
||||
set result "" |
||||
set repopaths [punk::repo::find_repos [pwd]] |
||||
set repos [dict get $repopaths repos] |
||||
if {![llength $repos]} { |
||||
append result [dict get $repopaths warnings] |
||||
} else { |
||||
append result [dict get $repopaths warnings] |
||||
lassign [lindex $repos 0] repopath repotypes |
||||
if {"fossil" in $repotypes} { |
||||
append result \n "Fossil repo based at $repopath" |
||||
set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes fossil] |
||||
append result \n [punk::repo::workingdir_state_summary $repostate] |
||||
} |
||||
if {"git" in $repotypes} { |
||||
append result \n "Git repo based at $repopath" |
||||
set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes git] |
||||
append result \n [punk::repo::workingdir_state_summary $repostate] |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::repo [namespace eval punk::mix::commandset::repo { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,634 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::scriptwrap 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
package require punk::mix |
||||
package require punk::mix::base |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::scriptwrap { |
||||
namespace export * |
||||
|
||||
|
||||
#scriptpath allows templates command to use same custom template set as when multishell pointed to a filepath |
||||
#it may or may not be within a project |
||||
#by using the same folder or path, the same project root will be discovered. REVIEW. |
||||
proc templates_dict {args} { |
||||
set defaults [list -scriptpath ""] |
||||
set opts [dict merge $defaults $args] |
||||
set opt_scriptpath [dict get $opts -scriptpath] |
||||
|
||||
set wrapper_folders [lib::get_wrapper_folders $opt_scriptpath] |
||||
|
||||
set wrapper_templates [list] |
||||
foreach fld $wrapper_folders { |
||||
set templates [glob -nocomplain -dir $fld -type f *] |
||||
foreach tf $templates { |
||||
if {[string match ignore* $tf]} { |
||||
continue |
||||
} |
||||
set ext [file extension $tf] |
||||
if {$ext in [list "" ".bat" ".cmd" ".sh"]} { |
||||
lappend wrapper_templates $tf |
||||
} |
||||
} |
||||
} |
||||
|
||||
set tdict [dict create] |
||||
set seen_dict [dict create] |
||||
foreach fullpath $wrapper_templates { |
||||
set ftail [file tail $fullpath] |
||||
if {![dict exists $seen_dict $ftail]} { |
||||
dict set seen_dict $ftail 1 |
||||
dict set tdict $ftail $fullpath ; #first seen of filename gets no number |
||||
} else { |
||||
set n [dict get $seen_dict $ftail] |
||||
incr n |
||||
dict incr seen_dict $ftail |
||||
dict set tdict ${ftail}.$n $fullpath |
||||
} |
||||
} |
||||
return $tdict |
||||
} |
||||
proc templates {args} { |
||||
package require overtype |
||||
set tdict [templates_dict {*}$args] |
||||
|
||||
|
||||
set paths [dict values $tdict] |
||||
set names [dict keys $tdict] |
||||
|
||||
set title1 "Path" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $paths] {punk::strlen $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
|
||||
set title2 "Template Name" |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $names] {punk::strlen $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
|
||||
set tablewidth [expr {$widest1 + 1 + $widest2}] |
||||
set table "" |
||||
append table [string repeat - $tablewidth] \n |
||||
append table "[overtype::left $col1 $title1] [overtype::left $col2 $title2]" \n |
||||
append table [string repeat - $tablewidth] \n |
||||
|
||||
foreach p $paths n $names { |
||||
append table "[overtype::left $col1 $p] [overtype::left $col2 $n]" \n |
||||
} |
||||
|
||||
|
||||
return $table |
||||
} |
||||
#specific filepath to just wrap one script at the tcl-payload or xxx-payload-pre-tcl site |
||||
#scriptset name to substiture multiple scriptset.xxx files at the default locations - or as specified in scriptset.wrapconf |
||||
proc multishell {filepath_or_scriptset args} { |
||||
set defaults [list -askme 1 -template \uFFFF] |
||||
set opts [dict merge $defaults $args] |
||||
set opt_askme [dict get $opts -askme] |
||||
set opt_template [dict get $opts -template] |
||||
set ext [file extension $filepath_or_scriptset] |
||||
set startdir [pwd] |
||||
|
||||
set usage "" |
||||
append usage "Use directly with the script file to wrap, or supply the name of a scriptset" \n |
||||
append usage "The scriptset name will be used to search for yourname.sh|tcl|ps1 or names as you specify in yourname.wrapconfig if it exists" \n |
||||
append usage "If no template is specified in a .wrapconfig and no -template argument is supplied, it will default to punk-multishell.cmd" \n |
||||
if {![string length $filepath_or_scriptset]} { |
||||
puts stderr "No filepath_or_scriptset specified" |
||||
puts stderr $usage |
||||
return false |
||||
} |
||||
|
||||
|
||||
#first check if relative or absolute path matches a file |
||||
if {[file pathtype $filepath_or_scriptset] eq "absolute"} { |
||||
set specified_path $filepath_or_scriptset |
||||
} else { |
||||
set specified_path [file join $startdir $filepath_or_scriptset] |
||||
} |
||||
|
||||
set ext [string trim [file extension $filepath_or_scriptset] .] |
||||
set allowed_extensions [list wrapconfig tcl ps1 sh bash] |
||||
#set allowed_extensions [list tcl] |
||||
set found_script 0 |
||||
if {[file exists $specified_path]} { |
||||
set found_script 1 |
||||
} else { |
||||
foreach e $allowed_extensions { |
||||
if {[file exists $filepath_or_scriptset.$e]} { |
||||
set found_script 1 |
||||
break |
||||
} |
||||
} |
||||
} |
||||
|
||||
#TODO! - use get_wrapper_folders - multishell should use same available templates as the 'templates' function |
||||
set scriptset [file rootname [file tail $specified_path]] |
||||
if {$found_script} { |
||||
if {[file type $specified_path] eq "file"} { |
||||
set specified_root [file dirname $specified_path] |
||||
set pathinfo [punk::repo::find_repos [file dirname $specified_path]] |
||||
set projectroot [dict get $pathinfo closest] |
||||
if {[string length $projectroot]} { |
||||
#use the specified files folder - but use the main scriptapps/wrappers folder if specified one has no wrappers subfolder |
||||
set scriptroot [file dirname $specified_path] |
||||
if {[file exists $scriptroot/wrappers]} { |
||||
set customwrapper_folder $scriptroot/wrappers |
||||
} else { |
||||
set customwrapper_folder $projectroot/src/scriptapps/wrappers |
||||
} |
||||
} else { |
||||
#outside of any project |
||||
set scriptroot [file dirname $specified_path] |
||||
if {[file exists $scriptroot/wrappers]} { |
||||
set customwrapper_folder $scriptroot/wrappers |
||||
} else { |
||||
#no customwrapper folder available |
||||
set customwrapper_folder "" |
||||
} |
||||
} |
||||
} else { |
||||
puts stderr "wrap_in_multishell doesn't currently support a directory as the path." |
||||
puts stderr $usage |
||||
return false |
||||
} |
||||
} else { |
||||
set pathinfo [punk::repo::find_repos $startdir] |
||||
set projectroot [dict get $pathinfo closest] |
||||
if {[string length $projectroot]} { |
||||
if {[llength [file split $filepath_or_scriptset]] > 1} { |
||||
puts stderr "filepath_or_scriptset looks like a path - but doesn't seem to point to a file" |
||||
puts stderr "Ensure you are within a project and use just the name of the scriptset, or pass in the full correct path or relative path to current directory" |
||||
puts stderr $usage |
||||
return false |
||||
} else { |
||||
#we've already ruled out empty string - so must have a single element representing scriptset - possibly with file extension |
||||
set scriptroot $projectroot/src/scriptapps |
||||
set customwrapper_folder $projectroot/src/scriptapps/wrappers |
||||
#check something matches the scriptset.. |
||||
set something_found "" |
||||
if {[file exists $scriptroot/$scriptset]} { |
||||
set found_script 1 |
||||
set something_found $scriptroot/$scriptset ;#extensionless file - that's ok too |
||||
} else { |
||||
foreach e $allowed_extensions { |
||||
if {[file exists $scriptroot/$scriptset.$e]} { |
||||
set found_script 1 |
||||
set something_found $scriptroot/$scriptset.$e |
||||
break |
||||
} |
||||
} |
||||
} |
||||
if {!$found_script} { |
||||
puts stderr "Searched within $scriptroot" |
||||
puts stderr "Unable to find a file matching $scriptset or one of the extensions: $allowed_extensions" |
||||
puts stderr $usage |
||||
return false |
||||
} else { |
||||
if {[file pathtype $something_found] ne "file"} { |
||||
puts stderr "wrap_in_multishell doesn't currently support a directory as the path." |
||||
puts stderr $usage |
||||
return false |
||||
} |
||||
} |
||||
} |
||||
|
||||
} else { |
||||
puts stderr "filepath_or_scriptset parameter doesn't seem to refer to a file, and you are not within a directory where projectroot and src/scriptapps/wrappers can be determined" |
||||
puts stderr $usage |
||||
return false |
||||
} |
||||
} |
||||
#assert - customwrapper_folder var exists - but might be empty |
||||
|
||||
|
||||
if {[string length $ext]} { |
||||
#If there was an explicitly supplied extension - then that file should exist |
||||
if {![file exists $scriptroot/$scriptset.$ext]} { |
||||
puts stderr "Explicit extension .$ext was supplied - but matching file not found." |
||||
puts stderr $usage |
||||
return false |
||||
} else { |
||||
if {$ext eq "wrapconfig"} { |
||||
set process_extensions ALLFOUNDORCONFIGURED |
||||
} else { |
||||
set process_extensions $ext |
||||
} |
||||
} |
||||
} else { |
||||
#no explicit extension - process all for scriptset |
||||
set process_extensions ALLFOUNDORCONFIGURED |
||||
} |
||||
#process_extensions - either a single one - or all found or as per .wrapconfig |
||||
|
||||
if {$opt_template eq "\uFFFF"} { |
||||
set templatename punk-multishell.cmd |
||||
} else { |
||||
set templatename $opt_template |
||||
} |
||||
|
||||
|
||||
|
||||
set template_base_dict [punk::mix::base::lib::get_template_basefolders] |
||||
set tpldirs [list] |
||||
dict for {tdir tsourceinfo} $template_base_dict { |
||||
if {[file exists $tdir/utility/scriptappwrappers/$templatename]} { |
||||
lappend tpldirs $tdir |
||||
} |
||||
} |
||||
|
||||
if {[string length $customwrapper_folder] && [file exists [file join $customwrapper_folder $templatename] ]} { |
||||
set wrapper_template [file join $customwrapper_folder $templatename] |
||||
} else { |
||||
if {![llength $tpldirs]} { |
||||
set msg "No template named '$templatename' found in src/scriptapps/wrappers or in template dirs from packages" |
||||
append msg \n "Searched [dict size $template_base_dict] template dirs" |
||||
error $msg |
||||
} |
||||
|
||||
#last pkg with templates cap which was loaded has highest precedence |
||||
set wrapper_template "" |
||||
foreach tdir [lreverse $tpldirs] { |
||||
set ftest [file join $tdir utility scriptappwrappers $templatename] |
||||
if {[file exists $ftest]} { |
||||
set wrapper_template $ftest |
||||
break |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {$wrapper_template eq "" || ![file exists $wrapper_template]} { |
||||
error "wrap_in_multishell: unable to find multishell template $templatename in template folders [concat $tpldirs $customwrapper_folder]" |
||||
} |
||||
|
||||
|
||||
#todo |
||||
#output_file extension depends on the template being used.. |
||||
|
||||
|
||||
set output_file $scriptset.cmd |
||||
if {[file exists $output_file]} { |
||||
error "wrap_in_multishell: target file $output_file already exists.. aborting" |
||||
} |
||||
|
||||
|
||||
set fdt [open $wrapper_template r] |
||||
fconfigure $fdt -translation binary |
||||
set template_data [read $fdt] |
||||
close $fdt |
||||
puts stdout "Read [string length $template_data] bytes of template data.." |
||||
set template_lines [split $template_data \n] |
||||
puts stdout "Displaying first 3 lines of template between dashed lines..." |
||||
puts stdout "-----------------------------------------------" |
||||
foreach ln [lrange $template_lines 0 3] { |
||||
puts stdout $ln |
||||
} |
||||
puts stdout "-----------------------------------------------\n" |
||||
#foreach ln $template_lines { |
||||
#} |
||||
|
||||
set list_input_files [list] |
||||
if {$process_extensions eq "ALLFOUNDORCONFIGURED"} { |
||||
#todo - look for .wrapconfig or all extensions for the scriptset |
||||
puts stderr "Sorry - only single input file supported - implementation incomplete" |
||||
return false |
||||
} else { |
||||
lappend list_input_files $scriptroot/$scriptset.$ext |
||||
} |
||||
|
||||
#todo - split template at each <ext-payload> etc marker and build a dict of parts |
||||
|
||||
|
||||
#hack - process one input |
||||
set filepath [lindex $list_input_files 0] |
||||
|
||||
set fdscript [open $filepath r] |
||||
fconfigure $fdscript -translation binary |
||||
set script_data [read $fdscript] |
||||
close $fdscript |
||||
puts stdout "Read [string length $script_data] bytes of template data.." |
||||
set script_lines [split $script_data \n] |
||||
puts stdout "Displaying first 3 lines of your script between dashed lines..." |
||||
puts stdout "-----------------------------------------------" |
||||
foreach ln [lrange $script_lines 0 3] { |
||||
puts stdout $ln |
||||
} |
||||
puts stdout "-----------------------------------------------\n" |
||||
if {$opt_askme} { |
||||
puts stdout "Target for above data is '$output_file'" |
||||
set answer [util::askuser "Does this look correct? Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y or y to proceed) use -askme 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
|
||||
set start_idx 0 |
||||
set end_idx 0 |
||||
set line_idx 0 |
||||
set existing_payload [list] |
||||
foreach ln $template_lines { |
||||
|
||||
if {[string match "#<tcl-payload>*" $ln]} { |
||||
set start_idx $line_idx |
||||
} elseif {[string match "#</tcl-payload>*" $ln]} { |
||||
set end_idx $line_idx |
||||
break |
||||
} elseif {$start_idx > 0} { |
||||
if {$end_idx > 0} { |
||||
lappend existing_payload [string trim $ln] |
||||
} |
||||
} else { |
||||
|
||||
} |
||||
incr line_idx |
||||
} |
||||
if {($start_idx == 0) || ($end_idx == 0)} { |
||||
error "wrap_in_multishell was unable to find payload area in template marked with #<tcl-payload> and #</tcl-payload> on separate lines" |
||||
} |
||||
set existing_string [join $existing_payload \n] |
||||
if {[string length [string trim $existing_string]]} { |
||||
puts stdout "EXISTING PAYLOAD!!" |
||||
puts stdout "-----------------------------------------------\n" |
||||
puts stdout $existing_string |
||||
puts stdout "-----------------------------------------------\n" |
||||
error "wrap_in_multishell found existing payload.. aborting." |
||||
#todo - allow overwrite only in files outside of punkshell distribution? |
||||
if 0 { |
||||
puts stderr "Found existing payload.. overwrite?" |
||||
if {$opt_askme} { |
||||
set answer [util::askuser "Are you sure you want to replace the tcl payload shown above? Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
set tpl_head_lines [lrange $template_lines 0 $start_idx] ;#include tag line |
||||
set tpl_tail_lines [lrange $template_lines $end_idx end] |
||||
set newscript [join $tpl_head_lines \n]\n[join $script_lines \n]\n[join $tpl_tail_lines \n] |
||||
puts stdout "New script is [string length $newscript] bytes" |
||||
puts stdout $newscript |
||||
set fdtarget [open $output_file w] |
||||
fconfigure $fdtarget -translation binary |
||||
puts -nonewline $fdtarget $newscript |
||||
close $fdtarget |
||||
puts stdout "Wrote script file at $output_file" |
||||
puts stdout "-done-" |
||||
return $output_file |
||||
} |
||||
|
||||
namespace eval lib { |
||||
|
||||
#get_wrapper_folders |
||||
# scriptpath - file or folder |
||||
# It represents the base point from which to search for /wrapper folders either directly above the scriptpath or in the containing project if any |
||||
# The cwd will also be searched for /wrapper folder and project - but with lower precedence in the resultset (later in list) |
||||
proc get_wrapper_folders {{scriptpath ""}} { |
||||
set wrapper_folders [list] |
||||
if {$scriptpath ne ""} { |
||||
if {[file type $scriptpath] eq "file"} { |
||||
set searchbase [file dirname $scriptpath] |
||||
} else { |
||||
set searchbase $scriptpath |
||||
} |
||||
if {[file isdirectory [file join $searchbase wrappers]]} { |
||||
lappend wrapper_folders [file join $searchbase wrappers] |
||||
} |
||||
set pathinfo [punk::repo::find_repos $searchbase] |
||||
set scriptpath_projectroot [dict get $pathinfo closest] |
||||
if {$scriptpath_projectroot ne ""} { |
||||
set fld [file join $scriptpath_projectroot src/scriptapps/wrappers] |
||||
if {[file isdirectory $fld]} { |
||||
if {$fld ni $wrapper_folders} { |
||||
lappend wrapper_folders $fld |
||||
} |
||||
} |
||||
} |
||||
} |
||||
set searchbase [pwd] |
||||
set fld [file join $searchbase wrappers] |
||||
if {[file isdirectory $fld]} { |
||||
if {$fld ni $wrapper_folders} { |
||||
lappend wrapper_folders $fld |
||||
} |
||||
} |
||||
set pathinfo [punk::repo::find_repos $searchbase] |
||||
set pwd_projectroot [dict get $pathinfo closest] |
||||
if {$pwd_projectroot ne ""} { |
||||
set fld [file join $pwd_projectroot src/scriptapps/wrappers] |
||||
if {[file isdirectory $fld]} { |
||||
if {$fld ni $wrapper_folders} { |
||||
lappend wrapper_folders $fld |
||||
} |
||||
} |
||||
} |
||||
|
||||
set template_base_dict [punk::mix::base::lib::get_template_basefolders] |
||||
set tpldirs [list] |
||||
dict for {tdir tsourceinfo} $template_base_dict { |
||||
if {[file exists $tdir/utility/scriptappwrappers]} { |
||||
lappend tpldirs $tdir |
||||
} |
||||
} |
||||
foreach tpldir $tpldirs { |
||||
set fld [file join $tpldir utility scriptappwrappers] |
||||
if {[file isdirectory $fld]} { |
||||
if {$fld ni $wrapper_folders} { |
||||
lappend wrapper_folders $fld |
||||
} |
||||
} |
||||
} |
||||
return $wrapper_folders |
||||
} |
||||
proc _scriptapp_tag_from_line {line} { |
||||
set result [list istag 0 raw ""] ;#default assumption. All |
||||
#---- |
||||
set startc [string first "#" $line] ;#tags must be commented |
||||
#todo - review. next line is valid - note # doesn't have to be the only one before <tagname> |
||||
# @REM # etc < blah # <tagname> etc |
||||
#--- |
||||
#fix - we should use a regexp on at least <tagname> </tagname> <tagname/> and only catch tagname without whitespace |
||||
regexp {(\s*).*} $line _ln indent ;#will match on empty line, whitespace only line - or anything really. |
||||
set indent [string map [list \t " "] $indent] ;#opinionated I guess - but need to normalize to something. The spec is that spaces should be used anyway. |
||||
dict set result indent [string length $indent] |
||||
set starttag [string first "<" $line] |
||||
set pretag [string range $line $startc $starttag-1] |
||||
if {[string match "*>*" $pretag]} { |
||||
return [list istag 0 raw $line reason pretag_contents] |
||||
} |
||||
set closetag [string first ">" $line] |
||||
set inelement [string range $line $starttag+1 $closetag-1] |
||||
if {[string match "*<*" $inelement]} { |
||||
return [list istag 0 raw $line reason tag_malformed_angles] |
||||
} |
||||
set elementchars [split $inelement ""] |
||||
set numslashes [llength [lsearch -all $elementchars "/"]] |
||||
if {$numslashes == 0} { |
||||
dict set result type "open" |
||||
} elseif {$numslashes == 1} { |
||||
if {[lindex $elementchars 0] eq "/"} { |
||||
dict set result type "close" |
||||
} elseif {[lindex $elementchars end] eq "/"} { |
||||
dict set result type "openclose" |
||||
} else { |
||||
return [list istag 0 raw $line reason tag_malformed_slashes] |
||||
} |
||||
} else { |
||||
return [list istag 0 raw $line reason tag_malformed_extraslashes] |
||||
} |
||||
if {[dict get $result type] eq "open"} { |
||||
dict set result name $inelement |
||||
} elseif {[dict get $result type] eq "close"} { |
||||
dict set result name [string range $inelement 1 end] |
||||
} else { |
||||
dict set result name [string range $inelement 0 end-1] |
||||
} |
||||
dict set result istag 1 |
||||
dict set result raw $line |
||||
return $result |
||||
} |
||||
|
||||
#get all \n#<something>\n ...\n#</something> data - where number of intervening newlines is at least one (and whitespace and/or other data can precede #) |
||||
#we don't verify 'something' against known tags - as custom templates can have own tags |
||||
#An openclose tag #<xxx/> is used to substitute a specific line in its entirety - but the tag *must* remain in the line |
||||
# |
||||
#e.g for the line: |
||||
# @set "nextshell=pwsh" & :: #<batch-nextshell-line/> |
||||
#The .wrapconfig might contain |
||||
# tag <batch-nextshell-line> line {@set "nextshell=tclsh" & :: @<batch-nextshell-line/>} |
||||
# |
||||
proc scriptapp_wrapper_get_tags {wrapperdata} { |
||||
set wrapperdata [string map [list \r\n \n] $wrapperdata] |
||||
set lines [split $wrapperdata \n] |
||||
#set tags_in_data [dict create];#active tags - list of lines accumulating. supports nested tags |
||||
set status 0 |
||||
set tags [dict create] |
||||
set errors [list] |
||||
set errortags [dict create] ;#mark names invalid on first error so that more than 2 tags can't obscure config problem |
||||
set linenum 1 ;#editors and other utils use 1-based indexing when referencing files - we should too to avoid confusion, despite it being less natural for lindex operations on the result. |
||||
foreach ln $lines { |
||||
set lntrim [string trim $ln] |
||||
if {![string length $lntrim]} { |
||||
incr linenum |
||||
continue |
||||
} |
||||
if {[string match "*#*<*>*" $lntrim]} { |
||||
set taginfo [_scriptapp_tag_from_line $ln] ;#use untrimmed line - to get indent |
||||
if {[dict get $taginfo istag]} { |
||||
set nm [dict get $taginfo name] |
||||
if {[dict exists $errortags $nm]} { |
||||
#tag is already in error condition - |
||||
} else { |
||||
set tp [dict get $taginfo type] ;# type singular - related to just one line |
||||
#set raw [dict get $taginfo raw] #equivalent to $ln |
||||
if {[dict exists $tags $nm]} { |
||||
#already seen tag name |
||||
#tags dict has types key *plural* - need to track whether we have type open and type close (or openclose for self-closing tags) |
||||
if {[dict get $tags $nm types] ne "open"} { |
||||
lappend errors "line: $linenum tag $nm encountered type $tp after existing type [dict get $tags $nm types]" |
||||
dict incr errortags $nm |
||||
} else { |
||||
#we already have open - expect only close |
||||
if {$tp ne "close"} { |
||||
lappend errors "line: $linenum tag $nm encountered type $tp after existing type [dict get $tags $nm types]" |
||||
dict incr errortags $nm |
||||
} else { |
||||
#close after open |
||||
dict set tags $nm types [list open close] |
||||
dict set tags $nm end $linenum |
||||
set taglines [dict get $tags $nm taglines] |
||||
if {[llength $taglines] != 1} { |
||||
error "Unexpected result when closing tag $nm. Existing taglines length not 1." |
||||
} |
||||
dict set tags $nm taglines [concat $taglines $ln] |
||||
} |
||||
} |
||||
} else { |
||||
#first seen of tag name |
||||
if {$tp eq "close"} { |
||||
lappend errors "line: $linenum tag $nm encountered type $p close first" |
||||
dict incr errortags $nm |
||||
} else { |
||||
dict set tags $nm types $tp |
||||
dict set tags $nm indent [dict get $taginfo indent] |
||||
if {$tp eq "open"} { |
||||
dict set tags $nm start $linenum |
||||
dict set tags $nm taglines [list $ln] ;#first entry - another will be added on encountering matching closing tag |
||||
} elseif {$tp eq "openclose"} { |
||||
dict set tags $nm start $linenum |
||||
dict set tags $nm end $linenum |
||||
dict set tags $nm taglines [list $ln] ;#single entry is final result for self-closing tag |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} else { |
||||
#looks like it should be a tag.. but failed to even parse for some reason.. just add to errorlist |
||||
lappend errors "line: $linenum tag parse failure reason: [dict get $taginfo reason] raw line: [dict get $taginfo raw]" |
||||
} |
||||
} |
||||
#whether the line is tag or not append to any tags_in_data |
||||
#foreach t [dict keys $tags_in_data] { |
||||
# dict lappend tags_in_data $t $ln ;#accumulate raw lines - written to the tag entry in tags only on encountering a closing tag, then removed from tags_in_data |
||||
#} |
||||
incr linenum |
||||
} |
||||
#assert [expr {$linenum -1 == [llength $lines]}] |
||||
if {[llength $errors]} { |
||||
set status 0 |
||||
} else { |
||||
set status 1 |
||||
} |
||||
if {$linenum == 0} { |
||||
|
||||
} |
||||
return [dict create ok $status linecount [llength $lines] data $tags errors $errors] |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::scriptwrap [namespace eval punk::mix::commandset::scriptwrap { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,49 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::templates 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
package require punk::cap |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::templates { |
||||
punk::cap::register_package punk::mix::templates [list\ |
||||
{templates {relpath ../templates}}\ |
||||
] |
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::templates [namespace eval punk::mix::templates { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,427 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::util 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
namespace eval punk::mix::util { |
||||
variable has_winpath 0 |
||||
} |
||||
|
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
if {![catch {package require punk::winpath}]} { |
||||
set punk::mix::util::has_winpath 1 |
||||
} |
||||
} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::util { |
||||
variable tmpfile_counter 0 ;#additional tmpfile collision avoidance |
||||
|
||||
namespace export * |
||||
|
||||
|
||||
proc fcat {args} { |
||||
variable has_winpath |
||||
|
||||
if {$::tcl_platform(platform) ne "windows"} { |
||||
return [fileutil::cat {*}$args] |
||||
} |
||||
|
||||
set knownopts [list -eofchar -translation -encoding --] |
||||
set last_opt 0 |
||||
for {set i 0} {$i < [llength $args]} {incr i} { |
||||
set ival [lindex $args $i] |
||||
#puts stdout "i:$i a: $ival known: [expr {$ival in $knownopts}]" |
||||
if {$ival eq "--"} { |
||||
set last_opt $i |
||||
break |
||||
} else { |
||||
if {$ival in $knownopts} { |
||||
#puts ">known at $i : [lindex $args $i]" |
||||
if {($i % 2) != 0} { |
||||
error "unexpected option at index $i. known options: $knownopts must come in -opt val pairs." |
||||
} |
||||
incr i |
||||
set last_opt $i |
||||
} else { |
||||
set last_opt [expr {$i - 1}] |
||||
break |
||||
} |
||||
} |
||||
} |
||||
set first_non_opt [expr {$last_opt + 1}] |
||||
|
||||
#puts stderr "first_non_opt: $first_non_opt" |
||||
set opts [lrange $args -1 $first_non_opt-1] |
||||
set paths [lrange $args $first_non_opt end] |
||||
if {![llength $paths]} { |
||||
error "Unable to find file in the supplied arguments: $args. Ensure options are all -opt val pairs and that file name(s) follow" |
||||
} |
||||
#puts stderr "opts: $opts paths: $paths" |
||||
set finalpaths [list] |
||||
foreach p $paths { |
||||
if {$has_winpath && [punk::winpath::illegalname_test $p]} { |
||||
lappend finalpaths [punk::winpath::illegalname_fix $p] |
||||
} else { |
||||
lappend finalpaths $p |
||||
} |
||||
} |
||||
fileutil::cat {*}$opts {*}$finalpaths |
||||
} |
||||
|
||||
#---------------------------------------- |
||||
namespace eval internal { |
||||
proc path_common_prefix_pop {varname} { |
||||
upvar 1 $varname var |
||||
set var [lassign $var head] |
||||
return $head |
||||
} |
||||
} |
||||
proc path_common_prefix {args} { |
||||
set dirs $args |
||||
set parts [file split [internal::path_common_prefix_pop dirs]] |
||||
while {[llength $dirs]} { |
||||
set r {} |
||||
foreach cmp $parts elt [file split [internal::path_common_prefix_pop dirs]] { |
||||
if {$cmp ne $elt} break |
||||
lappend r $cmp |
||||
} |
||||
set parts $r |
||||
} |
||||
if {[llength $parts]} { |
||||
return [file join {*}$parts] |
||||
} else { |
||||
return "" |
||||
} |
||||
} |
||||
|
||||
#retains case from first argument only - caseless comparison |
||||
proc path_common_prefix_nocase {args} { |
||||
set dirs $args |
||||
set parts [file split [internal::path_common_prefix_pop dirs]] |
||||
while {[llength $dirs]} { |
||||
set r {} |
||||
foreach cmp $parts elt [file split [internal::path_common_prefix_pop dirs]] { |
||||
if {![string equal -nocase $cmp $elt]} break |
||||
lappend r $cmp |
||||
} |
||||
set parts $r |
||||
} |
||||
if {[llength $parts]} { |
||||
return [file join {*}$parts] |
||||
} else { |
||||
return "" |
||||
} |
||||
} |
||||
#---------------------------------------- |
||||
|
||||
#maint warning - also in punkcheck |
||||
proc path_relative {base dst} { |
||||
#see also kettle |
||||
# Modified copy of ::fileutil::relative (tcllib) |
||||
# Adapted to 8.5 ({*}). |
||||
# |
||||
# Taking two _directory_ paths, a base and a destination, computes the path |
||||
# of the destination relative to the base. |
||||
# |
||||
# Arguments: |
||||
# base The path to make the destination relative to. |
||||
# dst The destination path |
||||
# |
||||
# Results: |
||||
# The path of the destination, relative to the base. |
||||
|
||||
# Ensure that the link to directory 'dst' is properly done relative to |
||||
# the directory 'base'. |
||||
|
||||
#review - check volume info on windows.. UNC paths? |
||||
if {[file pathtype $base] ne [file pathtype $dst]} { |
||||
return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)" |
||||
} |
||||
|
||||
#avoid normalizing if possible (file normalize *very* expensive on windows) |
||||
set do_normalize 0 |
||||
if {[file pathtype $base] eq "relative"} { |
||||
#if base is relative so is dst |
||||
if {[regexp {[.]{2}} [list $base $dst]]} { |
||||
set do_normalize 1 |
||||
} |
||||
if {[regexp {[.]/} [list $base $dst]]} { |
||||
set do_normalize 1 |
||||
} |
||||
} else { |
||||
set do_normalize 1 |
||||
} |
||||
if {$do_normalize} { |
||||
set base [file normalize $base] |
||||
set dst [file normalize $dst] |
||||
} |
||||
|
||||
set save $dst |
||||
set base [file split $base] |
||||
set dst [file split $dst] |
||||
|
||||
while {[lindex $dst 0] eq [lindex $base 0]} { |
||||
set dst [lrange $dst 1 end] |
||||
set base [lrange $base 1 end] |
||||
if {![llength $dst]} {break} |
||||
} |
||||
|
||||
set dstlen [llength $dst] |
||||
set baselen [llength $base] |
||||
|
||||
if {($dstlen == 0) && ($baselen == 0)} { |
||||
# Cases: |
||||
# (a) base == dst |
||||
|
||||
set dst . |
||||
} else { |
||||
# Cases: |
||||
# (b) base is: base/sub = sub |
||||
# dst is: base = {} |
||||
|
||||
# (c) base is: base = {} |
||||
# dst is: base/sub = sub |
||||
|
||||
while {$baselen > 0} { |
||||
set dst [linsert $dst 0 ..] |
||||
incr baselen -1 |
||||
} |
||||
set dst [file join {*}$dst] |
||||
} |
||||
|
||||
return $dst |
||||
} |
||||
#namespace import ::punk::ns::nsimport_noclobber |
||||
|
||||
proc namespace_import_pattern_to_namespace_noclobber {pattern ns} { |
||||
set source_ns [namespace qualifiers $pattern] |
||||
if {![namespace exists $source_ns]} { |
||||
error "namespace_import_pattern_to_namespace_noclobber error namespace $source_ns not found" |
||||
} |
||||
if {![string match ::* $ns]} { |
||||
set nscaller [uplevel 1 {namespace current}] |
||||
set ns [punk::nsjoin $nscaller $ns] |
||||
} |
||||
set a_export_patterns [namespace eval $source_ns {namespace export}] |
||||
set a_commands [info commands $pattern] |
||||
set a_tails [lmap v $a_commands {namespace tail $v}] |
||||
set a_exported_tails [list] |
||||
foreach pattern $a_export_patterns { |
||||
set matches [lsearch -all -inline $a_tails $pattern] |
||||
foreach m $matches { |
||||
if {$m ni $a_exported_tails} { |
||||
lappend a_exported_tails $m |
||||
} |
||||
} |
||||
} |
||||
set imported_commands [list] |
||||
foreach e $a_exported_tails { |
||||
set imported [namespace eval $ns [string map [list <func> $e <a> $source_ns] { |
||||
set cmd "" |
||||
if {![catch {namespace import <a>::<func>}]} { |
||||
set cmd <func> |
||||
} |
||||
set cmd |
||||
}]] |
||||
if {[string length $imported]} { |
||||
lappend imported_commands $imported |
||||
} |
||||
} |
||||
return $imported_commands |
||||
} |
||||
|
||||
proc askuser {question} { |
||||
puts stdout $question |
||||
flush stdout |
||||
set stdin_state [fconfigure stdin] |
||||
fconfigure stdin -blocking 1 |
||||
set answer [gets stdin] |
||||
fconfigure stdin -blocking [dict get $stdin_state -blocking] |
||||
return $answer |
||||
} |
||||
|
||||
proc do_in_path {path script} { |
||||
#from ::kettle::path::in |
||||
set here [pwd] |
||||
try { |
||||
cd $path |
||||
uplevel 1 $script |
||||
} finally { |
||||
cd $here |
||||
} |
||||
} |
||||
|
||||
proc foreach-file {path script_pathvariable script} { |
||||
upvar 1 $script_pathvariable thepath |
||||
|
||||
set known {} |
||||
lappend waiting $path |
||||
while {[llength $waiting]} { |
||||
set pending $waiting |
||||
set waiting {} |
||||
set at 0 |
||||
while {$at < [llength $pending]} { |
||||
set current [lindex $pending $at] |
||||
incr at |
||||
|
||||
# Do not follow into parent. |
||||
if {[string match *.. $current]} continue |
||||
|
||||
# Ignore what we have visited already. |
||||
set c [file dirname [file normalize $current/___]] |
||||
if {[dict exists $known $c]} continue |
||||
dict set known $c . |
||||
|
||||
if {[file tail $c] eq ".git"} { |
||||
continue |
||||
} |
||||
|
||||
# Expand directories. |
||||
if {[file isdirectory $c]} { |
||||
lappend waiting {*}[lsort -unique [glob -directory $c * .*]] |
||||
continue |
||||
} |
||||
|
||||
# Handle files as per the user's will. |
||||
set thepath $current |
||||
switch -exact -- [catch { uplevel 1 $script } result] { |
||||
0 - 4 { |
||||
# ok, continue - nothing |
||||
} |
||||
2 { |
||||
# return, abort, rethrow |
||||
return -code return |
||||
} |
||||
3 { |
||||
# break, abort |
||||
return |
||||
} |
||||
1 - default { |
||||
# error, any thing else - rethrow |
||||
return -code error $result |
||||
} |
||||
} |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc is_valid_tm_version {versionpart} { |
||||
#Needs to be suitable for use with Tcl's 'package vcompare' |
||||
if {![catch [list package vcompare $versionpart $versionpart]]} { |
||||
return 1 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
#Note that semver only has a small overlap with tcl tm versions. |
||||
#todo - work out what overlap and whether it's even useful |
||||
#see also TIP #439: Semantic Versioning (tcl 9??) |
||||
proc semver {versionstring} { |
||||
set re {^(0|[1-9]\d*)\.(0|[1-9]\d*)\.(0|[1-9]\d*)(?:-((?:0|[1-9]\d*|\d*[a-zA-Z-][0-9a-zA-Z-]*)(?:\.(?:0|[1-9]\d*|\d*[a-zA-Z-][0-9a-zA-Z-]*))*))?(?:\+([0-9a-zA-Z-]+(?:\.[0-9a-zA-Z-]+)*))?$} |
||||
} |
||||
#todo - semver conversion/validation for other systems? |
||||
proc magic_tm_version {} { |
||||
set magicbase 999999 ;#deliberately large so given load-preference when testing! |
||||
#we split the literal to avoid the literal appearing here - reduce risk of accidentally converting to a release version |
||||
return ${magicbase}.0a1.0 |
||||
} |
||||
|
||||
|
||||
|
||||
proc tmpfile {{prefix tmp_}} { |
||||
#note risk of collision if pregenerating a list of tmpfile names |
||||
#we will maintain an icrementing id so the caller doesn't have to bear that in mind |
||||
variable tmpfile_counter |
||||
global tcl_platform |
||||
return .punkutil_$prefix[pid]_[clock microseconds]_[incr tmpfile_counter]_[info hostname]_$tcl_platform(user) |
||||
} |
||||
|
||||
proc tmpdir {} { |
||||
# Taken from tcllib fileutil. |
||||
global tcl_platform env |
||||
|
||||
set attempdirs [list] |
||||
set problems {} |
||||
|
||||
foreach tmp {TEMP TMP TMPDIR} { |
||||
if { [info exists env($tmp)] } { |
||||
lappend attempdirs $env($tmp) |
||||
} else { |
||||
lappend problems "No environment variable $tmp" |
||||
} |
||||
} |
||||
|
||||
switch $tcl_platform(platform) { |
||||
windows { |
||||
lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP" |
||||
} |
||||
macintosh { |
||||
lappend attempdirs $env(TRASH_FOLDER) ;# a better place? |
||||
} |
||||
default { |
||||
lappend attempdirs \ |
||||
[file join / tmp] \ |
||||
[file join / var tmp] \ |
||||
[file join / usr tmp] |
||||
} |
||||
} |
||||
|
||||
lappend attempdirs [pwd] |
||||
|
||||
foreach tmp $attempdirs { |
||||
if { [file isdirectory $tmp] && |
||||
[file writable $tmp] } { |
||||
return [file normalize $tmp] |
||||
} elseif { ![file isdirectory $tmp] } { |
||||
lappend problems "Not a directory: $tmp" |
||||
} else { |
||||
lappend problems "Not writable: $tmp" |
||||
} |
||||
} |
||||
|
||||
# Fail if nothing worked. |
||||
return -code error "Unable to determine a proper directory for temporary files\n[join $problems \n]" |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::util [namespace eval punk::mix::util { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,158 @@
|
||||
|
||||
|
||||
package require punk::mix::util |
||||
|
||||
namespace eval ::punk::overlay { |
||||
#based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend |
||||
# extend an ensemble-like routine with the routines in some namespace |
||||
# |
||||
# e.g custom_from_base ::punk::mix::cli ::punk::mix::base |
||||
# |
||||
proc custom_from_base {routine base} { |
||||
if {![string match ::* $routine]} { |
||||
set resolved [uplevel 1 [list ::namespace which $routine]] |
||||
if {$resolved eq {}} { |
||||
error [list {no such routine} $routine] |
||||
} |
||||
set routine $resolved |
||||
} |
||||
set routinens [namespace qualifiers $routine] |
||||
if {$routinens eq {::}} { |
||||
set routinens {} |
||||
} |
||||
set routinetail [namespace tail $routine] |
||||
|
||||
if {![string match ::* $base]} { |
||||
set base [uplevel 1 [ |
||||
list [namespace which namespace] current]]::$base |
||||
} |
||||
|
||||
if {![namespace exists $base]} { |
||||
error [list {no such namespace} $base] |
||||
} |
||||
|
||||
set base [namespace eval $base [ |
||||
list [namespace which namespace] current]] |
||||
|
||||
|
||||
#while 1 { |
||||
# set renamed ${routinens}::${routinetail}_[info cmdcount] |
||||
# if {[namespace which $renamed] eq {}} break |
||||
#} |
||||
|
||||
namespace eval $routine [ |
||||
list namespace ensemble configure $routine -unknown [ |
||||
list apply {{base ensemble subcommand args} { |
||||
list ${base}::_redirected $ensemble $subcommand |
||||
}} $base |
||||
] |
||||
] |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${routine}::util |
||||
#namespace eval ${routine}::util { |
||||
#namespace import ::punk::mix::util::* |
||||
#} |
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ${base}::lib::* ${routine}::lib |
||||
#namespace eval ${routine}::lib [string map [list <base> $base] { |
||||
# namespace import <base>::lib::* |
||||
#}] |
||||
|
||||
namespace eval ${routine}::lib [string map [list <base> $base <routine> $routine] { |
||||
if {[namespace exists <base>::lib]} { |
||||
set current_paths [namespace path] |
||||
if {"<routine>" ni $current_paths} { |
||||
lappend current_paths <routine> |
||||
} |
||||
namespace path $current_paths |
||||
} |
||||
}] |
||||
|
||||
namespace eval $routine { |
||||
set exportlist [list] |
||||
foreach cmd [info commands [namespace current]::*] { |
||||
set c [namespace tail $cmd] |
||||
if {![string match _* $c]} { |
||||
lappend exportlist $c |
||||
} |
||||
} |
||||
namespace export {*}$exportlist |
||||
} |
||||
|
||||
return $routine |
||||
} |
||||
#load *exported* commands from cmdnamespace into caller's namespace - prefixing each command with $prefix |
||||
#Note: commandset may be imported by different CLIs with different bases *at the same time* |
||||
#so we don't make commands from the cli or its base available automatically (will generally require fully-qualified commands to use code from cli/base) |
||||
#we do load punk::mix::util::* into the util subnamespace even though the commandset might not be loaded in a cli using punk::mix::base i.e punk::mix::util is a common dependency for CLIs. |
||||
#commandsets designed to be used with a specific cli/base may choose to do their own import e.g with util::namespace_import_pattern_to_namespace_noclobber and/or set namespace path if they |
||||
#want the convenience of using lib:xxx with commands coming from those packages. |
||||
#This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. |
||||
#The basic principle is that the commandset is loaded into the caller(s) with a prefix |
||||
#- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) |
||||
proc import_commandset {prefix separator cmdnamespace} { |
||||
set bad_seps [list "::"] |
||||
if {$separator in $bad_seps} { |
||||
error "import_commandset invalid separator '$separator'" |
||||
} |
||||
#namespace may or may not be a package |
||||
# allow with or without leading :: |
||||
if {[string range $cmdnamespace 0 1] eq "::"} { |
||||
set cmdpackage [string range $cmdnamespace 2 end] |
||||
} else { |
||||
set cmdpackage $cmdnamespace |
||||
set cmdnamespace ::$cmdnamespace |
||||
} |
||||
|
||||
if {![namespace exists $cmdnamespace]} { |
||||
#only do package require if the namespace not already present |
||||
catch {package require $cmdpackage} pkg_load_info |
||||
#recheck |
||||
if {![namespace exists $cmdnamespace]} { |
||||
set prov [package provide $cmdpackage] |
||||
if {[string length $prov]} { |
||||
set provinfo "(package $cmdpackage is present with version $prov)" |
||||
} else { |
||||
set provinfo "(package $cmdpackage not present)" |
||||
} |
||||
error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Pkg_load_result: $pkg_load_info Usage: import_commandset prefix separator namespace" |
||||
} |
||||
} |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util |
||||
|
||||
#let child namespace 'lib' resolve parent namespace and thus util::xxx |
||||
namespace eval ${cmdnamespace}::lib [string map [list <cmdns> $cmdnamespace] { |
||||
set nspaths [namespace path] |
||||
if {"<cmdns>" ni $nspaths} { |
||||
lappend nspaths <cmdns> |
||||
} |
||||
namespace path $nspaths |
||||
}] |
||||
|
||||
set imported_commands [list] |
||||
set nscaller [uplevel 1 [list namespace current]] |
||||
if {[catch { |
||||
namespace eval ${nscaller}::temp_import [list namespace import ${cmdnamespace}::*] |
||||
foreach cmd [info commands ${nscaller}::temp_import::*] { |
||||
set cmdtail [namespace tail $cmd] |
||||
if {$cmdtail eq "_default"} { |
||||
set import_as ${nscaller}::${prefix} |
||||
} else { |
||||
set import_as ${nscaller}::${prefix}${separator}${cmdtail} |
||||
} |
||||
rename $cmd $import_as |
||||
lappend imported_commands $import_as |
||||
} |
||||
} errM]} { |
||||
puts stderr "Error loading commandset $prefix $separator $cmdnamespace" |
||||
puts stderr "err: $errM" |
||||
} |
||||
return $imported_commands |
||||
} |
||||
} |
||||
|
||||
|
||||
package provide punk::overlay [namespace eval punk::overlay { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,104 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::tdl 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::tdl { |
||||
# https://wiki.tcl-lang.org/page/Config+file+using+slave+interp |
||||
|
||||
variable sample_script { |
||||
server -name bsd1 -os FreeBSD |
||||
server -name p1 -os linux |
||||
server -name trillion -os windows |
||||
|
||||
server -name vmhost1 -os FreeBSD { |
||||
guest -name bsd1 -vmmanager iocage |
||||
guest -name p1 -vmmanager bhyve |
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
proc prettyparse {script} { |
||||
set i [interp create -safe] |
||||
try { |
||||
# $i eval {unset {*}[info vars]} |
||||
# foreach command [$i eval {info commands}] {$i hide $command} |
||||
# $i invokehidden namespace delete {*}[$i invokehidden namespace children] |
||||
$i alias unknown apply {{i tag args} { |
||||
upvar 1 result result |
||||
set e [concat [list tag $tag]\ |
||||
[lrange $args 0 [expr {([llength $args] & ~1) - 1}]]] |
||||
if {[llength $args] % 2} { |
||||
set saved $result |
||||
set result {} |
||||
$i eval [lindex $args end] |
||||
lappend e body $result |
||||
set result $saved |
||||
} |
||||
lappend result $e |
||||
list |
||||
}} $i |
||||
set result {} |
||||
$i eval $script |
||||
return $result |
||||
} finally { |
||||
interp delete $i |
||||
} |
||||
} |
||||
proc prettyprint {data {level 0}} { |
||||
set ind [string repeat " " $level] |
||||
incr level |
||||
set result {} |
||||
foreach e $data { |
||||
set line $ind[concat [list [dict get $e tag]] [dict remove $e tag body]] |
||||
if {[dict exists $e body] && [llength [dict get $e body]]} { |
||||
append line " {\n[prettyprint [dict get $e body] $level]\n$ind}" |
||||
} |
||||
lappend result $line |
||||
} |
||||
join $result \n |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::tdl [namespace eval punk::tdl { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,266 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::winpath 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::winpath { |
||||
namespace export winpath windir cdwin cdwindir illegalname_fix illegalname_test |
||||
|
||||
|
||||
|
||||
|
||||
#\\servername\share etc or \\?\UNC\servername\share etc. |
||||
proc is_unc_path {path} { |
||||
set strcopy_path [punk::objclone $path] |
||||
set strcopy_path [string map [list \\ /] $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway) |
||||
if {[string first "//" $strcopy_path] == 0} { |
||||
#check for "Dos device path" syntax |
||||
if {[string range $strcopy_path 0 3] in [list "//?/" "//./"]} { |
||||
#Note that //./ doesn't appear to be supported in Tcl as at 2023-08 - but //?/ works (except for //?/UNC/Server/share) |
||||
if {[string range $strcopy_path 4 6] eq "UNC"} { |
||||
return 1 |
||||
} else { |
||||
#some other Dos device path. Could be a drive which is mapped to a UNC path - but the path itself isn't a unc path |
||||
return 0 |
||||
} |
||||
} else { |
||||
#leading double slash and not dos device path syntax |
||||
return 1 |
||||
} |
||||
} |
||||
return 0 |
||||
} |
||||
|
||||
#ordinary \\Servername or \\servername\share or \\servername\share\path (or forward-slash equivalent) with no dos device syntax //?/ //./ etc. |
||||
proc is_unc_path_plain {path} { |
||||
if {[is_unc_path $path]} { |
||||
if {![is_dos_device_path $path]} { |
||||
return 1 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
|
||||
#int-rep path preserved - but 'file attributes', and therefor this operation, is expensive (on windows at least) |
||||
proc pwdshortname {{path {}}} { |
||||
if {$path eq ""} { |
||||
set path [pwd] |
||||
} else { |
||||
if {[file pathtype $path] eq "relative"} { |
||||
set path [file normalize $path] |
||||
} |
||||
} |
||||
return [dict get [file attributes $path] -shortname] |
||||
} |
||||
#dos device path syntax allows windows api to acces extended-length paths and filenames with illegal path characters such as trailing dots or whitespace |
||||
#(can exist on server shares and on NTFS - but standard apps can't access without dos device syntax) |
||||
proc is_dos_device_path {path} { |
||||
set strcopy_path [punk::objclone $path] |
||||
set strcopy_path [string map [list \\ /] $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway) |
||||
if {[string range $strcopy_path 0 3] in [list "//?/" "//./"]} { |
||||
return 1 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
proc strip_dos_device_prefix {path} { |
||||
#it's unlikely to be valid to strip only //?/ from a //?/UNC path so check for it here and diver to strip that. |
||||
#(review.. or raise error because a //?/UNC path isn't *strictly* a UNC path? ) |
||||
if {[is_unc_path $path]} { |
||||
return [strip_unc_path_prefix $path] |
||||
} |
||||
if {[is_dos_device_path $path]} { |
||||
return [string range $path 4 end] |
||||
} else { |
||||
return $path |
||||
} |
||||
} |
||||
proc strip_unc_path_prefix {path} { |
||||
if {[is_unc_path $path]} { |
||||
#//?/UNC/server/etc |
||||
set strcopy_path [punk::objclone $path] |
||||
set trimmedpath [string range $strcopy_path 7 end] |
||||
file pathtype $trimmedpath ;#shimmer it to path rep |
||||
return $trimmedpath |
||||
} elseif {is_unc_path_plain $path} { |
||||
#plain unc //server |
||||
set strcopy_path [punk::objclone $path] |
||||
set trimmedpath [string range $strcopy_path 2 end] |
||||
file pathtype $trimmedpath |
||||
return $trimmedpath |
||||
} else { |
||||
return $path |
||||
} |
||||
} |
||||
#we don't validate that path is actually illegal because we don't know the full range of such names. |
||||
#The caller can apply this to any path. |
||||
#don't test for platform here - needs to be callable from any platform for potential passing to windows (what usecase? 8.3 name is not always calculable independently) |
||||
#The utility of this is questionable. prepending a dos-device path won't make a filename with illegal characters readable by windows. |
||||
#It will need the 'shortname' at least for the illegal segment - if not the whole path |
||||
#Whilst the 8.3 name algorithm - including undocumented hash function has been reverse engineered |
||||
#- it depends on the content of the directory - as collisions cause a different name (e.g incremented number) |
||||
#- it also depends on the history of the folder |
||||
#- you can't take the current dir contents and a particular *existing* longname and determine the shortname algorithmically... |
||||
#- the shortname may have been generated during a different directory state. |
||||
#- It is then stored on disk (where?) - so access to reading the existing shortname is required. |
||||
#- An implementation of the 8.3 algorithm would only be potentially useful in determining the name that will result from adding a new file |
||||
# and would be subject to potential collisions if there are race-conditions in file creation |
||||
#- Using an 8.3 algorithm externally would be dangerous in that it could appear to work a lot of the time - but return a different file entirely sometimes. |
||||
#- Conclusion is that the 8.3 name must be retrieved rathern than calclated |
||||
proc illegalname_fix {path} { |
||||
#don't add extra dos device path syntax protection-prefix if already done |
||||
if {[is_unc_path $path]} { |
||||
error "illegalname_fix called on UNC path $path - unable to process" |
||||
} |
||||
if {[is_dos_device_path $path]} { |
||||
#we may have appended |
||||
return $path |
||||
} |
||||
|
||||
|
||||
|
||||
#\\servername\share theoretically maps to: \\?\UNC\servername\share in protected form. https://learn.microsoft.com/en-us/dotnet/standard/io/file-path-formats |
||||
#NOTE: 2023-08 on windows 10 at least \\?\UNC\Server\share doesn't work - ie we can't use illegalname_fix on UNC paths such as \\Server\share |
||||
#(but mapped drive to same path will work) |
||||
#Note that test-path cmdlet in powershell is also flaky with regards to \\?\UNC\Server paths. |
||||
#It seems prudent for now to disallow \\?\ protection for UNC paths such as \\server\etc |
||||
if {[is_unc_path $path]} { |
||||
set err "" |
||||
append err "illegalname_fix doesn't currently support UNC paths (non dos device leading double slash or //?/UNC/...)" |
||||
append err \n " - because //?/UNC/Servername/share is not supported in Tcl (and only minimally even in powershell) as at 2023. (on windows use mapped drive instead)" |
||||
error $err |
||||
} |
||||
|
||||
set strcopy_path [punk::objclone $path] |
||||
|
||||
|
||||
#Note: path could still have leading double slash if it is a Dos device path: e.g. //?/c:/etc |
||||
if {[file pathtype $path] eq "absolute"} { |
||||
if {$path eq "~"} { |
||||
# non-normalized ~ is classified as absolute |
||||
# tilde special meaning is a bit of a nuisance.. but as it's the entire path in this case.. presumably it should be kept that way |
||||
# leave for caller to interpret it - but it's not an illegal name whether it's interpreted with special meaning or not |
||||
# unlikely this fix will be called on a plain tilde anyway |
||||
return $path |
||||
} else { |
||||
set fullpath $path |
||||
} |
||||
} else { |
||||
#set fullpath [file normalize $path] ;#very slow on windows |
||||
#set fullpath [pwd]/$path ;#will keep ./ in middle of path - not valid for dos-device paths |
||||
if {[string range $strcopy_path 0 1] eq "./"} { |
||||
set strcopy_path [string range $strcopy_path 2 end] |
||||
} |
||||
set fullpath [file join [pwd] $strcopy_path] |
||||
} |
||||
#For file I/O, the "\\?\" prefix to a path string tells the Windows APIs to disable all string parsing |
||||
# and to send the string that follows it straight to the file system. |
||||
set protect "\\\\?\\" ;# value is: \\?\ prefix |
||||
set protect2 "//?/" ;#file normalize may do this - it still works |
||||
#don't use "//./" - not currently supported in Tcl - seems to work in powershell though. |
||||
|
||||
|
||||
#choose //?/ as normalized version - since likely 'file normalize' will do it anyway, and experimentall, the windows API accepts both REVIEW |
||||
set result ${protect2}$fullpath |
||||
file pathtype $result ;#make it return a path rep |
||||
return $result |
||||
} |
||||
|
||||
#don't test for platform here - needs to be callable from any platform for potential passing to windows |
||||
#we can create files with windows illegal names by using //?/ dos device path syntax - but we need to detect when that is required. |
||||
# |
||||
# path int-rep preserving |
||||
proc illegalname_test {path} { |
||||
#https://learn.microsoft.com/en-us/windows/win32/fileio/naming-a-file |
||||
#according to the above: Use any character in the current code page for a name, including Unicode characters and characters in the extended character set (128–255), except for the following: |
||||
set reserved [list < > : \" / \\ | ? *] |
||||
|
||||
|
||||
#we need to exclude things like path/.. path/. |
||||
foreach seg [file split $path] { |
||||
if {$seg in [list . ..]} { |
||||
#review - what if there is a folder or file that actually has a name such as . or .. ? |
||||
#unlikely in normal use - but could done deliberately for bad reasons? |
||||
#We are unable to check for it here anyway - as this command is intended for checking the path string - not the actual path on a filesystem. |
||||
# |
||||
#/./ /../ segments don't require protection - keep checking. |
||||
continue |
||||
} |
||||
|
||||
#only check for actual space as other whitespace seems to work without being stripped |
||||
#trailing tab and trailing \n or \r seem to be creatable in windows with Tcl - map to some glyph |
||||
if {[string index $seg end] in [list " " "."]} { |
||||
#windows API doesn't handle trailing dots or spaces (silently strips) - even though such files can be created on NTFS systems (or seen via samba etc) |
||||
return 1 |
||||
} |
||||
} |
||||
#glob chars '* ?' are probably illegal.. but although x*y.txt and x?y.txt don't display properly (* ? replaced with some other glyph) |
||||
#- they seem to be readable from cmd and tclsh as is. |
||||
# pipe symbol also has glyph substitution and behaves the same e.g a|b.txt |
||||
#(at least with encoding system utf-8) |
||||
|
||||
#todo - determine what else constitutes an illegal name according to windows APIs and requires protection with dos device syntax |
||||
return 0 |
||||
} |
||||
|
||||
proc test_ntfs_tunneling {f1 f2 args} { |
||||
file mkdir $f1 |
||||
puts stderr "waiting 15secs..." |
||||
after 5000 {puts -nonewline stderr .} |
||||
after 5000 {puts -nonewline stderr .} |
||||
after 5000 {puts -nonewline stderr .} |
||||
after 500 {puts stderr \n} |
||||
file mkdir $f2 |
||||
puts stdout "$f1 [file stat $f1]" |
||||
puts stdout "$f2 [file stat $f2]" |
||||
file delete $f1 |
||||
puts stdout "renaming $f2 to $f1" |
||||
file rename $f2 $f1 |
||||
puts stdout "$f1 [file stat $f1]" |
||||
|
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::winpath [namespace eval punk::winpath { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,189 @@
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# sets.tcl -- |
||||
# |
||||
# Definitions for the processing of sets. |
||||
# |
||||
# Copyright (c) 2004-2008 by Andreas Kupries. |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: sets.tcl,v 1.17 2008/03/09 04:24:37 andreas_kupries Exp $ |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
# @mdgen EXCLUDE: sets_c.tcl |
||||
|
||||
package require Tcl 8.5- |
||||
|
||||
namespace eval ::struct::set {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Management of set implementations. |
||||
|
||||
# ::struct::set::LoadAccelerator -- |
||||
# |
||||
# Loads a named implementation, if possible. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to load. |
||||
# |
||||
# Results: |
||||
# A boolean flag. True if the implementation |
||||
# was successfully loaded; and False otherwise. |
||||
|
||||
proc ::struct::set::LoadAccelerator {key} { |
||||
variable accel |
||||
set r 0 |
||||
switch -exact -- $key { |
||||
critcl { |
||||
# Critcl implementation of set requires Tcl 8.4. |
||||
if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} |
||||
if {[catch {package require tcllibc}]} {return 0} |
||||
set r [llength [info commands ::struct::set_critcl]] |
||||
} |
||||
tcl { |
||||
variable selfdir |
||||
source [file join $selfdir sets_tcl.tcl] |
||||
set r 1 |
||||
} |
||||
default { |
||||
return -code error "invalid accelerator/impl. package $key:\ |
||||
must be one of [join [KnownImplementations] {, }]" |
||||
} |
||||
} |
||||
set accel($key) $r |
||||
return $r |
||||
} |
||||
|
||||
# ::struct::set::SwitchTo -- |
||||
# |
||||
# Activates a loaded named implementation. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to activate. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
proc ::struct::set::SwitchTo {key} { |
||||
variable accel |
||||
variable loaded |
||||
|
||||
if {[string equal $key $loaded]} { |
||||
# No change, nothing to do. |
||||
return |
||||
} elseif {![string equal $key ""]} { |
||||
# Validate the target implementation of the switch. |
||||
|
||||
if {![info exists accel($key)]} { |
||||
return -code error "Unable to activate unknown implementation \"$key\"" |
||||
} elseif {![info exists accel($key)] || !$accel($key)} { |
||||
return -code error "Unable to activate missing implementation \"$key\"" |
||||
} |
||||
} |
||||
|
||||
# Deactivate the previous implementation, if there was any. |
||||
|
||||
if {![string equal $loaded ""]} { |
||||
rename ::struct::set ::struct::set_$loaded |
||||
} |
||||
|
||||
# Activate the new implementation, if there is any. |
||||
|
||||
if {![string equal $key ""]} { |
||||
rename ::struct::set_$key ::struct::set |
||||
} |
||||
|
||||
# Remember the active implementation, for deactivation by future |
||||
# switches. |
||||
|
||||
set loaded $key |
||||
return |
||||
} |
||||
|
||||
proc ::struct::set::Loaded {} { |
||||
variable loaded |
||||
return $loaded |
||||
} |
||||
|
||||
# ::struct::set::Implementations -- |
||||
# |
||||
# Determines which implementations are |
||||
# present, i.e. loaded. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. |
||||
|
||||
proc ::struct::set::Implementations {} { |
||||
variable accel |
||||
set res {} |
||||
foreach n [array names accel] { |
||||
if {!$accel($n)} continue |
||||
lappend res $n |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
# ::struct::set::KnownImplementations -- |
||||
# |
||||
# Determines which implementations are known |
||||
# as possible implementations. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. In the order |
||||
# of preference, most prefered first. |
||||
|
||||
proc ::struct::set::KnownImplementations {} { |
||||
return {critcl tcl} |
||||
} |
||||
|
||||
proc ::struct::set::Names {} { |
||||
return { |
||||
critcl {tcllibc based} |
||||
tcl {pure Tcl} |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization: Data structures. |
||||
|
||||
namespace eval ::struct::set { |
||||
variable selfdir [file dirname [info script]] |
||||
variable accel |
||||
array set accel {tcl 0 critcl 0} |
||||
variable loaded {} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization: Choose an implementation, |
||||
## most prefered first. Loads only one of the |
||||
## possible implementations. And activates it. |
||||
|
||||
namespace eval ::struct::set { |
||||
variable e |
||||
foreach e [KnownImplementations] { |
||||
if {[LoadAccelerator $e]} { |
||||
SwitchTo $e |
||||
break |
||||
} |
||||
} |
||||
unset e |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::struct { |
||||
# Export the constructor command. |
||||
namespace export set |
||||
} |
||||
|
||||
package provide struct::set 2.2.3 |
||||
@ -0,0 +1,189 @@
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# sets.tcl -- |
||||
# |
||||
# Definitions for the processing of sets. |
||||
# |
||||
# Copyright (c) 2004-2008 by Andreas Kupries. |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: sets.tcl,v 1.17 2008/03/09 04:24:37 andreas_kupries Exp $ |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
# @mdgen EXCLUDE: sets_c.tcl |
||||
|
||||
package require Tcl 8.5- |
||||
|
||||
namespace eval ::struct::set {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Management of set implementations. |
||||
|
||||
# ::struct::set::LoadAccelerator -- |
||||
# |
||||
# Loads a named implementation, if possible. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to load. |
||||
# |
||||
# Results: |
||||
# A boolean flag. True if the implementation |
||||
# was successfully loaded; and False otherwise. |
||||
|
||||
proc ::struct::set::LoadAccelerator {key} { |
||||
variable accel |
||||
set r 0 |
||||
switch -exact -- $key { |
||||
critcl { |
||||
# Critcl implementation of set requires Tcl 8.4. |
||||
if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} |
||||
if {[catch {package require tcllibc}]} {return 0} |
||||
set r [llength [info commands ::struct::set_critcl]] |
||||
} |
||||
tcl { |
||||
variable selfdir |
||||
source [file join $selfdir sets_tcl.tcl] |
||||
set r 1 |
||||
} |
||||
default { |
||||
return -code error "invalid accelerator/impl. package $key:\ |
||||
must be one of [join [KnownImplementations] {, }]" |
||||
} |
||||
} |
||||
set accel($key) $r |
||||
return $r |
||||
} |
||||
|
||||
# ::struct::set::SwitchTo -- |
||||
# |
||||
# Activates a loaded named implementation. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to activate. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
proc ::struct::set::SwitchTo {key} { |
||||
variable accel |
||||
variable loaded |
||||
|
||||
if {[string equal $key $loaded]} { |
||||
# No change, nothing to do. |
||||
return |
||||
} elseif {![string equal $key ""]} { |
||||
# Validate the target implementation of the switch. |
||||
|
||||
if {![info exists accel($key)]} { |
||||
return -code error "Unable to activate unknown implementation \"$key\"" |
||||
} elseif {![info exists accel($key)] || !$accel($key)} { |
||||
return -code error "Unable to activate missing implementation \"$key\"" |
||||
} |
||||
} |
||||
|
||||
# Deactivate the previous implementation, if there was any. |
||||
|
||||
if {![string equal $loaded ""]} { |
||||
rename ::struct::set ::struct::set_$loaded |
||||
} |
||||
|
||||
# Activate the new implementation, if there is any. |
||||
|
||||
if {![string equal $key ""]} { |
||||
rename ::struct::set_$key ::struct::set |
||||
} |
||||
|
||||
# Remember the active implementation, for deactivation by future |
||||
# switches. |
||||
|
||||
set loaded $key |
||||
return |
||||
} |
||||
|
||||
proc ::struct::set::Loaded {} { |
||||
variable loaded |
||||
return $loaded |
||||
} |
||||
|
||||
# ::struct::set::Implementations -- |
||||
# |
||||
# Determines which implementations are |
||||
# present, i.e. loaded. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. |
||||
|
||||
proc ::struct::set::Implementations {} { |
||||
variable accel |
||||
set res {} |
||||
foreach n [array names accel] { |
||||
if {!$accel($n)} continue |
||||
lappend res $n |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
# ::struct::set::KnownImplementations -- |
||||
# |
||||
# Determines which implementations are known |
||||
# as possible implementations. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. In the order |
||||
# of preference, most prefered first. |
||||
|
||||
proc ::struct::set::KnownImplementations {} { |
||||
return {critcl tcl} |
||||
} |
||||
|
||||
proc ::struct::set::Names {} { |
||||
return { |
||||
critcl {tcllibc based} |
||||
tcl {pure Tcl} |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization: Data structures. |
||||
|
||||
namespace eval ::struct::set { |
||||
variable selfdir [file dirname [info script]] |
||||
variable accel |
||||
array set accel {tcl 0 critcl 0} |
||||
variable loaded {} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization: Choose an implementation, |
||||
## most prefered first. Loads only one of the |
||||
## possible implementations. And activates it. |
||||
|
||||
namespace eval ::struct::set { |
||||
variable e |
||||
foreach e [KnownImplementations] { |
||||
if {[LoadAccelerator $e]} { |
||||
SwitchTo $e |
||||
break |
||||
} |
||||
} |
||||
unset e |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::struct { |
||||
# Export the constructor command. |
||||
namespace export set |
||||
} |
||||
|
||||
package provide struct::set 2.2.3 |
||||
@ -0,0 +1,93 @@
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# sets_tcl.tcl -- |
||||
# |
||||
# Definitions for the processing of sets. C implementation. |
||||
# |
||||
# Copyright (c) 2007 by Andreas Kupries. |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: sets_c.tcl,v 1.3 2008/03/25 07:15:34 andreas_kupries Exp $ |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
package require critcl |
||||
# @sak notprovided struct_setc |
||||
package provide struct_setc 2.1.1 |
||||
package require Tcl 8.5- |
||||
|
||||
namespace eval ::struct { |
||||
# Supporting code for the main command. |
||||
|
||||
catch { |
||||
#critcl::cheaders -g |
||||
#critcl::debug memory symbols |
||||
} |
||||
|
||||
critcl::cheaders sets/*.h |
||||
critcl::csources sets/*.c |
||||
|
||||
critcl::ccode { |
||||
/* -*- c -*- */ |
||||
|
||||
#include <m.h> |
||||
} |
||||
|
||||
# Main command, set creation. |
||||
|
||||
critcl::ccommand set_critcl {dummy interp objc objv} { |
||||
/* Syntax - dispatcher to the sub commands. |
||||
*/ |
||||
|
||||
static CONST char* methods [] = { |
||||
"add", "contains", "difference", "empty", |
||||
"equal","exclude", "include", "intersect", |
||||
"intersect3", "size", "subsetof", "subtract", |
||||
"symdiff", "union", |
||||
NULL |
||||
}; |
||||
enum methods { |
||||
S_add, S_contains, S_difference, S_empty, |
||||
S_equal,S_exclude, S_include, S_intersect, |
||||
S_intersect3, S_size, S_subsetof, S_subtract, |
||||
S_symdiff, S_union |
||||
}; |
||||
|
||||
int m; |
||||
|
||||
if (objc < 2) { |
||||
Tcl_WrongNumArgs (interp, objc, objv, "cmd ?arg ...?"); |
||||
return TCL_ERROR; |
||||
} else if (Tcl_GetIndexFromObj (interp, objv [1], methods, "option", |
||||
0, &m) != TCL_OK) { |
||||
return TCL_ERROR; |
||||
} |
||||
|
||||
/* Dispatch to methods. They check the #args in detail before performing |
||||
* the requested functionality |
||||
*/ |
||||
|
||||
switch (m) { |
||||
case S_add: return sm_ADD (NULL, interp, objc, objv); |
||||
case S_contains: return sm_CONTAINS (NULL, interp, objc, objv); |
||||
case S_difference: return sm_DIFFERENCE (NULL, interp, objc, objv); |
||||
case S_empty: return sm_EMPTY (NULL, interp, objc, objv); |
||||
case S_equal: return sm_EQUAL (NULL, interp, objc, objv); |
||||
case S_exclude: return sm_EXCLUDE (NULL, interp, objc, objv); |
||||
case S_include: return sm_INCLUDE (NULL, interp, objc, objv); |
||||
case S_intersect: return sm_INTERSECT (NULL, interp, objc, objv); |
||||
case S_intersect3: return sm_INTERSECT3 (NULL, interp, objc, objv); |
||||
case S_size: return sm_SIZE (NULL, interp, objc, objv); |
||||
case S_subsetof: return sm_SUBSETOF (NULL, interp, objc, objv); |
||||
case S_subtract: return sm_SUBTRACT (NULL, interp, objc, objv); |
||||
case S_symdiff: return sm_SYMDIFF (NULL, interp, objc, objv); |
||||
case S_union: return sm_UNION (NULL, interp, objc, objv); |
||||
} |
||||
/* Not coming to this place */ |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
@ -0,0 +1,452 @@
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# sets_tcl.tcl -- |
||||
# |
||||
# Definitions for the processing of sets. |
||||
# |
||||
# Copyright (c) 2004-2008 by Andreas Kupries. |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: sets_tcl.tcl,v 1.4 2008/03/09 04:38:47 andreas_kupries Exp $ |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
package require Tcl 8.5- |
||||
|
||||
namespace eval ::struct::set { |
||||
# Only export one command, the one used to instantiate a new tree |
||||
namespace export set_tcl |
||||
} |
||||
|
||||
########################## |
||||
# Public functions |
||||
|
||||
# ::struct::set::set -- |
||||
# |
||||
# Command that access all set commands. |
||||
# |
||||
# Arguments: |
||||
# cmd Name of the subcommand to dispatch to. |
||||
# args Arguments for the subcommand. |
||||
# |
||||
# Results: |
||||
# Whatever the result of the subcommand is. |
||||
|
||||
proc ::struct::set::set_tcl {cmd args} { |
||||
# Do minimal args checks here |
||||
if { [llength [info level 0]] == 1 } { |
||||
return -code error "wrong # args: should be \"$cmd ?arg arg ...?\"" |
||||
} |
||||
::set sub S_$cmd |
||||
if { [llength [info commands ::struct::set::$sub]] == 0 } { |
||||
::set optlist [info commands ::struct::set::S_*] |
||||
::set xlist {} |
||||
foreach p $optlist { |
||||
lappend xlist [string range $p 17 end] |
||||
} |
||||
return -code error \ |
||||
"bad option \"$cmd\": must be [linsert [join [lsort $xlist] ", "] "end-1" "or"]" |
||||
} |
||||
return [uplevel 1 [linsert $args 0 ::struct::set::$sub]] |
||||
} |
||||
|
||||
########################## |
||||
# Implementations of the functionality. |
||||
# |
||||
|
||||
# ::struct::set::S_empty -- |
||||
# |
||||
# Determines emptiness of the set |
||||
# |
||||
# Parameters: |
||||
# set -- The set to check for emptiness. |
||||
# |
||||
# Results: |
||||
# A boolean value. True indicates that the set is empty. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
# |
||||
# Notes: |
||||
|
||||
proc ::struct::set::S_empty {set} { |
||||
return [expr {[llength $set] == 0}] |
||||
} |
||||
|
||||
# ::struct::set::S_size -- |
||||
# |
||||
# Computes the cardinality of the set. |
||||
# |
||||
# Parameters: |
||||
# set -- The set to inspect. |
||||
# |
||||
# Results: |
||||
# An integer greater than or equal to zero. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_size {set} { |
||||
return [llength [Cleanup $set]] |
||||
} |
||||
|
||||
# ::struct::set::S_contains -- |
||||
# |
||||
# Determines if the item is in the set. |
||||
# |
||||
# Parameters: |
||||
# set -- The set to inspect. |
||||
# item -- The element to look for. |
||||
# |
||||
# Results: |
||||
# A boolean value. True indicates that the element is present. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_contains {set item} { |
||||
return [expr {[lsearch -exact $set $item] >= 0}] |
||||
} |
||||
|
||||
# ::struct::set::S_union -- |
||||
# |
||||
# Computes the union of the arguments. |
||||
# |
||||
# Parameters: |
||||
# args -- List of sets to unify. |
||||
# |
||||
# Results: |
||||
# The union of the arguments. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_union {args} { |
||||
switch -exact -- [llength $args] { |
||||
0 {return {}} |
||||
1 {return [lindex $args 0]} |
||||
} |
||||
foreach setX $args { |
||||
foreach x $setX {::set ($x) {}} |
||||
} |
||||
return [array names {}] |
||||
} |
||||
|
||||
|
||||
# ::struct::set::S_intersect -- |
||||
# |
||||
# Computes the intersection of the arguments. |
||||
# |
||||
# Parameters: |
||||
# args -- List of sets to intersect. |
||||
# |
||||
# Results: |
||||
# The intersection of the arguments |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_intersect {args} { |
||||
switch -exact -- [llength $args] { |
||||
0 {return {}} |
||||
1 {return [lindex $args 0]} |
||||
} |
||||
::set res [lindex $args 0] |
||||
foreach set [lrange $args 1 end] { |
||||
if {[llength $res] && [llength $set]} { |
||||
::set res [Intersect $res $set] |
||||
} else { |
||||
# Squash 'res'. Otherwise we get the wrong result if res |
||||
# is not empty, but 'set' is. |
||||
::set res {} |
||||
break |
||||
} |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
proc ::struct::set::Intersect {A B} { |
||||
if {[llength $A] == 0} {return {}} |
||||
if {[llength $B] == 0} {return {}} |
||||
|
||||
# This is slower than local vars, but more robust |
||||
if {[llength $B] > [llength $A]} { |
||||
::set res $A |
||||
::set A $B |
||||
::set B $res |
||||
} |
||||
::set res {} |
||||
foreach x $A {::set ($x) {}} |
||||
foreach x $B { |
||||
if {[info exists ($x)]} { |
||||
lappend res $x |
||||
} |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
# ::struct::set::S_difference -- |
||||
# |
||||
# Compute difference of two sets. |
||||
# |
||||
# Parameters: |
||||
# A, B -- Sets to compute the difference for. |
||||
# |
||||
# Results: |
||||
# A - B |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_difference {A B} { |
||||
if {[llength $A] == 0} {return {}} |
||||
if {[llength $B] == 0} {return $A} |
||||
|
||||
array set tmp {} |
||||
foreach x $A {::set tmp($x) .} |
||||
foreach x $B {catch {unset tmp($x)}} |
||||
return [array names tmp] |
||||
} |
||||
|
||||
if {0} { |
||||
# Tcllib SF Bug 1002143. We cannot use the implementation below. |
||||
# It will treat set elements containing '(' and ')' as array |
||||
# elements, and this screws up the storage of elements as the name |
||||
# of local vars something fierce. No way around this. Disabling |
||||
# this code and always using the other implementation (s.a.) is |
||||
# the only possible fix. |
||||
|
||||
if {[package vcompare [package provide Tcl] 8.4] < 0} { |
||||
# Tcl 8.[23]. Use explicit array to perform the operation. |
||||
} else { |
||||
# Tcl 8.4+, has 'unset -nocomplain' |
||||
|
||||
proc ::struct::set::S_difference {A B} { |
||||
if {[llength $A] == 0} {return {}} |
||||
if {[llength $B] == 0} {return $A} |
||||
|
||||
# Get the variable B out of the way, avoid collisions |
||||
# prepare for "pure list optimization" |
||||
::set ::struct::set::tmp [lreplace $B -1 -1 unset -nocomplain] |
||||
unset B |
||||
|
||||
# unset A early: no local variables left |
||||
foreach [lindex [list $A [unset A]] 0] {.} {break} |
||||
|
||||
eval $::struct::set::tmp |
||||
return [info locals] |
||||
} |
||||
} |
||||
} |
||||
|
||||
# ::struct::set::S_symdiff -- |
||||
# |
||||
# Compute symmetric difference of two sets. |
||||
# |
||||
# Parameters: |
||||
# A, B -- The sets to compute the s.difference for. |
||||
# |
||||
# Results: |
||||
# The symmetric difference of the two input sets. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_symdiff {A B} { |
||||
# symdiff == (A-B) + (B-A) == (A+B)-(A*B) |
||||
if {[llength $A] == 0} {return $B} |
||||
if {[llength $B] == 0} {return $A} |
||||
return [S_union \ |
||||
[S_difference $A $B] \ |
||||
[S_difference $B $A]] |
||||
} |
||||
|
||||
# ::struct::set::S_intersect3 -- |
||||
# |
||||
# Return intersection and differences for two sets. |
||||
# |
||||
# Parameters: |
||||
# A, B -- The sets to inspect. |
||||
# |
||||
# Results: |
||||
# List containing A*B, A-B, and B-A |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_intersect3 {A B} { |
||||
return [list \ |
||||
[S_intersect $A $B] \ |
||||
[S_difference $A $B] \ |
||||
[S_difference $B $A]] |
||||
} |
||||
|
||||
# ::struct::set::S_equal -- |
||||
# |
||||
# Compares two sets for equality. |
||||
# |
||||
# Parameters: |
||||
# a First set to compare. |
||||
# b Second set to compare. |
||||
# |
||||
# Results: |
||||
# A boolean. True if the lists are equal. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_equal {A B} { |
||||
::set A [Cleanup $A] |
||||
::set B [Cleanup $B] |
||||
|
||||
# Equal if of same cardinality and difference is empty. |
||||
|
||||
if {[::llength $A] != [::llength $B]} {return 0} |
||||
return [expr {[llength [S_difference $A $B]] == 0}] |
||||
} |
||||
|
||||
|
||||
proc ::struct::set::Cleanup {A} { |
||||
# unset A to avoid collisions |
||||
if {[llength $A] < 2} {return $A} |
||||
# We cannot use variables to avoid an explicit array. The set |
||||
# elements may look like namespace vars (i.e. contain ::), and |
||||
# such elements break that, cannot be proc-local variables. |
||||
array set S {} |
||||
foreach item $A {set S($item) .} |
||||
return [array names S] |
||||
} |
||||
|
||||
# ::struct::set::S_include -- |
||||
# |
||||
# Add an element to a set. |
||||
# |
||||
# Parameters: |
||||
# Avar -- Reference to the set variable to extend. |
||||
# element -- The item to add to the set. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# The set in the variable referenced by Avar is extended |
||||
# by the element (if the element was not already present). |
||||
|
||||
proc ::struct::set::S_include {Avar element} { |
||||
# Avar = Avar + {element} |
||||
upvar 1 $Avar A |
||||
if {![info exists A] || ![S_contains $A $element]} { |
||||
lappend A $element |
||||
} |
||||
return |
||||
} |
||||
|
||||
# ::struct::set::S_exclude -- |
||||
# |
||||
# Remove an element from a set. |
||||
# |
||||
# Parameters: |
||||
# Avar -- Reference to the set variable to shrink. |
||||
# element -- The item to remove from the set. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# The set in the variable referenced by Avar is shrunk, |
||||
# the element remove (if the element was actually present). |
||||
|
||||
proc ::struct::set::S_exclude {Avar element} { |
||||
# Avar = Avar - {element} |
||||
upvar 1 $Avar A |
||||
if {![info exists A]} {return -code error "can't read \"$Avar\": no such variable"} |
||||
while {[::set pos [lsearch -exact $A $element]] >= 0} { |
||||
::set A [lreplace [K $A [::set A {}]] $pos $pos] |
||||
} |
||||
return |
||||
} |
||||
|
||||
# ::struct::set::S_add -- |
||||
# |
||||
# Add a set to a set. Similar to 'union', but the first argument |
||||
# is a variable. |
||||
# |
||||
# Parameters: |
||||
# Avar -- Reference to the set variable to extend. |
||||
# B -- The set to add to the set in Avar. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# The set in the variable referenced by Avar is extended |
||||
# by all the elements in B. |
||||
|
||||
proc ::struct::set::S_add {Avar B} { |
||||
# Avar = Avar + B |
||||
upvar 1 $Avar A |
||||
if {![info exists A]} {set A {}} |
||||
::set A [S_union [K $A [::set A {}]] $B] |
||||
return |
||||
} |
||||
|
||||
# ::struct::set::S_subtract -- |
||||
# |
||||
# Remove a set from a set. Similar to 'difference', but the first argument |
||||
# is a variable. |
||||
# |
||||
# Parameters: |
||||
# Avar -- Reference to the set variable to shrink. |
||||
# B -- The set to remove from the set in Avar. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# The set in the variable referenced by Avar is shrunk, |
||||
# all elements of B are removed. |
||||
|
||||
proc ::struct::set::S_subtract {Avar B} { |
||||
# Avar = Avar - B |
||||
upvar 1 $Avar A |
||||
if {![info exists A]} {return -code error "can't read \"$Avar\": no such variable"} |
||||
::set A [S_difference [K $A [::set A {}]] $B] |
||||
return |
||||
} |
||||
|
||||
# ::struct::set::S_subsetof -- |
||||
# |
||||
# A predicate checking if the first set is a subset |
||||
# or equal to the second set. |
||||
# |
||||
# Parameters: |
||||
# A -- The possible subset. |
||||
# B -- The set to compare to. |
||||
# |
||||
# Results: |
||||
# A boolean value, true if A is subset of or equal to B |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_subsetof {A B} { |
||||
# A subset|== B <=> (A == A*B) |
||||
return [S_equal $A [S_intersect $A $B]] |
||||
} |
||||
|
||||
# ::struct::set::K -- |
||||
# Performance helper command. |
||||
|
||||
proc ::struct::set::K {x y} {::set x} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::struct { |
||||
# Put 'set::set' into the general structure namespace |
||||
# for pickup by the main management. |
||||
|
||||
namespace import -force set::set_tcl |
||||
} |
||||
@ -0,0 +1,6 @@
|
||||
#!/bin/sh |
||||
# -*- tcl -*- \ |
||||
# 'build.tcl' name as required by kettle |
||||
# Can be run directly - but also using `pmix Kettle ...` or `pmix KettleShell ...`\ |
||||
exec ./kettle -f "$0" "${1+$@}" |
||||
kettle doc |
||||
@ -0,0 +1,961 @@
|
||||
# tcl |
||||
# |
||||
#make any tclkits and modules in src and place them and associated data files/scripts in the parent folder of src. |
||||
#e.g in 'bin' and 'modules' folders at same level as 'src' folder. |
||||
|
||||
set hashline "# ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###" |
||||
puts $hashline |
||||
puts " punkshell make script " |
||||
puts $hashline\n |
||||
namespace eval ::punkmake { |
||||
variable scriptfolder [file normalize [file dirname [info script]]] |
||||
variable foldername [file tail $scriptfolder] |
||||
variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list] |
||||
variable non_help_flags [list -k] |
||||
variable help_flags [list -help --help /?] |
||||
variable known_commands [list project get-project-info shell bootsupport] |
||||
} |
||||
if {"::try" ni [info commands ::try]} { |
||||
puts stderr "Tcl interpreter possibly too old - 'try' command not found - aborting" |
||||
exit 1 |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
#Module loading from /src/bootsupport or src/*.vfs if script is within a .vfs folder |
||||
#------------------------------------------------------------------------------ |
||||
#If the there is a folder under the current directory /src/bootsupport/modules which contains .tm files |
||||
# - then it will attempt to preference these modules |
||||
# This allows a source update via 'fossil update' 'git pull' etc to pull in a minimal set of support modules for the make script |
||||
# and load these in preference to ones that may have been in the interp's tcl::tm::list or auto_path due to environment variables |
||||
set startdir [pwd] |
||||
if {[file exists [file join $startdir src bootsupport]]} { |
||||
set bootsupport_mod [file join $startdir src bootsupport modules] |
||||
set bootsupport_lib [file join $startdir src bootsupport lib] |
||||
} else { |
||||
set bootsupport_mod [file join $startdir bootsupport modules] |
||||
set bootsupport_lib [file join $startdir bootsupport lib] |
||||
} |
||||
if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} { |
||||
|
||||
set original_tm_list [tcl::tm::list] |
||||
tcl::tm::remove {*}$original_tm_list |
||||
set original_auto_path $::auto_path |
||||
set ::auto_path [list $bootsupport_lib] |
||||
|
||||
set support_modules [glob -nocomplain -dir $bootsupport_mod -type f -tail *.tm] |
||||
set tcl_core_packages [list tcl::zlib zlib tcl::oo TclOO tcl::tommath tcl::zipfs Tcl Tk] ;#packages we |
||||
if {[llength $support_modules] || [llength [glob -nocomplain -dir $bootsupport_lib -tail *]]} { |
||||
#only forget all *unloaded* package names |
||||
foreach pkg [package names] { |
||||
if {$pkg in $tcl_core_packages} { |
||||
continue |
||||
} |
||||
if {![llength [package versions $pkg]]} { |
||||
#puts stderr "Got no versions for pkg $pkg" |
||||
continue |
||||
} |
||||
if {![string length [package provide $pkg]]} { |
||||
#no returned version indicates it wasn't loaded - so we can forget its index |
||||
package forget $pkg |
||||
} |
||||
} |
||||
tcl::tm::add $bootsupport_mod |
||||
} |
||||
|
||||
|
||||
if {[file exists [pwd]/modules]} { |
||||
tcl::tm::add [pwd]/modules |
||||
} |
||||
|
||||
#package require Thread |
||||
# - the full repl requires Threading and punk,shellfilter,shellrun to call and display properly. |
||||
|
||||
|
||||
# tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list |
||||
#These are strong dependencies |
||||
package forget punk::mix |
||||
package require punk::mix |
||||
package forget punk::repo |
||||
package require punk::repo |
||||
package forget punkcheck |
||||
package require punkcheck |
||||
|
||||
|
||||
|
||||
#restore module paths and auto_path in addition to the bootsupport ones |
||||
set tm_list_now [tcl::tm::list] |
||||
foreach p $original_tm_list { |
||||
if {$p ni $tm_list_now} { |
||||
tcl::tm::add $p |
||||
} |
||||
} |
||||
set ::auto_path [list $bootsupport_lib {*}$original_auto_path] |
||||
#------------------------------------------------------------------------------ |
||||
} |
||||
|
||||
# ** *** *** *** *** *** *** *** *** *** *** *** |
||||
#*temporarily* hijack package command |
||||
# ** *** *** *** *** *** *** *** *** *** *** *** |
||||
try { |
||||
rename ::package ::punkmake::package_temp_aside |
||||
proc ::package {args} { |
||||
if {[lindex $args 0] eq "require"} { |
||||
lappend ::punkmake::pkg_requirements [lindex $args 1] |
||||
} |
||||
} |
||||
package require punk::mix |
||||
package require punk::repo |
||||
} finally { |
||||
catch {rename ::package ""} |
||||
catch {rename ::punkmake::package_temp_aside ::package} |
||||
} |
||||
# ** *** *** *** *** *** *** *** *** *** *** *** |
||||
foreach pkg $::punkmake::pkg_requirements { |
||||
if {[catch {package require $pkg} errM]} { |
||||
puts stderr "missing pkg: $pkg" |
||||
lappend ::punkmake::pkg_missing $pkg |
||||
} else { |
||||
lappend ::punkmake::pkg_loaded $pkg |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
proc punkmake_gethelp {args} { |
||||
set scriptname [file tail [info script]] |
||||
append h "Usage:" \n |
||||
append h "" \n |
||||
append h " $scriptname -help or $scriptname --help or $scriptname /? or just $scriptname" \n |
||||
append h " - This help." \n \n |
||||
append h " $scriptname project ?-k?" \n |
||||
append h " - this is the literal word project - and confirms you want to run the project build" \n |
||||
append h " - the optional -k flag will terminate processes running as the executable being built (if applicable)" \n \n |
||||
append h " $scriptname bootsupport" \n |
||||
append h " - update the src/bootsupport modules as well as the mixtemplates/layouts/<layoutname>/src/bootsupport modules if the folder exists" \n \n |
||||
append h " $scriptname get-project-info" \n |
||||
append h " - show the name and base folder of the project to be built" \n |
||||
append h "" \n |
||||
if {[llength $::punkmake::pkg_missing]} { |
||||
append h "* ** NOTE ** ***" \n |
||||
append h " punkmake has detected that the following packages could not be loaded:" \n |
||||
append h " " [join $::punkmake::pkg_missing "\n "] \n |
||||
append h "* ** *** *** ***" \n |
||||
append h " These packages are required for punk make to function" \n \n |
||||
append h "* ** *** *** ***" \n\n |
||||
append h "Successfully Loaded packages:" \n |
||||
append h " " [join $::punkmake::pkg_loaded "\n "] \n |
||||
} |
||||
return $h |
||||
} |
||||
set scriptargs $::argv |
||||
set do_help 0 |
||||
if {![llength $scriptargs]} { |
||||
set do_help 1 |
||||
} else { |
||||
foreach h $::punkmake::help_flags { |
||||
if {[lsearch $scriptargs $h] >= 0} { |
||||
set do_help 1 |
||||
break |
||||
} |
||||
} |
||||
} |
||||
set commands_found [list] |
||||
foreach a $scriptargs { |
||||
if {![string match -* $a]} { |
||||
lappend commands_found $a |
||||
} else { |
||||
if {$a ni $::punkmake::non_help_flags} { |
||||
set do_help 1 |
||||
} |
||||
} |
||||
} |
||||
if {[llength $commands_found] != 1 } { |
||||
set do_help 1 |
||||
} elseif {[lindex $commands_found 0] ni $::punkmake::known_commands} { |
||||
puts stderr "Unknown command: [lindex $commands_found 0]\n\n" |
||||
set do_help 1 |
||||
} |
||||
if {$do_help} { |
||||
puts stderr [punkmake_gethelp] |
||||
exit 0 |
||||
} |
||||
|
||||
set ::punkmake::command [lindex $commands_found 0] |
||||
|
||||
|
||||
if {[lsearch $::argv -k] >= 0} { |
||||
set forcekill 1 |
||||
} else { |
||||
set forcekill 0 |
||||
} |
||||
#puts stdout "::argv $::argv" |
||||
# ---------------------------------------- |
||||
|
||||
set scriptfolder $::punkmake::scriptfolder |
||||
|
||||
|
||||
|
||||
#first look for a project root (something under fossil or git revision control AND matches punk project folder structure) |
||||
#If that fails - just look for a 'project shaped folder' ie meets minimum requirements of /src /src/lib /src/modules /lib /modules |
||||
if {![string length [set projectroot [punk::repo::find_project $scriptfolder]]]} { |
||||
if {![string length [set projectroot [punk::repo::find_candidate $scriptfolder]]]} { |
||||
puts stderr "punkmake script unable to determine an approprite project root at or above the path '$scriptfolder' ensure the make script is within a project folder structure" |
||||
puts stderr " -aborted- " |
||||
exit 2 |
||||
#todo? |
||||
#ask user for a project name and create basic structure? |
||||
#call punk::mix::cli::new $projectname on parent folder? |
||||
} else { |
||||
puts stderr "WARNING punkmake script operating in project space that is not under version control" |
||||
} |
||||
} else { |
||||
|
||||
} |
||||
|
||||
set sourcefolder $projectroot/src |
||||
|
||||
if {$::punkmake::command eq "get-project-info"} { |
||||
puts stdout "- -- --- --- --- --- --- --- --- --- ---" |
||||
puts stdout "- -- get-project-info -- -" |
||||
puts stdout "- -- --- --- --- --- --- --- --- --- ---" |
||||
puts stdout "- projectroot : $projectroot" |
||||
if {[punk::repo::find_fossil $scriptfolder] eq $projectroot} { |
||||
set vc "fossil" |
||||
set rev [punk::repo::fossil_revision $scriptfolder] |
||||
set rem [punk::repo::fossil_remote $scriptfolder] |
||||
} elseif {[punk::repo::find_git $scriptfolder] eq $projectroot} { |
||||
set vc "git" |
||||
set rev [punk::repo::git_revision $scriptfolder] |
||||
set rem [punk::repo::git_remote $scriptfolder] |
||||
} else { |
||||
set vc " - none found -" |
||||
set rev "n/a" |
||||
set remotes "n/a" |
||||
} |
||||
puts stdout "- version control : $vc" |
||||
puts stdout "- revision : $rev" |
||||
puts stdout "- remote : $rem" |
||||
puts stdout "- -- --- --- --- --- --- --- --- --- ---" |
||||
|
||||
exit 0 |
||||
} |
||||
|
||||
if {$::punkmake::command eq "shell"} { |
||||
package require punk |
||||
package require punk::repl |
||||
puts stderr "make shell not fully implemented - dropping into ordinary punk shell" |
||||
repl::start stdin |
||||
|
||||
exit 1 |
||||
} |
||||
|
||||
if {$::punkmake::command eq "bootsupport"} { |
||||
puts "projectroot: $projectroot" |
||||
puts "script: [info script]" |
||||
#puts "-- [tcl::tm::list] --" |
||||
puts stdout "Updating bootsupport from local files" |
||||
|
||||
proc bootsupport_localupdate {projectroot} { |
||||
set bootsupport_modules [list] |
||||
set bootsupport_config $projectroot/src/bootsupport/include_modules.config ;# |
||||
if {[file exists $bootsupport_config]} { |
||||
source $bootsupport_config ;#populate $bootsupport_modules with project-specific list |
||||
if {![llength $bootsupport_modules]} { |
||||
puts stderr "No local bootsupport modules configured for updating" |
||||
return |
||||
} |
||||
set targetroot $projectroot/src/bootsupport/modules |
||||
|
||||
if {[catch { |
||||
#---------- |
||||
set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck] |
||||
$boot_installer set_source_target $projectroot $projectroot/src/bootsupport |
||||
set boot_event [$boot_installer start_event {-make_step bootsupport}] |
||||
#---------- |
||||
} errM]} { |
||||
puts stderr "Unable to use punkcheck for bootsupport error: $errM" |
||||
set boot_event "" |
||||
} |
||||
|
||||
foreach {relpath module} $bootsupport_modules { |
||||
set module [string trim $module :] |
||||
set module_subpath [string map [list :: /] [namespace qualifiers $module]] |
||||
set srclocation [file join $projectroot $relpath $module_subpath] |
||||
#puts stdout "$relpath $module $module_subpath $srclocation" |
||||
set pkgmatches [glob -nocomplain -dir $srclocation -tail [namespace tail $module]-*] |
||||
#lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1 |
||||
if {![llength $pkgmatches]} { |
||||
puts stderr "Missing source for bootsupport module $module - not found in $srclocation" |
||||
continue |
||||
} |
||||
set latestfile [lindex $pkgmatches 0] |
||||
set latestver [lindex [split [file rootname $latestfile] -] 1] |
||||
foreach m $pkgmatches { |
||||
lassign [split [file rootname $m] -] _pkg ver |
||||
#puts "comparing $ver vs $latestver" |
||||
if {[package vcompare $ver $latestver] == 1} { |
||||
set latestver $ver |
||||
set latestfile $m |
||||
} |
||||
} |
||||
set srcfile [file join $srclocation $latestfile] |
||||
set tgtfile [file join $targetroot $module_subpath $latestfile] |
||||
if {$boot_event ne ""} { |
||||
#---------- |
||||
$boot_event targetset_init INSTALL $tgtfile |
||||
$boot_event targetset_addsource $srcfile |
||||
#---------- |
||||
if {\ |
||||
[llength [dict get [$boot_event targetset_source_changes] changed]]\ |
||||
|| [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\ |
||||
} { |
||||
file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists |
||||
$boot_event targetset_started |
||||
# -- --- --- --- --- --- |
||||
puts "BOOTSUPPORT update: $srcfile -> $tgtfile" |
||||
if {[catch { |
||||
file copy -force $srcfile $tgtfile |
||||
} errM]} { |
||||
$boot_event targetset_end FAILED |
||||
} else { |
||||
$boot_event targetset_end OK |
||||
} |
||||
# -- --- --- --- --- --- |
||||
} else { |
||||
puts -nonewline stderr "." |
||||
$boot_event targetset_end SKIPPED |
||||
} |
||||
$boot_event end |
||||
} else { |
||||
file copy -force $srcfile $tgtfile |
||||
} |
||||
} |
||||
if {$boot_event ne ""} { |
||||
puts \n |
||||
$boot_event destroy |
||||
$boot_installer destroy |
||||
} |
||||
} |
||||
} |
||||
|
||||
bootsupport_localupdate $projectroot |
||||
|
||||
#/modules/punk/mix/templates/layouts only applies if the project has it's own copy of the punk/mix modules. Generally this should only apply to the punkshell project itself. |
||||
set layout_bases [list\ |
||||
$sourcefolder/mixtemplates/layouts\ |
||||
$sourcefolder/modules/punk/mix/templates/layouts\ |
||||
] |
||||
foreach project_layout_base $layout_bases { |
||||
if {[file exists $project_layout_base]} { |
||||
set project_layouts [glob -nocomplain -dir $project_layout_base -type d -tail *] |
||||
foreach layoutname $project_layouts { |
||||
if {[file exists [file join $project_layout_base $layoutname/src/bootsupport]]} { |
||||
set unpublish [list\ |
||||
README.md\ |
||||
] |
||||
set sourcemodules $projectroot/src/bootsupport/modules |
||||
set targetroot [file join $project_layout_base $layoutname/src/bootsupport/modules] |
||||
file mkdir $targetroot |
||||
|
||||
puts stdout "BOOTSUPPORT layouts/$layoutname: copying from $sourcemodules to $targetroot (if source file changed)" |
||||
set resultdict [punkcheck::install $sourcemodules $targetroot -overwrite installedsourcechanged-targets -unpublish_paths $unpublish] |
||||
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
||||
flush stdout |
||||
} |
||||
} |
||||
} else { |
||||
puts stderr "No layout base at $project_layout_base" |
||||
} |
||||
} |
||||
puts stdout " bootsupport done " |
||||
flush stderr |
||||
flush stdout |
||||
#punk86 can hang if calling make.tcl via 'run' without this 'after' delay. punk87 unaffected. cause unknown. |
||||
#after 500 |
||||
::exit 0 |
||||
} |
||||
|
||||
|
||||
|
||||
if {$::punkmake::command ne "project"} { |
||||
puts stderr "Command $::punkmake::command not implemented - aborting." |
||||
exit 1 |
||||
} |
||||
|
||||
|
||||
|
||||
#only a single consolidated /modules folder used for target |
||||
set target_modules_base $projectroot/modules |
||||
file mkdir $target_modules_base |
||||
|
||||
#external libs and modules first - and any supporting files - no 'building' required |
||||
if {[file exists $sourcefolder/vendorlib]} { |
||||
#unpublish README.md from source folder - but only the root one |
||||
#-unpublish_paths takes relative patterns e.g |
||||
# */test.txt will only match test.txt exactly one level deep. |
||||
# */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. |
||||
# **/test.txt will match at any level below the root (but not in the root) |
||||
set unpublish [list\ |
||||
README.md\ |
||||
] |
||||
|
||||
puts stdout "VENDORLIB: copying from $sourcefolder/vendorlib to $projectroot/lib (if source file changed)" |
||||
set resultdict [punkcheck::install $sourcefolder/vendorlib $projectroot/lib -overwrite installedsourcechanged-targets -unpublish_paths $unpublish] |
||||
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
||||
|
||||
} else { |
||||
puts stderr "VENDORLIB: No src/vendorlib folder found." |
||||
} |
||||
|
||||
if {[file exists $sourcefolder/vendormodules]} { |
||||
#install .tm *and other files* |
||||
puts stdout "VENDORMODULES: copying from $sourcefolder/vendormodules to $target_modules_base (if source file changed)" |
||||
set resultdict [punkcheck::install $sourcefolder/vendormodules $target_modules_base -installer make.tcl -overwrite installedsourcechanged-targets -unpublish_paths {README.md}] |
||||
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
||||
} else { |
||||
puts stderr "VENDORMODULES: No src/vendormodules folder found." |
||||
} |
||||
|
||||
######################################################## |
||||
#templates |
||||
#e.g The default project layout is mainly folder structure and readme files - but has some scripts developed under the main src that we want to sync |
||||
#src to src/modules/punk/mix/templates/layouts/project/src |
||||
|
||||
set layout_update_list [list\ |
||||
[list project $sourcefolder/modules/punk/mix/templates]\ |
||||
[list basic $sourcefolder/mixtemplates]\ |
||||
] |
||||
|
||||
foreach layoutinfo $layout_update_list { |
||||
lassign $layoutinfo layout templatebase |
||||
if {![file exists $templatebase]} { |
||||
continue |
||||
} |
||||
set config [dict create\ |
||||
-make-step sync_templates\ |
||||
] |
||||
#---------- |
||||
set tpl_installer [punkcheck::installtrack new make.tcl $templatebase/.punkcheck] |
||||
$tpl_installer set_source_target $sourcefolder $templatebase |
||||
set tpl_event [$tpl_installer start_event $config] |
||||
#---------- |
||||
set pairs [list] |
||||
set pairs [list\ |
||||
[list $sourcefolder/build.tcl $templatebase/layouts/$layout/src/build.tcl]\ |
||||
[list $sourcefolder/make.tcl $templatebase/layouts/$layout/src/make.tcl]\ |
||||
] |
||||
|
||||
foreach filepair $pairs { |
||||
lassign $filepair srcfile tgtfile |
||||
file mkdir [file dirname $tgtfile] |
||||
#---------- |
||||
$tpl_event targetset_init INSTALL $tgtfile |
||||
$tpl_event targetset_addsource $srcfile |
||||
#---------- |
||||
if {\ |
||||
[llength [dict get [$tpl_event targetset_source_changes] changed]]\ |
||||
|| [llength [$tpl_event get_targets_exist]] < [llength [$tpl_event get_targets]]\ |
||||
} { |
||||
$tpl_event targetset_started |
||||
# -- --- --- --- --- --- |
||||
puts stdout "punk module templates: Copying from $srcfile to $tgtfile" |
||||
if {[catch { |
||||
file copy -force $srcfile $tgtfile |
||||
} errM]} { |
||||
$tpl_event targetset_end FAILED -note "copy failed with err: $errM" |
||||
} else { |
||||
$tpl_event targetset_end OK -note "test" |
||||
} |
||||
# -- --- --- --- --- --- |
||||
} else { |
||||
puts stderr "." |
||||
$tpl_event targetset_end SKIPPED |
||||
} |
||||
} |
||||
|
||||
$tpl_event end |
||||
$tpl_event destroy |
||||
$tpl_installer destroy |
||||
} |
||||
######################################################## |
||||
|
||||
|
||||
#default source module folder is at projectroot/src/modules |
||||
#There may be multiple other src module folders at same level (e.g folder not being other special-purpose folder and not matching name vendor* that contains at least one .tm file in its root) |
||||
set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot] |
||||
foreach src_module_dir $source_module_folderlist { |
||||
puts stderr "Processing source module dir: $src_module_dir" |
||||
set dirtail [file tail $src_module_dir] |
||||
#modules and associated files belonging to this package/app |
||||
set copied [punk::mix::cli::lib::build_modules_from_source_to_base $src_module_dir $target_modules_base -glob *.tm] ;#will only accept a glob ending in .tm |
||||
#set copied [list] |
||||
puts stdout "--------------------------" |
||||
puts stderr "Copied [llength $copied] tm modules from src/$dirtail to $target_modules_base " |
||||
puts stdout "--------------------------" |
||||
|
||||
set overwrite "installedsourcechanged-targets" |
||||
#set overwrite "ALL-TARGETS" |
||||
puts stdout "MODULEFOLDER non_tm_files $src_module_dir - copying to $target_modules_base (if source file changed)" |
||||
set resultdict [punkcheck::install_non_tm_files $src_module_dir $target_modules_base -installer make.tcl -overwrite $overwrite -unpublish_paths {README.md}] |
||||
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
||||
} |
||||
|
||||
set installername "make.tcl" |
||||
|
||||
# ---------------------------------------- |
||||
if {[punk::repo::is_fossil_root $projectroot]} { |
||||
set config [dict create\ |
||||
-make-step configure_fossil\ |
||||
] |
||||
#---------- |
||||
set installer [punkcheck::installtrack new $installername $projectroot/.punkcheck] |
||||
$installer set_source_target $projectroot $projectroot |
||||
|
||||
set event [$installer start_event $config] |
||||
$event targetset_init VIRTUAL fossil_settings_mainmenu ;#VIRTUAL - since there is no actual target file |
||||
set menufile $projectroot/.fossil-custom/mainmenu |
||||
$event targetset_addsource $menufile |
||||
#---------- |
||||
|
||||
if {\ |
||||
[llength [dict get [$event targetset_source_changes] changed]]\ |
||||
} { |
||||
$event targetset_started |
||||
# -- --- --- --- --- --- |
||||
puts stdout "Configuring fossil setting: mainmenu from: $menufile" |
||||
if {[catch { |
||||
set fd [open $menufile r] |
||||
fconfigure $fd -translation binary |
||||
set data [read $fd] |
||||
close $fd |
||||
exec fossil settings mainmenu $data |
||||
} errM]} { |
||||
$event targetset_end FAILED -note "fossil update failed: $errM" |
||||
} else { |
||||
$event targetset_end OK |
||||
} |
||||
# -- --- --- --- --- --- |
||||
} else { |
||||
puts stderr "." |
||||
$event targetset_end SKIPPED |
||||
} |
||||
$event end |
||||
$event destroy |
||||
$installer destroy |
||||
} |
||||
|
||||
set buildfolder [punk::mix::cli::lib::get_build_workdir $sourcefolder] |
||||
if {$buildfolder ne "$sourcefolder/_build"} { |
||||
puts stderr "$sourcefolder/_build doesn't match the project buildfolder $buildfolder - check project filestructure" |
||||
puts stdout " -aborted- " |
||||
exit 2 |
||||
} |
||||
|
||||
|
||||
#find runtimes |
||||
set rtfolder $sourcefolder/runtime |
||||
set runtimes [glob -nocomplain -dir $rtfolder -types {f x} -tail *] |
||||
if {![llength $runtimes]} { |
||||
puts stderr "No executable runtimes found in $rtfolder - unable to build any .vfs folders into executables." |
||||
puts stderr "Add runtimes to $sourcefolder/runtime if required" |
||||
exit 0 |
||||
} |
||||
|
||||
if {[catch {exec sdx help} errM]} { |
||||
puts stderr "FAILED to find usable sdx command - check that sdx executable is on path" |
||||
puts stderr "err: $errM" |
||||
exit 1 |
||||
} |
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- |
||||
#load mapvfs.config file (if any) in runtime folder to map runtimes to vfs folders. |
||||
#build a dict keyed on runtime executable name. |
||||
#If no mapfile (or no mapfile entry for that runtime) - the runtime will be paired with a matching .vfs folder in src folder. e.g punk.exe to src/punk.vfs |
||||
#If vfs folders or runtime executables which are explicitly listed in the mapfile don't exist - warn on stderr - but continue. if such nonexistants found; prompt user for whether to continue or abort. |
||||
set mapfile $rtfolder/mapvfs.config |
||||
set runtime_vfs_map [dict create] |
||||
set vfs_runtime_map [dict create] |
||||
if {[file exists $mapfile]} { |
||||
set fdmap [open $mapfile r] |
||||
fconfigure $fdmap -translation binary |
||||
set mapdata [read $fdmap] |
||||
close $fdmap |
||||
set mapdata [string map [list \r\n \n] $mapdata] |
||||
set missing [list] |
||||
foreach ln [split $mapdata \n] { |
||||
set ln [string trim $ln] |
||||
if {$ln eq "" || [string match #* $ln]} { |
||||
continue |
||||
} |
||||
set vfspaths [lassign $ln runtime] |
||||
if {[string match *.exe $runtime]} { |
||||
#.exe is superfluous but allowed |
||||
#drop windows .exe suffix so same config can work cross platform - extension will be re-added if necessary later |
||||
set runtime [string range $runtime 0 end-4] |
||||
} |
||||
if {$runtime ne "-"} { |
||||
set runtime_test $runtime |
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
set runtime_test $runtime.exe |
||||
} |
||||
if {![file exists [file join $rtfolder $runtime_test]]} { |
||||
puts stderr "WARNING: Missing runtime file $rtfolder/$runtime_test (line in mapvfs.config: $ln)" |
||||
lappend missing $runtime |
||||
} |
||||
} |
||||
foreach vfs $vfspaths { |
||||
if {![file isdirectory [file join $sourcefolder $vfs]]} { |
||||
puts stderr "WARNNING: Missing vfs folder [file join $sourcefolder $vfs] specified in mapvfs.config for runtime $runtime" |
||||
lappend missing $vfs |
||||
} |
||||
dict lappend vfs_runtime_map $vfs $runtime |
||||
} |
||||
if {[dict exists $runtime_vfs_map $runtime]} { |
||||
puts stderr "CONFIG FILE ERROR. runtime: $runtime was specified more than once in $mapfile." |
||||
exit 3 |
||||
} |
||||
dict set runtime_vfs_map $runtime $vfspaths |
||||
} |
||||
if {[llength $missing]} { |
||||
puts stderr "WARNING [llength $missing] missing items from $mapfile. (TODO - prompt user to continue/abort)" |
||||
foreach m $missing { |
||||
puts stderr " $m" |
||||
} |
||||
puts stderr "continuing..." |
||||
} |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- |
||||
|
||||
set vfs_folders [glob -nocomplain -dir $sourcefolder -types d -tail *.vfs] |
||||
#add any extra .vfs folders found in runtime/mapvfs.config file (e.g myotherruntimes/something.vfs) |
||||
foreach vfs [dict keys $vfs_runtime_map] { |
||||
if {$vfs ni $vfs_folders} { |
||||
lappend vfs_folders $vfs |
||||
} |
||||
} |
||||
if {![llength $vfs_folders]} { |
||||
puts stdout "No .vfs folders found at '$sourcefolder' - no kits to build" |
||||
puts stdout " -done- " |
||||
exit 0 |
||||
} |
||||
|
||||
set vfs_folder_changes [dict create] ;#cache whether each .vfs folder has changes so we don't re-run tests if building from same .vfs with multiple runtime executables |
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
#set runtimefile [lindex $runtimes 0] |
||||
foreach runtimefile $runtimes { |
||||
#runtimefile e.g tclkit86bi.exe on windows tclkit86bi on other platforms |
||||
|
||||
#sdx *may* be pointed to use the runtime we use to build the kit, or the user may manually use this runtime if they don't have tclsh |
||||
#sdx will complain if the same runtime is used for the shell as is used in the -runtime argument - so we make a copy (REVIEW) |
||||
#if {![file exists $buildfolder/buildruntime.exe]} { |
||||
# file copy $rtfolder/$runtimefile $buildfolder/buildruntime.exe |
||||
#} |
||||
|
||||
set basedir $buildfolder |
||||
set config [dict create\ |
||||
-make-step copy_runtime\ |
||||
] |
||||
#---------- |
||||
set installer [punkcheck::installtrack new $installername $basedir/.punkcheck] |
||||
$installer set_source_target $rtfolder $buildfolder |
||||
set event [$installer start_event $config] |
||||
$event targetset_init INSTALL $buildfolder/build_$runtimefile |
||||
$event targetset_addsource $rtfolder/$runtimefile |
||||
#---------- |
||||
|
||||
#set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] |
||||
if {\ |
||||
[llength [dict get [$event targetset_source_changes] changed]]\ |
||||
|| [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ |
||||
} { |
||||
$event targetset_started |
||||
# -- --- --- --- --- --- |
||||
puts stdout "Copying runtime from $rtfolder/$runtimefile to $buildfolder/build_$runtimefile" |
||||
if {[catch { |
||||
file copy -force $rtfolder/$runtimefile $buildfolder/build_$runtimefile |
||||
} errM]} { |
||||
$event targetset_end FAILED |
||||
} else { |
||||
$event targetset_end OK |
||||
} |
||||
# -- --- --- --- --- --- |
||||
} else { |
||||
puts stderr "." |
||||
$event targetset_end SKIPPED |
||||
} |
||||
$event end |
||||
|
||||
} |
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
|
||||
# |
||||
# loop over vfs_folders and for each one, loop over configured (or matching) runtimes - build with sdx if source .vfs or source runtime exe has changed. |
||||
# we are using punkcheck to install result to buildfolder so we create a .punkcheck file at the target folder to store metadata. |
||||
# punkcheck allows us to not rely purely on timestamps (which may be unreliable) |
||||
# |
||||
set startdir [pwd] |
||||
puts stdout "Found [llength $vfs_folders] .vfs folders - building executable for each..." |
||||
cd [file dirname $buildfolder] |
||||
#root folder mtime is insufficient for change detection. Tree mtime of folders only is a barely passable mechanism for vfs change detection in some circumstances - e.g if files added/removed but never edited in place |
||||
#a hash of full tree file & dir mtime may be more reasonable - but it remains to be seen if just tar & checksum is any/much slower. |
||||
#Simply rebuilding all the time may be close the speed of detecting change anyway - and almost certainly much faster when there is a change. |
||||
#Using first mtime encountered that is later than target is another option - but likely to be highly variable in speed. Last file in the tree could happen to be the latest, and this mechanism doesn't handle build on reversion to older source. |
||||
set exe_names_seen [list] |
||||
foreach vfs $vfs_folders { |
||||
|
||||
set vfsname [file rootname $vfs] |
||||
puts stdout " Processing vfs $sourcefolder/$vfs" |
||||
puts stdout " ------------------------------------" |
||||
set skipped_vfs_build 0 |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set basedir $buildfolder |
||||
set config [dict create\ |
||||
-make-step build_vfs\ |
||||
] |
||||
|
||||
set runtimes [list] |
||||
if {[dict exists $vfs_runtime_map $vfs]} { |
||||
set runtimes [dict get $vfs_runtime_map $vfs] ;#map dict is unsuffixed (.exe stripped or was not present) |
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
set runtimes_raw $runtimes |
||||
set runtimes [list] |
||||
foreach rt $runtimes_raw { |
||||
if {![string match *.exe $rt] && $rt ne "-"} { |
||||
set rt $rt.exe |
||||
} |
||||
lappend runtimes $rt |
||||
} |
||||
} |
||||
} else { |
||||
#only match this vfs to a correspondingly named runtime if there was no explicit entry for that runtime |
||||
set matchrt [file rootname [file tail $vfs]] ;#e.g project.vfs -> project |
||||
if {![dict exists $runtime_vfs_map $matchrt]} { |
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
if {[file exists $rtfolder/$matchrt.exe]} { |
||||
lappend runtimes $matchrt.exe |
||||
} |
||||
} else { |
||||
lappend runtimes $matchrt |
||||
} |
||||
} |
||||
} |
||||
#assert $runtimes is a list of executable names suffixed with .exe if on windows - whether or not specified with .exe in the mapvfs.config |
||||
|
||||
|
||||
#todo - non kit based - zipkit? |
||||
# $runtimes may now include a dash entry "-" (from mapvfs.config file) |
||||
foreach rtname $runtimes { |
||||
#rtname of "-" indicates build a kit without a runtime |
||||
|
||||
#first configured runtime will be the one to use the same name as .vfs folder for output executable. Additional runtimes on this .vfs will need to suffix the runtime name to disambiguate. |
||||
#review: This mechanism may not be great for multiplatform builds ? We may be better off consistently combining vfsname and rtname and letting a later platform-specific step choose ones to install in bin with simpler names. |
||||
if {$rtname eq "-"} { |
||||
set targetkit $vfsname.kit |
||||
} else { |
||||
if {$::tcl_platform(platform) eq "windows"} { |
||||
set targetkit ${vfsname}.exe |
||||
} else { |
||||
set targetkit $vfsname |
||||
} |
||||
if {$targetkit in $exe_names_seen} { |
||||
#more than one runtime for this .vfs |
||||
set targetkit ${vfsname}_$rtname |
||||
} |
||||
} |
||||
lappend exe_names_seen $targetkit |
||||
# -- ---------- |
||||
set vfs_installer [punkcheck::installtrack new $installername $basedir/.punkcheck] |
||||
$vfs_installer set_source_target $sourcefolder $buildfolder |
||||
set vfs_event [$vfs_installer start_event {-make-step build_vfs}] |
||||
$vfs_event targetset_init INSTALL $buildfolder/$targetkit |
||||
$vfs_event targetset_addsource $sourcefolder/$vfs |
||||
if {$rtname ne "-"} { |
||||
$vfs_event targetset_addsource $buildfolder/build_$rtname |
||||
} |
||||
# -- ---------- |
||||
|
||||
set changed_unchanged [$vfs_event targetset_source_changes] |
||||
|
||||
if {[llength [dict get $changed_unchanged changed]] || [llength [$vfs_event get_targets_exist]] < [llength [$vfs_event get_targets]]} { |
||||
#source .vfs folder has changes |
||||
$vfs_event targetset_started |
||||
# -- --- --- --- --- --- |
||||
|
||||
#use |
||||
if {[file exists $buildfolder/$vfsname.new]} { |
||||
puts stderr "deleting existing $buildfolder/$vfsname.new" |
||||
file delete $buildfolder/$vfsname.new |
||||
} |
||||
|
||||
puts stdout "building $vfsname with sdx.. vfsdir:$vfs cwd: [pwd]" |
||||
|
||||
|
||||
if {[catch { |
||||
if {$rtname ne "-"} { |
||||
exec sdx wrap $buildfolder/$vfsname.new -vfs $sourcefolder/$vfs -runtime $buildfolder/build_$rtname -verbose |
||||
} else { |
||||
exec sdx wrap $buildfolder/$vfsname.new -vfs $sourcefolder/$vfs -verbose |
||||
} |
||||
} result]} { |
||||
if {$rtname ne "-"} { |
||||
puts stderr "sdx wrap $buildfolder/$vfsname.new -vfs $sourcefolder/$vfs -runtime $buildfolder/build_$rtname -verbose failed with msg: $result" |
||||
} else { |
||||
puts stderr "sdx wrap $buildfolder/$vfsname.new -vfs $sourcefolder/$vfs -verbose failed with msg: $result" |
||||
} |
||||
} else { |
||||
puts stdout "ok - finished sdx" |
||||
set separator [string repeat = 40] |
||||
puts stdout $separator |
||||
puts stdout $result |
||||
puts stdout $separator |
||||
} |
||||
|
||||
if {![file exists $buildfolder/$vfsname.new]} { |
||||
puts stderr "|err> make.tcl build didn't seem to produce output at $sourcefolder/_build/$vfsname.new" |
||||
$vfs_event targetset_end FAILED |
||||
exit 2 |
||||
} |
||||
|
||||
# -- --- --- |
||||
if {$::tcl_platform(platform) eq "windows"} { |
||||
set pscmd "tasklist" |
||||
} else { |
||||
set pscmd "ps" |
||||
} |
||||
|
||||
#killing process doesn't apply to .kit build |
||||
if {$rtname ne "-"} { |
||||
if {![catch { |
||||
exec $pscmd | grep $vfsname |
||||
} still_running]} { |
||||
|
||||
puts stdout "found $vfsname instances still running\n" |
||||
set count_killed 0 |
||||
foreach ln [split $still_running \n] { |
||||
puts stdout " $ln" |
||||
|
||||
if {$::tcl_platform(platform) eq "windows"} { |
||||
set pid [lindex $ln 1] |
||||
if {$forcekill} { |
||||
set killcmd [list taskkill /F /PID $pid] |
||||
} else { |
||||
set killcmd [list taskkill /PID $pid] |
||||
} |
||||
} else { |
||||
set pid [lindex $ln 0] |
||||
#review! |
||||
if {$forcekill} { |
||||
set killcmd [list kill -9 $pid] |
||||
} else { |
||||
set killcmd [list kill $pid] |
||||
} |
||||
} |
||||
puts stdout " pid: $pid (attempting to kill now using '$killcmd')" |
||||
if {[catch { |
||||
exec {*}$killcmd |
||||
} errMsg]} { |
||||
puts stderr "$killcmd returned an error:" |
||||
puts stderr $errMsg |
||||
if {!$forcekill} { |
||||
puts stderr "(try '[info script] -k' option to force kill)" |
||||
} |
||||
#avoid exiting if the kill failure was because the task has already exited |
||||
#review - *no running instance* works with windows taskkill - "*No such process*" works with kill -9 on FreeBSD and linux - other platforms? |
||||
if {![string match "*no running instance*" $errMsg] && ![string match "*No such process*" $errMsg]} { |
||||
exit 4 |
||||
} |
||||
} else { |
||||
puts stderr "$killcmd ran without error" |
||||
incr count_killed |
||||
} |
||||
} |
||||
if {$count_killed > 0} { |
||||
puts stderr "\nKilled $count_killed processes. Waiting a short time before attempting to delete executable" |
||||
after 1000 |
||||
} |
||||
} else { |
||||
puts stderr "Ok.. no running '$vfsname' processes found" |
||||
} |
||||
} |
||||
|
||||
if {[file exists $buildfolder/$targetkit]} { |
||||
puts stderr "deleting existing $buildfolder/$targetkit" |
||||
if {[catch { |
||||
file delete $buildfolder/$targetkit |
||||
} msg]} { |
||||
puts stderr "Failed to delete $buildfolder/$targetkit" |
||||
exit 4 |
||||
} |
||||
} |
||||
#WINDOWS filesystem 'tunneling' (file replacement within 15secs) could cause targetkit to copy ctime & shortname metadata from previous file! |
||||
#This is probably harmless - but worth being aware of. |
||||
file rename $buildfolder/$vfsname.new $buildfolder/$targetkit |
||||
# -- --- --- --- --- --- |
||||
$vfs_event targetset_end OK |
||||
|
||||
|
||||
after 200 |
||||
set deployment_folder [file dirname $sourcefolder]/bin |
||||
file mkdir $deployment_folder |
||||
|
||||
# -- ---------- |
||||
set bin_installer [punkcheck::installtrack new "make.tcl" $deployment_folder/.punkcheck] |
||||
$bin_installer set_source_target $buildfolder $deployment_folder |
||||
set bin_event [$bin_installer start_event {-make-step final_kit_install}] |
||||
$bin_event targetset_init INSTALL $deployment_folder/$targetkit |
||||
#todo - move final deployment step outside of the build vfs loop? (final deployment can fail and then isn't rerun even though _build and deployed versions differ, unless .vfs modified again) |
||||
#set last_completion [$bin_event targetset_last_complete] |
||||
|
||||
$bin_event targetset_addsource $buildfolder/$targetkit |
||||
$bin_event targetset_started |
||||
# -- ---------- |
||||
|
||||
|
||||
set delete_failed 0 |
||||
if {[file exists $deployment_folder/$targetkit]} { |
||||
puts stderr "deleting existing deployed at $deployment_folder/$targetkit" |
||||
if {[catch { |
||||
file delete $deployment_folder/$targetkit |
||||
} errMsg]} { |
||||
puts stderr "deletion of deployed version at $deployment_folder/$targetkit failed: $errMsg" |
||||
set delete_failed 1 |
||||
} |
||||
} |
||||
if {!$delete_failed} { |
||||
puts stdout "copying.." |
||||
puts stdout "$buildfolder/$targetkit" |
||||
puts stdout "to:" |
||||
puts stdout "$deployment_folder/$targetkit" |
||||
after 300 |
||||
file copy $buildfolder/$targetkit $deployment_folder/$targetkit |
||||
# -- ---------- |
||||
$bin_event targetset_end OK |
||||
# -- ---------- |
||||
} else { |
||||
$bin_event targetset_end FAILED -note "could not delete" |
||||
exit 5 |
||||
} |
||||
$bin_event destroy |
||||
$bin_installer destroy |
||||
|
||||
} else { |
||||
set skipped_vfs_build 1 |
||||
puts stderr "." |
||||
puts stdout "Skipping build for vfs $vfs with runtime $rtname - no change detected" |
||||
$vfs_event targetset_end SKIPPED |
||||
} |
||||
$vfs_event destroy |
||||
$vfs_installer destroy |
||||
} ;#end foreach rtname in runtimes |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
} |
||||
cd $startdir |
||||
|
||||
puts stdout "done" |
||||
exit 0 |
||||
|
||||
|
||||
@ -0,0 +1,52 @@
|
||||
# -*- 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) %year% |
||||
# |
||||
# @@ Meta Begin |
||||
# Application %pkg% 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license %license% |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval %pkg% { |
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide %pkg% [namespace eval %pkg% { |
||||
variable pkg %pkg% |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,51 @@
|
||||
# -*- tcl -*- |
||||
# |
||||
# 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) %year% |
||||
# |
||||
# @@ Meta Begin |
||||
# Application %pkg% %version% |
||||
# Meta platform tcl |
||||
# Meta license %license% |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval %pkg% { |
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide %pkg% [namespace eval %pkg% { |
||||
variable pkg %pkg% |
||||
variable version |
||||
set version %version% |
||||
}] |
||||
return |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,218 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::cap 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta description pkg capability register |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::cap { |
||||
variable pkgcap [dict create] |
||||
variable caps [dict create] |
||||
proc register_package {pkg capabilitylist} { |
||||
variable pkgcap |
||||
variable caps |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
#for each capability |
||||
# - ensure 1st element is a single word |
||||
# - ensure that if 2nd element (capdict) is present - it is dict shaped |
||||
foreach c $capabilitylist { |
||||
lassign $c capname capdict |
||||
if {[llength $capname] !=1} { |
||||
error "register_package error. pkg: '$pkg' An entry in the capability list doesn't appear to have a single-word name. Problematic entry:'$c'" |
||||
} |
||||
if {[expr {[llength $capdict] %2 != 0}]} { |
||||
error "register_package error. pkg:'$pkg' The second element for capname:'$capname' doesn't appear to be a valid dict. Problematic entry: '$c'" |
||||
} |
||||
if {[dict exists $caps $capname]} { |
||||
set cap_pkgs [dict get $caps $capname] |
||||
} else { |
||||
set cap_pkgs [list] |
||||
} |
||||
if {$pkg ni $cap_pkgs} { |
||||
dict lappend caps $capname $pkg |
||||
} |
||||
} |
||||
dict set pkgcap $pkg $capabilitylist |
||||
} |
||||
proc promote_package {pkg} { |
||||
variable pkgcap |
||||
variable caps |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
if {![dict exists $pkgcap $pkg]} { |
||||
error "punk::cap::promote_package error pkg'$pkg' not registered. Use register_package \$pkg first" |
||||
} |
||||
if {[dict size $pkgcap] > 1} { |
||||
set pkginfo [dict get $pkgcap $pkg] |
||||
#remove and re-add at end of dict |
||||
dict unset pkgcap $pkg |
||||
dict set pkgcap $pkg $pkginfo |
||||
foreach {cap cap_pkgs} $caps { |
||||
if {$pkg in $cap_pkgs} { |
||||
set posn [lsearch $cap_pkgs $pkg] |
||||
if {$posn >=0} { |
||||
#rewrite package list with pkg at tail of list for this capability |
||||
set cap_pkgs [lreplace $cap_pkgs $posn $posn] |
||||
lappend cap_pkgs $pkg |
||||
dict set caps $cap $cap_pkgs |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
proc demote_package {pkg} { |
||||
variable pkgcap |
||||
variable caps |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
if {![dict exists $pkgcap $pkg]} { |
||||
error "punk::cap::promote_package error pkg'$pkg' not registered. Use register_package \$pkg first" |
||||
} |
||||
if {[dict size $pkgcap] > 1} { |
||||
set pkginfo [dict get $pkgcap $pkg] |
||||
#remove and re-add at start of dict |
||||
dict unset pkgcap $pkg |
||||
dict set pkgcap $pkg $pkginfo |
||||
set pkgcap [dict merge [dict create $pkg $pkginfo] $pkgcap] |
||||
foreach {cap cap_pkgs} $caps { |
||||
if {$pkg in $cap_pkgs} { |
||||
set posn [lsearch $cap_pkgs $pkg] |
||||
if {$posn >=0} { |
||||
#rewrite package list with pkg at head of list for this capability |
||||
set cap_pkgs [lreplace $cap_pkgs $posn $posn] |
||||
set cap_pkgs [list $pkg {*}$cap_pkgs] |
||||
dict set caps $cap $cap_pkgs |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
proc unregister_package {pkg} { |
||||
variable pkgcap |
||||
variable caps |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
if {[dict exists $pkgcap $pkg]} { |
||||
#remove corresponding entries in caps |
||||
set capabilitylist [dict get $pkgcap $pkg] |
||||
foreach c $capabilitylist { |
||||
lassign $c capname _capdict |
||||
set pkglist [dict get $caps $capname] |
||||
set posn [lsearch $pkglist $pkg] |
||||
if {$posn >= 0} { |
||||
set pkglist [lreplace $pkglist $posn $posn] |
||||
dict set caps $capname $pkglist |
||||
} |
||||
} |
||||
#delete the main registration record |
||||
dict unset pkgcap $pkg |
||||
} |
||||
} |
||||
proc registered_package {pkg} { |
||||
variable pkgcap |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
if {[dict exists $pkgcap $pkg]} { |
||||
return [dict get $pkgcap $pkg] |
||||
} else { |
||||
return |
||||
} |
||||
} |
||||
proc registered_packages {} { |
||||
variable pkgcap |
||||
return $pkgcap |
||||
} |
||||
|
||||
proc capabilities {{glob *}} { |
||||
variable caps |
||||
set keys [lsort [dict keys $caps $glob]] |
||||
set cap_list [list] |
||||
foreach k $keys { |
||||
lappend cap_list [list $k [dict get $caps $k]] |
||||
} |
||||
return $cap_list |
||||
} |
||||
|
||||
namespace eval templates { |
||||
#return a dict keyed on folder with source pkg as value |
||||
proc folders {} { |
||||
package require punk::cap |
||||
set caplist [punk::cap::capabilities templates] |
||||
# e.g {templates {punk::mix::templates ::somepkg}} |
||||
set templates_record [lindex $caplist 0] |
||||
set pkgs [lindex $templates_record 1] |
||||
|
||||
set folderdict [dict create] |
||||
foreach pkg $pkgs { |
||||
set caplist [punk::cap::registered_package $pkg] |
||||
set templates_entries [lsearch -all -inline -index 0 $caplist templates] ;#we generally expect only one - but if multiple exist - use them |
||||
foreach templates_info $templates_entries { |
||||
lassign $templates_info _templates templates_dict |
||||
if {[dict exists $templates_dict relpath]} { |
||||
set provide_statement [package ifneeded $pkg [package require $pkg]] |
||||
set tmfile [lindex $provide_statement end] |
||||
#set tmdir [file dirname [lindex $provide_statement end]] |
||||
set tpath [file normalize [file join $tmfile [dict get $templates_dict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder |
||||
#relpath relative to file is important for tm files that are zip/tar based containers |
||||
if {[file isdirectory $tpath]} { |
||||
dict set folderdict $tpath [list source $pkg sourcetype package] |
||||
} else { |
||||
puts stderr "punk::cap::templates::folders WARNING - unable to determine base folder for package '$pkg' which is registered with punk::mix as a provider of 'templates' capability" |
||||
} |
||||
} else { |
||||
puts stderr "punk::cap::templates::folders WARNING - registered pkg 'pkg' has capability 'templates' but no 'relpath' key - unable to use as source of templates" |
||||
} |
||||
} |
||||
} |
||||
return $folderdict |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::cap [namespace eval punk::cap { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,904 @@
|
||||
package provide punk::mix::base [namespace eval punk::mix::base { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
||||
|
||||
#base internal plumbing functions |
||||
namespace eval punk::mix::base { |
||||
proc set_alias {cmdname args} { |
||||
#--------- |
||||
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||
lassign [_split_args $args] _opts opts _args args |
||||
if {[dict exists $opts -extension]} { |
||||
set extension [dict get $opts -extension] |
||||
} else { |
||||
set extension "" |
||||
} |
||||
#--------- |
||||
|
||||
uplevel #0 [list interp alias {} $cmdname {} punk::mix::base::_cli -extension $extension] |
||||
} |
||||
proc _cli {args} { |
||||
#--------- |
||||
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||
lassign [_split_args $args] _opts opts _args args |
||||
if {[dict exists $opts -extension]} { |
||||
set extension [dict get $opts -extension] |
||||
} else { |
||||
set extension "" |
||||
} |
||||
#--------- |
||||
if {![string length $extension]} { |
||||
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||
} |
||||
#puts stderr "punk::mix::base extension: [string trimleft $extension :]" |
||||
if {![string length $extension]} { |
||||
#if still no extension - must have been called dirctly as punk::mix::base::_cli |
||||
if {![llength $args]} { |
||||
set args "help" |
||||
} |
||||
set extension [namespace current] |
||||
} |
||||
if {![llength $args]} { |
||||
if {[info exists ${extension}::default_command]} { |
||||
tailcall $extension [set ${extension}::default_command] |
||||
} |
||||
tailcall $extension |
||||
} else { |
||||
tailcall $extension {*}$args |
||||
} |
||||
} |
||||
proc _unknown {ns args} { |
||||
#--------- |
||||
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||
lassign [_split_args $args] _opts opts _args args |
||||
if {[dict exists $opts -extension]} { |
||||
set extension [dict get $opts -extension] |
||||
} else { |
||||
set extension "" |
||||
} |
||||
#--------- |
||||
|
||||
if {![string length $extension]} { |
||||
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||
} |
||||
#puts stderr "arglen:[llength $args]" |
||||
#puts stdout "_unknown '$ns' '$args'" |
||||
|
||||
set d_commands [get_commands -extension $extension] |
||||
set all_commands [list {*}[dict get $d_commands main] {*}[dict get $d_commands base]] |
||||
error "Unknown subcommand \"[lindex $args 0]\": must be one of: $all_commands" "punk::mix::base _unknown $ns $args" [list unknown_ensemble_subcommand ensemble punk::mix::base] |
||||
} |
||||
proc _redirected {from_ns subcommand args} { |
||||
#puts stderr "_redirected from_ns: $from_ns subcommand:$subcommand args:$args" |
||||
set pname [namespace current]::$subcommand |
||||
if {$pname in [info procs $pname]} { |
||||
set argnames [info args $pname] |
||||
#puts stderr "_redirected $subcommand argnames: $argnames" |
||||
if {[lindex $argnames end] eq "args"} { |
||||
set pos_argnames [lrange $argnames 0 end-1] |
||||
} else { |
||||
set pos_argnames $argnames |
||||
} |
||||
set argvals [list] |
||||
set numargs [llength $pos_argnames] |
||||
if {$numargs > 0} { |
||||
set argvals [lrange $args 0 $numargs-1] |
||||
set args [lrange $args $numargs end] |
||||
} |
||||
if {[llength $argvals] < $numargs} { |
||||
error "wrong # args: $from_ns $subcommand requires args: $pos_argnames" |
||||
} |
||||
tailcall [namespace current] $subcommand {*}$argvals {*}$args -extension $from_ns |
||||
} else { |
||||
tailcall [namespace current] $subcommand {*}$args -extension $from_ns |
||||
} |
||||
} |
||||
proc _split_args {arglist} { |
||||
#don't assume arglist is fully paired. |
||||
set posn [lsearch $arglist -extension] |
||||
set opts [list] |
||||
if {$posn >= 0} { |
||||
if {$posn+2 <= [llength $arglist]} { |
||||
set opts [list -extension [lindex $arglist $posn+1]] |
||||
set argsremaining [lreplace $arglist $posn $posn+1] |
||||
} else { |
||||
#no value supplied to -extension |
||||
error "punk::mix::base::_split_args - no value found for option '-extension'. Supply a value or omit the option." |
||||
} |
||||
} else { |
||||
set argsremaining $arglist |
||||
} |
||||
|
||||
return [list opts $opts args $argsremaining] |
||||
} |
||||
} |
||||
|
||||
|
||||
#base API (potentially overridden functions - may also be called from overriding namespace) |
||||
#commands should either handle or silently ignore -extension <namespace/ensemble> |
||||
namespace eval punk::mix::base { |
||||
namespace ensemble create |
||||
namespace export help dostuff get_commands set_alias |
||||
namespace ensemble configure [namespace current] -unknown punk::mix::base::_unknown |
||||
proc get_commands {args} { |
||||
#--------- |
||||
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||
lassign [_split_args $args] _opts opts _args args |
||||
if {[dict exists $opts -extension]} { |
||||
set extension [dict get $opts -extension] |
||||
} else { |
||||
set extension "" |
||||
} |
||||
#--------- |
||||
if {![string length $extension]} { |
||||
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||
} |
||||
|
||||
set maincommands [list] |
||||
#extension may still be blank e.g if punk::mix::base::get_commands called directly |
||||
if {[string length $extension]} { |
||||
set nsmain $extension |
||||
#puts stdout "get_commands nsmain: $nsmain" |
||||
set parentpatterns [namespace eval $nsmain [list namespace export]] |
||||
set nscommands [list] |
||||
foreach p $parentpatterns { |
||||
lappend nscommands {*}[info commands ${nsmain}::$p] |
||||
} |
||||
foreach c $nscommands { |
||||
set cmd [namespace tail $c] |
||||
lappend maincommands $cmd |
||||
} |
||||
set maincommands [lsort $maincommands] |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
set nsbase [namespace current] |
||||
set basepatterns [namespace export] |
||||
#puts stdout "basepatterns:$basepatterns" |
||||
set nscommands [list] |
||||
foreach p $basepatterns { |
||||
lappend nscommands {*}[info commands ${nsbase}::$p] |
||||
} |
||||
|
||||
set basecommands [list] |
||||
foreach c $nscommands { |
||||
set cmd [namespace tail $c] |
||||
if {$cmd ni $maincommands} { |
||||
lappend basecommands $cmd |
||||
} |
||||
} |
||||
set basecommands [lsort $basecommands] |
||||
|
||||
|
||||
return [list main $maincommands base $basecommands] |
||||
} |
||||
proc help {args} { |
||||
#' **%ensemblecommand% help** *args* |
||||
#' |
||||
#' Help for ensemble commands in the command line interface |
||||
#' |
||||
#' |
||||
#' Arguments: |
||||
#' |
||||
#' * args - first word of args is the helptopic requested - usually a command name |
||||
#' - calling help with no arguments will list available commands |
||||
#' |
||||
#' Returns: help text (text) |
||||
#' |
||||
#' Examples: |
||||
#' |
||||
#' ``` |
||||
#' %ensemblecommand% help <commandname> |
||||
#' ``` |
||||
#' |
||||
#' |
||||
|
||||
|
||||
#extension.= @@opts/@?@-extension,args@@args=>. [_split_args $args] {| |
||||
# >} inspect -label a {| |
||||
# >} .=e>end,data>end pipeswitch { |
||||
# pipecase ,0/1/#= $switchargs {| |
||||
# e/0 |
||||
# >} .=>. {set e} |
||||
# pipecase /1,1/1/#= $switchargs |
||||
#} |@@ok/result> <e/0| [namespace qualifiers [lindex [info level -1] 0]] |
||||
|
||||
|
||||
#--------- |
||||
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||
lassign [_split_args $args] _opts opts _args args |
||||
if {[dict exists $opts -extension]} { |
||||
set extension [dict get $opts -extension] |
||||
} else { |
||||
set extension "" |
||||
} |
||||
#--------- |
||||
|
||||
|
||||
|
||||
if {![string length $extension]} { |
||||
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||
} |
||||
#puts stderr "-1:[info level -1]" |
||||
|
||||
set command_info [punk::mix::base::get_commands -extension $extension] |
||||
set subhelp1 [lindex $args 0] |
||||
if {[string length $subhelp1]} { |
||||
if {[regexp {[*?]} $subhelp1]} { |
||||
set helpstr "" |
||||
append helpstr "matched commands:\n" |
||||
dict for {source cmdlist} $command_info { |
||||
set matches [lsearch -all -inline -glob $cmdlist $subhelp1] |
||||
if {[llength $matches]} { |
||||
append helpstr \n " $source" |
||||
foreach cmd $matches { |
||||
append helpstr \n " - $cmd" |
||||
} |
||||
} |
||||
} |
||||
return $helpstr |
||||
} else { |
||||
dict for {source cmdlist} $command_info { |
||||
if {$subhelp1 in $cmdlist} { |
||||
if {$source eq "base"} { |
||||
set ns [namespace current] |
||||
} else { |
||||
set ns $extension |
||||
} |
||||
set procname ${ns}::$subhelp1 |
||||
if {$procname in [info procs $procname]} { |
||||
return "proc: $subhelp1 arguments: [info args $procname]" |
||||
} else { |
||||
set a [interp alias {} ${ns}::$subhelp1] |
||||
if {[string length $a]} { |
||||
return "alias: $subhelp1 target: $a" |
||||
} else { |
||||
return "command: $subhelp1 (No info available)" |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
return "No info found" |
||||
} |
||||
|
||||
} |
||||
#result for just 'pmix help' |
||||
set helpstr "" |
||||
append helpstr "commands:\n" |
||||
|
||||
foreach {source cmdlist} $command_info { |
||||
append helpstr \n " $source" |
||||
foreach cmd $cmdlist { |
||||
append helpstr \n " - $cmd" |
||||
} |
||||
} |
||||
return $helpstr |
||||
} |
||||
#proc dostuff {args} { |
||||
# extension@@opts/@?@-extension,args@@args= [_split_args $args] |
||||
# puts stdout "base doingstuff-with-args:'$args'-in-namespace:'[namespace current]'" |
||||
#} |
||||
namespace eval lib { |
||||
variable sha3_implementation "" ;#set by cksum_algorithms (which is called by cksum_path) It looks for fossil or sqlite3. Todo - add proper Tcl implementation. |
||||
namespace export * |
||||
|
||||
#----------------------------------------------------- |
||||
#literate-programming style naming for some path tests |
||||
#Note the naming of the operator portion of a_op_b is consistent in that it is the higher side of the filesystem tree first. |
||||
#hence aboveorat vs atorbelow |
||||
#These names also sort in the logical order of higher to lower in the filesystem (when considering the root as 'higher' in the filesystem) |
||||
proc path_a_above_b {path_a path_b} { |
||||
#stripPath prefix path |
||||
return [expr {[fileutil::stripPath $path_a $path_b] ni [list . $path_b]}] |
||||
} |
||||
proc path_a_aboveorat_b {path_a path_b} { |
||||
return [expr {[fileutil::stripPath $path_a $path_b] ne $path_b}] |
||||
} |
||||
proc path_a_at_b {path_a path_b} { |
||||
return [expr {[fileutil::stripPath $path_a $path_b] eq "." }] |
||||
} |
||||
proc path_a_atorbelow_b {path_a path_b} { |
||||
return [expr {[fileutil::stripPath $path_b $path_a] ne $path_a}] |
||||
} |
||||
proc path_a_below_b {path_a path_b} { |
||||
return [expr {[fileutil::stripPath $path_b $path_a] ni [list . $path_a]}] |
||||
} |
||||
proc path_a_inlinewith_b {path_a path_b} { |
||||
return [expr {[path_a_aboveorat_b $path_a $path_b] || [path_a_below_b $path_a $path_b]}] |
||||
} |
||||
#----------------------------------------------------- |
||||
|
||||
|
||||
|
||||
#find src/something folders which are not certain known folders with other purposes, (such as: bootsupport .vfs folders or vendor folders etc) and contain .tm file(s) |
||||
proc find_source_module_paths {{path {}}} { |
||||
if {![string length [set candidate [punk::repo::find_candidate $path]]]} { |
||||
error "find_source_module_paths cannot determine a suitable project root at or above path '$path' - path supplied should be within a project" |
||||
} |
||||
#we can return module paths even if the project isn't yet under revision control |
||||
set src_subs [glob -nocomplain -dir [file join $candidate src] -type d -tail *] |
||||
set antipatterns [list *.vfs vendor* lib _build doc embedded runtime bootsupport] |
||||
set tm_folders [list] |
||||
foreach sub $src_subs { |
||||
set is_ok 1 |
||||
foreach anti $antipatterns { |
||||
if {[string match $anti $sub]} { |
||||
set is_ok 0 |
||||
break |
||||
} |
||||
} |
||||
if {!$is_ok} { |
||||
continue |
||||
} |
||||
set testfolder [file join $candidate src $sub] |
||||
set tmfiles [glob -nocomplain -dir $testfolder -type f -tail *.tm] |
||||
if {[llength $tmfiles]} { |
||||
lappend tm_folders $testfolder |
||||
} |
||||
} |
||||
return $tm_folders |
||||
} |
||||
|
||||
proc mix_templates_dir {} { |
||||
puts stderr "mix_templates_dir WARNING: deprecated - use get_template_basefolders instead" |
||||
set provide_statement [package ifneeded punk::mix [package require punk::mix]] |
||||
set tmdir [file dirname [lindex $provide_statement end]] |
||||
set tpldir $tmdir/mix/templates |
||||
if {![file exists $tpldir]} { |
||||
error "punk::mix::lib::mix_templates_dir unable to locate mix templates folder at '$tpldir'" |
||||
} |
||||
return $tpldir |
||||
} |
||||
|
||||
#get_template_basefolders |
||||
# scriptpath - file or folder |
||||
# It represents the base point from which to search for mixtemplates folders either directly related to the scriptpath (../) or in the containing project if any |
||||
# The cwd will also be searched for project root - but with lower precedence in the resultset (later in list) |
||||
proc get_template_basefolders {{scriptpath ""}} { |
||||
#1 lowest precedence - templates from packages (ordered by order in which packages registered with punk::cap) |
||||
set folderdict [dict create] |
||||
set template_folder_dict [punk::cap::templates::folders] |
||||
dict for {dir folderinfo} $template_folder_dict { |
||||
dict set folderdict $dir $folderinfo |
||||
} |
||||
|
||||
#2 middle precedence - mixtemplates folder relative to cwd |
||||
set searchbase [pwd] |
||||
set fld [file join $searchbase mixtemplates] |
||||
if {[file isdirectory $fld]} { |
||||
if {![dict exists $folderdict $fld]} { |
||||
dict set folderdict $fld [list source $searchbase sourcetype cwd] |
||||
} |
||||
} |
||||
set pathinfo [punk::repo::find_repos $searchbase] |
||||
set pwd_projectroot [dict get $pathinfo closest] |
||||
if {$pwd_projectroot ne ""} { |
||||
set fld [file join $pwd_projectroot src/mixtemplates] |
||||
if {![dict exists $folderdict $fld]} { |
||||
dict set folderdict $fld [list source $pwd_projectroot sourcetype project] |
||||
} |
||||
} |
||||
|
||||
#3 highest precedence - mixtemplates relative to scriptpath argument |
||||
if {$scriptpath ne ""} { |
||||
if {[file type $scriptpath] eq "file"} { |
||||
set searchbase [file dirname $scriptpath] |
||||
} else { |
||||
set searchbase $scriptpath |
||||
} |
||||
if {[file isdirectory [file join $searchbase mixtemplates]]} { |
||||
dict set folderdict [file join $searchbase mixtemplates] [list source $searchbase sourcetype pathsearch] |
||||
} |
||||
set pathinfo [punk::repo::find_repos $searchbase] |
||||
set scriptpath_projectroot [dict get $pathinfo closest] |
||||
if {$scriptpath_projectroot ne ""} { |
||||
set fld [file join $scriptpath_projectroot src/mixtemplates] |
||||
if {[file isdirectory $fld]} { |
||||
dict set folderdict $fld [list source $scriptpath_projectroot sourcetype project] |
||||
} |
||||
} |
||||
} |
||||
#don't sort - order in which encountered defines the precedence - with later overriding earlier |
||||
return $folderdict |
||||
} |
||||
|
||||
proc module_subpath {modulename} { |
||||
set modulename [string trim $modulename :] |
||||
set nsq [namespace qualifiers $modulename] |
||||
return [string map [list :: /] $nsq] |
||||
} |
||||
|
||||
proc get_build_workdir {path} { |
||||
set repo_info [punk::repo::find_repos $path] |
||||
set base [lindex [dict get $repo_info project] 0] |
||||
if {![string length $base]} { |
||||
error "get_build_workdir unable to determine project base for path '$path'" |
||||
} |
||||
if {![file exists $base/src] || ![file writable $base/src]} { |
||||
error "get_build_workdir unable to access $base/src" |
||||
} |
||||
file mkdir $base/src/_build |
||||
return $base/src/_build |
||||
} |
||||
|
||||
|
||||
|
||||
#todo - move cksum stuff to punkcheck - more logical home |
||||
proc cksum_path_content {path args} { |
||||
dict set args -cksum_content 1 |
||||
dict set args -cksum_meta 0 |
||||
tailcall cksum_path $path {*}$args |
||||
} |
||||
|
||||
#not just used by cksum_path. used by caller (e.g fill_relativecksums_from_base_and_relativepathdict via cksum_filter_opts) to determine what opt names passed through |
||||
proc cksum_default_opts {} { |
||||
return [dict create -cksum_content 1 -cksum_meta auto -cksum_acls 0 -cksum_usetar auto -cksum_algorithm sha1] |
||||
} |
||||
|
||||
#crc::cksum is extremely slow in tcllib as at 2023 e.g 20x slower (no c implementation?) |
||||
#sha1 is performant - and this is not being used in a cryptographic or adversarial context - so performance and practical unlikelihood of accidental collisions should be the main consideration. |
||||
#adler32 is fastest for some larger files of a few MB but slower on small files (possibly due to Tcl-based file load?) |
||||
#sha1 as at 2023 seems a good default |
||||
proc cksum_algorithms {} { |
||||
variable sha3_implementation |
||||
#sha2 is an alias for sha256 |
||||
#2023 - no sha3 available in tcllib - we can exec fossil for now - which will be very slow |
||||
set algs [list md5 sha1 sha2 sha256 cksum adler32] |
||||
set sha3_algs [list sha3 sha3-224 sha3-256 sha3-384 sha3-512] |
||||
if {[auto_execok sqlite3] ne ""} { |
||||
lappend algs {*}$sha3_algs |
||||
set sha3_implementation sqlite3_sha3 |
||||
} else { |
||||
if {[auto_execok fossil] ne ""} { |
||||
lappend algs {*}$sha3_algs |
||||
set sha3_implementation fossil_sha3 |
||||
} |
||||
} |
||||
return $algs |
||||
} |
||||
|
||||
proc sqlite3_sha3 {bits filename} { |
||||
return [exec sqlite3 :memory: "select lower(hex(sha3(readfile('$filename'),$bits)))"] |
||||
} |
||||
proc fossil_sha3 {bits filename} { |
||||
return [lindex [exec fossil sha3sum -$bits $filename] 0] |
||||
} |
||||
|
||||
#adler32 via file-slurp |
||||
proc cksum_adler32_file {filename} { |
||||
package require zlib; #should be builtin anyway |
||||
set data [punk::mix::util::fcat -translation binary $filename] |
||||
#set data [fileutil::cat -translation binary $filename] ;#no significant performance diff on windows - and doesn't handle win-illegal names |
||||
zlib adler32 $data |
||||
} |
||||
|
||||
|
||||
#required to be able to accept relative paths |
||||
#for full cksum - using tar could reduce number of hashes to be made.. |
||||
#but as it stores metadata such as permission - we don't know if/how the archive will vary based on platform/filesystem |
||||
#-noperms only available on extraction - so that doesn't help |
||||
#Needs to operate on non-existant paths and return empty string in cksum field |
||||
proc cksum_path {path args} { |
||||
variable sha3_implementation |
||||
if {$path eq {}} { set path [pwd] } |
||||
if {[file pathtype $path] eq "relative"} { |
||||
set path [file normalize $path] |
||||
} |
||||
set base [file dirname $path] |
||||
set startdir [pwd] |
||||
|
||||
set defaults [cksum_default_opts] |
||||
set known_opts [dict keys $defaults] |
||||
foreach {k v} $args { |
||||
if {$k ni $known_opts} { |
||||
error "cksum_path unknown option '$k' known_options: $known_opts" |
||||
} |
||||
} |
||||
|
||||
set opts [dict merge $defaults $args] |
||||
set opts_actual $opts ;#default - auto updated to 0 or 1 later |
||||
|
||||
#if {![file exists $path]} { |
||||
# return [list cksum "" opts $opts] |
||||
#} |
||||
|
||||
if {[catch {file type $path} ftype]} { |
||||
return [list cksum "<PATHNOTFOUND>" opts $opts] |
||||
} |
||||
if {$ftype ni [list file directory]} { |
||||
#review - links? |
||||
error "cksum_path error file type '$ftype' not supported" |
||||
} |
||||
|
||||
|
||||
set opt_cksum_algorithm [dict get $opts -cksum_algorithm] |
||||
if {$opt_cksum_algorithm ni [cksum_algorithms]} { |
||||
return [list error unsupported_cksum_algorithm cksum "<ERR>" opts $opts] |
||||
} |
||||
set opt_cksum_acls [dict get $opts -cksum_acls] |
||||
if {$opt_cksum_acls} { |
||||
puts stderr "cksum_path is not yet able to cksum ACLs" |
||||
return |
||||
} |
||||
|
||||
set opt_cksum_meta [dict get $opts -cksum_meta] |
||||
set opt_use_tar [dict get $opts -cksum_usetar] |
||||
if {$ftype eq "file"} { |
||||
if {$opt_use_tar eq "auto"} { |
||||
if {$opt_cksum_meta eq "1"} { |
||||
set opt_use_tar 1 |
||||
} else { |
||||
#prefer no tar if meta not required - faster/simpler |
||||
#meta == auto or 0 |
||||
set opt_cksum_meta 0 |
||||
set opt_use_tar 0 |
||||
} |
||||
} elseif {$opt_use_tar eq "0"} { |
||||
if {$opt_cksum_meta eq "1"} { |
||||
puts stderr "cksum_path doesn't yet support a non-tar cksum with metadata for a file" |
||||
return [list error unsupported_meta_without_tar cksum "<ERR>" opts $opts] |
||||
} else { |
||||
#meta == auto or 0 |
||||
set opt_cksum_meta 0 |
||||
} |
||||
} else { |
||||
#tar == 1 |
||||
if {$opt_cksum_meta eq "0"} { |
||||
puts stderr "cksum_path doesn't yet support a tar cksum without metadata for a file" |
||||
return [list error unsupported_tar_without_meta cksum "<ERR>" opts $opts] |
||||
} else { |
||||
#meta == auto or 1 |
||||
set opt_cksum_meta 1 |
||||
} |
||||
} |
||||
} elseif {$ftype eq "directory"} { |
||||
if {$opt_use_tar eq "auto"} { |
||||
if {$opt_cksum_meta in [list "auto" "1"]} { |
||||
set opt_use_tar 1 |
||||
set opt_cksum_meta 1 |
||||
} else { |
||||
puts stderr "cksum_path doesn't yet support a content-only cksum of a folder structure. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto" |
||||
return [list error unsupported_directory_cksum_without_meta cksum "<ERR>" opts $opts] |
||||
} |
||||
} elseif {$opt_use_tar eq "0"} { |
||||
puts stderr "cksum_path doesn't yet support a cksum of a folder structure without tar. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" |
||||
return [list error unsupported_directory_cksum_without_tar cksum "<ERR>" opts $opts] |
||||
} else { |
||||
#tar 1 |
||||
if {$opt_cksum_meta eq "0"} { |
||||
puts stderr "cksum_path doesn't yet support a tar checksum of a folder structure without metadat. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" |
||||
return [list error unsupported_without_meta cksum "<ERR>" opts $opts] |
||||
} else { |
||||
#meta == auto or 1 |
||||
set opt_cksum_meta 1 |
||||
} |
||||
} |
||||
} |
||||
|
||||
dict set opts_actual -cksum_meta $opt_cksum_meta |
||||
dict set opts_actual -cksum_usetar $opt_use_tar |
||||
|
||||
|
||||
if {$opt_use_tar} { |
||||
package require tar ;#from tcllib |
||||
} |
||||
|
||||
if {$path eq $base} { |
||||
#attempting to cksum at root/volume level of a filesystem.. extra work |
||||
#This needs fixing for general use.. not necessarily just for project repos |
||||
puts stderr "cksum_path doesn't yet support cksum of entire volume. (todo)" |
||||
return [list error unsupported_path opts $opts] |
||||
} |
||||
|
||||
if {$opt_cksum_algorithm eq "sha1"} { |
||||
package require sha1 |
||||
set cksum_command [list sha1::sha1 -hex -file] |
||||
} elseif {$opt_cksum_algorithm in [list "sha2" "sha256"]} { |
||||
package require sha256 |
||||
set cksum_command [list sha2::sha256 -hex -file] |
||||
} elseif {$opt_cksum_algorithm eq "md5"} { |
||||
package require md5 |
||||
set cksum_command [list md5::md5 -hex -file] |
||||
} elseif {$opt_cksum_algorithm eq "cksum"} { |
||||
package require cksum ;#tcllib |
||||
set cksum_command [list crc::cksum -format 0x%X -file] |
||||
} elseif {$opt_cksum_algorithm eq "adler32"} { |
||||
set cksum_command [list cksum_adler32_file] |
||||
} elseif {$opt_cksum_algorithm in [list "sha3" "sha3-256"]} { |
||||
#todo - replace with something that doesn't call another process |
||||
#set cksum_command [list apply {{file} {lindex [exec fossil sha3sum -256 $file] 0}}] |
||||
set cksum_command [list $sha3_implementation 256] |
||||
} elseif {$opt_cksum_algorithm in [list "sha3-224" "sha3-384" "sha3-512"]} { |
||||
set bits [lindex [split $opt_cksum_algorithm -] 1] |
||||
#set cksum_command [list apply {{bits file} {lindex [exec fossil sha3sum -$bits $file] 0}} $bits] |
||||
set cksum_command [list $sha3_implementation $bits] |
||||
} |
||||
|
||||
set cksum "" |
||||
if {$opt_use_tar != 0} { |
||||
set target [file tail $path] |
||||
set tmplocation [punk::mix::util::tmpdir] |
||||
set archivename $tmplocation/[punk::mix::util::tmpfile].tar |
||||
|
||||
cd $base ;#cd is process-wide.. keep cd in effect for as small a scope as possible. (review for thread issues) |
||||
|
||||
#temp emission to stdout.. todo - repl telemetry channel |
||||
puts stdout "cksum_path: creating temporary tar archive at: $archivename .." |
||||
tar::create $archivename $target |
||||
if {$ftype eq "file"} { |
||||
set sizeinfo "(size [file size $target])" |
||||
} else { |
||||
set sizeinfo "(file type $ftype - size unknown)" |
||||
} |
||||
puts stdout "cksum_path: calculating cksum for $target $sizeinfo..." |
||||
set cksum [{*}$cksum_command $archivename] |
||||
#puts stdout "cksum_path: cleaning up.. " |
||||
file delete -force $archivename |
||||
cd $startdir |
||||
|
||||
} else { |
||||
#todo |
||||
if {$ftype eq "file"} { |
||||
if {$opt_cksum_meta} { |
||||
return [list error unsupported_opts_combo cksum "<ERR>" opts $opts] |
||||
} else { |
||||
set cksum [{*}$cksum_command $path] |
||||
} |
||||
} else { |
||||
error "cksum_path unsupported $opts for path type [file type $path]" |
||||
} |
||||
} |
||||
set result [dict create] |
||||
dict set result cksum $cksum |
||||
dict set result opts $opts_actual |
||||
return $result |
||||
} |
||||
|
||||
#dict_path_cksum keyed on path - with value as a dict that must contain cksum key - but can contain other keys |
||||
#e.g -cksum_usetar which is one of the keys understood by the punk::mix::base::lib::cksum_path function - or unrelated keys which will also be passed through |
||||
#cksum only calculated for keys in dict where cksum is empty - ie return same dict but with empty cksums filled out. |
||||
#base can be empty string in which case paths must be absolute |
||||
proc fill_relativecksums_from_base_and_relativepathdict {base {dict_path_cksum {}}} { |
||||
if {$base eq ""} { |
||||
set error_paths [list] |
||||
dict for {path pathinfo} $dict_path_cksum { |
||||
if {[file pathtype $path] ne "absolute"} { |
||||
lappend error_paths $path |
||||
} |
||||
} |
||||
if {[llength $error_paths]} { |
||||
puts stderr "get_relativecksums_from_base_and_relativepathdict has empty base - and non-absolute paths in the supplied checksum dict - aborting" |
||||
puts stderr "error_paths: $error_paths" |
||||
error "fill_relativecksums_from_base_and_relativepathdict error: non-absolute paths when base empty. $error_paths" |
||||
} |
||||
} else { |
||||
if {[file pathtype $base] ne "absolute"} { |
||||
error "fill_relativecksums_from_base_and_relativepathdict error: base supplied but was not absolute path. $base" |
||||
} |
||||
#conversely now we have a base - so we require all paths are relative. |
||||
#We will ignore/disallow volume-relative - as these shouldn't be used here either |
||||
set error_paths [list] |
||||
dict for {path pathinfo} $dict_path_cksum { |
||||
if {[file pathtype $path] ne "relative"} { |
||||
lappend error_paths $path |
||||
} |
||||
} |
||||
if {[llength $error_paths]} { |
||||
puts stderr "fill_relativecksums_from_base_and_relativepathdict has a supplied absolute base path, but some of the paths in the supplied dict are not relative - aborting" |
||||
error "fill_relativecksums_from_base_and_relativepathdict error: non-relative paths when base supplied. $error_paths" |
||||
} |
||||
} |
||||
|
||||
|
||||
dict for {path pathinfo} $dict_path_cksum { |
||||
if {![dict exists $pathinfo cksum]} { |
||||
dict set pathinfo cksum "" |
||||
} else { |
||||
if {[dict get $pathinfo cksum] ne "" && ![cksum_is_tag [dict get $pathinfo cksum]]} { |
||||
continue ;#already filled with non-tag value |
||||
} |
||||
} |
||||
if {$base ne ""} { |
||||
set fullpath [file join $base $path] |
||||
} else { |
||||
set fullpath $path |
||||
} |
||||
|
||||
set ckopts [cksum_filter_opts {*}$pathinfo] |
||||
|
||||
if {![file exists $fullpath]} { |
||||
dict set dict_path_cksum $path cksum "<PATHNOTFOUND>" |
||||
} else { |
||||
set ckinfo [cksum_path $fullpath {*}$ckopts] |
||||
dict set dict_path_cksum $path cksum [dict get $ckinfo cksum] |
||||
dict set dict_path_cksum $path cksum_all_opts [dict get $ckinfo opts] |
||||
if {[dict exists $ckinfo error]} { |
||||
dict set dict_path_cksum $path cksum_error [dict get $ckinfo error] |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $dict_path_cksum |
||||
} |
||||
#whether cksum is <XXX> e.g <ERR> <PATHNOTFOUND> |
||||
proc cksum_is_tag {cksum} { |
||||
expr {[string index $cksum 0] eq "<" && [string index $cksum end] eq ">"} |
||||
} |
||||
proc cksum_filter_opts {args} { |
||||
set ck_opt_names [dict keys [cksum_default_opts]] |
||||
set ck_opts [dict create] |
||||
dict for {k v} $args { |
||||
if {$k in $ck_opt_names} { |
||||
dict set ck_opts $k $v |
||||
} |
||||
} |
||||
return $ck_opts |
||||
} |
||||
|
||||
#convenience so caller doesn't have to pre-calculate the relative path from the base |
||||
#Note semantic difference from fill_relativecksums_from_base_and_relativepathdict (hence get_ vs fill_) |
||||
#Here we will raise an error if cksum exists and is not empty or a tag - whereas the multiple path version will ignore valid-looking prefilled cksum values |
||||
#base is the presumed location to store the checksum file. The caller should retain (normalize if relative) |
||||
proc get_relativecksum_from_base {base specifiedpath args} { |
||||
if {$base ne ""} { |
||||
#targetpath ideally should be within same project tree as base if base supplied - but not necessarily below it |
||||
#we don't necessarily want to restrict this to use in punk projects though - so we'll allow anything with a common prefix |
||||
if {[file pathtype $specifiedpath] eq "relative"} { |
||||
if {[file pathtype $base] eq "relative"} { |
||||
set normbase [file normalize $base] |
||||
set normtarg [file normalize [file join $normbase $specifiedpath]] |
||||
set targetpath $normtarg |
||||
set storedpath [punk::mix::util::path_relative $normbase $normtarg] |
||||
} else { |
||||
set targetpath [file join $base $specifiedpath] |
||||
set storedpath $specifiedpath |
||||
} |
||||
} else { |
||||
#specifed absolute |
||||
if {[file pathtype $base] eq "relative"} { |
||||
#relative to cwd or to specifiedpath? For consistency it should arguably be cwd but a case could be made that when one path is relative it is in reference to the other |
||||
#there is a strong possibility that allowing this combination will cause confusion - better to disallow |
||||
error "get_relativecksum_from_base error: disallowed pathtype combination. Base must be empty or absolute when specified path is absolute" |
||||
} |
||||
#both absolute - compute relative path if they share a common prefix |
||||
set commonprefix [punk::mix::util::path_common_prefix $base $specifiedpath] |
||||
if {$commonprefix eq ""} { |
||||
#absolute base with no shared prefix doesn't make sense - we could ignore it - but better to error-out and require the caller specify an empty base |
||||
error "get_relativecksum_from_base error: base '$base' and specifiedpath '$specifiedpath' don't share a common root. Use empty-string for base if independent absolute path is required" |
||||
} |
||||
set targetpath $specifiedpath |
||||
set storedpath [punk::mix::util::path_relative $base $specifiedpath] |
||||
|
||||
} |
||||
} else { |
||||
if {[file type $specifiedpath] eq "relative"} { |
||||
#if specifiedpath is relative - and we don't have a base, we now need to convert relative to cwd to an absolute path for storage |
||||
set targetpath [file normalize $specifiedpath] |
||||
set storedpath $targetpath |
||||
} else { |
||||
set targetpath $specifiedpath |
||||
set storedpath $targetpath |
||||
} |
||||
} |
||||
|
||||
# |
||||
#NOTE: specifiedpath can be a relative path (to cwd) when base is empty |
||||
#OR - a relative path when base itself is relative e.g base: somewhere targetpath somewhere/etc |
||||
#possibly also: base: somewhere targetpath: ../elsewhere/etc |
||||
# |
||||
#todo - write tests |
||||
|
||||
|
||||
if {([llength $args] % 2) != 0} { |
||||
error "get_relativecksum_from_base error. args supplied must be in the form of key-value pairs. received '$args' " |
||||
} |
||||
if {[dict exists $args cksum]} { |
||||
if {[dict get $args cksum] ne "" && ![cksum_is_tag [dict get $args cksum]]} { |
||||
error "get_relativecksum_from_base called with existing cksum value (and is not a tag or empty-value to be replaced) cksum: [dict get $args cksum] Set cksum to be empty, any tag such as <REPLACE> or remove the key and try again." |
||||
} |
||||
} |
||||
|
||||
|
||||
set ckopts [cksum_filter_opts {*}$args] |
||||
set ckinfo [cksum_path $targetpath {*}$ckopts] |
||||
|
||||
set keyvals $args |
||||
dict set keyvals cksum [dict get $ckinfo cksum] |
||||
dict set keyvals cksum_all_opts [dict get $ckinfo opts] |
||||
if {[dict exists $ckinfo error]} { |
||||
dict set keyvals cksum_error [dict get $ckinfo error] |
||||
} |
||||
|
||||
#set relpath [punk::repo::path_strip_alreadynormalized_prefixdepth $fullpath $base] ;#empty base ok noop |
||||
#storedpath is relative if possible |
||||
return [dict create $storedpath $keyvals] |
||||
} |
||||
|
||||
#calculate the runtime checksum and vfs checksums |
||||
proc get_all_vfs_build_cksums {path} { |
||||
set buildfolder [get_build_workdir $path] |
||||
set cksum_base_folder [file dirname $buildfolder] ;#this is the <project>/src folder - a reasonable base for our vfs cksums |
||||
set dict_cksums [dict create] |
||||
|
||||
set buildrelpath [punk::repo::path_strip_alreadynormalized_prefixdepth $buildfolder $cksum_base_folder] |
||||
set vfs_tail_list [glob -nocomplain -dir $cksum_base_folder -type d -tails *.vfs] |
||||
|
||||
foreach vfstail $vfs_tail_list { |
||||
set vname [file rootname $vfstail] |
||||
dict set dict_cksums $vfstail [list cksum ""] |
||||
dict set dict_cksums [file join $buildrelpath $vname.exe] [list cksum ""] |
||||
} |
||||
|
||||
set fullpath_buildruntime $buildfolder/buildruntime.exe |
||||
|
||||
set ckinfo_buildruntime [cksum_path $fullpath_buildruntime] |
||||
set ck [dict get $ckinfo_buildruntime cksum] |
||||
|
||||
|
||||
set relpath [file join $buildrelpath "buildruntime.exe"] |
||||
dict set dict_cksums $relpath [list cksum $ck] |
||||
|
||||
set dict_cksums [fill_relativecksums_from_base_and_relativepathdict $cksum_base_folder $dict_cksums] |
||||
|
||||
return $dict_cksums |
||||
} |
||||
|
||||
proc get_vfs_build_cksums_stored {vfsfolder} { |
||||
set vfscontainer [file dirname $vfsfolder] |
||||
set buildfolder $vfscontainer/_build |
||||
set vfs [file tail $vfsfolder] |
||||
set vname [file rootname $vfs] |
||||
set dict_vfs [list $vname.vfs "" $vname.exe "" buildruntime.exe ""] |
||||
set ckfile $buildfolder/$vname.cksums |
||||
if {[file exists $ckfile]} { |
||||
set data [punk::mix::util::fcat -translation binary $ckfile] |
||||
foreach ln [split $data \n] { |
||||
if {[string trim $ln] eq ""} {continue} |
||||
lassign $ln path cksum |
||||
dict set dict_vfs $path $cksum |
||||
} |
||||
} |
||||
return $dict_vfs |
||||
} |
||||
proc get_all_build_cksums_stored {path} { |
||||
set buildfolder [get_build_workdir $path] |
||||
|
||||
set vfscontainer [file dirname $buildfolder] |
||||
set vfslist [glob -nocomplain -dir $vfscontainer -type d -tail *.vfs] |
||||
set dict_cksums [dict create] |
||||
foreach vfs $vfslist { |
||||
set vname [file rootname $vfs] |
||||
set dict_vfs [get_vfs_build_cksums_stored $vfscontainer/$vfs] |
||||
|
||||
dict set dict_cksums $vname $dict_vfs |
||||
} |
||||
return $dict_cksums |
||||
} |
||||
|
||||
proc store_vfs_build_cksums {vfsfolder} { |
||||
if {![file isdirectory $vfsfolder]} { |
||||
error "Unable to find supplied vfsfolder: $vfsfolder" |
||||
} |
||||
set vfscontainer [file dirname $vfsfolder] |
||||
set buildfolder $vfscontainer/_build |
||||
set dict_vfs [get_vfs_build_cksums $vfsfolder] |
||||
set data "" |
||||
dict for {path cksum} $dict_vfs { |
||||
append data "$path $cksum" \n |
||||
} |
||||
set fd [open $buildfolder/$vname.cksums w] |
||||
chan configure $fd -translation binary |
||||
puts $fd $data |
||||
close $fd |
||||
return $dict_vfs |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
} |
||||
@ -0,0 +1,909 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::cli 0.3 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
package require punk::repo |
||||
package require punkcheck ;#checksum and/or timestamp records |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
namespace eval punk::mix::cli { |
||||
namespace eval temp_import { |
||||
} |
||||
namespace ensemble create |
||||
|
||||
package require punk::overlay |
||||
catch { |
||||
punk::overlay::import_commandset module . ::punk::mix::commandset::module |
||||
} |
||||
punk::overlay::import_commandset debug . ::punk::mix::commandset::debug |
||||
punk::overlay::import_commandset repo . ::punk::mix::commandset::repo |
||||
punk::overlay::import_commandset lib . ::punk::mix::commandset::loadedlib |
||||
|
||||
catch { |
||||
package require punk::mix::commandset::project |
||||
punk::overlay::import_commandset project . ::punk::mix::commandset::project |
||||
punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection |
||||
} |
||||
if {[catch { |
||||
package require punk::mix::commandset::layout |
||||
punk::overlay::import_commandset project.layout . ::punk::mix::commandset::layout |
||||
punk::overlay::import_commandset project.layouts . ::punk::mix::commandset::layout::collection |
||||
} errM]} { |
||||
puts stderr "error loading punk::mix::commandset::layout" |
||||
puts stderr $errM |
||||
} |
||||
if {[catch { |
||||
package require punk::mix::commandset::buildsuite |
||||
punk::overlay::import_commandset buildsuite . ::punk::mix::commandset::buildsuite |
||||
punk::overlay::import_commandset buildsuites . ::punk::mix::commandset::buildsuite::collection |
||||
} errM]} { |
||||
puts stderr "error loading punk::mix::commandset::buildsuite" |
||||
puts stderr $errM |
||||
} |
||||
punk::overlay::import_commandset scriptwrap . ::punk::mix::commandset::scriptwrap |
||||
if {[catch { |
||||
package require punk::mix::commandset::doc |
||||
punk::overlay::import_commandset doc . ::punk::mix::commandset::doc |
||||
punk::overlay::import_commandset "" "" ::punk::mix::commandset::doc::collection |
||||
} errM]} { |
||||
puts stderr "error loading punk::mix::commandset::doc" |
||||
puts stderr $errM |
||||
} |
||||
|
||||
|
||||
proc help {args} { |
||||
#set basehelp [punk::mix::base::help -extension [namespace current] {*}$args] |
||||
set basehelp [punk::mix::base help {*}$args] |
||||
#puts stdout "punk::mix help" |
||||
return $basehelp |
||||
} |
||||
|
||||
proc stat {{workingdir ""} args} { |
||||
dict set args -v 0 |
||||
punk::mix::cli::lib::get_status $workingdir {*}$args |
||||
} |
||||
proc status {{workingdir ""} args} { |
||||
dict set args -v 1 |
||||
punk::mix::cli::lib::get_status $workingdir {*}$args |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
namespace eval punk::mix::cli { |
||||
|
||||
|
||||
#interp alias {} ::punk::mix::cli::project.new {} ::punk::mix::cli::new |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
proc make {args} { |
||||
set startdir [pwd] |
||||
set project_base "" ;#empty for unknown |
||||
if {[punk::repo::is_git $startdir]} { |
||||
set project_base [punk::repo::find_git] |
||||
set sourcefolder $project_base/src |
||||
} elseif {[punk::repo::is_fossil $startdir]} { |
||||
set project_base [punk::repo::find_fossil] |
||||
set sourcefolder $project_base/src |
||||
} else { |
||||
if {[punk::repo::is_candidate $startdir]} { |
||||
set project_base [punk::repo::find_candidate] |
||||
set sourcefolder $project_base/src |
||||
puts stderr "WARNING - project not under git or fossil control" |
||||
puts stderr "Using base folder $project_base" |
||||
} else { |
||||
set sourcefolder $startdir |
||||
} |
||||
} |
||||
|
||||
#review - why can't we be anywhere in the project? |
||||
if {([file tail $sourcefolder] ne "src") || (![file exists $sourcefolder/make.tcl])} { |
||||
puts stderr "pmix make must be run from src folder containing make.tcl - unable to proceed (cwd: [pwd])" |
||||
if {[string length $project_base]} { |
||||
if {[file exists $project_base/src] && [string tolower [pwd]] ne [string tolower $project_base/src]} { |
||||
puts stderr "Try cd to $project_base/src" |
||||
} |
||||
} else { |
||||
if {[file exists $startdir/Makefile]} { |
||||
puts stdout "A Makefile exists at $startdir/Makefile." |
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
puts stdout "Try running: msys2 -ucrt64 -here -c \"make build\" or bash -c \"make build\"" |
||||
} else { |
||||
puts stdout "Try runing: make build" |
||||
} |
||||
} |
||||
} |
||||
return false |
||||
} |
||||
|
||||
if {![string length $project_base]} { |
||||
puts stderr "WARNING no git or fossil repository detected." |
||||
puts stderr "Using base folder $startdir" |
||||
set project_base $startdir |
||||
} |
||||
|
||||
set lc_this_exe [string tolower [info nameofexecutable]] |
||||
set lc_proj_bin [string tolower $project_base/bin] |
||||
set lc_build_bin [string tolower $project_base/src/_build] |
||||
|
||||
if {"project" in $args} { |
||||
set is_own_exe 0 |
||||
if {[string match "${lc_proj_bin}*" $lc_this_exe] || [string match "${lc_build_bin}" $lc_this_exe]} { |
||||
set is_own_exe 1 |
||||
puts stderr "WARNING - running make using executable that may be created by the project being built" |
||||
set answer [util::askuser "Do you want to proceed using this executable? (build will probably stop when it is unable to update the executable) Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
} |
||||
cd $sourcefolder |
||||
#use run so that stdout visible as it goes |
||||
if {![catch {run --timeout=5000 -debug [info nameofexecutable] $sourcefolder/make.tcl {*}$args} exitinfo]} { |
||||
puts stderr "exitinfo: $exitinfo" |
||||
set exitcode [dict get $exitinfo exitcode] |
||||
} else { |
||||
puts stderr "Error unable to determine exitcode. err: $exitinfo" |
||||
cd $startdir |
||||
return false |
||||
} |
||||
|
||||
cd $startdir |
||||
if {$exitcode != 0} { |
||||
puts stderr "FAILED with exitcode $exitcode" |
||||
return false |
||||
} else { |
||||
puts stdout "OK make finished " |
||||
return true |
||||
} |
||||
} |
||||
|
||||
proc Kettle {args} { |
||||
tailcall lib::kettle_call lib {*}$args |
||||
} |
||||
proc KettleShell {args} { |
||||
tailcall lib::kettle_call shell {*}$args |
||||
} |
||||
|
||||
|
||||
|
||||
namespace eval lib { |
||||
namespace path ::punk::mix::util |
||||
|
||||
|
||||
proc module_types {} { |
||||
#first in list is default for unspecified -type when creating new module |
||||
return [list plain tarjar zipkit] |
||||
} |
||||
|
||||
proc validate_modulename {modulename args} { |
||||
set defaults [list\ |
||||
-name_description modulename\ |
||||
] |
||||
if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"} |
||||
set known_opts [dict keys $defaults] |
||||
foreach k [dict keys $args] { |
||||
if {$k ni $known_opts} { |
||||
error "validate_modulename error: unknown option $k. known options: $known_opts" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_name_description [dict get $opts -name_description] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
|
||||
validate_name_not_empty_or_spaced $modulename -name_description $opt_name_description |
||||
set testname [string map [list :: ""] $modulename] |
||||
if {[string first : $testname] >=0} { |
||||
error "$opt_name_description '$modulename' can only contain paired colons" |
||||
} |
||||
set badchars [list - "$" "?" "*"] |
||||
foreach bc $badchars { |
||||
if {[string first $bc $modulename] >= 0} { |
||||
error "$opt_name_description '$modulename' can not contain character '$bc'" |
||||
} |
||||
} |
||||
return $modulename |
||||
} |
||||
|
||||
proc validate_projectname {projectname args} { |
||||
set defaults [list\ |
||||
-name_description projectname\ |
||||
] |
||||
if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"} |
||||
set known_opts [dict keys $defaults] |
||||
foreach k [dict keys $args] { |
||||
if {$k ni $known_opts} { |
||||
error "validate_modulename error: unknown option $k. known options: $known_opts" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_name_description [dict get $opts -name_description] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
validate_name_not_empty_or_spaced $projectname -name_description $opt_name_description |
||||
set reserved_words [list etc lib bin modules src doc vendorlib vendormodules embedded runtime _aside _build] |
||||
if {$projectname in $reserved_words } { |
||||
error "$opt_name_description '$projectname' cannot be one of reserved_words: $reserved_words" |
||||
} |
||||
if {[string first "::" $projectname] >= 0} { |
||||
error "$opt_name_description '$projectname' cannot contain namespace separator '::'" |
||||
} |
||||
return $projectname |
||||
} |
||||
proc validate_name_not_empty_or_spaced {name args} { |
||||
set defaults [list\ |
||||
-name_description projectname\ |
||||
] |
||||
if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"} |
||||
set known_opts [dict keys $defaults] |
||||
foreach k [dict keys $args] { |
||||
if {$k ni $known_opts} { |
||||
error "validate_modulename error: unknown option $k. known options: $known_opts" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_name_description [dict get $opts -name_description] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
if {![string length $name]} { |
||||
error "$opt_name_description cannot be empty" |
||||
} |
||||
if {[string length [string map [list " " "" \n "" \r "" \t ""] $name]] != [string length $name]} { |
||||
error "$opt_name_description cannot contain whitespace" |
||||
} |
||||
return $name |
||||
} |
||||
|
||||
#split modulename (as present in a filename or namespaced name) into name/version ignoring leading namespace path |
||||
#ignore trailing .tm .TM if present |
||||
#if version doesn't pass validation - treat it as part of the modulename and return empty version string without error |
||||
#Up to caller to validate. |
||||
proc split_modulename_version {modulename} { |
||||
set lastpart [namespace tail $modulename] |
||||
set lastpart [file tail $lastpart] ;# should be ok to use file tail now that we've ensured no namespace components |
||||
if {[string equal -nocase [file extension $modulename] ".tm"]} { |
||||
set fileparts [split [file rootname $lastpart] -] |
||||
} else { |
||||
set fileparts [split $lastpart -] |
||||
} |
||||
if {[punk::mix::util::is_valid_tm_version [lindex $fileparts end]]} { |
||||
set versionsegment [lindex $fileparts end] |
||||
set namesegment [join [lrange $fileparts 0 end-1] -];#re-stitch |
||||
} else { |
||||
# |
||||
set namesegment [join $fileparts -] |
||||
set versionsegment "" |
||||
} |
||||
return [list $namesegment $versionsegment] |
||||
} |
||||
|
||||
proc get_status {{workingdir ""} args} { |
||||
set result "" |
||||
if {$workingdir ne ""} { |
||||
if {[file pathtype $workingdir] ne "absolute"} { |
||||
set workingdir [file normalize $workingdir] |
||||
} |
||||
set active_dir $workingdir |
||||
} else { |
||||
set active_dir [pwd] |
||||
} |
||||
set defaults [dict create\ |
||||
-v 1\ |
||||
] |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- --- --- |
||||
set opt_v [dict get $opts -v] |
||||
# -- --- --- --- --- --- --- --- --- |
||||
|
||||
|
||||
set repopaths [punk::repo::find_repos [pwd]] |
||||
set repos [dict get $repopaths repos] |
||||
if {![llength $repos]} { |
||||
append result [dict get $repopaths warnings] |
||||
} else { |
||||
append result [dict get $repopaths warnings] |
||||
lassign [lindex $repos 0] repopath repotypes |
||||
if {"fossil" in $repotypes} { |
||||
#review - multiple process launches to fossil a bit slow on windows.. |
||||
#could we query global db in one go instead? |
||||
# |
||||
set fossil_prog [auto_execok fossil] |
||||
append result "FOSSIL project based at $repopath with revision: [punk::repo::fossil_revision $repopath]" \n |
||||
set fosinfo [exec {*}$fossil_prog info] |
||||
append result [join [punk::repo::grep {repository:*} $fosinfo] \n] \n |
||||
|
||||
set fosrem [exec {*}$fossil_prog remote ls] |
||||
if {[string length $fosrem]} { |
||||
append result "Remotes:\n" |
||||
append result " " $fosrem \n |
||||
} |
||||
|
||||
|
||||
append result [join [punk::repo::grep {tags:*} $fosinfo] \n] \n |
||||
|
||||
set dbinfo [exec {*}$fossil_prog dbstat] |
||||
append result [join [punk::repo::grep {project-name:*} $dbinfo] \n] \n |
||||
append result [join [punk::repo::grep {tickets:*} $dbinfo] \n] \n |
||||
append result [join [punk::repo::grep {project-age:*} $dbinfo] \n] \n |
||||
append result [join [punk::repo::grep {latest-change:*} $dbinfo] \n] \n |
||||
append result [join [punk::repo::grep {files:*} $dbinfo] \n] \n |
||||
append result [join [punk::repo::grep {check-ins:*} $dbinfo] \n] \n |
||||
if {"project" in $repotypes} { |
||||
#punk project |
||||
if {![catch {package require textblock; package require patternpunk}]} { |
||||
set result [textblock::join [textblock::join [>punk . logo] " "] $result] |
||||
append result \n |
||||
} |
||||
} |
||||
|
||||
set timeline [exec fossil timeline -n 5 -t ci] |
||||
set timeline [string map [list \r\n \n] $timeline] |
||||
append result $timeline |
||||
if {$opt_v} { |
||||
set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes fossil] |
||||
append result \n [punk::repo::workingdir_state_summary $repostate] |
||||
} |
||||
|
||||
} |
||||
#repotypes *could* be both git and fossil - so report both if so |
||||
if {"git" in $repotypes} { |
||||
append result "GIT project based at $repopath with revision: [punk::repo::git_revision $repopath]" \n |
||||
if {[string length [set git_prog [auto_execok git]]]} { |
||||
set git_remotes [exec {*}$git_prog remote -v] |
||||
append result $git_remotes |
||||
if {$opt_v} { |
||||
set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes git] |
||||
append result \n [punk::repo::workingdir_state_summary $repostate] |
||||
} |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
|
||||
proc build_modules_from_source_to_base {srcdir basedir args} { |
||||
set antidir [list "#*" "_aside" ".git" ".fossil*"] ;#exact or glob patterns for folders we don't want to search in. |
||||
set defaults [list\ |
||||
-installer punk::mix::cli::build_modules_from_source_to_base\ |
||||
-call-depth-internal 0\ |
||||
-max_depth 1000\ |
||||
-subdirlist {}\ |
||||
-punkcheck_eventobj "\uFFFF"\ |
||||
-glob *.tm\ |
||||
] |
||||
set opts [dict merge $defaults $args] |
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set installername [dict get $opts -installer] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set CALLDEPTH [dict get $opts -call-depth-internal] |
||||
set max_depth [dict get $opts -max_depth] |
||||
set subdirlist [dict get $opts -subdirlist] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set fileglob [dict get $opts -glob] |
||||
if {![string match "*.tm" $fileglob]} { |
||||
error "build_modules_from_source_to_base -glob '$fileglob' doesn't seem to target tcl modules." |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_punkcheck_eventobj [dict get $opts -punkcheck_eventobj] |
||||
|
||||
set magicversion [punk::mix::util::magic_tm_version] ;#deliberately large so given load-preference when testing |
||||
set module_list [list] |
||||
|
||||
if {[file tail [file dirname $srcdir]] ne "src"} { |
||||
puts stderr "ERROR build_modules_from_source_to_base can only be called with a srcdir that is a subfolder of your 'src' directory" |
||||
puts stderr "The .tm modules are namespaced based on their directory depth - so we need to start at the root" |
||||
puts stderr "To build a subtree of your modules - use an appropriate src/modules folder and pass in the -subdirlist." |
||||
puts stderr "e.g if your modules are based at /x/src/modules2 and you wish to build only the .tm files at /x/src/modules2/skunkworks/lib" |
||||
puts stderr "Use: >build_modules_from_source_to_base /x/src/modules2 /x/modules2 -subdirlist {skunkworks lib}" |
||||
exit 2 |
||||
} |
||||
set srcdirname [file tail $srcdir] |
||||
|
||||
set build [file dirname $srcdir]/_build/$srcdirname ;#relative to *original* srcdir - not current_source_dir |
||||
if {[llength $subdirlist] == 0} { |
||||
set target_module_dir $basedir |
||||
set current_source_dir $srcdir |
||||
} else { |
||||
set target_module_dir $basedir/[file join {*}$subdirlist] |
||||
set current_source_dir $srcdir/[file join {*}$subdirlist] |
||||
} |
||||
if {![file exists $target_module_dir]} { |
||||
error "build_modules_from_source_to_base from current source dir: '$current_source_dir'. Basedir:'$current_module_dir' doesn't exist or is empty" |
||||
} |
||||
if {![file exists $current_source_dir]} { |
||||
error "build_modules_from_source_to_base from current source dir:'$current_source_dir' doesn't exist or is empty" |
||||
} |
||||
|
||||
#---------------------------------------- |
||||
set punkcheck_file [file join $basedir/.punkcheck] |
||||
if {$CALLDEPTH == 0} { |
||||
|
||||
set config [dict create\ |
||||
-glob $fileglob\ |
||||
-max_depth 0\ |
||||
] |
||||
#lassign [punkcheck::start_installer_event $punkcheck_file $installername $srcdir $basedir $config] _eventid punkcheck_eventid _recordset record_list |
||||
# -- --- |
||||
set installer [punkcheck::installtrack new $installername $punkcheck_file] |
||||
$installer set_source_target $srcdir $basedir |
||||
set event [$installer start_event $config] |
||||
# -- --- |
||||
|
||||
} else { |
||||
set event $opt_punkcheck_eventobj |
||||
} |
||||
#---------------------------------------- |
||||
|
||||
|
||||
|
||||
set src_modules [glob -nocomplain -dir $current_source_dir -type f -tail $fileglob] |
||||
|
||||
set did_skip 0 ;#flag for stdout/stderr formatting only |
||||
foreach m $src_modules { |
||||
#puts "build_modules_from_source_to_base >>> module $m" |
||||
set fileparts [split [file rootname $m] -] |
||||
set tmfile_versionsegment [lindex $fileparts end] |
||||
if {$tmfile_versionsegment eq $magicversion} { |
||||
#rebuild the .tm from the #tarjar |
||||
set basename [join [lrange $fileparts 0 end-1] -] |
||||
set versionfile $current_source_dir/$basename-buildversion.txt |
||||
set versionfiledata "" |
||||
if {![file exists $versionfile]} { |
||||
puts stderr "\nWARNING: Missing buildversion text file: $versionfile" |
||||
puts stderr "Using version 0.1 - create $versionfile containing the desired version number as the top line to avoid this warning\n" |
||||
set module_build_version "0.1" |
||||
} else { |
||||
set fd [open $versionfile r] |
||||
set versionfiledata [read $fd]; close $fd |
||||
set ln0 [lindex [split $versionfiledata \n] 0] |
||||
set ln0 [string trim $ln0]; set ln0 [string trim $ln0 \r] |
||||
if {![util::is_valid_tm_version $ln0]} { |
||||
puts stderr "ERROR: build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file" |
||||
exit 3 |
||||
} |
||||
set module_build_version $ln0 |
||||
} |
||||
|
||||
|
||||
if {[file exists $current_source_dir/#tarjar-$basename-$magicversion]} { |
||||
#TODO |
||||
file mkdir $buildfolder |
||||
|
||||
if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { |
||||
|
||||
} else { |
||||
|
||||
} |
||||
#REVIEW - should be in same structure/depth as $target_module_dir in _build? |
||||
set tmfile $basedir/_build/$basename-$module_build_version.tm |
||||
file mkdir $basedir/_build |
||||
file delete -force $basedir/_build/#tarjar-$basename-$module_build_version |
||||
file delete -force $tmfile |
||||
|
||||
|
||||
file copy -force $current_source_dir/#tarjar-$basename-$magicversion $basedir/_build/#tarjar-$basename-$module_build_version |
||||
# |
||||
#bsdtar doesn't seem to work.. or I haven't worked out the right options? |
||||
#exec tar -cvf $basedir/_build/$basename-$module_build_version.tm $basedir/_build/#tarjar-$basename-$module_build_version |
||||
package require tar |
||||
tar::create $tmfile $basedir/_build/#tarjar-$basename-$module_build_version |
||||
if {![file exists $tmfile]} { |
||||
puts stdout "ERROR: Failed to build tarjar file $tmfile" |
||||
exit 4 |
||||
} |
||||
#copy the file? |
||||
#set target $target_module_dir/$basename-$module_build_version.tm |
||||
#file copy -force $tmfile $target |
||||
|
||||
lappend module_list $tmfile |
||||
} else { |
||||
#assume that either the .tm is not a tarjar - or the tarjar dir is capped (trailing #) and the .tm has been manually tarred. |
||||
if {[file exists $current_source_dir/#tarjar-$basename-${magicversion}#]} { |
||||
puts stderr "\nWarning: found 'capped' folder #tarjar-$basename-${magicversion}# - No attempt being made to update version in description.txt" |
||||
} |
||||
|
||||
#------------------------------ |
||||
# |
||||
#set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$basename-$module_build_version.tm] |
||||
#set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] |
||||
$event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm |
||||
$event targetset_addsource $versionfile |
||||
$event targetset_addsource $current_source_dir/$m |
||||
|
||||
#set changed_list [list] |
||||
## -- --- --- --- --- --- |
||||
#set source_relpath [punkcheck::lib::path_relative $basedir $versionfile] |
||||
#set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] |
||||
## -- --- --- --- --- --- |
||||
#set source_relpath [punkcheck::lib::path_relative $basedir $current_source_dir/$m] |
||||
#set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] |
||||
## -- --- --- --- --- --- |
||||
#set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] |
||||
#set changed_list [dict get $changed_unchanged changed] |
||||
|
||||
|
||||
if {\ |
||||
[llength [dict get [$event targetset_source_changes] changed]]\ |
||||
|| [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ |
||||
} { |
||||
|
||||
#set file_record [punkcheck::installfile_started_install $basedir $file_record] |
||||
$event targetset_started |
||||
# -- --- --- --- --- --- |
||||
set target $target_module_dir/$basename-$module_build_version.tm |
||||
if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} |
||||
puts stdout "copying module $current_source_dir/$m to $target as version: $module_build_version ([file tail $target])" |
||||
set fd [open $current_source_dir/$m r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd |
||||
set data [string map [list $magicversion $module_build_version] $data] |
||||
set fdout [open $target w] |
||||
fconfigure $fdout -translation binary |
||||
puts -nonewline $fdout $data |
||||
close $fdout |
||||
#file copy -force $srcdir/$m $target |
||||
lappend module_list $target |
||||
# -- --- --- --- --- --- |
||||
#set file_record [punkcheck::installfile_finished_install $basedir $file_record] |
||||
$event targetset_end OK |
||||
} else { |
||||
#puts stdout "skipping module $current_source_dir/$m - no change in sources detected" |
||||
puts -nonewline stderr "." |
||||
set did_skip 1 |
||||
#set file_record [punkcheck::installfile_skipped_install $basedir $file_record] |
||||
$event targetset_end SKIPPED |
||||
} |
||||
|
||||
#------------------------------ |
||||
|
||||
} |
||||
|
||||
continue |
||||
} |
||||
|
||||
|
||||
if {![util::is_valid_tm_version $tmfile_versionsegment]} { |
||||
#last segment doesn't look even slightly versiony - fail. |
||||
puts stderr "ERROR: Unable to confirm file $current_source_dir/$m is a reasonably versioned .tm module - ABORTING." |
||||
exit 1 |
||||
} |
||||
|
||||
##------------------------------ |
||||
## |
||||
#set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$m] |
||||
#set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] |
||||
#set changed_list [list] |
||||
## -- --- --- --- --- --- |
||||
#set source_relpath [punkcheck::lib::path_relative $basedir $current_source_dir/$m] |
||||
#set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] |
||||
## -- --- --- --- --- --- |
||||
#set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] |
||||
#set changed_list [dict get $changed_unchanged changed] |
||||
|
||||
#---------- |
||||
$event targetset_init INSTALL $target_module_dir/$m |
||||
$event targetset_addsource $current_source_dir/$m |
||||
if {\ |
||||
[llength [dict get [$event targetset_source_changes] changed]]\ |
||||
|| [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ |
||||
} { |
||||
|
||||
#set file_record [punkcheck::installfile_started_install $basedir $file_record] |
||||
$event targetset_started |
||||
# -- --- --- --- --- --- |
||||
if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} |
||||
puts stderr "Copied already versioned module $current_source_dir/$m to $target_module_dir" |
||||
lappend module_list $current_source_dir/$m |
||||
file copy -force $current_source_dir/$m $target_module_dir |
||||
# -- --- --- --- --- --- |
||||
#set file_record [punkcheck::installfile_finished_install $basedir $file_record] |
||||
$event targetset_end OK -note "already versioned module" |
||||
} else { |
||||
puts -nonewline stderr "." |
||||
set did_skip 1 |
||||
#set file_record [punkcheck::installfile_skipped_install $basedir $file_record] |
||||
$event targetset_end SKIPPED |
||||
} |
||||
|
||||
} |
||||
if {$CALLDEPTH >= $max_depth} { |
||||
set subdirs [list] |
||||
} else { |
||||
set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] |
||||
} |
||||
#puts stderr "subdirs: $subdirs" |
||||
foreach d $subdirs { |
||||
set skipdir 0 |
||||
foreach dg $antidir { |
||||
if {[string match $dg $d]} { |
||||
set skipdir 1 |
||||
continue |
||||
} |
||||
} |
||||
if {$skipdir} { |
||||
continue |
||||
} |
||||
if {![file exists $target_module_dir/$d]} { |
||||
file mkdir $target_module_dir/$d |
||||
} |
||||
lappend module_list {*}[build_modules_from_source_to_base $srcdir $basedir\ |
||||
-call-depth-internal [expr {$CALLDEPTH +1}]\ |
||||
-subdirlist [list {*}$subdirlist $d]\ |
||||
-punkcheck_eventobj $event\ |
||||
-glob $fileglob\ |
||||
] |
||||
} |
||||
if {$did_skip} { |
||||
puts -nonewline stdout \n |
||||
} |
||||
if {$CALLDEPTH == 0} { |
||||
$event destroy |
||||
$installer destroy |
||||
} |
||||
return $module_list |
||||
} |
||||
|
||||
variable kettle_reset_bodies [dict create] |
||||
variable kettle_reset_args [dict create] |
||||
#We are abusing kettle to run in-process. |
||||
# when we change to another project we need recipes to be reloaded. |
||||
# Kettle rewrites some of it's own procs - stopping reloading of recipes when we change folders |
||||
#kettle_init stores the original proc bodies & args |
||||
proc kettle_init {} { |
||||
variable kettle_reset_bodies ;#dict |
||||
variable kettle_reset_args |
||||
set reset_procs [list\ |
||||
::kettle::benchmarks\ |
||||
::kettle::doc\ |
||||
::kettle::figures\ |
||||
::kettle::meta::scan\ |
||||
::kettle::testsuite\ |
||||
] |
||||
foreach p $reset_procs { |
||||
set b [info body $p] |
||||
if {[string match "*Overwrite self*" $b]} { |
||||
dict set kettle_reset_bodies $p $b |
||||
set argnames [info args $p] |
||||
set arglist [list] |
||||
foreach a $argnames { |
||||
if {[info default $p $a dval]} { |
||||
lappend arglist [list $a $dval] |
||||
} else { |
||||
lappend arglist $a |
||||
} |
||||
} |
||||
dict set kettle_reset_args $p $arglist |
||||
} |
||||
} |
||||
|
||||
} |
||||
#call kettle_reinit to ensure recipes point to current project |
||||
proc kettle_reinit {} { |
||||
variable kettle_reset_bodies |
||||
variable kettle_reset_args |
||||
foreach p [dict keys $kettle_reset_bodies] { |
||||
set b [dict get $kettle_reset_bodies $p] |
||||
set argl [dict get $kettle_reset_args $p] |
||||
uplevel 1 [list ::proc $p $argl $b] |
||||
} |
||||
#todo - determine standard recipes by examining standard.tcl instead of hard coding? |
||||
set standard_recipes [list\ |
||||
null\ |
||||
forever\ |
||||
list-recipes\ |
||||
help-recipes\ |
||||
help-dump\ |
||||
help-recipes\ |
||||
help\ |
||||
list\ |
||||
list-options\ |
||||
help-options\ |
||||
show-configuration\ |
||||
show-state\ |
||||
show\ |
||||
meta-status\ |
||||
gui\ |
||||
] |
||||
#set ::kettle::recipe::recipe [dict create] |
||||
foreach r [dict keys $::kettle::recipe::recipe] { |
||||
if {$r ni $standard_recipes} { |
||||
dict unset ::kettle::recipe::recipe $r |
||||
} |
||||
} |
||||
} |
||||
proc kettle_call {calltype args} { |
||||
variable kettle_reset_bodies |
||||
if {$calltype ni [list lib shell]} { |
||||
error "pmix kettle_call 1st argument must be one of: 'lib' for direct use of kettle module or 'shell' to call as separate process" |
||||
} |
||||
if {$calltype eq "shell"} { |
||||
set kettleappfile [file dirname [info nameofexecutable]]/kettle |
||||
set kettlebatfile [file dirname [info nameofexecutable]]/kettle.bat |
||||
|
||||
if {(![file exists $kettleappfile]) && (![file exists $kettlebatfile])} { |
||||
error "pmix kettle_call unable to find installed kettle application file '$kettleappfile' (or '$kettlebatfile' if on windows)" |
||||
} |
||||
if {[file exists $kettleappfile]} { |
||||
set kettlescript $kettleappfile |
||||
} |
||||
if {$::tcl_platform(platform) eq "windows"} { |
||||
if {[file exists $kettlebatfile]} { |
||||
set kettlescript $kettlebatfile |
||||
} |
||||
} |
||||
} |
||||
set startdir [pwd] |
||||
if {![file exists $startdir/build.tcl]} { |
||||
error "pmix kettle must be run from a folder containing build.tcl (cwd: [pwd])" |
||||
} |
||||
if {[package provide kettle] eq ""} { |
||||
puts stdout "Loading kettle package - may be delay on first load ..." |
||||
package require kettle |
||||
kettle_init ;#store original procs for those kettle procs that rewrite themselves |
||||
} else { |
||||
if {[dict size $kettle_reset_bodies] == 0} { |
||||
#presumably package require kettle was called without calling our kettle_init hack. |
||||
kettle_init |
||||
} else { |
||||
#undo proc rewrites |
||||
kettle_reinit |
||||
} |
||||
} |
||||
set first [lindex $args 0] |
||||
if {[string match @* $first]} { |
||||
error "pmix kettle doesn't support special operations - try calling tclsh kettle directly" |
||||
} |
||||
if {$first eq "-f"} { |
||||
set args [lassign $args __ path] |
||||
} else { |
||||
set path $startdir/build.tcl |
||||
} |
||||
set opts [list] |
||||
|
||||
if {[lindex $args 0] eq "-trace"} { |
||||
set args [lrange $args 1 end] |
||||
lappend opts --verbose on |
||||
} |
||||
set goals [list] |
||||
|
||||
if {$calltype eq "lib"} { |
||||
file mkdir ~/.kettle |
||||
set dotfile ~/.kettle/config |
||||
if {[file exists $dotfile] && |
||||
[file isfile $dotfile] && |
||||
[file readable $dotfile]} { |
||||
::kettle io trace {Loading dotfile $dotfile ...} |
||||
set args [list {*}[::kettle path cat $dotfile] {*}$args] |
||||
} |
||||
} |
||||
|
||||
#hardcoded kettle option names (::kettle option names) - retrieved using kettle::option names |
||||
#This is done so we don't have to load kettle lib for shell call (both loading as module and running shell are annoyingly SLOW) |
||||
#REVIEW - needs to be updated to keep in sync with kettle. |
||||
set knownopts [list\ |
||||
--exec-prefix --bin-dir --lib-dir --prefix --man-dir --html-dir --markdown-dir --include-dir \ |
||||
--ignore-glob --dry --verbose --machine --color --state --config --with-shell --log \ |
||||
--log-append --log-mode --with-dia --constraints --file --limitconstraints --tmatch --notfile --single --valgrind --tskip --repeats \ |
||||
--iters --collate --match --rmatch --with-doc-destination --with-git --target --test-include \ |
||||
] |
||||
|
||||
while {[llength $args]} { |
||||
set o [lindex $args 0] |
||||
switch -glob -- $o { |
||||
--* { |
||||
#instead of using: kettle option known |
||||
if {$o ni $knownopts} { |
||||
error "Unable to process unknown option $o." {} [list KETTLE (pmix)] |
||||
} |
||||
lappend opts $o [lindex $args 1] |
||||
#::kettle::option set $o [lindex $args 1] |
||||
set args [lrange $args 2 end] |
||||
} |
||||
default { |
||||
lappend goals $o |
||||
set args [lrange $args 1 end] |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {![llength $goals]} { |
||||
lappend goals help |
||||
} |
||||
if {"--prefix" ni [dict keys $opts]} { |
||||
dict set opts --prefix [file dirname $startdir] |
||||
} |
||||
if {$calltype eq "lib"} { |
||||
::kettle status clear |
||||
::kettle::option::set @kettle $startdir |
||||
foreach {o v} $opts { |
||||
::kettle option set $o $v |
||||
} |
||||
::kettle option set @srcscript $path |
||||
::kettle option set @srcdir [file dirname $path] |
||||
::kettle option set @goals $goals |
||||
::source $path |
||||
puts stderr "recipes: [::kettle recipe names]" |
||||
::kettle recipe run {*}[::kettle option get @goals] |
||||
|
||||
set state [::kettle option get --state] |
||||
if {$state ne {}} { |
||||
puts stderr "saving kettle state: $state" |
||||
::kettle status save $state |
||||
} |
||||
|
||||
} else { |
||||
#shell |
||||
puts stdout "Running external kettle process with args: $opts $goals" |
||||
run -n tclsh $kettlescript -f $path {*}$opts {*}$goals |
||||
} |
||||
|
||||
} |
||||
|
||||
} |
||||
} |
||||
|
||||
|
||||
namespace eval punk::mix::cli { |
||||
proc _cli {args} { |
||||
#don't use tailcall - base uses info level to determine caller |
||||
::punk::mix::base::_cli {*}$args |
||||
} |
||||
variable default_command help |
||||
package require punk::mix::base |
||||
package require punk::overlay |
||||
punk::overlay::custom_from_base [namespace current] ::punk::mix::base |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::cli [namespace eval punk::mix::cli { |
||||
variable version |
||||
set version 0.3 |
||||
}] |
||||
return |
||||
@ -0,0 +1,152 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::buildsuite 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::buildsuite { |
||||
namespace export * |
||||
proc projects {suite} { |
||||
set pathinfo [punk::repo::find_repos [pwd]] |
||||
set projectdir [dict get $pathinfo closest] |
||||
set suites_dir [file join $projectdir src buildsuites] |
||||
if {![file isdirectory [file join $suites_dir $suite]]} { |
||||
puts stderr "suite: $suite not found in buildsuites folder: $suites_dir" |
||||
return |
||||
} |
||||
set suite_dir [file join $suites_dir $suite] |
||||
set projects [glob -dir $suite_dir -type d -tails *] |
||||
|
||||
#use internal du which although breadth-first is generally faster |
||||
puts stdout "Examining source folders in $suite_dir." ;#A hint that something is happening in case sources are large |
||||
set du_info [punk::du::du -d 1 -b $suite_dir] |
||||
set du_sizes [dict create] |
||||
set suite_total_size "-" |
||||
foreach du_record $du_info { |
||||
if {[llength $du_record] != 2} { |
||||
#sanity precaution - punk::du::du should always output list of 2 element lists - at least with flags we're using |
||||
continue |
||||
} |
||||
set sz [lindex $du_record 0] |
||||
set path_parts [file split [lindex $du_record 1]] ;#should handle spaced-paths ok. |
||||
set s [lindex $path_parts end-1] |
||||
set p [lindex $path_parts end] |
||||
|
||||
#This handles case where a project folder is same name as suite e.g src/buildsuites/tcl/tcl |
||||
#so we can't just use tail as dict key. We could assume last record is always total - but |
||||
if {![string match -nocase $s $suite]} { |
||||
if {$s eq "buildsuites" && [string match -nocase $p $suite]} { |
||||
set suite_total_size $sz ;#this includes config files in suite base - so we don't really want to use this to report the total source size |
||||
} else { |
||||
#something else - shouldn't happen |
||||
puts stderr "Unexpected output from du in suite_dir: $suite_dir" |
||||
puts stderr "$du_record" |
||||
#try to continue anyway |
||||
} |
||||
} else { |
||||
dict set du_sizes $p $sz |
||||
} |
||||
} |
||||
|
||||
#build another dict for sizes where we ensure exactly one entry for each project exists and exclude total (don't blindly trust du output e.g in case weird filename/permission issue) |
||||
set psizes [list] |
||||
foreach p $projects { |
||||
if {[dict exists $du_sizes $p]} { |
||||
dict set psizes $p [dict get $du_sizes $p] |
||||
} else { |
||||
dict set psizes $p - |
||||
} |
||||
} |
||||
set total_source_size "-" |
||||
if {[catch { |
||||
set total_source_size [tcl::mathop::+ {*}[dict values $psizes]] |
||||
} errM]} { |
||||
puts stderr "Failed to calculate total source size. Errmsg: $errM" |
||||
} |
||||
package require overtype |
||||
|
||||
set title1 "Projects" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $projects] {punk::strlen $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
|
||||
set size_values [dict values $psizes] |
||||
# Title is probably widest - but go through the process anyway! |
||||
set title2 "Source Bytes" |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $size_values] {punk::strlen $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
|
||||
|
||||
set output "" |
||||
append output "[overtype::left $col1 $title1] [overtype::right $col2 $title2]" \n |
||||
foreach p [lsort $projects] { |
||||
#todo - provide some basic info for each - last build time? last time-to-build? |
||||
append output "[overtype::left $col1 $p] [overtype::right $col2 [dict get $psizes $p]]" \n |
||||
} |
||||
append output "Total Source size: $total_source_size bytes" \n |
||||
return $output |
||||
} |
||||
|
||||
|
||||
namespace eval collection { |
||||
namespace export * |
||||
proc _default {{glob {}}} { |
||||
if {![string length $glob]} { |
||||
set glob * |
||||
} |
||||
#todo - review - we want the furthest not the closest if we are potentially inside a buildsuite project |
||||
set pathinfo [punk::repo::find_repos [pwd]] |
||||
set projectdir [dict get $pathinfo closest] |
||||
set suites_dir [file join $projectdir src buildsuites] |
||||
if {![file exists $suites_dir]} { |
||||
puts stderr "No buildsuites folder found at $suites_dir" |
||||
return |
||||
} |
||||
set suites [lsort [glob -dir $suites_dir -type d -tails *]] |
||||
if {$glob ne "*"} { |
||||
set suites [lsearch -all -inline $suites $glob] |
||||
} |
||||
return $suites |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::buildsuite [namespace eval punk::mix::commandset::buildsuite { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,92 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::debug 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::debug { |
||||
namespace export get paths |
||||
namespace path ::punk::mix::cli |
||||
|
||||
#Except for 'get' - all debug commands should emit to stdout |
||||
proc paths {} { |
||||
set out "" |
||||
puts stdout "find_repos output:" |
||||
set pathinfo [punk::repo::find_repos [pwd]] |
||||
pdict $pathinfo |
||||
|
||||
set projectdir [dict get $pathinfo closest] |
||||
set modulefolders [lib::find_source_module_paths $projectdir] |
||||
puts stdout "modulefolders: $modulefolders" |
||||
|
||||
set template_base_dict [punk::mix::base::lib::get_template_basefolders] |
||||
puts stdout "get_template_basefolders output:" |
||||
pdict $template_base_dict |
||||
return |
||||
} |
||||
|
||||
#call other debug command - but capture stdout as return value |
||||
proc get {args} { |
||||
set nm [lindex $args 0] |
||||
if {$nm eq ""} { |
||||
set nscmds [info commands [namespace current]::*] |
||||
set cmds [lmap v $nscmds {namespace tail $v}] |
||||
error "debug.get missing debug command argument. Try one of: $cmds" |
||||
return |
||||
} |
||||
set nextargs [lrange $args 1 end] |
||||
set out "" |
||||
if {[info commands [namespace current]::$nm] ne ""} { |
||||
append out [runout -n -tcl [namespace current]::$nm {*}$nextargs] \n |
||||
} else { |
||||
set nscmds [info commands [namespace current]::*] |
||||
set cmds [lmap v $nscmds {namespace tail $v}] |
||||
error "debug.get invalid debug command '$nm' Try one of: $cmds" |
||||
} |
||||
return $out |
||||
} |
||||
namespace eval lib { |
||||
|
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::debug [namespace eval punk::mix::commandset::debug { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,181 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::doc 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::doc { |
||||
namespace export * |
||||
|
||||
proc _default {} { |
||||
puts "documentation subsystem" |
||||
puts "commands: doc.build" |
||||
puts " build documentation from src/doc to src/embedded using the kettle build tool" |
||||
} |
||||
|
||||
proc build {} { |
||||
puts "build docs" |
||||
set projectdir [punk::repo::find_project] |
||||
if {$projectdir eq ""} { |
||||
puts stderr "No current project dir - unable to build docs" |
||||
return |
||||
} |
||||
if {[file exists $projectdir/src/doc]} { |
||||
set original_wd [pwd] |
||||
cd $projectdir/src |
||||
#---------- |
||||
set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] |
||||
$installer set_source_target $projectdir/src/doc $projectdir/src/embedded |
||||
set event [$installer start_event {-install_step kettledoc}] |
||||
#use same virtual id "kettle_build_doc" as project.new - review best way to keep identifiers like this in sync. |
||||
$event targetset_init VIRTUAL kettle_build_doc ;#VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated |
||||
$event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source |
||||
#---------- |
||||
if {\ |
||||
[llength [dict get [$event targetset_source_changes] changed]]\ |
||||
} { |
||||
$event targetset_started |
||||
# -- --- --- --- --- --- |
||||
puts stdout "BUILDING DOCS at $projectdir/src/embedded from src/doc" |
||||
if {[catch { |
||||
|
||||
punk::mix::cli::lib::kettle_call lib doc |
||||
#Kettle doc |
||||
|
||||
} errM]} { |
||||
$event targetset_end FAILED -note "kettle_build_doc failed: $errM" |
||||
} else { |
||||
$event targetset_end OK |
||||
} |
||||
# -- --- --- --- --- --- |
||||
} else { |
||||
puts stderr "No change detected in src/doc" |
||||
$event targetset_end SKIPPED |
||||
} |
||||
$event end |
||||
$event destroy |
||||
$installer destroy |
||||
cd $original_wd |
||||
} else { |
||||
puts stderr "No doc folder found at $projectdir/src/doc" |
||||
} |
||||
} |
||||
proc status {} { |
||||
set projectdir [punk::repo::find_project] |
||||
if {$projectdir eq ""} { |
||||
puts stderr "No current project dir - unable to check doc status" |
||||
return |
||||
} |
||||
if {![file exists $projectdir/src/doc]} { |
||||
set result "No documentation source found. Expected .man files in doctools format at $projectdir/src/doc" |
||||
return $result |
||||
} |
||||
set original_wd [pwd] |
||||
cd $projectdir/src |
||||
puts stdout "Testing status of doctools source location $projectdir/src/doc ..." |
||||
flush stdout |
||||
#---------- |
||||
set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] |
||||
$installer set_source_target $projectdir/src/doc $projectdir/src/embedded |
||||
set event [$installer start_event {-install_step kettledoc}] |
||||
#use same virtual id "kettle_build_doc" as project.new - review best way to keep identifiers like this in sync. |
||||
$event targetset_init QUERY kettle_build_doc ;#usually VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated - but here we use QUERY to ensure no writes to .punkcheck |
||||
set last_completion [$event targetset_last_complete] |
||||
|
||||
if {[llength $last_completion]} { |
||||
#adding a source causes it to be checksummed |
||||
$event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source |
||||
#---------- |
||||
set changeinfo [$event targetset_source_changes] |
||||
if {\ |
||||
[llength [dict get $changeinfo changed]]\ |
||||
} { |
||||
puts stdout "changed" |
||||
puts stdout $changeinfo |
||||
} else { |
||||
puts stdout "No changes detected in $projectdir/src/doc tree" |
||||
} |
||||
} else { |
||||
#no previous completion-record for this target - must assume changed - no need to trigger checksumming |
||||
puts stdout "No existing record of doc build in .punkcheck. Assume it needs to be rebuilt." |
||||
} |
||||
|
||||
|
||||
$event destroy |
||||
$installer destroy |
||||
|
||||
cd $original_wd |
||||
} |
||||
proc validate {} { |
||||
set projectdir [punk::repo::find_project] |
||||
if {$projectdir eq ""} { |
||||
puts stderr "No current project dir - unable to check doc status" |
||||
return |
||||
} |
||||
if {![file exists $projectdir/src/doc]} { |
||||
set result "No documentation source found. Expected .man files in doctools format at $projectdir/src/doc" |
||||
return $result |
||||
} |
||||
set original_wd [pwd] |
||||
cd $projectdir/src |
||||
|
||||
punk::mix::cli::lib::kettle_call lib validate-doc |
||||
|
||||
cd $original_wd |
||||
} |
||||
|
||||
namespace eval collection { |
||||
variable pkg |
||||
set pkg punk::mix::commandset::doc |
||||
|
||||
namespace export * |
||||
namespace path [namespace parent] |
||||
|
||||
} |
||||
|
||||
namespace eval lib { |
||||
variable pkg |
||||
set pkg punk::mix::commandset::doc |
||||
|
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::doc [namespace eval punk::mix::commandset::doc { |
||||
variable pkg punk::mix::commandset::doc |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,185 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::layout 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
#sort of a circular dependency when commandset loaded by punk::mix::cli - that's ok, but this could theoretically be loaded by another cli and with another base |
||||
package require punk::mix |
||||
package require punk::mix::base |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::layout { |
||||
namespace export * |
||||
|
||||
#per layout functions |
||||
proc files {layout} { |
||||
set allfiles [lib::layout_all_files $layout] |
||||
return [join $allfiles \n] |
||||
} |
||||
proc templatefiles {layout} { |
||||
set templatefiles [lib::layout_scan_for_template_files $layout] |
||||
return [join $templatefiles \n] |
||||
} |
||||
proc templatefiles.relative {layout} { |
||||
set template_base_dict [punk::mix::base::lib::get_template_basefolders] |
||||
|
||||
set bases_containing_layout [list] |
||||
dict for {tbase folderinfo} $template_base_dict { |
||||
if {[file exists $tbase/layouts/$layout]} { |
||||
lappend bases_containing_layout $tbase |
||||
} |
||||
} |
||||
if {![llength $bases_containing_layout]} { |
||||
puts stderr "Unable to locate folder for layout '$layout'" |
||||
puts stderr "searched [dict size $template_base_dict] template folders" |
||||
return |
||||
} |
||||
set tpldir [lindex $bases_containing_layout end] |
||||
|
||||
set layout_base $tpldir/layouts |
||||
set layout_dir [file join $layout_base $layout] |
||||
|
||||
set stripprefix [file normalize $layout_dir] |
||||
set templatefiles [lib::layout_scan_for_template_files $layout] |
||||
set tails [list] |
||||
foreach templatefullpath $templatefiles { |
||||
lappend tails [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] |
||||
} |
||||
return [join $tails \n] |
||||
} |
||||
|
||||
#layout collection functions - to be imported with punk::overlay::import_commandset separately |
||||
namespace eval collection { |
||||
namespace export * |
||||
proc _default {{glob {}}} { |
||||
if {![string length $glob]} { |
||||
set glob * |
||||
} |
||||
set layouts [list] |
||||
#set tplfolderdict [punk::cap::templates::folders] |
||||
set tplfolderdict [punk::mix::base::lib::get_template_basefolders] |
||||
dict for {tdir folderinfo} $tplfolderdict { |
||||
set layout_base $tdir/layouts |
||||
#collect all layouts and use lsearch glob rather than the filesystem glob (avoid issues with dotted folder names) |
||||
set all_layouts [lsort [glob -nocomplain -dir $layout_base -type d -tail *]] |
||||
foreach match [lsearch -all -inline $all_layouts $glob] { |
||||
lappend layouts [list $match $folderinfo] |
||||
} |
||||
} |
||||
return [join [lsort -index 0 $layouts] \n] |
||||
} |
||||
|
||||
} |
||||
namespace eval lib { |
||||
proc layout_all_files {layout} { |
||||
set tplbasedict [punk::mix::base::lib::get_template_basefolders] |
||||
set layouts_found [list] |
||||
dict for {tplbase folderinfo} $tplbasedict { |
||||
if {[file isdirectory $tplbase/layouts/$layout]} { |
||||
lappend layouts_found $tplbase/layouts/$layout |
||||
} |
||||
} |
||||
if {![llength $layouts_found]} { |
||||
puts stderr "layout '$layout' not found." |
||||
puts stderr "searched [dict size $tplbasedict] template folders" |
||||
dict for {tplbase pkg} $tplbasedict { |
||||
puts stderr " - $tplbase $pkg" |
||||
} |
||||
return |
||||
} |
||||
set layoutfolder [lindex $layouts_found end] |
||||
|
||||
if {![file isdirectory $layoutfolder]} { |
||||
puts stderr "layout '$layout' not found in /layouts within one of template_folders. (get_template_folder returned: $tplbasedict)" |
||||
} |
||||
set file_list [list] |
||||
util::foreach-file $layoutfolder path { |
||||
lappend file_list $path |
||||
} |
||||
|
||||
return $file_list |
||||
} |
||||
|
||||
# |
||||
#todo - allow specifying which package the layout is from: e.g "punk::mix::templates project" ?? |
||||
proc layout_scan_for_template_files {layout {tags {}}} { |
||||
#equivalent for projects? punk::mix::commandset::module::lib::templates_dict -scriptpath "" |
||||
set tplbasedict [punk::mix::base::lib::get_template_basefolders] |
||||
set layouts_found [list] |
||||
dict for {tpldir pkg} $tplbasedict { |
||||
if {[file isdirectory $tpldir/layouts/$layout]} { |
||||
lappend layouts_found $tpldir/layouts/$layout |
||||
} |
||||
} |
||||
if {![llength $layouts_found]} { |
||||
puts stderr "layout '$layout' not found." |
||||
puts stderr "searched [dict size $tplbasedict] template folders" |
||||
dict for {tpldir pkg} $tplbasedict { |
||||
puts stderr " - $tpldir $pkg" |
||||
} |
||||
return |
||||
} |
||||
set layoutfolder [lindex $layouts_found end] |
||||
|
||||
#use last matching layout found. review silent if multiple? |
||||
if {![llength $tags]} { |
||||
#todo - get standard tags from somewhere |
||||
set tags [list %project%] |
||||
} |
||||
set file_list [list] |
||||
util::foreach-file $layoutfolder path { |
||||
set fd [open $path r] |
||||
fconfigure $fd -translation binary |
||||
set data [read $fd] |
||||
close $fd |
||||
foreach tag $tags { |
||||
if {[string match "*$tag*" $data]} { |
||||
lappend file_list $path |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $file_list |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::layout [namespace eval punk::mix::commandset::layout { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,529 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::loadedlib 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
package require punk::ns |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::loadedlib { |
||||
namespace export * |
||||
#search automatically wrapped in * * - can contain inner * ? globs |
||||
proc search {searchstring} { |
||||
catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything |
||||
if {[catch {package require natsort}]} { |
||||
set has_natsort 0 |
||||
} else { |
||||
set has_natsort 1 |
||||
} |
||||
if {[regexp {[?*]} $searchstring]} { |
||||
#caller has specified specific glob pattern - use it |
||||
#todo - respect supplied case only if uppers present? require another flag? |
||||
set matches [lsearch -all -inline -nocase [package names] $searchstring] |
||||
} else { |
||||
#make it easy to search for anything |
||||
set matches [lsearch -all -inline -nocase [package names] "*$searchstring*"] |
||||
} |
||||
|
||||
set matchinfo [list] |
||||
foreach m $matches { |
||||
set versions [package versions $m] |
||||
if {$has_natsort} { |
||||
set versions [natsort::sort $versions] |
||||
} else { |
||||
set versions [lsort $versions] |
||||
} |
||||
lappend matchinfo [list $m $versions] |
||||
} |
||||
return [join [lsort $matchinfo] \n] |
||||
} |
||||
proc loaded.search {searchstring} { |
||||
set search_result [search $searchstring] |
||||
set all_libs [split $search_result \n] |
||||
set col1items [list] |
||||
set col2items [list] |
||||
set col3items [list] |
||||
foreach libinfo $all_libs { |
||||
if {[string trim $libinfo] eq ""} { |
||||
continue |
||||
} |
||||
set versions [lassign $libinfo libname] |
||||
if {[set ver [package provide $libname]] ne ""} { |
||||
lappend col1items $libname |
||||
lappend col2items $versions |
||||
lappend col3items $ver |
||||
} |
||||
} |
||||
|
||||
package require overtype |
||||
set title1 "Library" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1items] {string length $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
set title2 "Versions Avail." |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {string length $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
set title3 "Loaded Version" |
||||
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {string length $v}]] |
||||
set col3 [string repeat " " $widest3] |
||||
|
||||
|
||||
set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3}] |
||||
|
||||
set table "" |
||||
append table [string repeat - $tablewidth] \n |
||||
append table "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]" \n |
||||
append table [string repeat - $tablewidth] \n |
||||
foreach c1 $col1items c2 $col2items c3 $col3items { |
||||
append table "[overtype::left $col1 $c1] [overtype::left $col2 $c2] [overtype::left $col3 $c3]" \n |
||||
} |
||||
|
||||
return $table |
||||
|
||||
|
||||
set loaded_libs [list] |
||||
foreach libinfo $all_libs { |
||||
if {[string trim $libinfo] eq ""} { |
||||
continue |
||||
} |
||||
set versions [lassign $libinfo libname] |
||||
if {[set ver [package provide $libname]] ne ""} { |
||||
lappend loaded_libs "$libname $versions (loaded $ver)" |
||||
} |
||||
} |
||||
return [join $loaded_libs \n] |
||||
} |
||||
|
||||
proc info {libname} { |
||||
if {[catch {package require natsort}]} { |
||||
set has_natsort 0 |
||||
} else { |
||||
set has_natsort 1 |
||||
} |
||||
catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything |
||||
set pkgsknown [package names] |
||||
if {[set posn [lsearch $pkgsknown $libname]] >= 0} { |
||||
puts stdout "Found package [lindex $pkgsknown $posn]" |
||||
} else { |
||||
puts stderr "Package not found as available library/module - check tcl::tm::list and \$auto_path" |
||||
} |
||||
set versions [package versions [lindex $libname 0]] |
||||
if {$has_natsort} { |
||||
set versions [natsort::sort $versions] |
||||
} else { |
||||
set versions [lsort $versions] |
||||
} |
||||
if {![llength $versions]} { |
||||
puts stderr "No version numbers found for library/module $libname" |
||||
return false |
||||
} |
||||
puts stdout "Versions of $libname found: $versions" |
||||
set alphaposn [lsearch $versions "999999.*"] |
||||
if {$alphaposn >= 0} { |
||||
set alpha [lindex $versions $alphaposn] |
||||
#remove and tack onto beginning.. |
||||
set versions [lreplace $versions $alphaposn $alphaposn] |
||||
set versions [list $alpha {*}$versions] |
||||
} |
||||
foreach ver $versions { |
||||
set loadinfo [package ifneeded $libname $ver] |
||||
puts stdout "$libname $ver" |
||||
puts stdout "--- 'package ifneeded' script ---" |
||||
puts stdout $loadinfo |
||||
puts stdout "---" |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc copyasmodule {library modulefoldername args} { |
||||
set defaults [list -askme 1] |
||||
set opts [dict merge $defaults $args] |
||||
set opt_askme [dict get $opts -askme] |
||||
|
||||
if {[catch {package require natsort}]} { |
||||
set has_natsort 0 |
||||
} else { |
||||
set has_natsort 1 |
||||
} |
||||
|
||||
catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything |
||||
|
||||
if {[file pathtype $modulefoldername] eq "absolute"} { |
||||
if {![file exists $modulefoldername]} { |
||||
error "Path '$modulefoldername' not found. Enter a fully qualified path, or just the tail such as 'modules' if you are within the project to use <projectdir>/src/modules" |
||||
} |
||||
#use the target folder as the source of projectdir info |
||||
set pathinfo [punk::repo::find_repos $modulefoldername] |
||||
set projectdir [dict get $pathinfo closest] |
||||
set modulefolder_path $modulefoldername |
||||
} else { |
||||
#use the current working directory as the source of projectdir info |
||||
set pathinfo [punk::repo::find_repos [pwd]] |
||||
set projectdir [dict get $pathinfo closest] |
||||
if {$projectdir ne ""} { |
||||
set modulefolders [punk::mix::cli::lib::find_source_module_paths $projectdir] |
||||
foreach k [list modules vendormodules] { |
||||
set knownfolder [file join $projectdir src $k] |
||||
if {$knownfolder ni $modulefolders} { |
||||
lappend modulefolders $knownfolder |
||||
} |
||||
} |
||||
set mtails [list] |
||||
foreach path $modulefolders { |
||||
lappend mtails [file tail $path] |
||||
} |
||||
|
||||
#special case bootsupport/modules so it can be referred to as just bootsupport or bootsupport/modules |
||||
lappend modulefolders [file join $projectdir src bootsupport/modules] |
||||
|
||||
if {$modulefoldername ni $mtails && $modulefoldername ni "bootsupport bootsupport/modules"} { |
||||
set msg "Suplied modulefoldername '$modulefoldername' doesn't appear to be a known module folder within the project at $projectdir\n" |
||||
append msg "Known module folders: [lsort $mtails]\n" |
||||
append msg "Use a name from the above list, or a fully qualified path\n" |
||||
error $msg |
||||
} |
||||
|
||||
if {$modulefoldername eq "bootsupport"} { |
||||
set modulefoldername "bootsupport/modules" |
||||
} |
||||
set modulefolder_path [file join $projectdir src $modulefoldername] |
||||
} else { |
||||
set msg "No current project found at or above current directory\n" |
||||
append msg "Supplied modulefoldername '$modulefoldername' is a name or relative path - cannot use when outside a project." \n |
||||
append msg "Supply an absolute path for the target modulefolder, or try again from within a project directory" \n |
||||
error $msg |
||||
} |
||||
} |
||||
puts stdout "-----------------------------" |
||||
if {$projectdir ne ""} { |
||||
puts stdout "Using projectdir: $projectdir for lib.copyasmodule" |
||||
} else { |
||||
puts stdout "No current project." |
||||
} |
||||
puts stdout "-----------------------------" |
||||
if {![file exists $modulefolder_path]} { |
||||
error "Selected module folder path '$modulefolder_path' doesn't exist. Required subdirectories for namespaced modules will be created automatically - but base selected folder must exist first" |
||||
} |
||||
|
||||
|
||||
set libfound [lsearch -all -inline [package names] $library] |
||||
if {[llength $libfound] != 1 || ![string length $libfound]} { |
||||
error "Library must match exactly one entry in the list of package names visible to the current interpretor: found '$libfound'" |
||||
} |
||||
|
||||
set versions [package versions [lindex $libfound 0]] |
||||
if {$has_natsort} { |
||||
set versions [natsort::sort $versions] |
||||
} else { |
||||
set versions [lsort $versions] |
||||
} |
||||
if {![llength $versions]} { |
||||
error "No version numbers found for library/module $libfound - sorry, you will need to copy it across manually" |
||||
} |
||||
puts stdout "Versions of $libfound found: $versions" |
||||
set alphaposn [lsearch $versions "999999.*"] |
||||
if {$alphaposn >= 0} { |
||||
set alpha [lindex $versions $alphaposn] |
||||
#remove and tack onto beginning.. |
||||
set versions [lreplace $versions $alphaposn $alphaposn] |
||||
set versions [list $alpha {*}$versions] |
||||
} |
||||
|
||||
set ver [lindex $versions end] ;# todo - make selectable! don't assume tail is latest?.. package vcompare? |
||||
if {[llength $versions] > 1} { |
||||
puts stdout "Version selected: $ver" |
||||
} |
||||
|
||||
set loadinfo [package ifneeded $libfound $ver] |
||||
set loadinfo [string map [list \r\n \n] $loadinfo] |
||||
set loadinfo_lines [split $loadinfo \n] |
||||
if {[catch {llength $loadinfo}]} { |
||||
set loadinfo_is_listshaped 0 |
||||
} else { |
||||
set loadinfo_is_listshaped 1 |
||||
} |
||||
|
||||
#check for redirection to differently cased version of self - this is only detected if this is the only command in the package ifneeded result |
||||
#- must have matching version. REVIEW this requirement. Is there a legitimate reason to divert to a differently cased other-version? |
||||
set is_package_require_self_recased 0 |
||||
set is_package_require_diversion 0 |
||||
set lib_diversion_name "" |
||||
if {[llength $loadinfo_lines] == 1} { |
||||
#e.g Thread 3.0b1 diverts to thread 3.0b1 |
||||
set line1 [lindex $loadinfo_lines 0] |
||||
#check if multiparted with semicolon |
||||
#We need to distinguish "package require <lib> <ver>; more stuff" from "package require <lib> ver> ;" possibly with trailing comment? |
||||
set parts [list] |
||||
if {[regexp {;} $line1]} { |
||||
foreach p [split $line1 {;}] { |
||||
set p [string trim $p] |
||||
if {[string length $p]} { |
||||
#only append parts with some content that doesn't look like a comment |
||||
if {![string match "#*" $p]} { |
||||
lappend parts $p |
||||
} |
||||
} |
||||
} |
||||
|
||||
} |
||||
if {[llength $parts] == 1} { |
||||
#seems like a lone package require statement. |
||||
#check if package require, package\trequire etc |
||||
if {[string match "package*require" [lrange $line1 0 1]]} { |
||||
set is_package_require_diversion 1 |
||||
if {[lindex $line1 2] eq "-exact"} { |
||||
#package require -exact <pkg> <ver> |
||||
set lib_diversion_name [lindex $line1 3] |
||||
#check not an exact match - but is a -nocase match - i.e differs in case only |
||||
if {($lib_diversion_name ne $libfound) && [string match -nocase $lib_diversion_name $libfound]} { |
||||
if {[lindex $line1 4] eq $ver} { |
||||
set is_package_require_self_recased 1 |
||||
} |
||||
} |
||||
} else { |
||||
#may be package require <pkg> <ver> |
||||
#or package require <pkg> <ver> ?<ver>?... |
||||
set lib_diversion_name [lindex $line1 2] |
||||
#check not an exact match - but is a -nocase match - i.e differs in case only |
||||
if {($lib_diversion_name ne $libfound) && [string match -nocase $lib_diversion_name $libfound]} { |
||||
set requiredversions [lrange $line1 3 end] |
||||
if {$ver in $requiredversions} { |
||||
set is_package_require_self_recased 1 |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {$is_package_require_self_recased && [string length $lib_diversion_name]} { |
||||
#we only follow one level of package require redirection - seems unlikely/imprudent to follow arbitrarily in a while loop(?) |
||||
set libfound $lib_diversion_name |
||||
set loadinfo [package ifneeded $libfound $ver] |
||||
set loadinfo [string map [list \r\n \n] $loadinfo] |
||||
set loadinfo_lines [split $loadinfo \n] |
||||
if {[catch {llength $loadinfo}]} { |
||||
set loadinfo_is_listshaped 0 |
||||
} else { |
||||
set loadinfo_is_listshaped 1 |
||||
} |
||||
|
||||
|
||||
} else { |
||||
if {$is_package_require_diversion} { |
||||
#single |
||||
#for now - we'll abort and tell the user to run again with specified pkg/version |
||||
#We could automate - but it seems likely to be surprising. |
||||
puts stderr "Loadinfo for $libfound seems to be diverting to another pkg/version: $loadinfo_lines" |
||||
puts stderr "Review and consider trying with the pkg/version described in the result above." |
||||
return |
||||
} |
||||
} |
||||
|
||||
|
||||
if {$loadinfo_is_listshaped && ([llength $loadinfo] == 2 && [lindex $loadinfo 0] eq "source")} { |
||||
set source_file [lindex $loadinfo 1] |
||||
} elseif {[string match "*source*" $loadinfo]} { |
||||
set parts [list] |
||||
foreach ln $loadinfo_lines { |
||||
if {![string length $ln]} {continue} |
||||
lappend parts {*}[split $ln ";"] |
||||
} |
||||
set sources_found [list] |
||||
set loads_found [list] |
||||
set dependencies [list] |
||||
set incomplete_lines [list] |
||||
foreach p $parts { |
||||
set p [string trim $p] |
||||
if {![string length $p]} { |
||||
continue ;#empty line or trailing colon |
||||
} |
||||
if {[string match "*tclPkgSetup*" $p]} { |
||||
puts stderr "Unable to process load script for library $libfound" |
||||
puts stderr "The library appears to use the deprecated tcl library support utility 'tclPkgSetup'" |
||||
return false |
||||
} |
||||
if {![::info complete $p]} { |
||||
# |
||||
#probably a perfectly valid script - but slightly more complicated than we can handle |
||||
#better to defer to manual processing |
||||
lappend incomplete_lines $p |
||||
continue |
||||
} |
||||
if {[lindex $p 0] eq "source"} { |
||||
#may have args.. e.g -encoding utf-8 |
||||
lappend sources_found [lindex $p end] |
||||
} |
||||
if {[lindex $p 0] eq "load"} { |
||||
lappend loads_found [lrange $p 1 end] |
||||
} |
||||
if {[lrange $p 0 1] eq "package require"} { |
||||
lappend dependencies [lrange $p 2 end] |
||||
} |
||||
} |
||||
if {[llength $incomplete_lines]} { |
||||
puts stderr "unable to interpret load script for library $libfound" |
||||
puts stderr "Load info: $loadinfo" |
||||
return false |
||||
} |
||||
if {[llength $loads_found]} { |
||||
puts stderr "package $libfound appears to have binary components" |
||||
foreach l $loads_found { |
||||
puts stderr " binary - $l" |
||||
} |
||||
foreach s $sources_found { |
||||
puts stderr " script - $s" |
||||
} |
||||
puts stderr "Unable to automatically copy binary libraries to your module folder." |
||||
return false |
||||
} |
||||
|
||||
if {[llength $sources_found] != 1} { |
||||
puts stderr "sorry - unable to interpret source library location" |
||||
puts stderr "Only 1 source supported for now" |
||||
puts stderr "Load info: $loadinfo" |
||||
return false |
||||
} |
||||
if {[llength $dependencies]} { |
||||
#todo - check/ignore if dependency is Tcl ? |
||||
puts stderr "WARNING the package appears to depend on at least one other. Review and copy dependencies if required." |
||||
foreach d $dependencies { |
||||
puts stderr " - $d" |
||||
} |
||||
} |
||||
|
||||
set source_file [lindex $sources_found 0] |
||||
} else { |
||||
puts stderr "sorry - unable to interpret source library location" |
||||
puts stderr "Load info: $loadinfo" |
||||
return false |
||||
} |
||||
|
||||
# -- --------------------------------------- |
||||
#Analyse source file |
||||
if {![file exists $source_file]} { |
||||
error "Unable to verify source file existence at: $source_file" |
||||
} |
||||
set source_data [fcat $source_file -translation binary] |
||||
if {![string match "*package provide*" $source_data]} { |
||||
puts stderr "Sorry - unable to verify source file contains 'package provide' statement of some sort - copy manually" |
||||
return false |
||||
} else { |
||||
if {![string match "*$libfound*" $source_data]} { |
||||
# as an exception - look for the specific 'package provide $pkg $version' as occurs in the auto-name auto-version modules |
||||
#e.g anyname-0.1.tm example |
||||
if {![string match "*package provide \$pkg \$version*" $source_data]} { |
||||
puts stderr "Sorry - unable to verify source file contains 'package provide' and '$libfound' - copy manually" |
||||
return false |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
if {[string match "*lappend ::auto_path*" $source_data] || [string match "*lappend auto_path*" $source_data] || [string match "*set ::auto_path*" $source_data]} { |
||||
puts stderr "Sorry - '$libfound' source file '$source_file' appears to rely on ::auto_path and can't be automatically copied as a .tm module" |
||||
puts stderr "Copy the library across to a lib folder instead" |
||||
return false |
||||
} |
||||
# -- --------------------------------------- |
||||
|
||||
set moduleprefix [punk::ns::nsprefix $libfound] |
||||
if {[string length $moduleprefix]} { |
||||
set moduleprefix_parts [punk::ns::nsparts $moduleprefix] |
||||
set relative_path [file join {*}$moduleprefix_parts] |
||||
} else { |
||||
set relative_path "" |
||||
} |
||||
set pkgtail [punk::ns::nstail $libfound] |
||||
set target_path [file join $modulefolder_path $relative_path ${pkgtail}-${ver}.tm] |
||||
|
||||
if {$opt_askme} { |
||||
puts stdout "WARNING - you should check that there aren't extra required files for the library/modules" |
||||
puts stdout "" |
||||
puts stdout "This is not intended for binary modules - use at own risk and check results" |
||||
puts stdout "" |
||||
puts stdout "Base module path: $modulefolder_path" |
||||
puts stdout "Target path : $target_path" |
||||
puts stdout "results of 'package ifneeded $libfound'" |
||||
puts stdout "---" |
||||
puts stdout "$loadinfo" |
||||
puts stdout "---" |
||||
puts stdout "Proceed to create ${pkgtail}-${ver}.tm module? Y|N" |
||||
set stdin_state [fconfigure stdin] |
||||
fconfigure stdin -blocking 1 |
||||
set answer [string tolower [gets stdin]] |
||||
fconfigure stdin -blocking [dict get $stdin_state -blocking] |
||||
if {$answer ne "y"} { |
||||
puts stderr "mix libcopy.asmodule aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
|
||||
if {![file exists $modulefolder_path]} { |
||||
puts stdout "Creating module base folder at $modulefolder_path" |
||||
file mkdir $modulefolder_path |
||||
} |
||||
if {![file exists [file dirname $target_path]]} { |
||||
puts stdout "Creating relative folder at [file dirname $target_path]" |
||||
file mkdir [file dirname $target_path] |
||||
} |
||||
|
||||
if {[file exists $target_path]} { |
||||
puts stdout "WARNING - module already exists at $target_path" |
||||
if {$opt_askme} { |
||||
puts stdout "Copy anyway? Y|N" |
||||
set stdin_state [fconfigure stdin] |
||||
fconfigure stdin -blocking 1 |
||||
set answer [string tolower [gets stdin]] |
||||
fconfigure stdin -blocking [dict get $stdin_state -blocking] |
||||
if {$answer ne "y"} { |
||||
puts stderr "mix libcopy.asmodule aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
} |
||||
|
||||
file copy -force $source_file $target_path |
||||
|
||||
return $target_path |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::loadedlib [namespace eval punk::mix::commandset::loadedlib { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,419 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::module 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::module { |
||||
namespace export * |
||||
|
||||
proc paths {} { |
||||
set roots [punk::repo::find_repos ""] |
||||
set project [lindex [dict get $roots project] 0] |
||||
if {$project ne ""} { |
||||
set is_project 1 |
||||
set searchbase $project |
||||
} else { |
||||
set is_project 0 |
||||
set searchbase [pwd] |
||||
} |
||||
|
||||
if {[catch { |
||||
set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $searchbase] |
||||
} errMsg]} { |
||||
set source_module_folderlist [list] |
||||
} |
||||
|
||||
set tm_folders [tcl::tm::list] |
||||
package require overtype |
||||
|
||||
set result "" |
||||
if {$is_project} { |
||||
append result "Project module source paths:" \n |
||||
foreach f $source_module_folderlist { |
||||
append result "$f" \n |
||||
} |
||||
} |
||||
append result \n |
||||
append result "tcl::tm::list" \n |
||||
foreach f $tm_folders { |
||||
if {$is_project} { |
||||
if {[punk::mix::cli::lib::path_a_aboveorat_b $project $f]} { |
||||
set pinfo "(within project)" |
||||
} else { |
||||
set pinfo "" |
||||
} |
||||
} else { |
||||
set pinfo "" |
||||
} |
||||
set warning "" |
||||
if {![file isdirectory $f]} { |
||||
set warning "(PATH NOT FOUND)" |
||||
} |
||||
append result "$f $pinfo $warning" \n |
||||
} |
||||
|
||||
|
||||
return $result |
||||
} |
||||
#require current dir when calling to be the projectdir, or |
||||
proc templates {args} { |
||||
set tdict [templates_dict {*}$args] |
||||
|
||||
package require overtype |
||||
set paths [dict values $tdict] |
||||
set names [dict keys $tdict] |
||||
|
||||
set title1 "Path" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $paths] {punk::strlen $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
|
||||
set title2 "Template Name" |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $names] {punk::strlen $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
|
||||
set tablewidth [expr {$widest1 + 1 + $widest2}] |
||||
set table "" |
||||
append table [string repeat - $tablewidth] \n |
||||
append table "[overtype::left $col1 $title1] [overtype::left $col2 $title2]" \n |
||||
append table [string repeat - $tablewidth] \n |
||||
|
||||
foreach p $paths n $names { |
||||
append table "[overtype::left $col1 $p] [overtype::left $col2 $n]" \n |
||||
} |
||||
|
||||
return $table |
||||
} |
||||
#return all module templates with repeated ones suffixed with .2 .3 etc |
||||
proc templates_dict {args} { |
||||
tailcall lib::templates_dict {*}$args |
||||
} |
||||
proc new {module args} { |
||||
set year [clock format [clock seconds] -format %Y] |
||||
set defaults [list\ |
||||
-project \uFFFF\ |
||||
-version \uFFFF\ |
||||
-license <unspecified>\ |
||||
-template module-0.0.1.tm\ |
||||
-type \uFFFF\ |
||||
-force 0\ |
||||
] |
||||
set opts [dict merge $defaults $args] |
||||
|
||||
#todo - review compatibility between -template and -type |
||||
#-type is the wrapping technology e.g 'plain' for none or tarjar/zipkit etc (consider also snappy/snappy-tcl) |
||||
#-template may be a folder - but only if the selected -type suports it |
||||
|
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
# option -version |
||||
# we need this value before looking at the named argument |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_version_supplied [dict get $opts -version] |
||||
if {$opt_version_supplied eq "\uFFFF"} { |
||||
set opt_version "0.1.0" |
||||
} else { |
||||
set opt_version $opt_version_supplied |
||||
if {![util::is_valid_tm_version $opt_version]} { |
||||
error "pmix module.new error - supplied -version $opt_version doesn't appear to be a valid Tcl module version" |
||||
} |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
#named argument |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set mversion_supplied "" ;#version supplied directly in module argument |
||||
if {[string first - $module]> 0} { |
||||
#if it has a dash then version is required to be valid |
||||
lassign [punk::mix::cli::lib::split_modulename_version $module] modulename mversion |
||||
if {![util::is_valid_tm_version $mversion]} { |
||||
error "pmix module.new error - unable to determine modulename-version from supplied value '$module'" |
||||
} |
||||
set mversion_supplied $mversion ;#record as may need to compare to version from templatefile name |
||||
set vcompare_is_mversion_bigger [package vcompare $mversion $opt_version] |
||||
if {$vcompare_is_mversion_bigger > 0} { |
||||
set opt_version $mversion; #module parameter has higher value than -version |
||||
set vmsg "from module argument: $module" |
||||
} else { |
||||
set vmsg "from -version option: $opt_version_supplied" |
||||
} |
||||
if {$opt_version_supplied ne "\uFFFF"} { |
||||
if {$vcompare_is_mversion_bigger != 0} { |
||||
#is bigger or smaller |
||||
puts stderr "module.new WARNING: version supplied in module argument as well as -version option. Using the higher version number $vmsg" |
||||
} |
||||
} |
||||
} else { |
||||
set modulename $module |
||||
} |
||||
punk::mix::cli::lib::validate_modulename $modulename -name_description "mix module.new name" |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
#options |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_project [dict get $opts -project] |
||||
set testdir [pwd] |
||||
if {![string length [set projectdir [punk::repo::find_project $testdir]]]} { |
||||
if {![string length [set projectdir [punk::repo::find_candidate $testdir]]]} { |
||||
set msg [punkc::repo::is_candidate_root_requirements_msg] |
||||
error "module.new unable to create module in projectdir:$projectdir - directory doesn't appear to meet basic standards $msg" |
||||
} |
||||
} |
||||
if {$opt_project == "\uFFFF"} { |
||||
set projectname [file tail $projectdir] |
||||
} else { |
||||
set projectname $opt_project |
||||
if {$projectname ne [file tail $projectdir]} { |
||||
error "module.new -project '$opt_project' doesn't match detected projectname '$projectname' at path: $projectdir" |
||||
} |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_license [dict get $opts -license] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_template [dict get $opts -template] |
||||
|
||||
set templates_dict [templates_dict] ;#possibly suffixed with .2 .3 etc |
||||
#todo - allow versionless name - pick latest which isn't suffixed with .2 etc |
||||
if {![dict exists $templates_dict $opt_template]} { |
||||
error "module.new unable to find template '$opt_template'. Known templates: [dict keys $templates_dict]" |
||||
} |
||||
set templatefile [dict get $templates_dict $opt_template] |
||||
set tpldir [file dirname $templatefile] ;#use same folder for modulename_buildversion.txt, modulename_description.txt if they exist |
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_type [dict get $opts -type] |
||||
if {$opt_type eq "\uFFFF"} { |
||||
set opt_type [lindex [punk::mix::cli::lib::module_types] 0] ;#default to plain |
||||
} |
||||
if {$opt_type ni [punk::mix::cli::lib::module_types]} { |
||||
error "module.new - error - unknown -type '$opt_type' known-types: [punk::mix::cli::lib::module_types]" |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
set subpath [punk::mix::cli::lib::module_subpath $modulename] ;#commonly empty string for simple modulename e.g "mymodule" but x::mymodule has subpath 'x' and x::y::mymodule has subpath 'x/y' |
||||
if {![string length $subpath]} { |
||||
set modulefolder $projectdir/src/modules |
||||
} else { |
||||
set modulefolder $projectdir/src/modules/$subpath |
||||
} |
||||
file mkdir $modulefolder |
||||
|
||||
set moduletail [namespace tail $modulename] |
||||
set magicversion [punk::mix::util::magic_tm_version] ;#deliberately large so given load-preference when testing |
||||
|
||||
|
||||
|
||||
|
||||
set template_tail [file tail $templatefile] ;#convert template_xxx-version.tm.x to {xxx version} |
||||
set template_tail [string range $template_tail [string length template_] end] |
||||
set ext [string tolower [file extension $template_tail]] |
||||
if {$ext eq ".tm"} { |
||||
set template_modulename_part [file rootname $template_tail] |
||||
} elseif {[string is integer -strict [string range $ext 1 end]]} { |
||||
#something like modulename-0.0.1.tm.2 |
||||
#strip of last 2 dotted parts |
||||
set shortened [file rootname $template_tail] |
||||
if {![string equal -nocase [file extension $shortened] ".tm"]} { |
||||
error "module.new error: Unable to interpret filename components of template file '$templatefile' (expected .tm as second-last or last component)" |
||||
} |
||||
set template_modulename_part [file rootname $shortened] |
||||
} else { |
||||
error "module.new error: Unable to interpret filename components of template file '$templatefile'" |
||||
} |
||||
lassign [punk::mix::cli::lib::split_modulename_version $template_modulename_part] t_mname t_version |
||||
#t_version may be empty string if template is unversioned e.g template_whatever.tm |
||||
|
||||
set fd [open $templatefile r]; set template_filedata [read $fd]; close $fd |
||||
if {[string match "*$magicversion*" $template_filedata]} { |
||||
set use_magic 1 |
||||
set build_version $opt_version |
||||
set infile_version $magicversion |
||||
} else { |
||||
set use_magic 0 |
||||
if {$opt_version_supplied ne "\uFFFF"} { |
||||
set build_version $opt_version |
||||
} else { |
||||
if {[util::is_valid_tm_version $t_version]} { |
||||
if {$mversion_supplied eq ""} { |
||||
set build_version $t_version |
||||
} else { |
||||
#we have a version from the named argument 'module' |
||||
if {[package vcompare $mversion_supplied $t_version] > 0} { |
||||
set build_version $mversion_supplied |
||||
} else { |
||||
set build_version $t_version |
||||
} |
||||
} |
||||
} else { |
||||
#probably an unversioned module template |
||||
#use opt_version default from above |
||||
set build_version $opt_version |
||||
} |
||||
} |
||||
set infile_version $build_version |
||||
} |
||||
|
||||
set template_filedata [string map [list %pkg% $modulename %year% $year %license% $opt_license %version% $infile_version] $template_filedata] |
||||
|
||||
set modulefile $modulefolder/${moduletail}-$infile_version.tm |
||||
if {[file exists $modulefile]} { |
||||
set errmsg "module.new error: module file $modulefile already exists - aborting" |
||||
if {[string match "*$magicversion*" $modulefile]} { |
||||
append errmsg \n "If you are attempting to create a module file with a specific version in the source-file name - you will need to use a template that doesn't contain the string '$magicversion' e.g the provided template moduleexactversion-0.0.1.tm" |
||||
} |
||||
error $errmsg |
||||
} |
||||
|
||||
|
||||
if {[file exists $tpldir/modulename_buildversion.txt]} { |
||||
set fd [open $tpldir/modulename_buildversion.txt r]; set buildversion_filedata [read $fd]; close $fd |
||||
} else { |
||||
#mix_templates_dir warns of deprecation - review |
||||
set lib_tpldir [file join [punk::mix::cli::lib::mix_templates_dir] modules];#fallback for modulename_buildversion.txt, modulename_description.txt |
||||
set fd [open $lib_tpldir/modulename_buildversion.txt r]; set buildversion_filedata [read $fd]; close $fd |
||||
} |
||||
set buildversionfile [file join $modulefolder ${moduletail}-buildversion.txt] |
||||
set existing_build_version "" |
||||
if {[file exists $buildversionfile]} { |
||||
set buildversiondata [punk::mix::util::fcat $buildversionfile] |
||||
set lines [split $buildversiondata \n] |
||||
set existing_build_version [string trim [lindex $lines 0]] |
||||
if {[package vcompare $existing_build_version $build_version] >= 0} { |
||||
#existing version in -buildversion.txt file is lower than the module version we are creating |
||||
error "module.new error: there is an existing buildversion file $buildversionfile with version $existing_build_version equal to or higher than $build_version - unable to continue" |
||||
} |
||||
} |
||||
|
||||
set existing_versions [glob -nocomplain -dir $modulefolder -tails ${moduletail}-*.tm] |
||||
#it shouldn't be possible to overmatch with the glob - because '-' is not valid in a Tcl module name |
||||
if {[llength $existing_versions]} { |
||||
set name_version_pairs [list] |
||||
lappend name_version_pairs [list $moduletail $infile_version] |
||||
foreach existing $existing_versions { |
||||
lappend name_version_pairs [punk::mix::cli::lib::split_modulename_version $existing] ;# .tm is stripped and ignored |
||||
} |
||||
set name_version_pairs [lsort -command {package vcompare} -index 1 $name_version_pairs] ;#while plain lsort will often work with versions - it can get order wrong with some - so use package vcompare |
||||
if {[lindex $name_version_pairs end] ne [list $moduletail $infile_version]} { |
||||
set thisposn [lsearch -index 1 $name_version_pairs $infile_version] |
||||
set name_version_pairs [lreplace $name_version_pairs $thisposn $thisposn] |
||||
set other_versions [lsearch -all -inline -index 1 -subindices $name_version_pairs *] |
||||
set errmsg "module.new error: There are existing modules in the target folder with higher versions than $infile_version." |
||||
append errmsg \n "Other versions found: $other_versions" |
||||
if {$magicversion in $other_versions} { |
||||
append errmsg \n "Existing build version for special source file name: '$magicversion' is: '$existing_build_version'" |
||||
append errmsg \n "If '$magicversion' file doesn't represent the latest source it should be removed or the filename and contents adjusted to be a specific version" |
||||
} |
||||
error $errmsg |
||||
} else { |
||||
puts stderr "module.new WARNING: There are existing modules in the target folder with lower versions than $infile_version - manual review recommended" |
||||
puts stderr "Other versions found: [lsearch -all -inline -index 1 -subindices [lrange $name_version_pairs 0 end-1] *]" |
||||
} |
||||
} |
||||
|
||||
|
||||
set fd [open $modulefile w] |
||||
fconfigure $fd -translation binary |
||||
puts -nonewline $fd $template_filedata |
||||
close $fd |
||||
|
||||
|
||||
set buildversion_filedata [string map [list %Major.Minor.Level% $build_version] $buildversion_filedata] |
||||
set fd [open $buildversionfile w] |
||||
fconfigure $fd -translation binary |
||||
puts -nonewline $fd $buildversion_filedata |
||||
close $fd |
||||
|
||||
return [list file $modulefile version $build_version] |
||||
} |
||||
|
||||
namespace eval lib { |
||||
proc templates_dict {args} { |
||||
set defaults [list -scriptpath ""] |
||||
set opts [dict merge $defaults $args] |
||||
set opt_scriptpath [dict get $opts -scriptpath] |
||||
|
||||
set module_template_bases [list] |
||||
set tbasedict [punk::mix::base::lib::get_template_basefolders $opt_scriptpath] |
||||
dict for {tbase folderinfo} $tbasedict { |
||||
lappend module_template_bases [file join $tbase modules] |
||||
} |
||||
|
||||
|
||||
|
||||
set template_files [list] |
||||
foreach basefld $module_template_bases { |
||||
set matched_files [glob -nocomplain -dir $basefld -type f template_*] |
||||
foreach tf $matched_files { |
||||
if {[string match ignore* $tf]} { |
||||
continue |
||||
} |
||||
set ext [file extension $tf] |
||||
if {$ext in [list ".tm"]} { |
||||
lappend template_files $tf |
||||
} |
||||
} |
||||
} |
||||
|
||||
set tdict [dict create] |
||||
set seen_dict [dict create] |
||||
foreach fullpath $template_files { |
||||
set ftail [file tail $fullpath] |
||||
set tname [string range $ftail [string length template_] end] |
||||
if {![dict exists $seen_dict $tname]} { |
||||
dict set seen_dict $tname 1 |
||||
dict set tdict $tname $fullpath ; #first seen of filename gets no number |
||||
} else { |
||||
set n [dict get $seen_dict $tname] |
||||
incr n |
||||
dict incr seen_dict $tname |
||||
dict set tdict ${tname}.$n $fullpath |
||||
} |
||||
} |
||||
return $tdict |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::module [namespace eval punk::mix::commandset::module { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,849 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::project 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::project { |
||||
namespace export * |
||||
|
||||
#new project structure - may be dedicated to one module, or contain many. |
||||
#create minimal folder structure only by specifying -modules {} |
||||
proc new {newprojectpath_or_name args} { |
||||
if {[file pathtype $newprojectpath_or_name] eq "absolute"} { |
||||
set projectfullpath [file normalize $newprojectpath_or_name] |
||||
set projectname [file tail $projectfullpath] |
||||
set projectparentdir [file dirname $newprojectpath_or_name] |
||||
} else { |
||||
set projectfullpath [file join [pwd] $newprojectpath_or_name] |
||||
set projectname [file tail $projectfullpath] |
||||
set projectparentdir [file dirname $projectfullpath] |
||||
} |
||||
if {[file type $projectparentdir] ne "directory"} { |
||||
error "punk::mix::cli::new error: unable to determine containing folder for '$newprojectpath_or_name'" |
||||
} |
||||
|
||||
punk::mix::cli::lib::validate_projectname $projectname -name_description "punk mix project.new" |
||||
|
||||
|
||||
set defaults [list\ |
||||
-type plain\ |
||||
-empty 0\ |
||||
-force 0\ |
||||
-update 0\ |
||||
-confirm 1\ |
||||
-modules \uFFFF\ |
||||
-layout project |
||||
] ;#todo |
||||
set known_opts [dict keys $defaults] |
||||
foreach {k v} $args { |
||||
if {$k ni $known_opts} { |
||||
error "project.new error: option '$k' not known. Known options: $known_opts" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_type [dict get $opts -type] |
||||
if {$opt_type ni [punk::mix::cli::lib::module_types]} { |
||||
error "pmix new error - unknown type '$opt_type' known types: [punk::mix::cli::lib::module_types]" |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_force [dict get $opts -force] |
||||
set opt_confirm [string tolower [dict get $opts -confirm]] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_modules [dict get $opts -modules] |
||||
if {[llength $opt_modules] == 1 && [lindex $opt_modules 0] eq "\uFFFF"} { |
||||
#if not specified - add a single module matching project name |
||||
set opt_modules [list $projectname] |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_layout [dict get $opts -layout] |
||||
set opt_update [dict get $opts -update] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
|
||||
|
||||
set fossil_prog [auto_execok fossil] |
||||
if {![string length $fossil_prog]} { |
||||
puts stderr "The fossil program was not found. A fossil executable is required to use most pmix features." |
||||
if {[string length [set scoop_prog [auto_execok scoop]]]} { |
||||
#restrict to windows? |
||||
set answer [util::askuser "scoop detected. Would you like pmix to install fossil now using scoop? Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." |
||||
return |
||||
} |
||||
#we don't assume 'unknown' is configured to run shell commands |
||||
if {[string length [package provide shellrun]]} { |
||||
set exitinfo [run {*}$scoop_prog install fossil] |
||||
#scoop tends to return successful exitcode (0) even when packages not found etc. - so exitinfo not much use. |
||||
puts stdout "scoop install fossil ran with result: $exitinfo" |
||||
} else { |
||||
puts stdout "Please wait while scoop runs - there may be a slight delay and then scoop output will be shown. (use punk shellrun package for )" |
||||
set result [exec {*}$scoop_prog install fossil] |
||||
puts stdout $result |
||||
} |
||||
catch {::auto_reset} ;#can be missing (unsure under what circumstances - but I've seen it raise error 'invalid command name "auto_reset"') |
||||
if {![string length [auto_execok fossil]]} { |
||||
puts stderr "Fossil still not detected. If it was successfully installed, try restarting your punk/tcl shell." |
||||
return |
||||
} |
||||
#todo - ask user if they want to configure fosssil first.. |
||||
set answer [util::askuser "Fossil command now appears to be available. You may wish to answer N to exit and customize it - but default config may be ok. Type the word 'continue' to proceed with default configuration."] |
||||
if {[string tolower $answer] ne "continue"} { |
||||
return |
||||
} |
||||
|
||||
} else { |
||||
puts stdout "See: https://fossil-scm.org/home/uv/download.html" |
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
puts stdout "Consider using a package manager such as scoop: https://scoop.sh" |
||||
puts stdout "(Then: scoop install fossil)" |
||||
} |
||||
return |
||||
} |
||||
} |
||||
set startdir [pwd] |
||||
if {[set in_project [punk::repo::find_project $startdir]] ne ""} { |
||||
# use this project as source of templates |
||||
puts stdout "-------------------------------------------" |
||||
puts stdout "Currently in a project directory '$in_project'" |
||||
puts stdout "This project will be searched for templates" |
||||
puts stdout "-------------------------------------------" |
||||
} |
||||
set template_base_dict [punk::mix::base::lib::get_template_basefolders] |
||||
set template_bases_containing_layout [list] |
||||
dict for {tbase folderinfo} $template_base_dict { |
||||
if {[file exists $tbase/layouts/$opt_layout]} { |
||||
lappend template_bases_containing_layout $tbase |
||||
} |
||||
} |
||||
if {![llength $template_bases_containing_layout]} { |
||||
puts stderr "layout '$opt_layout' was not found in template dirs" |
||||
puts stderr "searched [dict size $template_base_dict] template folders" |
||||
dict for {tbase folderinfo} $template_base_dict { |
||||
puts stderr " - $tbase $folderinfo" |
||||
} |
||||
return |
||||
} |
||||
#review: silently use last entry which had the layout (?) |
||||
set templatebase [lindex $template_bases_containing_layout end] |
||||
|
||||
|
||||
|
||||
#todo - detect whether inside cwd-project or inside a different project |
||||
set projectdir $projectparentdir/$projectname |
||||
if {[set target_in_project [punk::repo::find_project $projectparentdir]] ne ""} { |
||||
puts stderr "Target location for new project is already within a project: $target_in_project" |
||||
error "Nested projects not yet supported aborting" |
||||
} |
||||
|
||||
|
||||
|
||||
if {[punk::repo::is_git $projectparentdir]} { |
||||
puts stderr "mix new WARNING: target project location is within a git repo based at [punk::repo::find_git $projectparentdir]" |
||||
puts stderr "The new project will create a fossil repository (which you are free to ignore - but but will be used to confirm project base)" |
||||
puts stderr "If you intend to use both git and fossil in the same project space - you should research and understand the details and any possible interactions/issues" |
||||
set answer [util::askuser "Do you want to proceed to create a project based at: $projectdir? Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
set is_nested_fossil 0 ;#default assumption |
||||
if {[punk::repo::is_fossil $projectparentdir]} { |
||||
puts stderr "mix new WARNING: target project location is within an open fossil repo based at [punk::repo::find_fossil $projectparentdir] NESTED fossil repository" |
||||
if {$opt_confirm ni [list 0 no false]} { |
||||
puts stderr "If you proceed - the new project's fossil repo will be created using the --nested flag" |
||||
set answer [util::askuser "Do you want to proceed to create a NESTED project based at: $projectdir? Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." |
||||
return |
||||
} |
||||
set is_nested_fossil 1 |
||||
} |
||||
} |
||||
|
||||
|
||||
set project_dir_exists [file exists $projectdir] |
||||
if {$project_dir_exists && !($opt_force || $opt_update)} { |
||||
puts stderr "Unable to create new project at $projectdir - file/folder already exists use -update 1 to fill in missing items from template use -force 1 to overwrite from template" |
||||
return |
||||
} elseif {$project_dir_exists && $opt_force} { |
||||
puts stderr "mix new WARNING: -force 1 was supplied. Will copy layout $templatebase/layouts/$opt_layout using -force option to overwrite from template" |
||||
if {$opt_confirm ni [list 0 no false]} { |
||||
set answer [util::askuser "Do you want to proceed to possibly overwrite existing files in $projectdir? Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
} elseif {$project_dir_exists && $opt_update} { |
||||
puts stderr "mix new WARNING: -update 1 was supplied. Will copy layout $templatebase/layouts/$opt_layout using -update option to add missing items" |
||||
} |
||||
|
||||
set fossil_repo_file "" |
||||
set is_fossil_root 0 |
||||
if {$project_dir_exists && [punk::repo::is_fossil_root $projectdir]} { |
||||
set is_fossil_root 1 |
||||
set fossil_repo_file [punk::repo::fossil_get_repository_file $projectdir] |
||||
if {$fossil_repo_file ne ""} { |
||||
set repodb_folder [file dirname $fossil_repo_file] |
||||
} |
||||
} |
||||
|
||||
if {$fossil_repo_file eq ""} { |
||||
set repodb_folder [punk::repo::fossil_get_repository_folder_for_project $projectname -parentfolder $startdir] |
||||
if {![string length $repodb_folder]} { |
||||
puts stderr "No usable repository database folder selected for $projectname.fossil file" |
||||
return |
||||
} |
||||
} |
||||
if {[file exists $repodb_folder/$projectname.fossil]} { |
||||
puts stdout "NOTICE: $repodb_folder/$projectname.fossil already exists" |
||||
if {!($opt_force || $opt_update)} { |
||||
puts stderr "-force 1 or -update 1 not specified - aborting" |
||||
return |
||||
} |
||||
} |
||||
|
||||
if {$fossil_repo_file eq ""} { |
||||
puts stdout "Initialising fossil repo: $repodb_folder/$projectname.fossil" |
||||
set fossilinit [runx -n {*}$fossil_prog init $repodb_folder/$projectname.fossil -project-name $projectname] |
||||
if {[dict get $fossilinit exitcode] != 0} { |
||||
puts stderr "fossil init failed:" |
||||
puts stderr [dict get $fossilinit stderr] |
||||
return |
||||
} else { |
||||
puts stdout "fossil init result:" |
||||
puts stdout [dict get $fossilinit stdout] |
||||
} |
||||
} |
||||
|
||||
file mkdir $projectdir |
||||
|
||||
set layout_dir $templatebase/layouts/$opt_layout |
||||
puts stdout ">>> about to call punkcheck::install $layout_dir $projectdir" |
||||
set resultdict [dict create] |
||||
set unpublish [list\ |
||||
src/doc/*\ |
||||
src/doc/include/*\ |
||||
] |
||||
|
||||
#default antiglob_dir_core will stop .fossil* from being updated - which is generally desirable as these are likely to be customized |
||||
if {$opt_force} { |
||||
puts stdout "copying layout files - with force applied - overwrite all-targets" |
||||
set resultdict [punkcheck::install $layout_dir $projectdir -installer project.new -overwrite ALL-TARGETS -unpublish_paths $unpublish] |
||||
#file copy -force $layout_dir $projectdir |
||||
} else { |
||||
puts stdout "copying layout files - (if source file changed)" |
||||
set resultdict [punkcheck::install $layout_dir $projectdir -installer project.new -overwrite installedsourcechanged-targets -unpublish_paths $unpublish] |
||||
} |
||||
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
||||
|
||||
puts stdout "copying layout src/doc files (if target missing)" |
||||
set resultdict [punkcheck::install $layout_dir/src/doc $projectdir/src/doc -punkcheck_folder $projectdir -installer project.new -overwrite SYNCED-TARGETS] |
||||
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
||||
|
||||
#target folders .fossil-custom and .fossil-settings may not exist. use -createdir 1 to ensure existence. |
||||
#In this case we need to override the default dir antiglob - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized. |
||||
## default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"] |
||||
set override_antiglob_dir_core [list #* _aside .git] |
||||
puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)" |
||||
set resultdict [punkcheck::install $layout_dir/.fossil-custom $projectdir/.fossil-custom -createdir 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] |
||||
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
||||
|
||||
puts stdout "copying layout src/.fossil-settings files (if target missing or uncustomised)" |
||||
set resultdict [punkcheck::install $layout_dir/.fossil-settings $projectdir/.fossil-settings -createdir 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] |
||||
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
||||
|
||||
|
||||
|
||||
|
||||
#lappend substfiles $projectdir/README.md |
||||
#lappend substfiles $projectdir/src/README.md |
||||
#lappend substfiles $projectdir/src/doc/main.man |
||||
#expect this in all templates? - todo make these substitutions independent of specific paths and filenames? |
||||
#scan all files in template |
||||
# |
||||
#TODO - pmix command to substitute templates? |
||||
set templatefiles [punk::mix::commandset::layout::lib::layout_scan_for_template_files $opt_layout] |
||||
set stripprefix [file normalize $layout_dir] |
||||
|
||||
foreach templatefullpath $templatefiles { |
||||
set templatetail [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] |
||||
|
||||
set fpath [file join $projectdir $templatetail] |
||||
if {[file exists $fpath]} { |
||||
set fd [open $fpath r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd |
||||
set data2 [string map [list %project% $projectname] $data] |
||||
if {$data2 ne $data} { |
||||
puts stdout "updated template file: $fpath" |
||||
set fdout [open $fpath w]; fconfigure $fdout -translation binary; puts -nonewline $fdout $data2; close $fdout |
||||
} |
||||
} else { |
||||
puts stderr "warning: Missing template file $fpath" |
||||
} |
||||
} |
||||
#todo - tag substitutions in src/doc tree |
||||
|
||||
|
||||
cd $projectdir |
||||
|
||||
if {[file exists $projectdir/src/modules]} { |
||||
foreach m $opt_modules { |
||||
if {![file exists $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm]} { |
||||
punk::mix::commandset::module::new $m -project $projectname -type $opt_type |
||||
} else { |
||||
if {$opt_force} { |
||||
punk::mix::commandset::module::new $m -project $projectname -type $opt_type -force 1 |
||||
} |
||||
} |
||||
} |
||||
} else { |
||||
puts stderr "project.new WARNING template hasn't created src/modules - skipping creation of new module(s) for project" |
||||
} |
||||
|
||||
#generate www/man/md output in 'embedded' folder which should be checked into repo for online documentation |
||||
if {[file exists $projectdir/src]} { |
||||
cd $projectdir/src |
||||
#---------- |
||||
set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] |
||||
$installer set_source_target $projectdir/src/doc $projectdir/src/embedded |
||||
set event [$installer start_event {-install_step kettledoc}] |
||||
$event targetset_init VIRTUAL kettle_build_doc ;#VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated |
||||
$event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source |
||||
#---------- |
||||
if {\ |
||||
[llength [dict get [$event targetset_source_changes] changed]]\ |
||||
} { |
||||
$event targetset_started |
||||
# -- --- --- --- --- --- |
||||
puts stdout "BUILDING DOCS at src/embedded from src/doc" |
||||
if {[catch { |
||||
|
||||
punk::mix::cli::lib::kettle_call lib doc |
||||
#Kettle doc |
||||
|
||||
} errM]} { |
||||
$event targetset_end FAILED -note "kettle_build_doc failed: $errM" |
||||
} else { |
||||
$event targetset_end OK |
||||
} |
||||
# -- --- --- --- --- --- |
||||
} else { |
||||
puts stderr "No change detected in src/doc" |
||||
$event targetset_end SKIPPED |
||||
} |
||||
$event end |
||||
$event destroy |
||||
$installer destroy |
||||
} |
||||
|
||||
cd $projectdir |
||||
|
||||
if {![punk::repo::is_fossil_root $projectdir]} { |
||||
set first_fossil 1 |
||||
#-k = keep. (only modify the manifest file(s)) |
||||
if {$is_nested_fossil} { |
||||
set fossilopen [runx -n {*}$fossil_prog open --nested $repodb_folder/$projectname.fossil -k --workdir $projectdir] |
||||
} else { |
||||
set fossilopen [runx -n {*}$fossil_prog open $repodb_folder/$projectname.fossil -k --workdir $projectdir] |
||||
} |
||||
if {[file exists $projectdir/_FOSSIL_] && ![file exists $projectdir/.fslckout]} { |
||||
file rename $projectdir/_FOSSIL_ $projectdir/.fslckout |
||||
} |
||||
if {[dict get $fossilopen exitcode] != 0} { |
||||
puts stderr "fossil open in project workdir '$projectdir' FAILED:" |
||||
puts stderr [dict get $fossilopen stderr] |
||||
return |
||||
} else { |
||||
puts stdout "fossil open in project workdir '$projectdir' OK:" |
||||
puts stdout [dict get $fossilopen stdout] |
||||
} |
||||
} else { |
||||
set first_fossil 0 |
||||
} |
||||
set fossiladd [runx -n {*}$fossil_prog add --dotfiles $projectdir] |
||||
if {[dict get $fossiladd exitcode] != 0} { |
||||
puts stderr "fossil add workfiles in workdir '$projectdir' FAILED:" |
||||
puts stderr [dict get $fossiladd stderr] |
||||
return |
||||
} else { |
||||
puts stdout "fossil add workfiles in workdir '$projectdir' OK:" |
||||
puts stdout [dict get $fossiladd stdout] |
||||
} |
||||
if {$first_fossil} { |
||||
#fossil commit may prompt user for input.. runx runout etc will pause with no prompts |
||||
util::do_in_path $projectdir { |
||||
set fossilcommit [run -n {*}$fossil_prog commit -m "initial project commit"] |
||||
} |
||||
if {[dict get $fossilcommit exitcode] != 0} { |
||||
puts stderr "fossil commit in workdir '$projectdir' FAILED" |
||||
return |
||||
} else { |
||||
puts stdout "fossil commit in workdir '$projectdir' OK" |
||||
} |
||||
} |
||||
|
||||
puts stdout "-done- project:$projectname projectdir: $projectdir" |
||||
} |
||||
|
||||
|
||||
namespace eval collection { |
||||
namespace export * |
||||
namespace path [namespace parent] |
||||
|
||||
#e.g imported as 'projects' |
||||
proc _default {{glob {}} args} { |
||||
package require overtype |
||||
set db_projects [lib::get_projects $glob] |
||||
set col1items [lsearch -all -inline -index 0 -subindices $db_projects *] |
||||
set col2items [lsearch -all -inline -index 1 -subindices $db_projects *] |
||||
set checkouts [lsearch -all -inline -index 2 -subindices $db_projects *] |
||||
set col3items [lmap v $checkouts {llength $v}] |
||||
|
||||
set title1 "Fossil DB" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1items] {punk::strlen $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
set title2 "File Name" |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {punk::strlen $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
set title3 "Checkouts" |
||||
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {punk::strlen $v}]] |
||||
set col3 [string repeat " " $widest3] |
||||
set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3}] |
||||
|
||||
|
||||
append msg "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]" \n |
||||
append msg [string repeat "=" $tablewidth] \n |
||||
foreach p $col1items n $col2items c $col3items { |
||||
append msg "[overtype::left $col1 $p] [overtype::left $col2 $n] [overtype::right $col3 $c]" \n |
||||
} |
||||
return $msg |
||||
#return [list_as_lines [lib::get_projects $glob]] |
||||
} |
||||
proc detail {{glob {}} args} { |
||||
package require overtype |
||||
package require textutil |
||||
set defaults [dict create\ |
||||
-description 0\ |
||||
] |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- |
||||
set opt_description [dict get $opts -description] |
||||
# -- --- --- --- --- --- --- |
||||
|
||||
|
||||
set db_projects [lib::get_projects $glob] |
||||
set col1_dbfiles [lsearch -all -inline -index 0 -subindices $db_projects *] |
||||
set col2items [lsearch -all -inline -index 1 -subindices $db_projects *] |
||||
set checkouts [lsearch -all -inline -index 2 -subindices $db_projects *] |
||||
set col3items [lmap v $checkouts {llength $v}] |
||||
|
||||
set col4_pnames [list] |
||||
set col5_pcodes [list] |
||||
set col6_dupids [list] |
||||
set col7_pdescs [list] |
||||
set codes [dict create] |
||||
foreach dbfile $col1_dbfiles { |
||||
set project_name "" |
||||
set project_code "" |
||||
set project_desc "" |
||||
sqlite3 dbp $dbfile |
||||
dbp eval {select name,value from config where name like 'project-%';} r { |
||||
if {$r(name) eq "project-name"} { |
||||
set project_name $r(value) |
||||
} elseif {$r(name) eq "project-code"} { |
||||
set project_code $r(value) |
||||
} elseif {$r(name) eq "project-description"} { |
||||
set project_desc $r(value) |
||||
} |
||||
} |
||||
dbp close |
||||
lappend col4_pnames $project_name |
||||
lappend col5_pcodes $project_code |
||||
dict lappend codes $project_code $dbfile |
||||
lappend col7_pdescs $project_desc |
||||
} |
||||
|
||||
set setid 1 |
||||
set codeset [dict create] |
||||
dict for {code dbs} $codes { |
||||
if {[llength $dbs]>1} { |
||||
dict set codeset $code setid $setid |
||||
dict set codeset $code count [llength $dbs] |
||||
dict set codeset $code seen 0 |
||||
incr setid |
||||
} |
||||
} |
||||
set dupid 1 |
||||
foreach pc $col5_pcodes { |
||||
if {[dict exists $codeset $pc]} { |
||||
set seen [dict get $codeset $pc seen] |
||||
set this_seen [expr {$seen + 1}] |
||||
dict set codeset $pc seen $this_seen |
||||
lappend col6_dupids "[dict get $codeset $pc setid].${this_seen}/[dict get $codeset $pc count]" |
||||
} else { |
||||
lappend col6_dupids "" |
||||
} |
||||
} |
||||
|
||||
set title1 "Fossil DB" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1_dbfiles] {punk::strlen $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
set title2 "File Name" |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {punk::strlen $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
set title3 "Checkouts" |
||||
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {punk::strlen $v}]] |
||||
set col3 [string repeat " " $widest3] |
||||
set title4 "Project Name" |
||||
set widest4 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col4_pnames] {punk::strlen $v}]] |
||||
set col4 [string repeat " " $widest4] |
||||
set title5 "Project Code" |
||||
set widest5 [tcl::mathfunc::max {*}[lmap v [concat [list $title5] $col5_pcodes] {punk::strlen $v}]] |
||||
set col5 [string repeat " " $widest5] |
||||
set title6 "Dup" |
||||
set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col6_dupids] {punk::strlen $v}]] |
||||
set col6 [string repeat " " $widest6] |
||||
set title7 "Description" |
||||
#set widest7 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col7_pdescs] {punk::strlen $v}]] |
||||
set widest7 35 |
||||
set col7 [string repeat " " $widest7] |
||||
|
||||
|
||||
set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3 +1 + $widest4 + 1 + $widest5 + 1 + $widest6}] |
||||
|
||||
append msg "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]\ |
||||
[overtype::left $col4 $title4] [overtype::left $col5 $title5] [overtype::left $col6 $title6]" |
||||
if {!$opt_description} { |
||||
append msg \n |
||||
} else { |
||||
append msg "[overtype::left $col7 $title7]" \n |
||||
set tablewidth [expr {$tablewidth + 1 + $widest7}] |
||||
} |
||||
|
||||
append msg [string repeat "=" $tablewidth] \n |
||||
foreach p $col1_dbfiles n $col2items c $col3items pn $col4_pnames pc $col5_pcodes dup $col6_dupids desc $col7_pdescs { |
||||
set desclines [split [textutil::adjust $desc -length $widest7] \n] |
||||
set desc1 [lindex $desclines 0] |
||||
append msg "[overtype::left $col1 $p] [overtype::left $col2 $n] [overtype::right $col3 $c]\ |
||||
[overtype::left $col4 $pn] [overtype::left $col5 $pc] [overtype::left $col6 $dup]" |
||||
if {!$opt_description} { |
||||
append msg \n |
||||
} else { |
||||
append msg " [overtype::left $col7 $desc1]" \n |
||||
foreach dline [lrange $desclines 1 end] { |
||||
append msg "$col1 $col2 $col3 $col4 $col5 $col6 [overtype::left $col7 $dline]" \n |
||||
} |
||||
} |
||||
} |
||||
return $msg |
||||
#return [list_as_lines [lib::get_projects $glob]] |
||||
} |
||||
proc cd {{glob {}} args} { |
||||
dict set args -cd 1 |
||||
work $glob {*}$args |
||||
} |
||||
proc work {{glob {}} args} { |
||||
package require sqlite3 |
||||
set db_projects [lib::get_projects $glob] |
||||
#list of lists of the form: |
||||
#{fosdb fname workdirlist} |
||||
set defaults [dict create\ |
||||
-cd 0\ |
||||
] |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- |
||||
set opt_cd [dict get $opts -cd] |
||||
# -- --- --- --- --- --- --- |
||||
set workdir_dict [dict create] |
||||
set all_workdirs [list] |
||||
foreach pinfo $db_projects { |
||||
lassign $pinfo fosdb name workdirs |
||||
foreach wdir $workdirs { |
||||
dict set workdir_dict $wdir $pinfo |
||||
lappend all_workdirs $wdir |
||||
} |
||||
} |
||||
set col_rowids [list] |
||||
set workdirs [lsort -index 0 $all_workdirs] |
||||
set col_dupids [list] |
||||
set col_fnames [list] |
||||
set col_pnames [list] |
||||
set col_pcodes [list] |
||||
set col_dupids [list] |
||||
|
||||
set fosdb_count [dict create] |
||||
set fosdb_dupset [dict create] |
||||
set fosdb_cache [dict create] |
||||
set dupset 0 |
||||
set rowid 1 |
||||
foreach wd $workdirs { |
||||
set wdinfo [dict get $workdir_dict $wd] |
||||
lassign $wdinfo fosdb nm siblingworkdirs |
||||
dict incr fosdb_count $fosdb |
||||
set dbcount [dict get $fosdb_count $fosdb] |
||||
if {[llength $siblingworkdirs] > 1} { |
||||
if {![dict exists $fosdb_dupset $fosdb]} { |
||||
#first time this multi-checkout fosdb seen |
||||
dict set fosdb_dupset $fosdb [incr dupset] |
||||
} |
||||
set dupid "[dict get $fosdb_dupset $fosdb].$dbcount/[llength $siblingworkdirs]" |
||||
} else { |
||||
set dupid "" |
||||
} |
||||
if {$dbcount == 1} { |
||||
set pname "" |
||||
set pcode "" |
||||
if {[file exists $fosdb]} { |
||||
if {[catch { |
||||
sqlite3 fdb $fosdb |
||||
set pname [lindex [fdb eval {select value from config where name = 'project-name'}] 0] |
||||
set pcode [lindex [fdb eval {select value from config where name = 'project-code'}] 0] |
||||
fdb close |
||||
dict set fosdb_cache $fosdb [list name $pname code $pcode] |
||||
} errM]} { |
||||
puts stderr "!!! problem with fossil db: $fosdb when examining workdir $wd" |
||||
puts stderr "!!! error: $errM" |
||||
} |
||||
} else { |
||||
puts stderr "!!! missing fossil db $fosdb" |
||||
} |
||||
} else { |
||||
set info [dict get $fosdb_cache $fosdb] |
||||
lassign $info _name pname _code pcode |
||||
} |
||||
lappend col_rowids $rowid |
||||
lappend col_fnames $nm |
||||
lappend col_dupids $dupid |
||||
lappend col_pnames $pname |
||||
lappend col_pcodes [string range $pcode 0 9] |
||||
incr rowid |
||||
} |
||||
|
||||
set col_states [list] |
||||
set state_title "" |
||||
#if only one set of fossil checkouts in the resultset - retrieve workingdir state for each co |
||||
if {[llength [dict keys $fosdb_cache]] == 1} { |
||||
puts stderr "Result is a single project - gathering file state for each checkout folder" |
||||
set c_rev [list] |
||||
set c_unchanged [list] |
||||
set c_changed [list] |
||||
set c_new [list] |
||||
set c_missing [list] |
||||
set c_extra [list] |
||||
foreach wd $workdirs { |
||||
set wd_state [punk::repo::workingdir_state $wd] |
||||
set state_dict [punk::repo::workingdir_state_summary_dict $wd_state] |
||||
lappend c_rev [string range [dict get $state_dict revision] 0 9] |
||||
lappend c_unchanged [dict get $state_dict unchanged] |
||||
lappend c_changed [dict get $state_dict changed] |
||||
lappend c_new [dict get $state_dict new] |
||||
lappend c_missing [dict get $state_dict missing] |
||||
lappend c_extra [dict get $state_dict extra] |
||||
puts -nonewline stderr "." |
||||
} |
||||
puts -nonewline stderr \n |
||||
set t0 "Revision" |
||||
set w0 [tcl::mathfunc::max {*}[lmap v [concat [list $t0] $c_rev] {string length $v}]] |
||||
set c0 [string repeat " " $w0] |
||||
set t1 "Unch" |
||||
set w1 [tcl::mathfunc::max {*}[lmap v [concat [list $t1] $c_unchanged] {string length $v}]] |
||||
set c1 [string repeat " " $w1] |
||||
set t2 "Chgd" |
||||
set w2 [tcl::mathfunc::max {*}[lmap v [concat [list $t2] $c_changed] {string length $v}]] |
||||
set c2 [string repeat " " $w2] |
||||
set t3 "New" |
||||
set w3 [tcl::mathfunc::max {*}[lmap v [concat [list $t3] $c_new] {string length $v}]] |
||||
set c3 [string repeat " " $w3] |
||||
set t4 "Miss" |
||||
set w4 [tcl::mathfunc::max {*}[lmap v [concat [list $t4] $c_missing] {string length $v}]] |
||||
set c4 [string repeat " " $w4] |
||||
set t5 "Extr" |
||||
set w5 [tcl::mathfunc::max {*}[lmap v [concat [list $t5] $c_extra] {string length $v}]] |
||||
set c5 [string repeat " " $w5] |
||||
|
||||
set state_title "[overtype::left $c0 $t0] [overtype::right $c1 $t1] [overtype::right $c2 $t2] [overtype::right $c3 $t3] [overtype::right $c4 $t4] [overtype::right $c5 $t5]" |
||||
foreach r $c_rev u $c_unchanged c $c_changed n $c_new m $c_missing e $c_extra { |
||||
lappend col_states "[overtype::left $c0 $r] [overtype::right $c1 $u] [overtype::right $c2 $c] [overtype::right $c3 $n] [overtype::right $c4 $m] [overtype::right $c5 $e]" |
||||
} |
||||
} |
||||
|
||||
set msg "" |
||||
if {$opt_cd} { |
||||
set title0 "CD" |
||||
} else { |
||||
set title0 "" |
||||
} |
||||
set widest0 [tcl::mathfunc::max {*}[lmap v [concat [list $title0] $col_rowids] {punk::strlen $v}]] |
||||
set col0 [string repeat " " $widest0] |
||||
set title1 "Checkout dir" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $workdirs] {punk::strlen $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
set title2 "Db name" |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col_fnames] {string length $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
set title3 "CO dup" |
||||
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col_dupids] {string length $v}]] |
||||
set col3 [string repeat " " $widest3] |
||||
set title4 "Project Name" |
||||
set widest4 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col_pnames] {string length $v}]] |
||||
set col4 [string repeat " " $widest4] |
||||
set title5 "Project Code" |
||||
set widest5 [tcl::mathfunc::max {*}[lmap v [concat [list $title5] $col_pcodes] {string length $v}]] |
||||
set col5 [string repeat " " $widest5] |
||||
|
||||
set tablewidth [expr {$widest0 + 1 + $widest1 + 1 + $widest2 + 1 + $widest3 +1 + $widest4 + 1 + $widest5}] |
||||
append msg "[overtype::right $col0 $title0] [overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3] [overtype::left $col4 $title4] [overtype::left $col5 $title5]" |
||||
|
||||
if {[llength $col_states]} { |
||||
set title6 $state_title |
||||
set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col_states] {string length $v}]] |
||||
set col6 [string repeat " " $widest6] |
||||
incr tablewidth [expr {$widest6 + 1}] |
||||
append msg " [overtype::left $col6 $title6]" \n |
||||
} else { |
||||
append msg \n |
||||
} |
||||
append msg [string repeat "=" $tablewidth] \n |
||||
|
||||
if {[llength $col_states]} { |
||||
foreach row $col_rowids wd $workdirs db $col_fnames dup $col_dupids pname $col_pnames pcode $col_pcodes s $col_states { |
||||
append msg "[overtype::right $col0 $row] [overtype::left $col1 $wd] [overtype::left $col2 $db] [overtype::right $col3 $dup] [overtype::left $col4 $pname] [overtype::left $col5 $pcode] [overtype::left $col6 $s]" \n |
||||
} |
||||
} else { |
||||
foreach row $col_rowids wd $workdirs db $col_fnames dup $col_dupids pname $col_pnames pcode $col_pcodes { |
||||
append msg "[overtype::right $col0 $row] [overtype::left $col1 $wd] [overtype::left $col2 $db] [overtype::right $col3 $dup] [overtype::left $col4 $pname] [overtype::left $col5 $pcode]" \n |
||||
} |
||||
} |
||||
set numrows [llength $col_rowids] |
||||
if {$opt_cd && $numrows >= 1} { |
||||
puts stdout $msg |
||||
if {$numrows == 1} { |
||||
set workingdir [lindex $workdirs 0] |
||||
puts stdout "1 result. Changing dir to $workingdir" |
||||
if {[file exists $workingdir]} { |
||||
cd $workingdir |
||||
return $workingdir |
||||
} else { |
||||
puts stderr "path $workingdir doesn't appear to exist" |
||||
return [pwd] |
||||
} |
||||
} else { |
||||
set answer [util::askuser "Change directory to working folder - select a number from 1 to [llength $col_rowids] or any other key to cancel."] |
||||
if {[string trim $answer] in $col_rowids} { |
||||
set index [expr {$answer - 1}] |
||||
set workingdir [lindex $workdirs $index] |
||||
cd $workingdir |
||||
puts stdout [pmix stat] |
||||
return $workingdir |
||||
} |
||||
} |
||||
} |
||||
return $msg |
||||
} |
||||
} |
||||
|
||||
namespace eval lib { |
||||
#get project info only by opening the central confg-db |
||||
#(will not have proper project-name etc) |
||||
proc get_projects {{globlist {}} args} { |
||||
if {![llength $globlist]} { |
||||
set globlist [list *] |
||||
} |
||||
set fossil_prog [auto_execok fossil] |
||||
|
||||
set fossilinfo [exec {*}$fossil_prog info] ;#will give us the necessary config-db info whether in a project folder or not |
||||
set matching_lines [punk::repo::grep {config-db:*} $fossilinfo] |
||||
if {[llength $matching_lines] != 1} { |
||||
puts stderr "Unable to find config-db info from fossil. Check your fossil installation." |
||||
puts stderr "Fossil output was:" |
||||
puts stderr "-------------" |
||||
puts stderr "$fossilinfo" |
||||
puts stderr "-------------" |
||||
puts stderr "config-db info:" |
||||
puts stderr "$matching_lines" |
||||
return |
||||
} |
||||
set ln [lindex $matching_lines 0] |
||||
set configdb [string trim [string range $ln [string length "config-db: "] end]] |
||||
if {![file exists $configdb]} { |
||||
error "config-db not found at path $configdb" |
||||
} |
||||
package require sqlite3 |
||||
::sqlite3 fosconf $configdb |
||||
#set testresult [fosconf eval {select name,value from global_config;}] |
||||
#puts stderr $testresult |
||||
set project_repos [fosconf eval {select name from global_config where name like 'repo:%';}] |
||||
set paths_and_names [list] |
||||
foreach pr $project_repos { |
||||
set path [string trim [string range $pr 5 end]] |
||||
set nm [file rootname [file tail $path]] |
||||
set ckouts [fosconf eval {select name from global_config where value = $path;}] |
||||
set checkout_paths [list] |
||||
#strip "ckout:" |
||||
foreach ck $ckouts { |
||||
lappend checkout_paths [string trim [string range $ck 6 end]] |
||||
} |
||||
lappend paths_and_names [list $path $nm $checkout_paths] |
||||
} |
||||
set filtered_list [list] |
||||
foreach glob $globlist { |
||||
set matches [lsearch -all -inline -index 1 $paths_and_names $glob] |
||||
foreach m $matches { |
||||
if {$m ni $filtered_list} { |
||||
lappend filtered_list $m |
||||
} |
||||
} |
||||
} |
||||
set projects [lsort -index 1 $filtered_list] |
||||
return $projects |
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::project [namespace eval punk::mix::commandset::project { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,92 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::repo 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::repo { |
||||
namespace export * |
||||
proc tickets {{project ""}} { |
||||
set result "" |
||||
if {[string length $project]} { |
||||
puts stderr "project status unimplemented" |
||||
return |
||||
} |
||||
set active_dir [pwd] |
||||
append result "Retrieving top 10 tickets only (for more, use fossil timeline -n <int> -t t)" \n |
||||
append result [exec fossil timeline -n 10 -t t] |
||||
|
||||
return $result |
||||
} |
||||
|
||||
proc fossilize { args} { |
||||
#check if project already managed by fossil.. initialise and check in if not. |
||||
puts stderr "unimplemented" |
||||
} |
||||
|
||||
proc unfossilize {projectname args} { |
||||
#remove/archive .fossil |
||||
puts stderr "unimplemented" |
||||
} |
||||
proc state {} { |
||||
set result "" |
||||
set repopaths [punk::repo::find_repos [pwd]] |
||||
set repos [dict get $repopaths repos] |
||||
if {![llength $repos]} { |
||||
append result [dict get $repopaths warnings] |
||||
} else { |
||||
append result [dict get $repopaths warnings] |
||||
lassign [lindex $repos 0] repopath repotypes |
||||
if {"fossil" in $repotypes} { |
||||
append result \n "Fossil repo based at $repopath" |
||||
set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes fossil] |
||||
append result \n [punk::repo::workingdir_state_summary $repostate] |
||||
} |
||||
if {"git" in $repotypes} { |
||||
append result \n "Git repo based at $repopath" |
||||
set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes git] |
||||
append result \n [punk::repo::workingdir_state_summary $repostate] |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::repo [namespace eval punk::mix::commandset::repo { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,634 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::scriptwrap 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
package require punk::mix |
||||
package require punk::mix::base |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::scriptwrap { |
||||
namespace export * |
||||
|
||||
|
||||
#scriptpath allows templates command to use same custom template set as when multishell pointed to a filepath |
||||
#it may or may not be within a project |
||||
#by using the same folder or path, the same project root will be discovered. REVIEW. |
||||
proc templates_dict {args} { |
||||
set defaults [list -scriptpath ""] |
||||
set opts [dict merge $defaults $args] |
||||
set opt_scriptpath [dict get $opts -scriptpath] |
||||
|
||||
set wrapper_folders [lib::get_wrapper_folders $opt_scriptpath] |
||||
|
||||
set wrapper_templates [list] |
||||
foreach fld $wrapper_folders { |
||||
set templates [glob -nocomplain -dir $fld -type f *] |
||||
foreach tf $templates { |
||||
if {[string match ignore* $tf]} { |
||||
continue |
||||
} |
||||
set ext [file extension $tf] |
||||
if {$ext in [list "" ".bat" ".cmd" ".sh"]} { |
||||
lappend wrapper_templates $tf |
||||
} |
||||
} |
||||
} |
||||
|
||||
set tdict [dict create] |
||||
set seen_dict [dict create] |
||||
foreach fullpath $wrapper_templates { |
||||
set ftail [file tail $fullpath] |
||||
if {![dict exists $seen_dict $ftail]} { |
||||
dict set seen_dict $ftail 1 |
||||
dict set tdict $ftail $fullpath ; #first seen of filename gets no number |
||||
} else { |
||||
set n [dict get $seen_dict $ftail] |
||||
incr n |
||||
dict incr seen_dict $ftail |
||||
dict set tdict ${ftail}.$n $fullpath |
||||
} |
||||
} |
||||
return $tdict |
||||
} |
||||
proc templates {args} { |
||||
package require overtype |
||||
set tdict [templates_dict {*}$args] |
||||
|
||||
|
||||
set paths [dict values $tdict] |
||||
set names [dict keys $tdict] |
||||
|
||||
set title1 "Path" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $paths] {punk::strlen $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
|
||||
set title2 "Template Name" |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $names] {punk::strlen $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
|
||||
set tablewidth [expr {$widest1 + 1 + $widest2}] |
||||
set table "" |
||||
append table [string repeat - $tablewidth] \n |
||||
append table "[overtype::left $col1 $title1] [overtype::left $col2 $title2]" \n |
||||
append table [string repeat - $tablewidth] \n |
||||
|
||||
foreach p $paths n $names { |
||||
append table "[overtype::left $col1 $p] [overtype::left $col2 $n]" \n |
||||
} |
||||
|
||||
|
||||
return $table |
||||
} |
||||
#specific filepath to just wrap one script at the tcl-payload or xxx-payload-pre-tcl site |
||||
#scriptset name to substiture multiple scriptset.xxx files at the default locations - or as specified in scriptset.wrapconf |
||||
proc multishell {filepath_or_scriptset args} { |
||||
set defaults [list -askme 1 -template \uFFFF] |
||||
set opts [dict merge $defaults $args] |
||||
set opt_askme [dict get $opts -askme] |
||||
set opt_template [dict get $opts -template] |
||||
set ext [file extension $filepath_or_scriptset] |
||||
set startdir [pwd] |
||||
|
||||
set usage "" |
||||
append usage "Use directly with the script file to wrap, or supply the name of a scriptset" \n |
||||
append usage "The scriptset name will be used to search for yourname.sh|tcl|ps1 or names as you specify in yourname.wrapconfig if it exists" \n |
||||
append usage "If no template is specified in a .wrapconfig and no -template argument is supplied, it will default to punk-multishell.cmd" \n |
||||
if {![string length $filepath_or_scriptset]} { |
||||
puts stderr "No filepath_or_scriptset specified" |
||||
puts stderr $usage |
||||
return false |
||||
} |
||||
|
||||
|
||||
#first check if relative or absolute path matches a file |
||||
if {[file pathtype $filepath_or_scriptset] eq "absolute"} { |
||||
set specified_path $filepath_or_scriptset |
||||
} else { |
||||
set specified_path [file join $startdir $filepath_or_scriptset] |
||||
} |
||||
|
||||
set ext [string trim [file extension $filepath_or_scriptset] .] |
||||
set allowed_extensions [list wrapconfig tcl ps1 sh bash] |
||||
#set allowed_extensions [list tcl] |
||||
set found_script 0 |
||||
if {[file exists $specified_path]} { |
||||
set found_script 1 |
||||
} else { |
||||
foreach e $allowed_extensions { |
||||
if {[file exists $filepath_or_scriptset.$e]} { |
||||
set found_script 1 |
||||
break |
||||
} |
||||
} |
||||
} |
||||
|
||||
#TODO! - use get_wrapper_folders - multishell should use same available templates as the 'templates' function |
||||
set scriptset [file rootname [file tail $specified_path]] |
||||
if {$found_script} { |
||||
if {[file type $specified_path] eq "file"} { |
||||
set specified_root [file dirname $specified_path] |
||||
set pathinfo [punk::repo::find_repos [file dirname $specified_path]] |
||||
set projectroot [dict get $pathinfo closest] |
||||
if {[string length $projectroot]} { |
||||
#use the specified files folder - but use the main scriptapps/wrappers folder if specified one has no wrappers subfolder |
||||
set scriptroot [file dirname $specified_path] |
||||
if {[file exists $scriptroot/wrappers]} { |
||||
set customwrapper_folder $scriptroot/wrappers |
||||
} else { |
||||
set customwrapper_folder $projectroot/src/scriptapps/wrappers |
||||
} |
||||
} else { |
||||
#outside of any project |
||||
set scriptroot [file dirname $specified_path] |
||||
if {[file exists $scriptroot/wrappers]} { |
||||
set customwrapper_folder $scriptroot/wrappers |
||||
} else { |
||||
#no customwrapper folder available |
||||
set customwrapper_folder "" |
||||
} |
||||
} |
||||
} else { |
||||
puts stderr "wrap_in_multishell doesn't currently support a directory as the path." |
||||
puts stderr $usage |
||||
return false |
||||
} |
||||
} else { |
||||
set pathinfo [punk::repo::find_repos $startdir] |
||||
set projectroot [dict get $pathinfo closest] |
||||
if {[string length $projectroot]} { |
||||
if {[llength [file split $filepath_or_scriptset]] > 1} { |
||||
puts stderr "filepath_or_scriptset looks like a path - but doesn't seem to point to a file" |
||||
puts stderr "Ensure you are within a project and use just the name of the scriptset, or pass in the full correct path or relative path to current directory" |
||||
puts stderr $usage |
||||
return false |
||||
} else { |
||||
#we've already ruled out empty string - so must have a single element representing scriptset - possibly with file extension |
||||
set scriptroot $projectroot/src/scriptapps |
||||
set customwrapper_folder $projectroot/src/scriptapps/wrappers |
||||
#check something matches the scriptset.. |
||||
set something_found "" |
||||
if {[file exists $scriptroot/$scriptset]} { |
||||
set found_script 1 |
||||
set something_found $scriptroot/$scriptset ;#extensionless file - that's ok too |
||||
} else { |
||||
foreach e $allowed_extensions { |
||||
if {[file exists $scriptroot/$scriptset.$e]} { |
||||
set found_script 1 |
||||
set something_found $scriptroot/$scriptset.$e |
||||
break |
||||
} |
||||
} |
||||
} |
||||
if {!$found_script} { |
||||
puts stderr "Searched within $scriptroot" |
||||
puts stderr "Unable to find a file matching $scriptset or one of the extensions: $allowed_extensions" |
||||
puts stderr $usage |
||||
return false |
||||
} else { |
||||
if {[file pathtype $something_found] ne "file"} { |
||||
puts stderr "wrap_in_multishell doesn't currently support a directory as the path." |
||||
puts stderr $usage |
||||
return false |
||||
} |
||||
} |
||||
} |
||||
|
||||
} else { |
||||
puts stderr "filepath_or_scriptset parameter doesn't seem to refer to a file, and you are not within a directory where projectroot and src/scriptapps/wrappers can be determined" |
||||
puts stderr $usage |
||||
return false |
||||
} |
||||
} |
||||
#assert - customwrapper_folder var exists - but might be empty |
||||
|
||||
|
||||
if {[string length $ext]} { |
||||
#If there was an explicitly supplied extension - then that file should exist |
||||
if {![file exists $scriptroot/$scriptset.$ext]} { |
||||
puts stderr "Explicit extension .$ext was supplied - but matching file not found." |
||||
puts stderr $usage |
||||
return false |
||||
} else { |
||||
if {$ext eq "wrapconfig"} { |
||||
set process_extensions ALLFOUNDORCONFIGURED |
||||
} else { |
||||
set process_extensions $ext |
||||
} |
||||
} |
||||
} else { |
||||
#no explicit extension - process all for scriptset |
||||
set process_extensions ALLFOUNDORCONFIGURED |
||||
} |
||||
#process_extensions - either a single one - or all found or as per .wrapconfig |
||||
|
||||
if {$opt_template eq "\uFFFF"} { |
||||
set templatename punk-multishell.cmd |
||||
} else { |
||||
set templatename $opt_template |
||||
} |
||||
|
||||
|
||||
|
||||
set template_base_dict [punk::mix::base::lib::get_template_basefolders] |
||||
set tpldirs [list] |
||||
dict for {tdir tsourceinfo} $template_base_dict { |
||||
if {[file exists $tdir/utility/scriptappwrappers/$templatename]} { |
||||
lappend tpldirs $tdir |
||||
} |
||||
} |
||||
|
||||
if {[string length $customwrapper_folder] && [file exists [file join $customwrapper_folder $templatename] ]} { |
||||
set wrapper_template [file join $customwrapper_folder $templatename] |
||||
} else { |
||||
if {![llength $tpldirs]} { |
||||
set msg "No template named '$templatename' found in src/scriptapps/wrappers or in template dirs from packages" |
||||
append msg \n "Searched [dict size $template_base_dict] template dirs" |
||||
error $msg |
||||
} |
||||
|
||||
#last pkg with templates cap which was loaded has highest precedence |
||||
set wrapper_template "" |
||||
foreach tdir [lreverse $tpldirs] { |
||||
set ftest [file join $tdir utility scriptappwrappers $templatename] |
||||
if {[file exists $ftest]} { |
||||
set wrapper_template $ftest |
||||
break |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {$wrapper_template eq "" || ![file exists $wrapper_template]} { |
||||
error "wrap_in_multishell: unable to find multishell template $templatename in template folders [concat $tpldirs $customwrapper_folder]" |
||||
} |
||||
|
||||
|
||||
#todo |
||||
#output_file extension depends on the template being used.. |
||||
|
||||
|
||||
set output_file $scriptset.cmd |
||||
if {[file exists $output_file]} { |
||||
error "wrap_in_multishell: target file $output_file already exists.. aborting" |
||||
} |
||||
|
||||
|
||||
set fdt [open $wrapper_template r] |
||||
fconfigure $fdt -translation binary |
||||
set template_data [read $fdt] |
||||
close $fdt |
||||
puts stdout "Read [string length $template_data] bytes of template data.." |
||||
set template_lines [split $template_data \n] |
||||
puts stdout "Displaying first 3 lines of template between dashed lines..." |
||||
puts stdout "-----------------------------------------------" |
||||
foreach ln [lrange $template_lines 0 3] { |
||||
puts stdout $ln |
||||
} |
||||
puts stdout "-----------------------------------------------\n" |
||||
#foreach ln $template_lines { |
||||
#} |
||||
|
||||
set list_input_files [list] |
||||
if {$process_extensions eq "ALLFOUNDORCONFIGURED"} { |
||||
#todo - look for .wrapconfig or all extensions for the scriptset |
||||
puts stderr "Sorry - only single input file supported - implementation incomplete" |
||||
return false |
||||
} else { |
||||
lappend list_input_files $scriptroot/$scriptset.$ext |
||||
} |
||||
|
||||
#todo - split template at each <ext-payload> etc marker and build a dict of parts |
||||
|
||||
|
||||
#hack - process one input |
||||
set filepath [lindex $list_input_files 0] |
||||
|
||||
set fdscript [open $filepath r] |
||||
fconfigure $fdscript -translation binary |
||||
set script_data [read $fdscript] |
||||
close $fdscript |
||||
puts stdout "Read [string length $script_data] bytes of template data.." |
||||
set script_lines [split $script_data \n] |
||||
puts stdout "Displaying first 3 lines of your script between dashed lines..." |
||||
puts stdout "-----------------------------------------------" |
||||
foreach ln [lrange $script_lines 0 3] { |
||||
puts stdout $ln |
||||
} |
||||
puts stdout "-----------------------------------------------\n" |
||||
if {$opt_askme} { |
||||
puts stdout "Target for above data is '$output_file'" |
||||
set answer [util::askuser "Does this look correct? Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y or y to proceed) use -askme 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
|
||||
set start_idx 0 |
||||
set end_idx 0 |
||||
set line_idx 0 |
||||
set existing_payload [list] |
||||
foreach ln $template_lines { |
||||
|
||||
if {[string match "#<tcl-payload>*" $ln]} { |
||||
set start_idx $line_idx |
||||
} elseif {[string match "#</tcl-payload>*" $ln]} { |
||||
set end_idx $line_idx |
||||
break |
||||
} elseif {$start_idx > 0} { |
||||
if {$end_idx > 0} { |
||||
lappend existing_payload [string trim $ln] |
||||
} |
||||
} else { |
||||
|
||||
} |
||||
incr line_idx |
||||
} |
||||
if {($start_idx == 0) || ($end_idx == 0)} { |
||||
error "wrap_in_multishell was unable to find payload area in template marked with #<tcl-payload> and #</tcl-payload> on separate lines" |
||||
} |
||||
set existing_string [join $existing_payload \n] |
||||
if {[string length [string trim $existing_string]]} { |
||||
puts stdout "EXISTING PAYLOAD!!" |
||||
puts stdout "-----------------------------------------------\n" |
||||
puts stdout $existing_string |
||||
puts stdout "-----------------------------------------------\n" |
||||
error "wrap_in_multishell found existing payload.. aborting." |
||||
#todo - allow overwrite only in files outside of punkshell distribution? |
||||
if 0 { |
||||
puts stderr "Found existing payload.. overwrite?" |
||||
if {$opt_askme} { |
||||
set answer [util::askuser "Are you sure you want to replace the tcl payload shown above? Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
set tpl_head_lines [lrange $template_lines 0 $start_idx] ;#include tag line |
||||
set tpl_tail_lines [lrange $template_lines $end_idx end] |
||||
set newscript [join $tpl_head_lines \n]\n[join $script_lines \n]\n[join $tpl_tail_lines \n] |
||||
puts stdout "New script is [string length $newscript] bytes" |
||||
puts stdout $newscript |
||||
set fdtarget [open $output_file w] |
||||
fconfigure $fdtarget -translation binary |
||||
puts -nonewline $fdtarget $newscript |
||||
close $fdtarget |
||||
puts stdout "Wrote script file at $output_file" |
||||
puts stdout "-done-" |
||||
return $output_file |
||||
} |
||||
|
||||
namespace eval lib { |
||||
|
||||
#get_wrapper_folders |
||||
# scriptpath - file or folder |
||||
# It represents the base point from which to search for /wrapper folders either directly above the scriptpath or in the containing project if any |
||||
# The cwd will also be searched for /wrapper folder and project - but with lower precedence in the resultset (later in list) |
||||
proc get_wrapper_folders {{scriptpath ""}} { |
||||
set wrapper_folders [list] |
||||
if {$scriptpath ne ""} { |
||||
if {[file type $scriptpath] eq "file"} { |
||||
set searchbase [file dirname $scriptpath] |
||||
} else { |
||||
set searchbase $scriptpath |
||||
} |
||||
if {[file isdirectory [file join $searchbase wrappers]]} { |
||||
lappend wrapper_folders [file join $searchbase wrappers] |
||||
} |
||||
set pathinfo [punk::repo::find_repos $searchbase] |
||||
set scriptpath_projectroot [dict get $pathinfo closest] |
||||
if {$scriptpath_projectroot ne ""} { |
||||
set fld [file join $scriptpath_projectroot src/scriptapps/wrappers] |
||||
if {[file isdirectory $fld]} { |
||||
if {$fld ni $wrapper_folders} { |
||||
lappend wrapper_folders $fld |
||||
} |
||||
} |
||||
} |
||||
} |
||||
set searchbase [pwd] |
||||
set fld [file join $searchbase wrappers] |
||||
if {[file isdirectory $fld]} { |
||||
if {$fld ni $wrapper_folders} { |
||||
lappend wrapper_folders $fld |
||||
} |
||||
} |
||||
set pathinfo [punk::repo::find_repos $searchbase] |
||||
set pwd_projectroot [dict get $pathinfo closest] |
||||
if {$pwd_projectroot ne ""} { |
||||
set fld [file join $pwd_projectroot src/scriptapps/wrappers] |
||||
if {[file isdirectory $fld]} { |
||||
if {$fld ni $wrapper_folders} { |
||||
lappend wrapper_folders $fld |
||||
} |
||||
} |
||||
} |
||||
|
||||
set template_base_dict [punk::mix::base::lib::get_template_basefolders] |
||||
set tpldirs [list] |
||||
dict for {tdir tsourceinfo} $template_base_dict { |
||||
if {[file exists $tdir/utility/scriptappwrappers]} { |
||||
lappend tpldirs $tdir |
||||
} |
||||
} |
||||
foreach tpldir $tpldirs { |
||||
set fld [file join $tpldir utility scriptappwrappers] |
||||
if {[file isdirectory $fld]} { |
||||
if {$fld ni $wrapper_folders} { |
||||
lappend wrapper_folders $fld |
||||
} |
||||
} |
||||
} |
||||
return $wrapper_folders |
||||
} |
||||
proc _scriptapp_tag_from_line {line} { |
||||
set result [list istag 0 raw ""] ;#default assumption. All |
||||
#---- |
||||
set startc [string first "#" $line] ;#tags must be commented |
||||
#todo - review. next line is valid - note # doesn't have to be the only one before <tagname> |
||||
# @REM # etc < blah # <tagname> etc |
||||
#--- |
||||
#fix - we should use a regexp on at least <tagname> </tagname> <tagname/> and only catch tagname without whitespace |
||||
regexp {(\s*).*} $line _ln indent ;#will match on empty line, whitespace only line - or anything really. |
||||
set indent [string map [list \t " "] $indent] ;#opinionated I guess - but need to normalize to something. The spec is that spaces should be used anyway. |
||||
dict set result indent [string length $indent] |
||||
set starttag [string first "<" $line] |
||||
set pretag [string range $line $startc $starttag-1] |
||||
if {[string match "*>*" $pretag]} { |
||||
return [list istag 0 raw $line reason pretag_contents] |
||||
} |
||||
set closetag [string first ">" $line] |
||||
set inelement [string range $line $starttag+1 $closetag-1] |
||||
if {[string match "*<*" $inelement]} { |
||||
return [list istag 0 raw $line reason tag_malformed_angles] |
||||
} |
||||
set elementchars [split $inelement ""] |
||||
set numslashes [llength [lsearch -all $elementchars "/"]] |
||||
if {$numslashes == 0} { |
||||
dict set result type "open" |
||||
} elseif {$numslashes == 1} { |
||||
if {[lindex $elementchars 0] eq "/"} { |
||||
dict set result type "close" |
||||
} elseif {[lindex $elementchars end] eq "/"} { |
||||
dict set result type "openclose" |
||||
} else { |
||||
return [list istag 0 raw $line reason tag_malformed_slashes] |
||||
} |
||||
} else { |
||||
return [list istag 0 raw $line reason tag_malformed_extraslashes] |
||||
} |
||||
if {[dict get $result type] eq "open"} { |
||||
dict set result name $inelement |
||||
} elseif {[dict get $result type] eq "close"} { |
||||
dict set result name [string range $inelement 1 end] |
||||
} else { |
||||
dict set result name [string range $inelement 0 end-1] |
||||
} |
||||
dict set result istag 1 |
||||
dict set result raw $line |
||||
return $result |
||||
} |
||||
|
||||
#get all \n#<something>\n ...\n#</something> data - where number of intervening newlines is at least one (and whitespace and/or other data can precede #) |
||||
#we don't verify 'something' against known tags - as custom templates can have own tags |
||||
#An openclose tag #<xxx/> is used to substitute a specific line in its entirety - but the tag *must* remain in the line |
||||
# |
||||
#e.g for the line: |
||||
# @set "nextshell=pwsh" & :: #<batch-nextshell-line/> |
||||
#The .wrapconfig might contain |
||||
# tag <batch-nextshell-line> line {@set "nextshell=tclsh" & :: @<batch-nextshell-line/>} |
||||
# |
||||
proc scriptapp_wrapper_get_tags {wrapperdata} { |
||||
set wrapperdata [string map [list \r\n \n] $wrapperdata] |
||||
set lines [split $wrapperdata \n] |
||||
#set tags_in_data [dict create];#active tags - list of lines accumulating. supports nested tags |
||||
set status 0 |
||||
set tags [dict create] |
||||
set errors [list] |
||||
set errortags [dict create] ;#mark names invalid on first error so that more than 2 tags can't obscure config problem |
||||
set linenum 1 ;#editors and other utils use 1-based indexing when referencing files - we should too to avoid confusion, despite it being less natural for lindex operations on the result. |
||||
foreach ln $lines { |
||||
set lntrim [string trim $ln] |
||||
if {![string length $lntrim]} { |
||||
incr linenum |
||||
continue |
||||
} |
||||
if {[string match "*#*<*>*" $lntrim]} { |
||||
set taginfo [_scriptapp_tag_from_line $ln] ;#use untrimmed line - to get indent |
||||
if {[dict get $taginfo istag]} { |
||||
set nm [dict get $taginfo name] |
||||
if {[dict exists $errortags $nm]} { |
||||
#tag is already in error condition - |
||||
} else { |
||||
set tp [dict get $taginfo type] ;# type singular - related to just one line |
||||
#set raw [dict get $taginfo raw] #equivalent to $ln |
||||
if {[dict exists $tags $nm]} { |
||||
#already seen tag name |
||||
#tags dict has types key *plural* - need to track whether we have type open and type close (or openclose for self-closing tags) |
||||
if {[dict get $tags $nm types] ne "open"} { |
||||
lappend errors "line: $linenum tag $nm encountered type $tp after existing type [dict get $tags $nm types]" |
||||
dict incr errortags $nm |
||||
} else { |
||||
#we already have open - expect only close |
||||
if {$tp ne "close"} { |
||||
lappend errors "line: $linenum tag $nm encountered type $tp after existing type [dict get $tags $nm types]" |
||||
dict incr errortags $nm |
||||
} else { |
||||
#close after open |
||||
dict set tags $nm types [list open close] |
||||
dict set tags $nm end $linenum |
||||
set taglines [dict get $tags $nm taglines] |
||||
if {[llength $taglines] != 1} { |
||||
error "Unexpected result when closing tag $nm. Existing taglines length not 1." |
||||
} |
||||
dict set tags $nm taglines [concat $taglines $ln] |
||||
} |
||||
} |
||||
} else { |
||||
#first seen of tag name |
||||
if {$tp eq "close"} { |
||||
lappend errors "line: $linenum tag $nm encountered type $p close first" |
||||
dict incr errortags $nm |
||||
} else { |
||||
dict set tags $nm types $tp |
||||
dict set tags $nm indent [dict get $taginfo indent] |
||||
if {$tp eq "open"} { |
||||
dict set tags $nm start $linenum |
||||
dict set tags $nm taglines [list $ln] ;#first entry - another will be added on encountering matching closing tag |
||||
} elseif {$tp eq "openclose"} { |
||||
dict set tags $nm start $linenum |
||||
dict set tags $nm end $linenum |
||||
dict set tags $nm taglines [list $ln] ;#single entry is final result for self-closing tag |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} else { |
||||
#looks like it should be a tag.. but failed to even parse for some reason.. just add to errorlist |
||||
lappend errors "line: $linenum tag parse failure reason: [dict get $taginfo reason] raw line: [dict get $taginfo raw]" |
||||
} |
||||
} |
||||
#whether the line is tag or not append to any tags_in_data |
||||
#foreach t [dict keys $tags_in_data] { |
||||
# dict lappend tags_in_data $t $ln ;#accumulate raw lines - written to the tag entry in tags only on encountering a closing tag, then removed from tags_in_data |
||||
#} |
||||
incr linenum |
||||
} |
||||
#assert [expr {$linenum -1 == [llength $lines]}] |
||||
if {[llength $errors]} { |
||||
set status 0 |
||||
} else { |
||||
set status 1 |
||||
} |
||||
if {$linenum == 0} { |
||||
|
||||
} |
||||
return [dict create ok $status linecount [llength $lines] data $tags errors $errors] |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::scriptwrap [namespace eval punk::mix::commandset::scriptwrap { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,49 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::templates 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
package require punk::cap |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::templates { |
||||
punk::cap::register_package punk::mix::templates [list\ |
||||
{templates {relpath ../templates}}\ |
||||
] |
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::templates [namespace eval punk::mix::templates { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,427 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::util 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
namespace eval punk::mix::util { |
||||
variable has_winpath 0 |
||||
} |
||||
|
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
if {![catch {package require punk::winpath}]} { |
||||
set punk::mix::util::has_winpath 1 |
||||
} |
||||
} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::util { |
||||
variable tmpfile_counter 0 ;#additional tmpfile collision avoidance |
||||
|
||||
namespace export * |
||||
|
||||
|
||||
proc fcat {args} { |
||||
variable has_winpath |
||||
|
||||
if {$::tcl_platform(platform) ne "windows"} { |
||||
return [fileutil::cat {*}$args] |
||||
} |
||||
|
||||
set knownopts [list -eofchar -translation -encoding --] |
||||
set last_opt 0 |
||||
for {set i 0} {$i < [llength $args]} {incr i} { |
||||
set ival [lindex $args $i] |
||||
#puts stdout "i:$i a: $ival known: [expr {$ival in $knownopts}]" |
||||
if {$ival eq "--"} { |
||||
set last_opt $i |
||||
break |
||||
} else { |
||||
if {$ival in $knownopts} { |
||||
#puts ">known at $i : [lindex $args $i]" |
||||
if {($i % 2) != 0} { |
||||
error "unexpected option at index $i. known options: $knownopts must come in -opt val pairs." |
||||
} |
||||
incr i |
||||
set last_opt $i |
||||
} else { |
||||
set last_opt [expr {$i - 1}] |
||||
break |
||||
} |
||||
} |
||||
} |
||||
set first_non_opt [expr {$last_opt + 1}] |
||||
|
||||
#puts stderr "first_non_opt: $first_non_opt" |
||||
set opts [lrange $args -1 $first_non_opt-1] |
||||
set paths [lrange $args $first_non_opt end] |
||||
if {![llength $paths]} { |
||||
error "Unable to find file in the supplied arguments: $args. Ensure options are all -opt val pairs and that file name(s) follow" |
||||
} |
||||
#puts stderr "opts: $opts paths: $paths" |
||||
set finalpaths [list] |
||||
foreach p $paths { |
||||
if {$has_winpath && [punk::winpath::illegalname_test $p]} { |
||||
lappend finalpaths [punk::winpath::illegalname_fix $p] |
||||
} else { |
||||
lappend finalpaths $p |
||||
} |
||||
} |
||||
fileutil::cat {*}$opts {*}$finalpaths |
||||
} |
||||
|
||||
#---------------------------------------- |
||||
namespace eval internal { |
||||
proc path_common_prefix_pop {varname} { |
||||
upvar 1 $varname var |
||||
set var [lassign $var head] |
||||
return $head |
||||
} |
||||
} |
||||
proc path_common_prefix {args} { |
||||
set dirs $args |
||||
set parts [file split [internal::path_common_prefix_pop dirs]] |
||||
while {[llength $dirs]} { |
||||
set r {} |
||||
foreach cmp $parts elt [file split [internal::path_common_prefix_pop dirs]] { |
||||
if {$cmp ne $elt} break |
||||
lappend r $cmp |
||||
} |
||||
set parts $r |
||||
} |
||||
if {[llength $parts]} { |
||||
return [file join {*}$parts] |
||||
} else { |
||||
return "" |
||||
} |
||||
} |
||||
|
||||
#retains case from first argument only - caseless comparison |
||||
proc path_common_prefix_nocase {args} { |
||||
set dirs $args |
||||
set parts [file split [internal::path_common_prefix_pop dirs]] |
||||
while {[llength $dirs]} { |
||||
set r {} |
||||
foreach cmp $parts elt [file split [internal::path_common_prefix_pop dirs]] { |
||||
if {![string equal -nocase $cmp $elt]} break |
||||
lappend r $cmp |
||||
} |
||||
set parts $r |
||||
} |
||||
if {[llength $parts]} { |
||||
return [file join {*}$parts] |
||||
} else { |
||||
return "" |
||||
} |
||||
} |
||||
#---------------------------------------- |
||||
|
||||
#maint warning - also in punkcheck |
||||
proc path_relative {base dst} { |
||||
#see also kettle |
||||
# Modified copy of ::fileutil::relative (tcllib) |
||||
# Adapted to 8.5 ({*}). |
||||
# |
||||
# Taking two _directory_ paths, a base and a destination, computes the path |
||||
# of the destination relative to the base. |
||||
# |
||||
# Arguments: |
||||
# base The path to make the destination relative to. |
||||
# dst The destination path |
||||
# |
||||
# Results: |
||||
# The path of the destination, relative to the base. |
||||
|
||||
# Ensure that the link to directory 'dst' is properly done relative to |
||||
# the directory 'base'. |
||||
|
||||
#review - check volume info on windows.. UNC paths? |
||||
if {[file pathtype $base] ne [file pathtype $dst]} { |
||||
return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)" |
||||
} |
||||
|
||||
#avoid normalizing if possible (file normalize *very* expensive on windows) |
||||
set do_normalize 0 |
||||
if {[file pathtype $base] eq "relative"} { |
||||
#if base is relative so is dst |
||||
if {[regexp {[.]{2}} [list $base $dst]]} { |
||||
set do_normalize 1 |
||||
} |
||||
if {[regexp {[.]/} [list $base $dst]]} { |
||||
set do_normalize 1 |
||||
} |
||||
} else { |
||||
set do_normalize 1 |
||||
} |
||||
if {$do_normalize} { |
||||
set base [file normalize $base] |
||||
set dst [file normalize $dst] |
||||
} |
||||
|
||||
set save $dst |
||||
set base [file split $base] |
||||
set dst [file split $dst] |
||||
|
||||
while {[lindex $dst 0] eq [lindex $base 0]} { |
||||
set dst [lrange $dst 1 end] |
||||
set base [lrange $base 1 end] |
||||
if {![llength $dst]} {break} |
||||
} |
||||
|
||||
set dstlen [llength $dst] |
||||
set baselen [llength $base] |
||||
|
||||
if {($dstlen == 0) && ($baselen == 0)} { |
||||
# Cases: |
||||
# (a) base == dst |
||||
|
||||
set dst . |
||||
} else { |
||||
# Cases: |
||||
# (b) base is: base/sub = sub |
||||
# dst is: base = {} |
||||
|
||||
# (c) base is: base = {} |
||||
# dst is: base/sub = sub |
||||
|
||||
while {$baselen > 0} { |
||||
set dst [linsert $dst 0 ..] |
||||
incr baselen -1 |
||||
} |
||||
set dst [file join {*}$dst] |
||||
} |
||||
|
||||
return $dst |
||||
} |
||||
#namespace import ::punk::ns::nsimport_noclobber |
||||
|
||||
proc namespace_import_pattern_to_namespace_noclobber {pattern ns} { |
||||
set source_ns [namespace qualifiers $pattern] |
||||
if {![namespace exists $source_ns]} { |
||||
error "namespace_import_pattern_to_namespace_noclobber error namespace $source_ns not found" |
||||
} |
||||
if {![string match ::* $ns]} { |
||||
set nscaller [uplevel 1 {namespace current}] |
||||
set ns [punk::nsjoin $nscaller $ns] |
||||
} |
||||
set a_export_patterns [namespace eval $source_ns {namespace export}] |
||||
set a_commands [info commands $pattern] |
||||
set a_tails [lmap v $a_commands {namespace tail $v}] |
||||
set a_exported_tails [list] |
||||
foreach pattern $a_export_patterns { |
||||
set matches [lsearch -all -inline $a_tails $pattern] |
||||
foreach m $matches { |
||||
if {$m ni $a_exported_tails} { |
||||
lappend a_exported_tails $m |
||||
} |
||||
} |
||||
} |
||||
set imported_commands [list] |
||||
foreach e $a_exported_tails { |
||||
set imported [namespace eval $ns [string map [list <func> $e <a> $source_ns] { |
||||
set cmd "" |
||||
if {![catch {namespace import <a>::<func>}]} { |
||||
set cmd <func> |
||||
} |
||||
set cmd |
||||
}]] |
||||
if {[string length $imported]} { |
||||
lappend imported_commands $imported |
||||
} |
||||
} |
||||
return $imported_commands |
||||
} |
||||
|
||||
proc askuser {question} { |
||||
puts stdout $question |
||||
flush stdout |
||||
set stdin_state [fconfigure stdin] |
||||
fconfigure stdin -blocking 1 |
||||
set answer [gets stdin] |
||||
fconfigure stdin -blocking [dict get $stdin_state -blocking] |
||||
return $answer |
||||
} |
||||
|
||||
proc do_in_path {path script} { |
||||
#from ::kettle::path::in |
||||
set here [pwd] |
||||
try { |
||||
cd $path |
||||
uplevel 1 $script |
||||
} finally { |
||||
cd $here |
||||
} |
||||
} |
||||
|
||||
proc foreach-file {path script_pathvariable script} { |
||||
upvar 1 $script_pathvariable thepath |
||||
|
||||
set known {} |
||||
lappend waiting $path |
||||
while {[llength $waiting]} { |
||||
set pending $waiting |
||||
set waiting {} |
||||
set at 0 |
||||
while {$at < [llength $pending]} { |
||||
set current [lindex $pending $at] |
||||
incr at |
||||
|
||||
# Do not follow into parent. |
||||
if {[string match *.. $current]} continue |
||||
|
||||
# Ignore what we have visited already. |
||||
set c [file dirname [file normalize $current/___]] |
||||
if {[dict exists $known $c]} continue |
||||
dict set known $c . |
||||
|
||||
if {[file tail $c] eq ".git"} { |
||||
continue |
||||
} |
||||
|
||||
# Expand directories. |
||||
if {[file isdirectory $c]} { |
||||
lappend waiting {*}[lsort -unique [glob -directory $c * .*]] |
||||
continue |
||||
} |
||||
|
||||
# Handle files as per the user's will. |
||||
set thepath $current |
||||
switch -exact -- [catch { uplevel 1 $script } result] { |
||||
0 - 4 { |
||||
# ok, continue - nothing |
||||
} |
||||
2 { |
||||
# return, abort, rethrow |
||||
return -code return |
||||
} |
||||
3 { |
||||
# break, abort |
||||
return |
||||
} |
||||
1 - default { |
||||
# error, any thing else - rethrow |
||||
return -code error $result |
||||
} |
||||
} |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc is_valid_tm_version {versionpart} { |
||||
#Needs to be suitable for use with Tcl's 'package vcompare' |
||||
if {![catch [list package vcompare $versionpart $versionpart]]} { |
||||
return 1 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
#Note that semver only has a small overlap with tcl tm versions. |
||||
#todo - work out what overlap and whether it's even useful |
||||
#see also TIP #439: Semantic Versioning (tcl 9??) |
||||
proc semver {versionstring} { |
||||
set re {^(0|[1-9]\d*)\.(0|[1-9]\d*)\.(0|[1-9]\d*)(?:-((?:0|[1-9]\d*|\d*[a-zA-Z-][0-9a-zA-Z-]*)(?:\.(?:0|[1-9]\d*|\d*[a-zA-Z-][0-9a-zA-Z-]*))*))?(?:\+([0-9a-zA-Z-]+(?:\.[0-9a-zA-Z-]+)*))?$} |
||||
} |
||||
#todo - semver conversion/validation for other systems? |
||||
proc magic_tm_version {} { |
||||
set magicbase 999999 ;#deliberately large so given load-preference when testing! |
||||
#we split the literal to avoid the literal appearing here - reduce risk of accidentally converting to a release version |
||||
return ${magicbase}.0a1.0 |
||||
} |
||||
|
||||
|
||||
|
||||
proc tmpfile {{prefix tmp_}} { |
||||
#note risk of collision if pregenerating a list of tmpfile names |
||||
#we will maintain an icrementing id so the caller doesn't have to bear that in mind |
||||
variable tmpfile_counter |
||||
global tcl_platform |
||||
return .punkutil_$prefix[pid]_[clock microseconds]_[incr tmpfile_counter]_[info hostname]_$tcl_platform(user) |
||||
} |
||||
|
||||
proc tmpdir {} { |
||||
# Taken from tcllib fileutil. |
||||
global tcl_platform env |
||||
|
||||
set attempdirs [list] |
||||
set problems {} |
||||
|
||||
foreach tmp {TEMP TMP TMPDIR} { |
||||
if { [info exists env($tmp)] } { |
||||
lappend attempdirs $env($tmp) |
||||
} else { |
||||
lappend problems "No environment variable $tmp" |
||||
} |
||||
} |
||||
|
||||
switch $tcl_platform(platform) { |
||||
windows { |
||||
lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP" |
||||
} |
||||
macintosh { |
||||
lappend attempdirs $env(TRASH_FOLDER) ;# a better place? |
||||
} |
||||
default { |
||||
lappend attempdirs \ |
||||
[file join / tmp] \ |
||||
[file join / var tmp] \ |
||||
[file join / usr tmp] |
||||
} |
||||
} |
||||
|
||||
lappend attempdirs [pwd] |
||||
|
||||
foreach tmp $attempdirs { |
||||
if { [file isdirectory $tmp] && |
||||
[file writable $tmp] } { |
||||
return [file normalize $tmp] |
||||
} elseif { ![file isdirectory $tmp] } { |
||||
lappend problems "Not a directory: $tmp" |
||||
} else { |
||||
lappend problems "Not writable: $tmp" |
||||
} |
||||
} |
||||
|
||||
# Fail if nothing worked. |
||||
return -code error "Unable to determine a proper directory for temporary files\n[join $problems \n]" |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::util [namespace eval punk::mix::util { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,158 @@
|
||||
|
||||
|
||||
package require punk::mix::util |
||||
|
||||
namespace eval ::punk::overlay { |
||||
#based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend |
||||
# extend an ensemble-like routine with the routines in some namespace |
||||
# |
||||
# e.g custom_from_base ::punk::mix::cli ::punk::mix::base |
||||
# |
||||
proc custom_from_base {routine base} { |
||||
if {![string match ::* $routine]} { |
||||
set resolved [uplevel 1 [list ::namespace which $routine]] |
||||
if {$resolved eq {}} { |
||||
error [list {no such routine} $routine] |
||||
} |
||||
set routine $resolved |
||||
} |
||||
set routinens [namespace qualifiers $routine] |
||||
if {$routinens eq {::}} { |
||||
set routinens {} |
||||
} |
||||
set routinetail [namespace tail $routine] |
||||
|
||||
if {![string match ::* $base]} { |
||||
set base [uplevel 1 [ |
||||
list [namespace which namespace] current]]::$base |
||||
} |
||||
|
||||
if {![namespace exists $base]} { |
||||
error [list {no such namespace} $base] |
||||
} |
||||
|
||||
set base [namespace eval $base [ |
||||
list [namespace which namespace] current]] |
||||
|
||||
|
||||
#while 1 { |
||||
# set renamed ${routinens}::${routinetail}_[info cmdcount] |
||||
# if {[namespace which $renamed] eq {}} break |
||||
#} |
||||
|
||||
namespace eval $routine [ |
||||
list namespace ensemble configure $routine -unknown [ |
||||
list apply {{base ensemble subcommand args} { |
||||
list ${base}::_redirected $ensemble $subcommand |
||||
}} $base |
||||
] |
||||
] |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${routine}::util |
||||
#namespace eval ${routine}::util { |
||||
#namespace import ::punk::mix::util::* |
||||
#} |
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ${base}::lib::* ${routine}::lib |
||||
#namespace eval ${routine}::lib [string map [list <base> $base] { |
||||
# namespace import <base>::lib::* |
||||
#}] |
||||
|
||||
namespace eval ${routine}::lib [string map [list <base> $base <routine> $routine] { |
||||
if {[namespace exists <base>::lib]} { |
||||
set current_paths [namespace path] |
||||
if {"<routine>" ni $current_paths} { |
||||
lappend current_paths <routine> |
||||
} |
||||
namespace path $current_paths |
||||
} |
||||
}] |
||||
|
||||
namespace eval $routine { |
||||
set exportlist [list] |
||||
foreach cmd [info commands [namespace current]::*] { |
||||
set c [namespace tail $cmd] |
||||
if {![string match _* $c]} { |
||||
lappend exportlist $c |
||||
} |
||||
} |
||||
namespace export {*}$exportlist |
||||
} |
||||
|
||||
return $routine |
||||
} |
||||
#load *exported* commands from cmdnamespace into caller's namespace - prefixing each command with $prefix |
||||
#Note: commandset may be imported by different CLIs with different bases *at the same time* |
||||
#so we don't make commands from the cli or its base available automatically (will generally require fully-qualified commands to use code from cli/base) |
||||
#we do load punk::mix::util::* into the util subnamespace even though the commandset might not be loaded in a cli using punk::mix::base i.e punk::mix::util is a common dependency for CLIs. |
||||
#commandsets designed to be used with a specific cli/base may choose to do their own import e.g with util::namespace_import_pattern_to_namespace_noclobber and/or set namespace path if they |
||||
#want the convenience of using lib:xxx with commands coming from those packages. |
||||
#This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. |
||||
#The basic principle is that the commandset is loaded into the caller(s) with a prefix |
||||
#- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) |
||||
proc import_commandset {prefix separator cmdnamespace} { |
||||
set bad_seps [list "::"] |
||||
if {$separator in $bad_seps} { |
||||
error "import_commandset invalid separator '$separator'" |
||||
} |
||||
#namespace may or may not be a package |
||||
# allow with or without leading :: |
||||
if {[string range $cmdnamespace 0 1] eq "::"} { |
||||
set cmdpackage [string range $cmdnamespace 2 end] |
||||
} else { |
||||
set cmdpackage $cmdnamespace |
||||
set cmdnamespace ::$cmdnamespace |
||||
} |
||||
|
||||
if {![namespace exists $cmdnamespace]} { |
||||
#only do package require if the namespace not already present |
||||
catch {package require $cmdpackage} pkg_load_info |
||||
#recheck |
||||
if {![namespace exists $cmdnamespace]} { |
||||
set prov [package provide $cmdpackage] |
||||
if {[string length $prov]} { |
||||
set provinfo "(package $cmdpackage is present with version $prov)" |
||||
} else { |
||||
set provinfo "(package $cmdpackage not present)" |
||||
} |
||||
error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Pkg_load_result: $pkg_load_info Usage: import_commandset prefix separator namespace" |
||||
} |
||||
} |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util |
||||
|
||||
#let child namespace 'lib' resolve parent namespace and thus util::xxx |
||||
namespace eval ${cmdnamespace}::lib [string map [list <cmdns> $cmdnamespace] { |
||||
set nspaths [namespace path] |
||||
if {"<cmdns>" ni $nspaths} { |
||||
lappend nspaths <cmdns> |
||||
} |
||||
namespace path $nspaths |
||||
}] |
||||
|
||||
set imported_commands [list] |
||||
set nscaller [uplevel 1 [list namespace current]] |
||||
if {[catch { |
||||
namespace eval ${nscaller}::temp_import [list namespace import ${cmdnamespace}::*] |
||||
foreach cmd [info commands ${nscaller}::temp_import::*] { |
||||
set cmdtail [namespace tail $cmd] |
||||
if {$cmdtail eq "_default"} { |
||||
set import_as ${nscaller}::${prefix} |
||||
} else { |
||||
set import_as ${nscaller}::${prefix}${separator}${cmdtail} |
||||
} |
||||
rename $cmd $import_as |
||||
lappend imported_commands $import_as |
||||
} |
||||
} errM]} { |
||||
puts stderr "Error loading commandset $prefix $separator $cmdnamespace" |
||||
puts stderr "err: $errM" |
||||
} |
||||
return $imported_commands |
||||
} |
||||
} |
||||
|
||||
|
||||
package provide punk::overlay [namespace eval punk::overlay { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
@ -0,0 +1,104 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::tdl 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::tdl { |
||||
# https://wiki.tcl-lang.org/page/Config+file+using+slave+interp |
||||
|
||||
variable sample_script { |
||||
server -name bsd1 -os FreeBSD |
||||
server -name p1 -os linux |
||||
server -name trillion -os windows |
||||
|
||||
server -name vmhost1 -os FreeBSD { |
||||
guest -name bsd1 -vmmanager iocage |
||||
guest -name p1 -vmmanager bhyve |
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
proc prettyparse {script} { |
||||
set i [interp create -safe] |
||||
try { |
||||
# $i eval {unset {*}[info vars]} |
||||
# foreach command [$i eval {info commands}] {$i hide $command} |
||||
# $i invokehidden namespace delete {*}[$i invokehidden namespace children] |
||||
$i alias unknown apply {{i tag args} { |
||||
upvar 1 result result |
||||
set e [concat [list tag $tag]\ |
||||
[lrange $args 0 [expr {([llength $args] & ~1) - 1}]]] |
||||
if {[llength $args] % 2} { |
||||
set saved $result |
||||
set result {} |
||||
$i eval [lindex $args end] |
||||
lappend e body $result |
||||
set result $saved |
||||
} |
||||
lappend result $e |
||||
list |
||||
}} $i |
||||
set result {} |
||||
$i eval $script |
||||
return $result |
||||
} finally { |
||||
interp delete $i |
||||
} |
||||
} |
||||
proc prettyprint {data {level 0}} { |
||||
set ind [string repeat " " $level] |
||||
incr level |
||||
set result {} |
||||
foreach e $data { |
||||
set line $ind[concat [list [dict get $e tag]] [dict remove $e tag body]] |
||||
if {[dict exists $e body] && [llength [dict get $e body]]} { |
||||
append line " {\n[prettyprint [dict get $e body] $level]\n$ind}" |
||||
} |
||||
lappend result $line |
||||
} |
||||
join $result \n |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::tdl [namespace eval punk::tdl { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -1,158 +1,158 @@
|
||||
|
||||
|
||||
package require punk::mix::util |
||||
|
||||
namespace eval ::punk::overlay { |
||||
#based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend |
||||
# extend an ensemble-like routine with the routines in some namespace |
||||
# |
||||
# e.g custom_from_base ::punk::mix::cli ::punk::mix::base |
||||
# |
||||
proc custom_from_base {routine base} { |
||||
if {![string match ::* $routine]} { |
||||
set resolved [uplevel 1 [list ::namespace which $routine]] |
||||
if {$resolved eq {}} { |
||||
error [list {no such routine} $routine] |
||||
} |
||||
set routine $resolved |
||||
} |
||||
set routinens [namespace qualifiers $routine] |
||||
if {$routinens eq {::}} { |
||||
set routinens {} |
||||
} |
||||
set routinetail [namespace tail $routine] |
||||
|
||||
if {![string match ::* $base]} { |
||||
set base [uplevel 1 [ |
||||
list [namespace which namespace] current]]::$base |
||||
} |
||||
|
||||
if {![namespace exists $base]} { |
||||
error [list {no such namespace} $base] |
||||
} |
||||
|
||||
set base [namespace eval $base [ |
||||
list [namespace which namespace] current]] |
||||
|
||||
|
||||
#while 1 { |
||||
# set renamed ${routinens}::${routinetail}_[info cmdcount] |
||||
# if {[namespace which $renamed] eq {}} break |
||||
#} |
||||
|
||||
namespace eval $routine [ |
||||
list namespace ensemble configure $routine -unknown [ |
||||
list apply {{base ensemble subcommand args} { |
||||
list ${base}::_redirected $ensemble $subcommand |
||||
}} $base |
||||
] |
||||
] |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${routine}::util |
||||
#namespace eval ${routine}::util { |
||||
#namespace import ::punk::mix::util::* |
||||
#} |
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ${base}::lib::* ${routine}::lib |
||||
#namespace eval ${routine}::lib [string map [list <base> $base] { |
||||
# namespace import <base>::lib::* |
||||
#}] |
||||
|
||||
namespace eval ${routine}::lib [string map [list <base> $base <routine> $routine] { |
||||
if {[namespace exists <base>::lib]} { |
||||
set current_paths [namespace path] |
||||
if {"<routine>" ni $current_paths} { |
||||
lappend current_paths <routine> |
||||
} |
||||
namespace path $current_paths |
||||
} |
||||
}] |
||||
|
||||
namespace eval $routine { |
||||
set exportlist [list] |
||||
foreach cmd [info commands [namespace current]::*] { |
||||
set c [namespace tail $cmd] |
||||
if {![string match _* $c]} { |
||||
lappend exportlist $c |
||||
} |
||||
} |
||||
namespace export {*}$exportlist |
||||
} |
||||
|
||||
return $routine |
||||
} |
||||
#load *exported* commands from cmdnamespace into caller's namespace - prefixing each command with $prefix |
||||
#Note: commandset may be imported by different CLIs with different bases *at the same time* |
||||
#so we don't make commands from the cli or its base available automatically (will generally require fully-qualified commands to use code from cli/base) |
||||
#we do load punk::mix::util::* into the util subnamespace even though the commandset might not be loaded in a cli using punk::mix::base i.e punk::mix::util is a common dependency for CLIs. |
||||
#commandsets designed to be used with a specific cli/base may choose to do their own import e.g with util::namespace_import_pattern_to_namespace_noclobber and/or set namespace path if they |
||||
#want the convenience of using lib:xxx with commands coming from those packages. |
||||
#This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. |
||||
#The basic principle is that the commandset is loaded into the caller(s) with a prefix |
||||
#- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) |
||||
proc import_commandset {prefix separator cmdnamespace} { |
||||
set bad_seps [list "::"] |
||||
if {$separator in $bad_seps} { |
||||
error "import_commandset invalid separator '$separator'" |
||||
} |
||||
#namespace may or may not be a package |
||||
# allow with or without leading :: |
||||
if {[string range $cmdnamespace 0 1] eq "::"} { |
||||
set cmdpackage [string range $cmdnamespace 2 end] |
||||
} else { |
||||
set cmdpackage $cmdnamespace |
||||
set cmdnamespace ::$cmdnamespace |
||||
} |
||||
|
||||
if {![namespace exists $cmdnamespace]} { |
||||
#only do package require if the namespace not already present |
||||
catch {package require $cmdpackage} |
||||
#recheck |
||||
if {![namespace exists $cmdnamespace]} { |
||||
set prov [package provide $cmdpackage] |
||||
if {[string length $prov]} { |
||||
set provinfo "(package $cmdpackage is present with version $prov)" |
||||
} else { |
||||
set provinfo "(package $cmdpackage not present)" |
||||
} |
||||
error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Usage: import_commandset prefix separator namespace" |
||||
} |
||||
} |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util |
||||
|
||||
#let child namespace 'lib' resolve parent namespace and thus util::xxx |
||||
namespace eval ${cmdnamespace}::lib [string map [list <cmdns> $cmdnamespace] { |
||||
set nspaths [namespace path] |
||||
if {"<cmdns>" ni $nspaths} { |
||||
lappend nspaths <cmdns> |
||||
} |
||||
namespace path $nspaths |
||||
}] |
||||
|
||||
set imported_commands [list] |
||||
set nscaller [uplevel 1 [list namespace current]] |
||||
if {[catch { |
||||
namespace eval ${nscaller}::temp_import [list namespace import ${cmdnamespace}::*] |
||||
foreach cmd [info commands ${nscaller}::temp_import::*] { |
||||
set cmdtail [namespace tail $cmd] |
||||
if {$cmdtail eq "_default"} { |
||||
set import_as ${nscaller}::${prefix} |
||||
} else { |
||||
set import_as ${nscaller}::${prefix}${separator}${cmdtail} |
||||
} |
||||
rename $cmd $import_as |
||||
lappend imported_commands $import_as |
||||
} |
||||
} errM]} { |
||||
puts stderr "Error loading commandset $prefix $separator $cmdnamespace" |
||||
puts stderr "err: $errM" |
||||
} |
||||
return $imported_commands |
||||
} |
||||
} |
||||
|
||||
|
||||
package provide punk::overlay [namespace eval punk::overlay { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
||||
|
||||
package require punk::mix::util |
||||
|
||||
namespace eval ::punk::overlay { |
||||
#based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend |
||||
# extend an ensemble-like routine with the routines in some namespace |
||||
# |
||||
# e.g custom_from_base ::punk::mix::cli ::punk::mix::base |
||||
# |
||||
proc custom_from_base {routine base} { |
||||
if {![string match ::* $routine]} { |
||||
set resolved [uplevel 1 [list ::namespace which $routine]] |
||||
if {$resolved eq {}} { |
||||
error [list {no such routine} $routine] |
||||
} |
||||
set routine $resolved |
||||
} |
||||
set routinens [namespace qualifiers $routine] |
||||
if {$routinens eq {::}} { |
||||
set routinens {} |
||||
} |
||||
set routinetail [namespace tail $routine] |
||||
|
||||
if {![string match ::* $base]} { |
||||
set base [uplevel 1 [ |
||||
list [namespace which namespace] current]]::$base |
||||
} |
||||
|
||||
if {![namespace exists $base]} { |
||||
error [list {no such namespace} $base] |
||||
} |
||||
|
||||
set base [namespace eval $base [ |
||||
list [namespace which namespace] current]] |
||||
|
||||
|
||||
#while 1 { |
||||
# set renamed ${routinens}::${routinetail}_[info cmdcount] |
||||
# if {[namespace which $renamed] eq {}} break |
||||
#} |
||||
|
||||
namespace eval $routine [ |
||||
list namespace ensemble configure $routine -unknown [ |
||||
list apply {{base ensemble subcommand args} { |
||||
list ${base}::_redirected $ensemble $subcommand |
||||
}} $base |
||||
] |
||||
] |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${routine}::util |
||||
#namespace eval ${routine}::util { |
||||
#namespace import ::punk::mix::util::* |
||||
#} |
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ${base}::lib::* ${routine}::lib |
||||
#namespace eval ${routine}::lib [string map [list <base> $base] { |
||||
# namespace import <base>::lib::* |
||||
#}] |
||||
|
||||
namespace eval ${routine}::lib [string map [list <base> $base <routine> $routine] { |
||||
if {[namespace exists <base>::lib]} { |
||||
set current_paths [namespace path] |
||||
if {"<routine>" ni $current_paths} { |
||||
lappend current_paths <routine> |
||||
} |
||||
namespace path $current_paths |
||||
} |
||||
}] |
||||
|
||||
namespace eval $routine { |
||||
set exportlist [list] |
||||
foreach cmd [info commands [namespace current]::*] { |
||||
set c [namespace tail $cmd] |
||||
if {![string match _* $c]} { |
||||
lappend exportlist $c |
||||
} |
||||
} |
||||
namespace export {*}$exportlist |
||||
} |
||||
|
||||
return $routine |
||||
} |
||||
#load *exported* commands from cmdnamespace into caller's namespace - prefixing each command with $prefix |
||||
#Note: commandset may be imported by different CLIs with different bases *at the same time* |
||||
#so we don't make commands from the cli or its base available automatically (will generally require fully-qualified commands to use code from cli/base) |
||||
#we do load punk::mix::util::* into the util subnamespace even though the commandset might not be loaded in a cli using punk::mix::base i.e punk::mix::util is a common dependency for CLIs. |
||||
#commandsets designed to be used with a specific cli/base may choose to do their own import e.g with util::namespace_import_pattern_to_namespace_noclobber and/or set namespace path if they |
||||
#want the convenience of using lib:xxx with commands coming from those packages. |
||||
#This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. |
||||
#The basic principle is that the commandset is loaded into the caller(s) with a prefix |
||||
#- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) |
||||
proc import_commandset {prefix separator cmdnamespace} { |
||||
set bad_seps [list "::"] |
||||
if {$separator in $bad_seps} { |
||||
error "import_commandset invalid separator '$separator'" |
||||
} |
||||
#namespace may or may not be a package |
||||
# allow with or without leading :: |
||||
if {[string range $cmdnamespace 0 1] eq "::"} { |
||||
set cmdpackage [string range $cmdnamespace 2 end] |
||||
} else { |
||||
set cmdpackage $cmdnamespace |
||||
set cmdnamespace ::$cmdnamespace |
||||
} |
||||
|
||||
if {![namespace exists $cmdnamespace]} { |
||||
#only do package require if the namespace not already present |
||||
catch {package require $cmdpackage} pkg_load_info |
||||
#recheck |
||||
if {![namespace exists $cmdnamespace]} { |
||||
set prov [package provide $cmdpackage] |
||||
if {[string length $prov]} { |
||||
set provinfo "(package $cmdpackage is present with version $prov)" |
||||
} else { |
||||
set provinfo "(package $cmdpackage not present)" |
||||
} |
||||
error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Pkg_load_result: $pkg_load_info Usage: import_commandset prefix separator namespace" |
||||
} |
||||
} |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util |
||||
|
||||
#let child namespace 'lib' resolve parent namespace and thus util::xxx |
||||
namespace eval ${cmdnamespace}::lib [string map [list <cmdns> $cmdnamespace] { |
||||
set nspaths [namespace path] |
||||
if {"<cmdns>" ni $nspaths} { |
||||
lappend nspaths <cmdns> |
||||
} |
||||
namespace path $nspaths |
||||
}] |
||||
|
||||
set imported_commands [list] |
||||
set nscaller [uplevel 1 [list namespace current]] |
||||
if {[catch { |
||||
namespace eval ${nscaller}::temp_import [list namespace import ${cmdnamespace}::*] |
||||
foreach cmd [info commands ${nscaller}::temp_import::*] { |
||||
set cmdtail [namespace tail $cmd] |
||||
if {$cmdtail eq "_default"} { |
||||
set import_as ${nscaller}::${prefix} |
||||
} else { |
||||
set import_as ${nscaller}::${prefix}${separator}${cmdtail} |
||||
} |
||||
rename $cmd $import_as |
||||
lappend imported_commands $import_as |
||||
} |
||||
} errM]} { |
||||
puts stderr "Error loading commandset $prefix $separator $cmdnamespace" |
||||
puts stderr "err: $errM" |
||||
} |
||||
return $imported_commands |
||||
} |
||||
} |
||||
|
||||
|
||||
package provide punk::overlay [namespace eval punk::overlay { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
||||
@ -0,0 +1,50 @@
|
||||
# -*- tcl -*- |
||||
# |
||||
# 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application xxx 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval xxx { |
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide xxx [namespace eval xxx { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,3 @@
|
||||
0.1.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
@ -0,0 +1,51 @@
|
||||
# -*- 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application %pkg% 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
apply {code { #auto determine package name and version from name and placement of .tm file |
||||
foreach base [tcl::tm::list] { |
||||
set nsprefix "";#in case sourced directly and not in any of the .tm paths |
||||
if {[string match -nocase ${base}* [info script]]} { |
||||
set nsprefix [string trimleft [join [lrange [file split [string range [info script] [string length $base]+1 end]] 0 end-1] ::]:: ::] |
||||
break |
||||
} |
||||
} |
||||
set ver [join [lassign [split [file rootname [file tail [info script] ]] -] pkgtail] -] |
||||
set pkgns ${nsprefix}${pkgtail} |
||||
namespace eval $pkgns [string map [list <pkg> $pkgns <ver> $ver] $code] |
||||
package provide $pkgns $ver;# only provide package if code evaluated without error |
||||
} ::} { |
||||
#-------------------------------------- |
||||
variable pkg "<pkg>" |
||||
variable version "<ver>" |
||||
#-------------------------------------- |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
#proc test {args} {puts "[namespace current]::test got args: $args"} |
||||
|
||||
|
||||
|
||||
namespace eval [namespace current]::lib { |
||||
#proc test {args} {puts "[namespace current]::test got args: $args"} |
||||
} |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
} |
||||
return |
||||
|
||||
@ -1,195 +1,195 @@
|
||||
#JMN - api should be kept in sync with package patternlib where possible |
||||
# |
||||
package provide oolib [namespace eval oolib { |
||||
variable version |
||||
set version 0.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]} { |
||||
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 [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 {} { |
||||
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 |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
#JMN - api should be kept in sync with package patternlib where possible |
||||
# |
||||
package provide oolib [namespace eval oolib { |
||||
variable version |
||||
set version 0.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]} { |
||||
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 [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 {} { |
||||
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 |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
Loading…
Reference in new issue