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. |
This is primarily for tcl .tm modules required for your bootstrapping/make/build process. |
||||||
It could include other files necessary for this 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 .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 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. |
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. |
You can copy modules from a running punk shell to this location using the pmix command. |
||||||
|
|
||||||
e.g |
e.g |
||||||
>pmix visible_lib_copy_to_modulefolder some::module::lib bootsupport |
>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. |
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 |
e.g the result might be a file such as |
||||||
<projectname>/src/bootsupport/some/module/lib-0.1.tm |
<projectname>/src/bootsupport/some/module/lib-0.1.tm |
||||||
|
|
||||||
The originating library may not yet be in .tm form. |
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. |
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. |
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 |
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 |
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 |
#First line must be a semantic version number |
||||||
#all other lines are ignored. |
#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