71 changed files with 9804 additions and 2929 deletions
@ -0,0 +1,13 @@
|
||||
Home /home * {} |
||||
Timeline /timeline {o r j} {} |
||||
Files /dir?ci=tip oh desktoponly |
||||
Branches /brlist o wideonly |
||||
Tags /taglist o wideonly |
||||
Forum /forum {@2 3 4 5 6} wideonly |
||||
Chat /chat C wideonly |
||||
Tickets /ticket r wideonly |
||||
Wiki /wiki j wideonly |
||||
Download /download * {} |
||||
Admin /setup {a s} desktoponly |
||||
Logout /logout L wideonly |
||||
Login /login !L wideonly |
||||
@ -0,0 +1,7 @@
|
||||
src |
||||
src/vendorlib |
||||
src/vendormodules |
||||
src/modules |
||||
src/lib |
||||
lib |
||||
modules |
||||
@ -0,0 +1,29 @@
|
||||
.git |
||||
bin |
||||
lib |
||||
#The directory for compiled/built Tcl modules |
||||
modules |
||||
|
||||
#Temporary files e.g from tests |
||||
tmp |
||||
|
||||
logs |
||||
_aside |
||||
_build |
||||
|
||||
#Built documentation |
||||
html |
||||
man |
||||
md |
||||
doc |
||||
|
||||
test* |
||||
|
||||
#Built tclkits (if any) |
||||
punk*.exe |
||||
tcl*.exe |
||||
|
||||
#miscellaneous editor files etc |
||||
*.swp |
||||
|
||||
todo.txt |
||||
@ -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) %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 version |
||||
set version %version% |
||||
}] |
||||
return |
||||
@ -0,0 +1,70 @@
|
||||
# -*- 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 canaryspace 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# Meta summary Diagnostic tool for namespace navigation/introspection to help avoid command conflicts. |
||||
# Meta description canaryspace loads the ::canaryspace namespace with wrappers for the set of commands |
||||
# Meta description that exist in the global namespace :: at the time the canaryspace package is loaded. |
||||
# Meta description These commands just emit info to stderr to assist in determining whether calls are |
||||
# Meta description unintentionally being run in the namespace. |
||||
# Meta description This is often the case with commands which use uplevel 1 or similar constructs to call |
||||
# Meta description code in the callers namespace. If such commands need to run in arbitrary namespaces |
||||
# Meta description which may have arbitrary commands then uplevelled commands may need to be prefixed with |
||||
# Meta description :: or the appropriate namespace path. |
||||
# Meta description Constructs such as punk pipelines deliberately run script segments in the calling context |
||||
# Meta description and so may need to be comprised mainly of fully qualified commands. |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
namespace eval canaryspace::setup { |
||||
variable gcommands |
||||
proc build_commands {} { |
||||
variable gcommands |
||||
gcommands.= nscommands ::* -raw |> .=>1 linelist |
||||
foreach cmd $gcommands { |
||||
proc ::canaryspace::$cmd args [string map [list <cmd> $cmd] { |
||||
::puts stderr "CANARYSPACE <cmd>" |
||||
::puts stderr " [::info level 0]" |
||||
::tailcall ::<cmd> {*}$args |
||||
} ] |
||||
} |
||||
} |
||||
build_commands |
||||
} |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval canaryspace { |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide canaryspace [namespace eval canaryspace { |
||||
::variable version |
||||
::set version 999999.0a1.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,789 @@
|
||||
# -*- 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 "" ::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." ::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 "" ::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 |
||||
|
||||
|
||||
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] |
||||
|
||||
|
||||
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 |
||||
set exitinfo [run [info nameofexecutable] $sourcefolder/make.tcl project] |
||||
set exitcode [dict get $exitinfo exitcode] |
||||
|
||||
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_eventid "\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_eventid [dict get $opts -punkcheck_eventid] |
||||
|
||||
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 |
||||
|
||||
} else { |
||||
set punkcheck_eventid $opt_punkcheck_eventid |
||||
} |
||||
#---------------------------------------- |
||||
|
||||
|
||||
|
||||
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]} { |
||||
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] |
||||
|
||||
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 $changed_list]} { |
||||
set file_record [punkcheck::installfile_started_install $basedir $file_record] |
||||
# -- --- --- --- --- --- |
||||
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] |
||||
} 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] |
||||
} |
||||
|
||||
#------------------------------ |
||||
|
||||
} |
||||
|
||||
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] |
||||
|
||||
if {[llength $changed_list]} { |
||||
set file_record [punkcheck::installfile_started_install $basedir $file_record] |
||||
# -- --- --- --- --- --- |
||||
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] |
||||
} else { |
||||
puts -nonewline stderr "." |
||||
set did_skip 1 |
||||
set file_record [punkcheck::installfile_skipped_install $basedir $file_record] |
||||
} |
||||
|
||||
} |
||||
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_eventid $punkcheck_eventid\ |
||||
-glob $fileglob\ |
||||
] |
||||
} |
||||
if {$did_skip} { |
||||
puts -nonewline stdout \n |
||||
} |
||||
return $module_list |
||||
} |
||||
|
||||
proc kettle_call {calltype args} { |
||||
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 {[catch {package present kettle}]} { |
||||
puts stdout "Loading kettle package - may be delay on first load ..." |
||||
package require kettle |
||||
} |
||||
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 999999.0a1.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 buildsuites {{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 999999.0a1.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,65 @@
|
||||
# -*- 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 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::debug { |
||||
namespace export paths |
||||
namespace path ::punk::mix::cli |
||||
|
||||
proc paths {} { |
||||
set pathinfo [punk::repo::find_repos [pwd]] |
||||
puts stdout "pathinfo: $pathinfo" |
||||
set projectdir [dict get $pathinfo closest] |
||||
puts stdout "closest projectdir: $projectdir" |
||||
set modulefolders [lib::find_source_module_paths $projectdir] |
||||
puts stdout "modulefolders: $modulefolders" |
||||
return |
||||
} |
||||
|
||||
namespace eval lib { |
||||
|
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::debug [namespace eval punk::mix::commandset::debug { |
||||
variable version |
||||
set version 999999.0a1.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,140 @@
|
||||
# -*- 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 999999.0a1.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 tpldir [::punk::mix::base::lib::mix_templates_dir] |
||||
set layout_base $tpldir/layouts |
||||
set layout_dir [file join $layout_base $layout] |
||||
if {![file exists $layout_dir]} { |
||||
puts stderr "Unable to locate folder for layout '$layout' at $layout_dir" |
||||
return |
||||
} |
||||
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 layouts {{glob {}}} { |
||||
if {![string length $glob]} { |
||||
set glob * |
||||
} |
||||
|
||||
set tpldir [::punk::mix::base::lib::mix_templates_dir] |
||||
set layout_base $tpldir/layouts |
||||
set layouts [glob -nocomplain -dir $layout_base -type d -tail *] |
||||
set layouts [lsort $layouts] |
||||
if {$glob ne "*"} { |
||||
set layouts [lsearch -all -inline $layouts $glob] |
||||
} |
||||
return [join [lsort $layouts] \n] |
||||
} |
||||
|
||||
} |
||||
namespace eval lib { |
||||
proc layout_all_files {layout} { |
||||
set tpldir [::punk::mix::base::lib::mix_templates_dir] |
||||
set layoutfolder $tpldir/layouts/$layout |
||||
if {![file isdirectory $layoutfolder]} { |
||||
puts stderr "layout '$layout' not found in $tpldir/layouts" |
||||
} |
||||
set file_list [list] |
||||
util::foreach-file $layoutfolder path { |
||||
lappend file_list $path |
||||
} |
||||
|
||||
return $file_list |
||||
} |
||||
proc layout_scan_for_template_files {layout {tags {}}} { |
||||
#equivalent for projects? punk::mix::commandset::module::lib::templates_dict -scriptpath "" |
||||
set tpldir [::punk::mix::base::lib::mix_templates_dir] |
||||
set layoutfolder $tpldir/layouts/$layout |
||||
if {![file isdirectory $layoutfolder]} { |
||||
puts stderr "layout '$layout' not found in $tpldir/layouts" |
||||
} |
||||
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 999999.0a1.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,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 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
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::nsprefix $libfound] |
||||
if {[string length $moduleprefix]} { |
||||
set moduleprefix_parts [punk::nsparts $moduleprefix] |
||||
set relative_path [file join {*}$moduleprefix_parts] |
||||
} else { |
||||
set relative_path "" |
||||
} |
||||
set pkgtail [punk::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 999999.0a1.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,414 @@
|
||||
# -*- 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 999999.0a1.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 |
||||
} |
||||
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]]]} { |
||||
error "module.new unable to create module in projectdir:$projectdir - directory doesn't appear to meet basic standards (/src, src/modules, src/lib & /modules must exist, must not be a system path such as /usr/bin or c:/windows)" |
||||
} |
||||
} |
||||
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 lib_tpldir [file join [punk::mix::cli::lib::mix_templates_dir] module];#fallback for modulename_buildversion.txt, modulename_description.txt |
||||
set templates_dict [templates_dict] |
||||
#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 { |
||||
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_tfolders [list] |
||||
set tfolders [punk::mix::base::lib::get_template_folders $opt_scriptpath] |
||||
foreach tf $tfolders { |
||||
lappend module_tfolders [file join $tf module] |
||||
} |
||||
|
||||
|
||||
|
||||
set template_files [list] |
||||
foreach fld $module_tfolders { |
||||
set matched_files [glob -nocomplain -dir $fld -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 999999.0a1.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,734 @@
|
||||
# -*- 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 999999.0a1.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 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 "-------------------------------------------" |
||||
} |
||||
|
||||
#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" |
||||
} |
||||
|
||||
|
||||
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 |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
#punk::mix::base::lib::get_template_folders |
||||
#punk::mix::commandset::module::lib::templates_dict -scriptpath "" |
||||
|
||||
|
||||
set tpldir [punk::mix::cli::lib::mix_templates_dir] |
||||
|
||||
if {[file exists $projectdir] && !($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 {[file exists $projectdir] && $opt_force} { |
||||
puts stderr "mix new WARNING: -force 1 was supplied. Will copy layout $tpldir/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 {[file exists $projectdir] && $opt_update} { |
||||
puts stderr "mix new WARNING: -update 1 was supplied. Will copy layout $tpldir/layouts/$opt_layout using -update option to add missing items" |
||||
} |
||||
|
||||
|
||||
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 |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
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 $tpldir/layouts/$opt_layout |
||||
puts stdout ">>> about to call punkcheck::install $layout_dir $projectdir" |
||||
#In this case we need to override the default dir antiglob - as .fossil- folders need to be installed from template |
||||
## default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"] |
||||
set override_antiglob_dir_core [list #* _aside .git] |
||||
if {$opt_force} { |
||||
punkcheck::install $layout_dir $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite ALL-TARGETS |
||||
#file copy -force $layout_dir $projectdir |
||||
} else { |
||||
punkcheck::install $layout_dir $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core |
||||
} |
||||
|
||||
#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 data [string map [list %project% $projectname] $data] |
||||
set fdout [open $fpath w]; fconfigure $fdout -translation binary; puts -nonewline $fdout $data; close $fdout |
||||
} else { |
||||
puts stderr "warning: Missing template file $fpath" |
||||
} |
||||
} |
||||
#todo - tag substitutions in src/doc tree |
||||
|
||||
|
||||
cd $projectdir |
||||
|
||||
foreach m $opt_modules { |
||||
punk::mix::commandset::module::new $m -project $projectname -type $opt_type -force $opt_force |
||||
} |
||||
|
||||
#generate www/man/md output in 'embedded' folder which should be checked into repo for online documentation |
||||
cd $projectdir/src |
||||
punk::mix::cli::lib::kettle_call lib doc |
||||
#Kettle doc |
||||
|
||||
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] |
||||
|
||||
proc projects {{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 projects.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 projects.cd {{glob {}} args} { |
||||
dict set args -cd 1 |
||||
projects.work $glob {*}$args |
||||
} |
||||
proc projects.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} { |
||||
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] |
||||
} 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" |
||||
cd $workingdir |
||||
return $workingdir |
||||
} 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 999999.0a1.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,70 @@
|
||||
# -*- 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 999999.0a1.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" |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::repo [namespace eval punk::mix::commandset::repo { |
||||
variable version |
||||
set version 999999.0a1.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,600 @@
|
||||
# -*- 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 999999.0a1.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 |
||||
|
||||
|
||||
|
||||
set libwrapper_folder_default [file join [::punk::mix::base::lib::mix_templates_dir] utility scriptappwrappers] |
||||
if {$opt_template eq "\uFFFF"} { |
||||
set templatename punk-multishell.cmd |
||||
} |
||||
if {[string length $customwrapper_folder] && [file exists [file join $customwrapper_folder $templatename] ]} { |
||||
set wrapper_template [file join $customwrapper_folder $templatename] |
||||
} else { |
||||
set wrapper_template [file join $libwrapper_folder_default $templatename] |
||||
} |
||||
|
||||
if {![file exists $wrapper_template]} { |
||||
error "wrap_in_multishell: unable to find multishell template at $wrapper_template" |
||||
} |
||||
|
||||
|
||||
#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 fld [file join [::punk::mix::base::lib::mix_templates_dir] 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 999999.0a1.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,13 @@
|
||||
Home /home * {} |
||||
Timeline /timeline {o r j} {} |
||||
Files /dir?ci=tip oh desktoponly |
||||
Branches /brlist o wideonly |
||||
Tags /taglist o wideonly |
||||
Forum /forum {@2 3 4 5 6} wideonly |
||||
Chat /chat C wideonly |
||||
Tickets /ticket r wideonly |
||||
Wiki /wiki j wideonly |
||||
Download /download * {} |
||||
Admin /setup {a s} desktoponly |
||||
Logout /logout L wideonly |
||||
Login /login !L wideonly |
||||
@ -0,0 +1,7 @@
|
||||
src |
||||
src/vendorlib |
||||
src/vendormodules |
||||
src/modules |
||||
src/lib |
||||
lib |
||||
modules |
||||
@ -0,0 +1,29 @@
|
||||
.git |
||||
bin |
||||
lib |
||||
#The directory for compiled/built Tcl modules |
||||
modules |
||||
|
||||
#Temporary files e.g from tests |
||||
tmp |
||||
|
||||
logs |
||||
_aside |
||||
_build |
||||
|
||||
#Built documentation |
||||
html |
||||
man |
||||
md |
||||
doc |
||||
|
||||
test* |
||||
|
||||
#Built tclkits (if any) |
||||
punk*.exe |
||||
tcl*.exe |
||||
|
||||
#miscellaneous editor files etc |
||||
*.swp |
||||
|
||||
todo.txt |
||||
@ -0,0 +1,39 @@
|
||||
|
||||
/bin/ |
||||
/lib/ |
||||
#The directory for compiled/built Tcl modules |
||||
/modules/ |
||||
/vendorbuilds/ |
||||
|
||||
#Temporary files e.g from tests |
||||
/tmp/ |
||||
|
||||
/logs/ |
||||
**/_aside/ |
||||
**/_build/ |
||||
scratch* |
||||
|
||||
#Built documentation |
||||
/html/ |
||||
/man/ |
||||
/md/ |
||||
/doc/ |
||||
|
||||
/test* |
||||
|
||||
|
||||
#Built tclkits (if any) |
||||
punk*.exe |
||||
tcl*.exe |
||||
|
||||
#ignore fossil database files (but keep .fossil-settings and .fossil-custom in repository even if fossil not being used at your site) |
||||
_FOSSIL_ |
||||
.fos |
||||
.fslckout |
||||
*.fossil |
||||
|
||||
#miscellaneous editor files etc |
||||
*.swp |
||||
|
||||
|
||||
todo.txt |
||||
@ -0,0 +1,13 @@
|
||||
%project% |
||||
============================== |
||||
|
||||
+ |
||||
+ |
||||
|
||||
|
||||
About |
||||
------------------------------ |
||||
|
||||
+ |
||||
+ |
||||
+ |
||||
@ -0,0 +1,11 @@
|
||||
Tcl Module Source files for the project. |
||||
Consider using the punkshell pmix facility to create and manage these. |
||||
|
||||
pmix::newmodule <name> will create a basic .tm module template and assist in versioning. |
||||
|
||||
Tcl modules can be namespaced. |
||||
For example |
||||
> pmix::newmodule mymodule::utils |
||||
will create the new module under src/modules/mymodule/utils |
||||
|
||||
|
||||
@ -1,24 +1,24 @@
|
||||
This is primarily for tcl .tm modules required for your bootstrapping/make/build process. |
||||
It could include other files necessary for this process. |
||||
|
||||
The .tm modules here may be required for your build script if it intended the installation operator uses an existing tclsh or other shell as opposed to a tclkit you may have for distribution which is more likely to include necessary libraries. |
||||
|
||||
The modules here are loaded by your initialisation scripts and so can be a snapshot of different versions than those in your project src. |
||||
The modules can be your own, or 3rd party such as individual items from tcllib. |
||||
|
||||
You can copy modules from a running punk shell to this location using the pmix command. |
||||
|
||||
e.g |
||||
>pmix visible_lib_copy_to_modulefolder some::module::lib bootsupport |
||||
|
||||
The pmix command will help you pick the latest version, and will create any necessary file structure matching the namespace of the package. |
||||
|
||||
e.g the result might be a file such as |
||||
<projectname>/src/bootsupport/some/module/lib-0.1.tm |
||||
|
||||
The originating library may not yet be in .tm form. |
||||
You can copy a pkgIndex.tcl based library that is composed of a single .tcl file the same way using the above process and it will automatically name and file it appropriately but you need to check that the library doesn't require/load additional files - and that it is Tcl script only. |
||||
|
||||
Always verify that the library is copyable in this manner and test in a shell with tcl::tm::path pointed to ./bootsupport that it works. |
||||
|
||||
|
||||
This is primarily for tcl .tm modules required for your bootstrapping/make/build process. |
||||
It could include other files necessary for this process. |
||||
|
||||
The .tm modules here may be required for your build script if it intended the installation operator uses an existing tclsh or other shell as opposed to a tclkit you may have for distribution which is more likely to include necessary libraries. |
||||
|
||||
The modules here are loaded by your initialisation scripts and so can be a snapshot of different versions than those in your project src. |
||||
The modules can be your own, or 3rd party such as individual items from tcllib. |
||||
|
||||
You can copy modules from a running punk shell to this location using the pmix command. |
||||
|
||||
e.g |
||||
>pmix visible_lib_copy_to_modulefolder some::module::lib bootsupport |
||||
|
||||
The pmix command will help you pick the latest version, and will create any necessary file structure matching the namespace of the package. |
||||
|
||||
e.g the result might be a file such as |
||||
<projectname>/src/bootsupport/some/module/lib-0.1.tm |
||||
|
||||
The originating library may not yet be in .tm form. |
||||
You can copy a pkgIndex.tcl based library that is composed of a single .tcl file the same way using the above process and it will automatically name and file it appropriately but you need to check that the library doesn't require/load additional files - and that it is Tcl script only. |
||||
|
||||
Always verify that the library is copyable in this manner and test in a shell with tcl::tm::path pointed to ./bootsupport that it works. |
||||
|
||||
|
||||
|
||||
@ -0,0 +1,51 @@
|
||||
#======================================================= |
||||
#configuration data for download and build of buildsuite |
||||
#======================================================= |
||||
#windows build mechanism: mingw64 -ucrt64 gcc |
||||
#other platforms build mechanism: gcc |
||||
|
||||
|
||||
|
||||
#------------------------------------------------------- |
||||
set buildprefix <PROJECTDIR>/vendorbuild/samplesuite1 |
||||
set basemakeflags [list -j 2] |
||||
set baseconfigflags [list --enable-64bit --prefix=$buildprefix] |
||||
set repofolder ~/.fossils |
||||
#------------------------------------------------------- |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
SOURCEDOWNLOAD -project tcl\ |
||||
-mechanism fossil\ |
||||
-localrepo tcl.fossil\ |
||||
-branch core-8\ |
||||
-remote https://core.tcl-lang.org/tcl |
||||
|
||||
#etc. |
||||
#SOURCEDOWNLOAD tk... |
||||
#SOURCEDOWNLOAD thread... |
||||
|
||||
#SOURCEDOWNLOAD -project critcl\ |
||||
-mechanism git\ |
||||
-branch master\ |
||||
-remote http://github.com/andreas-kupries/critcl |
||||
|
||||
#SOURCEDOWNLOAD -project tclbench\ |
||||
-mechanism fossil\ |
||||
-remote https://core.tcl-lang.org/tclbench |
||||
|
||||
#CONFIGSTART tcl <SOURCEBASE>/win |
||||
|
||||
#CONFIGSTART tk <SOURCEBASE>/win |
||||
#EXTRACONFIG tk --with-tcl=$buildprefix/lib --with-tclinclude=$buildprefix/include |
||||
|
||||
|
||||
#CONFIGSTART thread ??? |
||||
#EXTRACONFIG thread --with-tcl=$buildprefix/lib --with-tclinclude=$buildprefix/include |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@ -1,3 +1,3 @@
|
||||
Install a tclkit runtime here by running the appropriate fetchruntime script in ../src |
||||
|
||||
Alternatively the runtime can be downloaded from: https://www.gitea1.intx.com.au/jn/punkbin |
||||
Install a tclkit runtime here by running the appropriate fetchruntime script in ../src |
||||
|
||||
Alternatively the runtime can be downloaded from: https://www.gitea1.intx.com.au/jn/punkbin |
||||
|
||||
@ -1,65 +0,0 @@
|
||||
|
||||
namespace eval punk::clitemplate { |
||||
|
||||
proc runcli {args} { |
||||
if {![llength $args]} { |
||||
tailcall punk::clitemplate::clicommands help |
||||
} else { |
||||
tailcall punk::clitemplate::clicommands {*}$args |
||||
} |
||||
} |
||||
} |
||||
|
||||
namespace eval punk::clitemplate::clicommands { |
||||
variable last_alias "" |
||||
namespace export help |
||||
namespace ensemble create |
||||
namespace ensemble configure [namespace current] -unknown punk::clitemplate::clicommands::_unknown |
||||
|
||||
proc set_alias {cmdname} { |
||||
variable last_alias |
||||
set last_alias $cmdname |
||||
uplevel #0 [list interp alias {} $cmdname {} punk::clitemplate::runcli] |
||||
} |
||||
proc _unknown {ns args} { |
||||
punk::clitemplate::clicommands::help {*}$args |
||||
} |
||||
|
||||
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> |
||||
#' ``` |
||||
#' |
||||
#' |
||||
|
||||
|
||||
set commands [namespace export] |
||||
set output "" |
||||
append output "commands:\n |
||||
foreach cmd $commands { |
||||
append output " $cmd" |
||||
} |
||||
return $output |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
package provide punk::clitemplate [namespace eval punk::clitemplate { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
@ -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 %pkg% 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
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 |
||||
} |
||||
} |
||||
namespace eval [lassign [split [file rootname [file tail [info script] ]] -] pkgtail verparts]${nsprefix}$pkgtail { |
||||
#-------------------------------------- |
||||
#Do not put any 'package require' statements above this block. (globals nsprefix,pkgtail,verparts still set) |
||||
variable pkg "${::nsprefix}${::pkgtail}[unset ::nsprefix; unset ::pkgtail]" |
||||
variable version [join $::verparts -][unset ::verparts] |
||||
#-------------------------------------- |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
namespace eval [namespace current]::lib { |
||||
|
||||
} |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
uplevel #0 [list package provide $pkg $version] |
||||
} |
||||
return |
||||
|
||||
@ -0,0 +1,63 @@
|
||||
# -*- 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 |
||||
|
||||
package require punk::mix::util |
||||
|
||||
namespace eval %pkg% { |
||||
namespace ensemble create |
||||
#package require punk::overlay |
||||
#punk::overlay::import_commandset debug. ::punk:mix::commandset::debug |
||||
|
||||
|
||||
proc help {args} { |
||||
set basehelp [punk::mix::base help {*}$args] |
||||
return $basehelp |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval %pkg%::lib { |
||||
namespace path ::punk::mix::util ;#askuser, do_in_path, foreach-file etc |
||||
|
||||
} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval %pkg% { |
||||
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 %pkg% [namespace eval %pkg% { |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
return |
||||
|
||||
|
||||
@ -0,0 +1,45 @@
|
||||
# -*- 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 version |
||||
set version %version% |
||||
}] |
||||
return |
||||
@ -0,0 +1,426 @@
|
||||
# -*- 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 999999.0a1.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 |
||||
} |
||||
|
||||
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 999999.0a1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,3 @@
|
||||
0.1.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
File diff suppressed because it is too large
Load Diff
@ -1,3 +1,3 @@
|
||||
0.1.0 |
||||
0.1.1 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
|
||||
@ -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 999999.0a1.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 999999.0a1.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,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 punk::temp2 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::temp2 { |
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::temp2 [namespace eval punk::temp2 { |
||||
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,233 @@
|
||||
# -*- 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::unixywindows 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
#for illegalname_test |
||||
package require punk::winpath |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::unixywindows { |
||||
#'cached' name to make obvious it could be out of date - and to distinguish from unixyroot arg |
||||
variable cachedunixyroot "" |
||||
|
||||
|
||||
#----------------- |
||||
#e.g something like c:/Users/geek/scoop/apps/msys2/current c:/msys2 |
||||
proc get_unixyroot {} { |
||||
variable cachedunixyroot |
||||
if {![string length $cachedunixyroot]} { |
||||
if {![catch { |
||||
set result [exec cygpath -m /] ;# -m gives result with forward-slashes - which is ok for windows paths in a Tcl context. |
||||
set cachedunixyroot [punk::objclone $result] |
||||
file pathtype $cachedunixyroot; #this call causes the int-rep to be path |
||||
set ::punk::last_run_display [list] ;#hack - review shouldn't really be necessary.. but because we call winpath from ./ - the repl looks for last_run_display |
||||
} errM]} { |
||||
|
||||
} else { |
||||
puts stderr "Warning: Failed to determine base for unix-like paths - using default of c:/msys2" |
||||
file pathtype [set cachedunixyroot [punk::objclone "c:/msys2"]] |
||||
} |
||||
} |
||||
#will have been shimmered from string to 'path' internal rep by 'file pathtype' call |
||||
|
||||
#let's return a different copy as it's so easy to lose path-rep |
||||
set copy [punk::objclone $cachedunixyroot] |
||||
return $copy |
||||
} |
||||
proc refresh_unixyroot {} { |
||||
variable cachedunixyroot |
||||
set result [exec cygpath -m /] ;# -m gives result with forward-slashes - which is ok for windows paths in a Tcl context. |
||||
set cachedunixyroot [punk::objclone $result] |
||||
file pathtype $cachedunixyroot; #this call causes the int-rep to be path |
||||
|
||||
set copy [punk::objclone $cachedunixyroot] |
||||
return $copy |
||||
} |
||||
proc set_unixyroot {windows_path} { |
||||
variable cachedunixyroot |
||||
file pathtype $windows_path |
||||
set cachedunixyroot [punk::objclone $windows_path] |
||||
#return the original - but probably int-rep will have shimmered to path even if started out as string |
||||
#- that's probably what we want. Caller can use as string or path without affecting cachedunixyroot |
||||
return $windows_path |
||||
} |
||||
|
||||
|
||||
proc windir {path} { |
||||
if {$path eq "~"} { |
||||
#as the tilde hasn't been normalized.. we can't assume we're running on the actual platform |
||||
return ~/.. |
||||
} |
||||
return [file dirname [winpath $path]] |
||||
} |
||||
|
||||
#REVIEW high-coupling |
||||
proc cdwin {path} { |
||||
set path [winpath $path] |
||||
if {$::repl::running} { |
||||
repl::term::set_console_title $path |
||||
} |
||||
cd $path |
||||
} |
||||
proc cdwindir {path} { |
||||
set path [winpath $path] |
||||
if {$::repl::running} { |
||||
repl::term::set_console_title $path |
||||
} |
||||
cd [file dirname $path] |
||||
} |
||||
|
||||
#NOTE - this is an expensive operation - avoid where possible. |
||||
#review - is this intended to be useful/callable on non-windows platforms? |
||||
#it should in theory be useable from another platform that wants to create a path for use on windows. |
||||
#In this case - we shouldn't examine what volumes exist (assume A: .. Z: are valid) |
||||
#review zipfs:// other uri schemes? |
||||
proc towinpath {unixypath {unixyroot ""}} { |
||||
#NOTE: tcl file exists gives different answers on windows for paths like /c depending on cwd (presumably based on file pathtype of volumerelative) |
||||
#(Tcl is also somewhat broken as at 2023 as far as volume relative paths - process can get out of sync with tcl if cd to a vol relative path is used) |
||||
#This is add odds with attempting to navigate on a windows system which has cygwin, wsl etc... It also makes it difficult for functions intended to operate independent of CWD. |
||||
#e.g there is potential confusion when there is a c folder on c: drive (c:/c) |
||||
#I will attempt to provide a coherent operation for winpath ./ ../ etc , but it may disallow for example; change to /something or /x where these don't match a driveletter or /mnt |
||||
#whereas tcl may allow cd to /something if a something folder happens to exist on the current volume based on cwd. |
||||
#I think it's preferable to require an explicit driveletter /x or /mnt when using unix-like paths on windows - but practical considerations may prove me wrong.. |
||||
#It's possible that this function should also ignore the current set of driveletters - and operate completely independent of whether a path actually exists |
||||
#This makes it hard to use things like 'file normalize' - which also looks at things like current volume. |
||||
# |
||||
#Note for example the results of 'which' grep on windows can produce a path like /c/Users/somewhere/bin/grep |
||||
#which tcl's file normalize may change to C:/c/Users or X:/c/Users - based on current volumen. Given that C:/c might exist - this can be problematic in a couple of ways. |
||||
#The mixing of unix-like and windows commands on the same machine is a large part of the problem.. but this mix is now common |
||||
# |
||||
#convert /c/etc to C:/etc |
||||
set re_slash_x_slash {^/([[:alpha:]]){1}/.*} |
||||
set re_slash_else {^/([[:alpha:]]*)(.*)} |
||||
set volumes [file volumes] |
||||
#exclude things like //zipfs:/ ?? |
||||
set driveletters [list] |
||||
foreach v $volumes { |
||||
if {[regexp {^([[:alpha:]]){1}:/$} $v _ letter]} { |
||||
lappend driveletters $letter |
||||
} |
||||
} |
||||
#puts stderr "->$driveletters" |
||||
|
||||
set path [punk::objclone $unixypath] ;#take another copy that we can deliberatley shimmer to path and know is separate to the supplied argument |
||||
set supplied_pathtype [file pathtype $path] ;#we don't care about the pathtype so much as the act of making this call shimmers to a path internal-rep |
||||
|
||||
#copy of var that we can treat as a string without affecting path rep |
||||
#Note that some but not all read operations will lose path rep e.g 'string length $x' will lose any path-rep $x had, (but 'string equal $x something' won't) |
||||
#Todo - make int-rep tests to check stability of these behaviours across Tcl versions! |
||||
set strcopy_path [punk::objclone $path] |
||||
|
||||
set str_newpath "" |
||||
|
||||
set have_pathobj 0 |
||||
|
||||
if {[regexp $re_slash_x_slash $strcopy_path _ letter]} { |
||||
#upper case appears to be windows canonical form |
||||
set str_newpath [string toupper $letter]:/[string range $strcopy_path 3 end] |
||||
} elseif {[regexp {^/mnt/([[:alpha:]]){1}/.*} [string tolower $strcopy_path] _ letter]} { |
||||
set str_newpath [string toupper $letter]:/[string range $strcopy_path 7 end] |
||||
} elseif {[regexp {^/mnt/([[:alpha:]]){1}$} [string tolower $strcopy_path] _ letter]} { |
||||
set str_newpath [string toupper $letter]:/ |
||||
} elseif {[regexp $re_slash_else $strcopy_path _ firstpart remainder]} { |
||||
#could be for example /c or /something/users |
||||
if {[string length $firstpart] == 1} { |
||||
set letter $firstpart |
||||
set str_newpath [string toupper $letter]:/ |
||||
} else { |
||||
#according to regex we have a single leading slash |
||||
set str_tail [string range $strcopy_path 1 end] |
||||
if {$unixyroot eq ""} { |
||||
set unixyroot [get_unixyroot] |
||||
} else { |
||||
file pathtype $unixyroot; #side-effect generates int-rep of type path ) |
||||
} |
||||
set pathobj [file join $unixyroot $str_tail] |
||||
file pathtype $pathobj |
||||
set have_pathobj 1 |
||||
} |
||||
} |
||||
|
||||
if {!$have_pathobj} { |
||||
if {$str_newpath eq ""} { |
||||
#dunno - pass through |
||||
set pathobj $path |
||||
} else { |
||||
set pathobj [punk::objclone $str_newpath] |
||||
file pathtype $pathobj |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
#puts stderr "=> $path" |
||||
#things like 'which' seem to return a path minus the .exe - so we'll just test the containing folder |
||||
# |
||||
#By now file normalize shouldn't do too many shannanigans related to cwd.. |
||||
#We want it to look at cwd for relative paths.. |
||||
#but we don't consider things like /c/Users to be relative even on windows where it would normally mean a volume-relative path e.g c:/c/Users if cwd happens to be somewhere on C: at the time. |
||||
#if {![file exists [file dirname $path]]} { |
||||
# set path [file normalize $path] |
||||
# #may still not exist.. that's ok. |
||||
#} |
||||
|
||||
|
||||
|
||||
#file normalize may change backslashes to forward slashes.. including things like the special \\?\ prefix which is intended to stop windows api from parsing a name |
||||
#2023 - this is ok as //?/ also seems to work.. but it is unclear if that is because Tcl is re-converting to backslashes |
||||
if {[punk::winpath::illegalname_test $pathobj]} { |
||||
set pathobj [punk::winpath::illegalname_fix $pathobj] |
||||
} |
||||
|
||||
return $pathobj |
||||
} |
||||
|
||||
#---------------------------------------------- |
||||
#leave the unixywindowws related aliases available on all platforms |
||||
#interp alias {} cdwin {} punk::unixywindows::cdwin |
||||
#interp alias {} cdwindir {} punk::unixywindoes::cdwindir |
||||
#interp alias {} towinpath {} punk::unixywindows::towinpath |
||||
#interp alias {} windir {} punk::unixywindows::windir |
||||
#---------------------------------------------- |
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::unixywindows [namespace eval punk::unixywindows { |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,3 @@
|
||||
0.1.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,164 @@
|
||||
# -*- 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 punkcheck::cli 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
package require punk::mix::util |
||||
|
||||
namespace eval punkcheck::cli { |
||||
namespace ensemble create |
||||
#package require punk::overlay |
||||
#punk::overlay::import_commandset debug. ::punk:mix::commandset::debug |
||||
|
||||
proc help {args} { |
||||
set basehelp [punk::mix::base help {*}$args] |
||||
return $basehelp |
||||
} |
||||
|
||||
proc paths {{path {}}} { |
||||
if {$path eq {}} { set path [pwd] } |
||||
set search_from $path |
||||
set bottom_to_top [list] |
||||
while {[string length [set pcheck_file [punkcheck::cli::lib::find_nearest_file $search_from]]]} { |
||||
set pcheck_folder [file dirname $pcheck_file] |
||||
lappend bottom_to_top $pcheck_file |
||||
set search_from [file dirname $pcheck_folder] |
||||
} |
||||
return $bottom_to_top |
||||
} |
||||
proc status {{path {}}} { |
||||
if {$path eq {}} { set path [pwd] } |
||||
set fullpath [file normalize $path] |
||||
set ftype [file type $fullpath] |
||||
set files [list] |
||||
if {$ftype eq "file"} { |
||||
set container [file dirname $fullpath] |
||||
lappend files $fullpath |
||||
} else { |
||||
set container $fullpath |
||||
set files [glob -nocomplain -dir $fullpath -type f *] |
||||
} |
||||
set punkcheck_files [paths $container] |
||||
set repodict [punk::repo::find_repo $container] |
||||
|
||||
if {![llength $punkcheck_files]} { |
||||
puts stderr "No .punkcheck files found at or above this folder" |
||||
} |
||||
|
||||
set table "" |
||||
foreach p $punkcheck_files { |
||||
set basedir [file dirname $p] |
||||
set recordlist [punkcheck::load_records_from_file $p] |
||||
set tgt_dict [punkcheck::recordlist::records_as_target_dict $recordlist] |
||||
foreach f $files { |
||||
set relpath [punkcheck::lib::path_relative $basedir $f] |
||||
if {[dict exists $tgt_dict $relpath]} { |
||||
if {[llength $files] == 1} { |
||||
set filerec [dict get $tgt_dict $relpath] |
||||
set records [punkcheck::dict_getwithdefault $filerec body [list]] |
||||
if {![llength $records]} { |
||||
set pcheck "(has file record but no installation entries)" |
||||
} else { |
||||
set pcheck \n |
||||
foreach irec $records { |
||||
append pcheck [punk::tdl::prettyprint [list $irec] 1] \n |
||||
#append pcheck " $irec" \n |
||||
} |
||||
} |
||||
} else { |
||||
set pcheck "(has record)" |
||||
} |
||||
} else { |
||||
set pcheck "" |
||||
} |
||||
append table "$f $pcheck" \n |
||||
} |
||||
} |
||||
return $table |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punkcheck::cli::lib { |
||||
namespace path ::punk::mix::util ;#askuser, do_in_path, foreach-file etc |
||||
|
||||
proc find_nearest_file {{path {}}} { |
||||
if {$path eq {}} { set path [pwd] } |
||||
set folder [lib::scanup $path lib::is_punkchecked_folder] |
||||
if {$folder eq ""} { |
||||
return "" |
||||
} else { |
||||
return [file join $folder .punkcheck] |
||||
} |
||||
} |
||||
|
||||
proc is_punkchecked_folder {{path {}}} { |
||||
if {$path eq {}} { set path [pwd] } |
||||
foreach control { |
||||
.punkcheck |
||||
} { |
||||
set control [file join $path $control] |
||||
if {[file isfile $control]} {return 1} |
||||
} |
||||
return 0 |
||||
} |
||||
|
||||
proc scanup {path cmd} { |
||||
if {$path eq {}} { set path [pwd] } |
||||
#based on kettle::path::scanup |
||||
if {[file pathtype $path] eq "relative"} { |
||||
set path [file normalize $path] |
||||
} |
||||
while {1} { |
||||
# Found the proper directory, per the predicate. |
||||
if {[{*}$cmd $path]} { return $path } |
||||
|
||||
# Not found, walk to parent |
||||
set new [file dirname $path] |
||||
|
||||
# Stop when reaching the root. |
||||
if {$new eq $path} { return {} } |
||||
if {$new eq {}} { return {} } |
||||
|
||||
# Ok, truly walk up. |
||||
set path $new |
||||
} |
||||
return {} |
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punkcheck::cli { |
||||
proc _cli {args} { |
||||
#don't use tailcall - base uses info level to determine caller |
||||
::punk::mix::base::_cli {*}$args |
||||
} |
||||
variable default_command status |
||||
package require punk::mix::base |
||||
package require punk::overlay |
||||
punk::overlay::custom_from_base [namespace current] ::punk::mix::base |
||||
} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punkcheck::cli [namespace eval punkcheck::cli { |
||||
variable version |
||||
set version 999999.0a1.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,107 @@
|
||||
# -*- 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 textblock 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
package require punk |
||||
package require patternpunk |
||||
package require overtype |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval textblock { |
||||
|
||||
proc width {block} { |
||||
if {![llength $block]} { |
||||
return [string length [stripcodes $block]] |
||||
} |
||||
tcl::mathfunc::max {*}[lmap v [linelist $block] {string length [stripcodes $v]}] |
||||
} |
||||
|
||||
pipealias ::textblock::padleft .= {list $input [string repeat " " $indent]} |/0,padding/1> linelist |> .= {lmap v $data {val "$padding$v"}} |> list_as_lines <input/0,indent/1| |
||||
pipealias ::textblock::padright .= {list $input [string repeat " " $colsize]} |/0,padding/1> linelist |> .= {lmap v $data {val "$v$padding"}} |> list_as_lines <input/0,colsize/1| |
||||
|
||||
pipealias ::textblock::join_width .= {list $lhs [string repeat " " $w1] $rhs [string repeat " " $w2]} {| |
||||
/2,col1/1,col2/3 |
||||
>} linelist {| |
||||
data2 |
||||
>} .=lhs> linelist {| |
||||
>} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| |
||||
>} list_as_lines <lhs/0,w1/1,rhs/2,w2/3| |
||||
|
||||
pipealias ::textblock::join .= {list $lhs [string repeat " " [width $lhs]] $rhs [string repeat " " [width $rhs]]} {| |
||||
/2,col1/1,col2/3 |
||||
>} linelist {| |
||||
data2 |
||||
>} .=lhs> linelist {| |
||||
>} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| |
||||
>} list_as_lines <lhs/0,rhs/1| |
||||
|
||||
pipealias ::textblock::join_right .= {list $lhs [string repeat " " [width $lhs]] $rhs [string repeat " " [width $rhs]]} {| |
||||
/2,col1/1,col2/3 |
||||
>} linelist {| |
||||
data2 |
||||
>} .=lhs> linelist {| |
||||
>} .= {lmap v $data w $data2 {val "[overtype::right $col1 $v][overtype::right $col2 $w]"}} {| |
||||
>} list_as_lines <lhs/0,rhs/1| |
||||
|
||||
proc example {{text "test\netc\nmore text"}} { |
||||
package require patternpunk |
||||
.= textblock::join [list 1 2 3 4 5 6 7] [>punk . lhs] |> .=>1 textblock::join " " |> .=>1 textblock::join $text |> .=>1 textblock::join [>punk . rhs] |> .=>1 textblock::join [lrepeat 7 " | "] |
||||
} |
||||
|
||||
#maintenance warning - also in 'shellfilter' pkg |
||||
#strip ansi codes from text - basic! assumes we don't get data split in the middle of an ansi-code ie best used with line-buffering |
||||
proc stripcodes {text} { |
||||
if {[set posn [string first "\033\[" $text]] >= 0} { |
||||
set mnext [string first m [string range $text $posn end]] |
||||
if {$mnext >= 0} { |
||||
set mpos [expr {$posn + $mnext}] |
||||
set stripped1 [string range $text 0 $posn-1][string range $text $mpos+1 end] |
||||
#return [stripcodes $stripped1] ;#recurse to get any others |
||||
tailcall ::textblock::stripcodes $stripped1 |
||||
} else { |
||||
#partial or not actually an ansi code.. pass it all through |
||||
return $text |
||||
} |
||||
} else { |
||||
return $text |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide textblock [namespace eval textblock { |
||||
variable version |
||||
set version 999999.0a1.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,112 @@
|
||||
: "[proc : args {}]" ;# *tcl shellbat - call with sh,bash,tclsh on any platform, or with cmd on windows. |
||||
: <<'HIDE_FROM_BASH_AND_SH' |
||||
: ;# leading colon hides from .bat, trailing slash hides next line from tcl \ |
||||
@call tclsh "%~dp0%~n0.bat" %* |
||||
: ;#\ |
||||
@set taskexitcode=%errorlevel% & goto :exit |
||||
# -*- tcl -*- |
||||
# ################################################################################################# |
||||
# This is a tcl shellbat file |
||||
# It is tuned to run when called as a batch file, a tcl script, an sh script or a bash script, |
||||
# so the specific layout and characters used are quite sensitive to change. |
||||
# It can be called on unix or windows platforms with or without the interpreter being specified on the commandline. |
||||
# e.g ./filename.sh.bat in sh or bash or powershell |
||||
# e.g filename.sh or filename.sh.bat at windows command prompt |
||||
# e.g tclsh filename.sh.bat | sh filename.sh.bat | bash filename.sh.bat |
||||
# In all cases an arbitrary number of arguments are accepted |
||||
# To avoid the initial commandline on stdout when calling as a batch file on windows, use: |
||||
# cmd /Q /c filename.sh.bat |
||||
# (because we cannot use @if to silence it, as this isn't understood by tcl,sh or bash) |
||||
# ################################################################################################# |
||||
#fconfigure stdout -translation crlf |
||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload |
||||
#puts "script : [info script]" |
||||
#puts "argcount : $::argc" |
||||
#puts "argvalues: $::argv" |
||||
|
||||
|
||||
#<tcl-payload> |
||||
#<tcl-payload/> |
||||
|
||||
# --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
# only exit if needed. see exitcode notes at bottom of file and exit there for consistency across invocation methods |
||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload |
||||
#-- |
||||
#-- bash/sh code follows. |
||||
#-- protect from tcl using line continuation char on the previous comment for each line, like so: \ |
||||
printf "etc" |
||||
#-- or alternatively place sh/bash script within the false==false block |
||||
#-- whilst being careful to balance braces {} |
||||
#-- For more complex needs you should call out to external scripts |
||||
#-- |
||||
#-- END marker for hide_from_bash_and_sh\ |
||||
HIDE_FROM_BASH_AND_SH |
||||
|
||||
#--------------------------------------------------------- |
||||
#-- This if statement hides(mostly) a sh/bash code block from Tcl |
||||
if false==false # else { |
||||
then |
||||
: |
||||
#--------------------------------------------------------- |
||||
#-- leave as is if all that's required is launching the Tcl payload" |
||||
#-- |
||||
#-- Note that sh/bash script isn't called when running a .bat from cmd.exe on windows by default |
||||
#-- adjust line 4: @call tclsh ... to something like @call sh ... @call bash .. or @call env sh ... etc as appropriate |
||||
#-- if sh/bash scripting needs to run on windows too. |
||||
#-- |
||||
#printf "start of bash or sh code" |
||||
|
||||
#<shell-payload-pre-tcl> |
||||
#</shell-payload-pre-tcl> |
||||
|
||||
|
||||
#-- sh/bash launches Tcl here instead of shebang line at top |
||||
#<shell-launch-tcl> |
||||
#-- use exec to use exitcode (if any) directly from the tcl script |
||||
exec /usr/bin/env tclsh "$0" "$@" |
||||
#</shell-launch-tcl> |
||||
|
||||
#-- alternative - if sh/bash script required to run after the tcl call. |
||||
#/usr/bin/env tclsh "$0" "$@" |
||||
#tcl_exitcode=$? |
||||
#echo "tcl_exitcode: ${tcl_exitcode}" |
||||
|
||||
#<shell-payload-post-tcl> |
||||
#</shell-payload-post-tcl> |
||||
|
||||
#-- override exitcode example |
||||
#exit 66 |
||||
|
||||
#printf "No need for trailing slashes for sh/bash code here\n" |
||||
#--------------------------------------------------------- |
||||
fi |
||||
# closing brace for Tcl } |
||||
#--------------------------------------------------------- |
||||
|
||||
#-- tcl and shell script now both active |
||||
|
||||
#-- comment for line sample 1 with trailing continuation slash \ |
||||
#printf "tcl-invisible sh/bash line sample 1 \n" |
||||
|
||||
#-- comment for line sample 2 with trailing continuation slash \ |
||||
#printf "tcl-invisible sh/bash line sample 2 \n" |
||||
|
||||
|
||||
#-- Consistent exitcode from sh,bash,tclsh or cmd |
||||
#-- Call exit in tcl (or sh/bash) code only if explicitly required, otherwise leave this commented out. |
||||
#-- (script might be more widely useable without explicit exit. e.g in tcl: set ::argc 1; set ::argv "val"; source filename.sh.bat ) |
||||
#-- exit line unprotected by trailing slash will work for tcl and/or sh/bash |
||||
#exit 0 |
||||
#exit 42 |
||||
|
||||
|
||||
|
||||
#-- make sure sh/bash/tcl all skip over .bat style exit \ |
||||
: <<'shell_end' |
||||
#-- .bat exit with exitcode from tcl process \ |
||||
:exit |
||||
: ;# \ |
||||
@exit /B %taskexitcode% |
||||
# .bat has exited \ |
||||
shell_end |
||||
|
||||
Loading…
Reference in new issue