From 28bb38078d5d52e384d1b8cb17d98c8b9effa84d Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Thu, 14 Dec 2023 12:45:34 +1100 Subject: [PATCH] template and bootsupport fixes + commandline fixes with -tcl,-punk,-tk support --- src/bootsupport/include_modules.config | 18 + src/bootsupport/modules/punk/cap-0.1.0.tm | 218 + src/bootsupport/modules/punk/du-0.1.0.tm | 9 +- src/bootsupport/modules/punk/mix/base-0.1.tm | 904 +++ src/bootsupport/modules/punk/mix/cli-0.3.tm | 909 +++ .../punk/mix/commandset/buildsuite-0.1.0.tm | 152 + .../punk/mix/commandset/debug-0.1.0.tm | 92 + .../modules/punk/mix/commandset/doc-0.1.0.tm | 181 + .../punk/mix/commandset/layout-0.1.0.tm | 185 + .../punk/mix/commandset/loadedlib-0.1.0.tm | 529 ++ .../punk/mix/commandset/module-0.1.0.tm | 419 ++ .../punk/mix/commandset/project-0.1.0.tm | 849 +++ .../modules/punk/mix/commandset/repo-0.1.0.tm | 92 + .../punk/mix/commandset/scriptwrap-0.1.0.tm | 634 ++ .../modules/punk/mix/templates-0.1.0.tm | 49 + .../modules/punk/mix/util-0.1.0.tm | 427 ++ src/bootsupport/modules/punk/ns-0.1.0.tm | 1694 +++++ src/bootsupport/modules/punk/overlay-0.1.tm | 158 + src/bootsupport/modules/punk/tdl-0.1.0.tm | 104 + src/make.tcl | 1 + .../layouts/basic/src/bootsupport/README.md | 1 + .../src/bootsupport/modules/cksum-1.1.4.tm | 200 + .../src/bootsupport/modules/cmdline-1.5.2.tm | 933 +++ .../bootsupport/modules/fileutil-1.16.1.tm | 2311 +++++++ .../src/bootsupport/modules/http-2.10b1.tm | 5457 +++++++++++++++++ .../bootsupport/modules/natsort-0.1.1.5.tm | 1886 ++++++ .../src/bootsupport/modules/oolib-0.1.tm | 195 + .../src/bootsupport/modules/overtype-1.5.0.tm | 1039 ++++ .../src/bootsupport/modules/punk/cap-0.1.0.tm | 218 + .../src/bootsupport/modules/punk/du-0.1.0.tm | 1313 ++++ .../src/bootsupport/modules/punk/mix-0.2.tm | 15 + .../bootsupport/modules/punk/mix/base-0.1.tm | 904 +++ .../bootsupport/modules/punk/mix/cli-0.3.tm | 909 +++ .../punk/mix/commandset/buildsuite-0.1.0.tm | 152 + .../punk/mix/commandset/debug-0.1.0.tm | 92 + .../modules/punk/mix/commandset/doc-0.1.0.tm | 181 + .../punk/mix/commandset/layout-0.1.0.tm | 185 + .../punk/mix/commandset/loadedlib-0.1.0.tm | 529 ++ .../punk/mix/commandset/module-0.1.0.tm | 419 ++ .../punk/mix/commandset/project-0.1.0.tm | 849 +++ .../modules/punk/mix/commandset/repo-0.1.0.tm | 92 + .../punk/mix/commandset/scriptwrap-0.1.0.tm | 634 ++ .../modules/punk/mix/templates-0.1.0.tm | 49 + .../modules/punk/mix/util-0.1.0.tm | 427 ++ .../src/bootsupport/modules/punk/ns-0.1.0.tm | 1694 +++++ .../bootsupport/modules/punk/overlay-0.1.tm | 158 + .../bootsupport/modules/punk/repo-0.1.1.tm | 1232 ++++ .../src/bootsupport/modules/punk/tdl-0.1.0.tm | 104 + .../bootsupport/modules/punk/winpath-0.1.0.tm | 266 + .../bootsupport/modules/punkcheck-0.1.0.tm | 1984 ++++++ .../bootsupport/modules/struct/set-2.2.3.tm | 189 + .../src/bootsupport/modules/struct/sets.tcl | 189 + .../src/bootsupport/modules/struct/sets_c.tcl | 93 + .../bootsupport/modules/struct/sets_tcl.tcl | 452 ++ src/mixtemplates/layouts/basic/src/build.tcl | 6 + src/mixtemplates/layouts/basic/src/make.tcl | 961 +++ .../modules/template_module-0.0.1.tm | 52 + .../modules/template_unversioned.tm | 51 + src/modules/flagfilter-0.3.tm | 2 +- src/modules/punk/du-999999.0a1.0.tm | 9 +- src/modules/punk/mix/base-0.1.tm | 1808 +++--- .../src/bootsupport/modules/punk/cap-0.1.0.tm | 218 + .../src/bootsupport/modules/punk/du-0.1.0.tm | 9 +- .../bootsupport/modules/punk/mix/base-0.1.tm | 904 +++ .../bootsupport/modules/punk/mix/cli-0.3.tm | 909 +++ .../punk/mix/commandset/buildsuite-0.1.0.tm | 152 + .../punk/mix/commandset/debug-0.1.0.tm | 92 + .../modules/punk/mix/commandset/doc-0.1.0.tm | 181 + .../punk/mix/commandset/layout-0.1.0.tm | 185 + .../punk/mix/commandset/loadedlib-0.1.0.tm | 529 ++ .../punk/mix/commandset/module-0.1.0.tm | 419 ++ .../punk/mix/commandset/project-0.1.0.tm | 849 +++ .../modules/punk/mix/commandset/repo-0.1.0.tm | 92 + .../punk/mix/commandset/scriptwrap-0.1.0.tm | 634 ++ .../modules/punk/mix/templates-0.1.0.tm | 49 + .../modules/punk/mix/util-0.1.0.tm | 427 ++ .../src/bootsupport/modules/punk/ns-0.1.0.tm | 1694 +++++ .../bootsupport/modules/punk/overlay-0.1.tm | 158 + .../src/bootsupport/modules/punk/tdl-0.1.0.tm | 104 + .../templates/layouts/project/src/make.tcl | 1 + .../sample.vfs/lib/app-sampleshell/repl.tcl | 2 +- src/modules/punk/overlay-0.1.tm | 316 +- src/modules/punk/repl-0.1.tm | 11 +- src/modules/punkapp-0.1.tm | 39 +- src/modules/shellfilter-0.1.8.tm | 6 +- src/modules/shellrun-0.1.tm | 26 +- src/modules/shellthread-1.6.tm | 160 +- src/modules/xxx-0.1.0.tm | 50 + src/modules/xxx-buildversion.txt | 3 + src/modules/zzzload-999999.0a1.0.tm | 4 +- src/punk86.vfs/lib/app-shellspy/shellspy.tcl | 232 +- src/punk86.vfs/modules/moduletest-0.1.1.tm | 51 + src/vendormodules/oolib-0.1.tm | 390 +- 93 files changed, 43377 insertions(+), 1383 deletions(-) create mode 100644 src/bootsupport/modules/punk/cap-0.1.0.tm create mode 100644 src/bootsupport/modules/punk/mix/base-0.1.tm create mode 100644 src/bootsupport/modules/punk/mix/cli-0.3.tm create mode 100644 src/bootsupport/modules/punk/mix/commandset/buildsuite-0.1.0.tm create mode 100644 src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm create mode 100644 src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm create mode 100644 src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm create mode 100644 src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm create mode 100644 src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm create mode 100644 src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm create mode 100644 src/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm create mode 100644 src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm create mode 100644 src/bootsupport/modules/punk/mix/templates-0.1.0.tm create mode 100644 src/bootsupport/modules/punk/mix/util-0.1.0.tm create mode 100644 src/bootsupport/modules/punk/ns-0.1.0.tm create mode 100644 src/bootsupport/modules/punk/overlay-0.1.tm create mode 100644 src/bootsupport/modules/punk/tdl-0.1.0.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/README.md create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/cksum-1.1.4.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/cmdline-1.5.2.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/fileutil-1.16.1.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/http-2.10b1.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/natsort-0.1.1.5.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/oolib-0.1.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/overtype-1.5.0.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/cap-0.1.0.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/du-0.1.0.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix-0.2.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/base-0.1.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/cli-0.3.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/buildsuite-0.1.0.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/templates-0.1.0.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/util-0.1.0.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/ns-0.1.0.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/overlay-0.1.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/repo-0.1.1.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/tdl-0.1.0.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/winpath-0.1.0.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/punkcheck-0.1.0.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/struct/set-2.2.3.tm create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/struct/sets.tcl create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/struct/sets_c.tcl create mode 100644 src/mixtemplates/layouts/basic/src/bootsupport/modules/struct/sets_tcl.tcl create mode 100644 src/mixtemplates/layouts/basic/src/build.tcl create mode 100644 src/mixtemplates/layouts/basic/src/make.tcl create mode 100644 src/mixtemplates/modules/template_module-0.0.1.tm create mode 100644 src/mixtemplates/modules/template_unversioned.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/cap-0.1.0.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/base-0.1.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/cli-0.3.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/commandset/buildsuite-0.1.0.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/templates-0.1.0.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix/util-0.1.0.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/ns-0.1.0.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/overlay-0.1.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/tdl-0.1.0.tm create mode 100644 src/modules/xxx-0.1.0.tm create mode 100644 src/modules/xxx-buildversion.txt create mode 100644 src/punk86.vfs/modules/moduletest-0.1.1.tm diff --git a/src/bootsupport/include_modules.config b/src/bootsupport/include_modules.config index 63c4a45a..694efa4b 100644 --- a/src/bootsupport/include_modules.config +++ b/src/bootsupport/include_modules.config @@ -6,7 +6,25 @@ set bootsupport_modules [list\ src/vendormodules oolib\ src/vendormodules http\ modules punkcheck\ + modules punk::ns\ + modules punk::cap\ modules punk::du\ modules punk::mix\ + modules punk::mix::base\ + modules punk::mix::cli\ + modules punk::mix::util\ + modules punk::mix::templates\ + modules punk::mix::commandset::module\ + modules punk::mix::commandset::debug\ + modules punk::mix::commandset::repo\ + modules punk::mix::commandset::loadedlib\ + modules punk::mix::commandset::project\ + modules punk::mix::commandset::layout\ + modules punk::mix::commandset::buildsuite\ + modules punk::mix::commandset::scriptwrap\ + modules punk::mix::commandset::doc\ + modules punk::overlay\ + modules punk::repo\ + modules punk::tdl\ modules punk::winpath\ ] diff --git a/src/bootsupport/modules/punk/cap-0.1.0.tm b/src/bootsupport/modules/punk/cap-0.1.0.tm new file mode 100644 index 00000000..6749035a --- /dev/null +++ b/src/bootsupport/modules/punk/cap-0.1.0.tm @@ -0,0 +1,218 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application punk::cap 0.1.0 +# Meta platform tcl +# Meta description pkg capability register +# Meta license BSD +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::cap { + variable pkgcap [dict create] + variable caps [dict create] + proc register_package {pkg capabilitylist} { + variable pkgcap + variable caps + if {[string match ::* $pkg]} { + set pkg [string range $pkg 2 end] + } + #for each capability + # - ensure 1st element is a single word + # - ensure that if 2nd element (capdict) is present - it is dict shaped + foreach c $capabilitylist { + lassign $c capname capdict + if {[llength $capname] !=1} { + error "register_package error. pkg: '$pkg' An entry in the capability list doesn't appear to have a single-word name. Problematic entry:'$c'" + } + if {[expr {[llength $capdict] %2 != 0}]} { + error "register_package error. pkg:'$pkg' The second element for capname:'$capname' doesn't appear to be a valid dict. Problematic entry: '$c'" + } + if {[dict exists $caps $capname]} { + set cap_pkgs [dict get $caps $capname] + } else { + set cap_pkgs [list] + } + if {$pkg ni $cap_pkgs} { + dict lappend caps $capname $pkg + } + } + dict set pkgcap $pkg $capabilitylist + } + proc promote_package {pkg} { + variable pkgcap + variable caps + if {[string match ::* $pkg]} { + set pkg [string range $pkg 2 end] + } + if {![dict exists $pkgcap $pkg]} { + error "punk::cap::promote_package error pkg'$pkg' not registered. Use register_package \$pkg first" + } + if {[dict size $pkgcap] > 1} { + set pkginfo [dict get $pkgcap $pkg] + #remove and re-add at end of dict + dict unset pkgcap $pkg + dict set pkgcap $pkg $pkginfo + foreach {cap cap_pkgs} $caps { + if {$pkg in $cap_pkgs} { + set posn [lsearch $cap_pkgs $pkg] + if {$posn >=0} { + #rewrite package list with pkg at tail of list for this capability + set cap_pkgs [lreplace $cap_pkgs $posn $posn] + lappend cap_pkgs $pkg + dict set caps $cap $cap_pkgs + } + } + } + } + } + proc demote_package {pkg} { + variable pkgcap + variable caps + if {[string match ::* $pkg]} { + set pkg [string range $pkg 2 end] + } + if {![dict exists $pkgcap $pkg]} { + error "punk::cap::promote_package error pkg'$pkg' not registered. Use register_package \$pkg first" + } + if {[dict size $pkgcap] > 1} { + set pkginfo [dict get $pkgcap $pkg] + #remove and re-add at start of dict + dict unset pkgcap $pkg + dict set pkgcap $pkg $pkginfo + set pkgcap [dict merge [dict create $pkg $pkginfo] $pkgcap] + foreach {cap cap_pkgs} $caps { + if {$pkg in $cap_pkgs} { + set posn [lsearch $cap_pkgs $pkg] + if {$posn >=0} { + #rewrite package list with pkg at head of list for this capability + set cap_pkgs [lreplace $cap_pkgs $posn $posn] + set cap_pkgs [list $pkg {*}$cap_pkgs] + dict set caps $cap $cap_pkgs + } + } + } + } + } + proc unregister_package {pkg} { + variable pkgcap + variable caps + if {[string match ::* $pkg]} { + set pkg [string range $pkg 2 end] + } + if {[dict exists $pkgcap $pkg]} { + #remove corresponding entries in caps + set capabilitylist [dict get $pkgcap $pkg] + foreach c $capabilitylist { + lassign $c capname _capdict + set pkglist [dict get $caps $capname] + set posn [lsearch $pkglist $pkg] + if {$posn >= 0} { + set pkglist [lreplace $pkglist $posn $posn] + dict set caps $capname $pkglist + } + } + #delete the main registration record + dict unset pkgcap $pkg + } + } + proc registered_package {pkg} { + variable pkgcap + if {[string match ::* $pkg]} { + set pkg [string range $pkg 2 end] + } + if {[dict exists $pkgcap $pkg]} { + return [dict get $pkgcap $pkg] + } else { + return + } + } + proc registered_packages {} { + variable pkgcap + return $pkgcap + } + + proc capabilities {{glob *}} { + variable caps + set keys [lsort [dict keys $caps $glob]] + set cap_list [list] + foreach k $keys { + lappend cap_list [list $k [dict get $caps $k]] + } + return $cap_list + } + + namespace eval templates { + #return a dict keyed on folder with source pkg as value + proc folders {} { + package require punk::cap + set caplist [punk::cap::capabilities templates] + # e.g {templates {punk::mix::templates ::somepkg}} + set templates_record [lindex $caplist 0] + set pkgs [lindex $templates_record 1] + + set folderdict [dict create] + foreach pkg $pkgs { + set caplist [punk::cap::registered_package $pkg] + set templates_entries [lsearch -all -inline -index 0 $caplist templates] ;#we generally expect only one - but if multiple exist - use them + foreach templates_info $templates_entries { + lassign $templates_info _templates templates_dict + if {[dict exists $templates_dict relpath]} { + set provide_statement [package ifneeded $pkg [package require $pkg]] + set tmfile [lindex $provide_statement end] + #set tmdir [file dirname [lindex $provide_statement end]] + set tpath [file normalize [file join $tmfile [dict get $templates_dict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder + #relpath relative to file is important for tm files that are zip/tar based containers + if {[file isdirectory $tpath]} { + dict set folderdict $tpath [list source $pkg sourcetype package] + } else { + puts stderr "punk::cap::templates::folders WARNING - unable to determine base folder for package '$pkg' which is registered with punk::mix as a provider of 'templates' capability" + } + } else { + puts stderr "punk::cap::templates::folders WARNING - registered pkg 'pkg' has capability 'templates' but no 'relpath' key - unable to use as source of templates" + } + } + } + return $folderdict + } + + + + } +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::cap [namespace eval punk::cap { + variable version + set version 0.1.0 +}] +return \ No newline at end of file diff --git a/src/bootsupport/modules/punk/du-0.1.0.tm b/src/bootsupport/modules/punk/du-0.1.0.tm index ff7999fe..b2e15e2a 100644 --- a/src/bootsupport/modules/punk/du-0.1.0.tm +++ b/src/bootsupport/modules/punk/du-0.1.0.tm @@ -24,8 +24,10 @@ namespace eval punk::du { variable has_twapi 0 } if {"windows" eq $::tcl_platform(platform)} { - package require zzzload - zzzload::pkg_require twapi + #jmn disable twapi + #package require zzzload + #zzzload::pkg_require twapi + #if {[catch {package require twapi}]} { # puts stderr "Warning: punk::du - unable to load twapi. Disk operations may be much slower on windows without the twapi package" #} else { @@ -1245,6 +1247,9 @@ namespace eval punk::du { proc du_dirlisting_undecided {folderpath args} { if {"windows" eq $::tcl_platform(platform)} { + #jmn disable twapi + tailcall du_dirlisting_generic $folderpath {*}$args + set loadstate [zzzload::pkg_require twapi] if {$loadstate ni [list loading failed]} { package require twapi ;#should be fast once twapi dll loaded in zzzload thread diff --git a/src/bootsupport/modules/punk/mix/base-0.1.tm b/src/bootsupport/modules/punk/mix/base-0.1.tm new file mode 100644 index 00000000..0f131936 --- /dev/null +++ b/src/bootsupport/modules/punk/mix/base-0.1.tm @@ -0,0 +1,904 @@ +package provide punk::mix::base [namespace eval punk::mix::base { + variable version + set version 0.1 +}] + + +#base internal plumbing functions +namespace eval punk::mix::base { + proc set_alias {cmdname args} { + #--------- + #extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system + lassign [_split_args $args] _opts opts _args args + if {[dict exists $opts -extension]} { + set extension [dict get $opts -extension] + } else { + set extension "" + } + #--------- + + uplevel #0 [list interp alias {} $cmdname {} punk::mix::base::_cli -extension $extension] + } + proc _cli {args} { + #--------- + #extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system + lassign [_split_args $args] _opts opts _args args + if {[dict exists $opts -extension]} { + set extension [dict get $opts -extension] + } else { + set extension "" + } + #--------- + if {![string length $extension]} { + set extension [namespace qualifiers [lindex [info level -1] 0]] + } + #puts stderr "punk::mix::base extension: [string trimleft $extension :]" + if {![string length $extension]} { + #if still no extension - must have been called dirctly as punk::mix::base::_cli + if {![llength $args]} { + set args "help" + } + set extension [namespace current] + } + if {![llength $args]} { + if {[info exists ${extension}::default_command]} { + tailcall $extension [set ${extension}::default_command] + } + tailcall $extension + } else { + tailcall $extension {*}$args + } + } + proc _unknown {ns args} { + #--------- + #extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system + lassign [_split_args $args] _opts opts _args args + if {[dict exists $opts -extension]} { + set extension [dict get $opts -extension] + } else { + set extension "" + } + #--------- + + if {![string length $extension]} { + set extension [namespace qualifiers [lindex [info level -1] 0]] + } + #puts stderr "arglen:[llength $args]" + #puts stdout "_unknown '$ns' '$args'" + + set d_commands [get_commands -extension $extension] + set all_commands [list {*}[dict get $d_commands main] {*}[dict get $d_commands base]] + error "Unknown subcommand \"[lindex $args 0]\": must be one of: $all_commands" "punk::mix::base _unknown $ns $args" [list unknown_ensemble_subcommand ensemble punk::mix::base] + } + proc _redirected {from_ns subcommand args} { + #puts stderr "_redirected from_ns: $from_ns subcommand:$subcommand args:$args" + set pname [namespace current]::$subcommand + if {$pname in [info procs $pname]} { + set argnames [info args $pname] + #puts stderr "_redirected $subcommand argnames: $argnames" + if {[lindex $argnames end] eq "args"} { + set pos_argnames [lrange $argnames 0 end-1] + } else { + set pos_argnames $argnames + } + set argvals [list] + set numargs [llength $pos_argnames] + if {$numargs > 0} { + set argvals [lrange $args 0 $numargs-1] + set args [lrange $args $numargs end] + } + if {[llength $argvals] < $numargs} { + error "wrong # args: $from_ns $subcommand requires args: $pos_argnames" + } + tailcall [namespace current] $subcommand {*}$argvals {*}$args -extension $from_ns + } else { + tailcall [namespace current] $subcommand {*}$args -extension $from_ns + } + } + proc _split_args {arglist} { + #don't assume arglist is fully paired. + set posn [lsearch $arglist -extension] + set opts [list] + if {$posn >= 0} { + if {$posn+2 <= [llength $arglist]} { + set opts [list -extension [lindex $arglist $posn+1]] + set argsremaining [lreplace $arglist $posn $posn+1] + } else { + #no value supplied to -extension + error "punk::mix::base::_split_args - no value found for option '-extension'. Supply a value or omit the option." + } + } else { + set argsremaining $arglist + } + + return [list opts $opts args $argsremaining] + } +} + + +#base API (potentially overridden functions - may also be called from overriding namespace) +#commands should either handle or silently ignore -extension +namespace eval punk::mix::base { + namespace ensemble create + namespace export help dostuff get_commands set_alias + namespace ensemble configure [namespace current] -unknown punk::mix::base::_unknown + proc get_commands {args} { + #--------- + #extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system + lassign [_split_args $args] _opts opts _args args + if {[dict exists $opts -extension]} { + set extension [dict get $opts -extension] + } else { + set extension "" + } + #--------- + if {![string length $extension]} { + set extension [namespace qualifiers [lindex [info level -1] 0]] + } + + set maincommands [list] + #extension may still be blank e.g if punk::mix::base::get_commands called directly + if {[string length $extension]} { + set nsmain $extension + #puts stdout "get_commands nsmain: $nsmain" + set parentpatterns [namespace eval $nsmain [list namespace export]] + set nscommands [list] + foreach p $parentpatterns { + lappend nscommands {*}[info commands ${nsmain}::$p] + } + foreach c $nscommands { + set cmd [namespace tail $c] + lappend maincommands $cmd + } + set maincommands [lsort $maincommands] + } + + + + + set nsbase [namespace current] + set basepatterns [namespace export] + #puts stdout "basepatterns:$basepatterns" + set nscommands [list] + foreach p $basepatterns { + lappend nscommands {*}[info commands ${nsbase}::$p] + } + + set basecommands [list] + foreach c $nscommands { + set cmd [namespace tail $c] + if {$cmd ni $maincommands} { + lappend basecommands $cmd + } + } + set basecommands [lsort $basecommands] + + + return [list main $maincommands base $basecommands] + } + proc help {args} { + #' **%ensemblecommand% help** *args* + #' + #' Help for ensemble commands in the command line interface + #' + #' + #' Arguments: + #' + #' * args - first word of args is the helptopic requested - usually a command name + #' - calling help with no arguments will list available commands + #' + #' Returns: help text (text) + #' + #' Examples: + #' + #' ``` + #' %ensemblecommand% help + #' ``` + #' + #' + + + #extension.= @@opts/@?@-extension,args@@args=>. [_split_args $args] {| + # >} inspect -label a {| + # >} .=e>end,data>end pipeswitch { + # pipecase ,0/1/#= $switchargs {| + # e/0 + # >} .=>. {set e} + # pipecase /1,1/1/#= $switchargs + #} |@@ok/result> " opts $opts] + } + if {$ftype ni [list file directory]} { + #review - links? + error "cksum_path error file type '$ftype' not supported" + } + + + set opt_cksum_algorithm [dict get $opts -cksum_algorithm] + if {$opt_cksum_algorithm ni [cksum_algorithms]} { + return [list error unsupported_cksum_algorithm cksum "" opts $opts] + } + set opt_cksum_acls [dict get $opts -cksum_acls] + if {$opt_cksum_acls} { + puts stderr "cksum_path is not yet able to cksum ACLs" + return + } + + set opt_cksum_meta [dict get $opts -cksum_meta] + set opt_use_tar [dict get $opts -cksum_usetar] + if {$ftype eq "file"} { + if {$opt_use_tar eq "auto"} { + if {$opt_cksum_meta eq "1"} { + set opt_use_tar 1 + } else { + #prefer no tar if meta not required - faster/simpler + #meta == auto or 0 + set opt_cksum_meta 0 + set opt_use_tar 0 + } + } elseif {$opt_use_tar eq "0"} { + if {$opt_cksum_meta eq "1"} { + puts stderr "cksum_path doesn't yet support a non-tar cksum with metadata for a file" + return [list error unsupported_meta_without_tar cksum "" opts $opts] + } else { + #meta == auto or 0 + set opt_cksum_meta 0 + } + } else { + #tar == 1 + if {$opt_cksum_meta eq "0"} { + puts stderr "cksum_path doesn't yet support a tar cksum without metadata for a file" + return [list error unsupported_tar_without_meta cksum "" opts $opts] + } else { + #meta == auto or 1 + set opt_cksum_meta 1 + } + } + } elseif {$ftype eq "directory"} { + if {$opt_use_tar eq "auto"} { + if {$opt_cksum_meta in [list "auto" "1"]} { + set opt_use_tar 1 + set opt_cksum_meta 1 + } else { + puts stderr "cksum_path doesn't yet support a content-only cksum of a folder structure. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto" + return [list error unsupported_directory_cksum_without_meta cksum "" opts $opts] + } + } elseif {$opt_use_tar eq "0"} { + puts stderr "cksum_path doesn't yet support a cksum of a folder structure without tar. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" + return [list error unsupported_directory_cksum_without_tar cksum "" opts $opts] + } else { + #tar 1 + if {$opt_cksum_meta eq "0"} { + puts stderr "cksum_path doesn't yet support a tar checksum of a folder structure without metadat. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" + return [list error unsupported_without_meta cksum "" opts $opts] + } else { + #meta == auto or 1 + set opt_cksum_meta 1 + } + } + } + + dict set opts_actual -cksum_meta $opt_cksum_meta + dict set opts_actual -cksum_usetar $opt_use_tar + + + if {$opt_use_tar} { + package require tar ;#from tcllib + } + + if {$path eq $base} { + #attempting to cksum at root/volume level of a filesystem.. extra work + #This needs fixing for general use.. not necessarily just for project repos + puts stderr "cksum_path doesn't yet support cksum of entire volume. (todo)" + return [list error unsupported_path opts $opts] + } + + if {$opt_cksum_algorithm eq "sha1"} { + package require sha1 + set cksum_command [list sha1::sha1 -hex -file] + } elseif {$opt_cksum_algorithm in [list "sha2" "sha256"]} { + package require sha256 + set cksum_command [list sha2::sha256 -hex -file] + } elseif {$opt_cksum_algorithm eq "md5"} { + package require md5 + set cksum_command [list md5::md5 -hex -file] + } elseif {$opt_cksum_algorithm eq "cksum"} { + package require cksum ;#tcllib + set cksum_command [list crc::cksum -format 0x%X -file] + } elseif {$opt_cksum_algorithm eq "adler32"} { + set cksum_command [list cksum_adler32_file] + } elseif {$opt_cksum_algorithm in [list "sha3" "sha3-256"]} { + #todo - replace with something that doesn't call another process + #set cksum_command [list apply {{file} {lindex [exec fossil sha3sum -256 $file] 0}}] + set cksum_command [list $sha3_implementation 256] + } elseif {$opt_cksum_algorithm in [list "sha3-224" "sha3-384" "sha3-512"]} { + set bits [lindex [split $opt_cksum_algorithm -] 1] + #set cksum_command [list apply {{bits file} {lindex [exec fossil sha3sum -$bits $file] 0}} $bits] + set cksum_command [list $sha3_implementation $bits] + } + + set cksum "" + if {$opt_use_tar != 0} { + set target [file tail $path] + set tmplocation [punk::mix::util::tmpdir] + set archivename $tmplocation/[punk::mix::util::tmpfile].tar + + cd $base ;#cd is process-wide.. keep cd in effect for as small a scope as possible. (review for thread issues) + + #temp emission to stdout.. todo - repl telemetry channel + puts stdout "cksum_path: creating temporary tar archive at: $archivename .." + tar::create $archivename $target + if {$ftype eq "file"} { + set sizeinfo "(size [file size $target])" + } else { + set sizeinfo "(file type $ftype - size unknown)" + } + puts stdout "cksum_path: calculating cksum for $target $sizeinfo..." + set cksum [{*}$cksum_command $archivename] + #puts stdout "cksum_path: cleaning up.. " + file delete -force $archivename + cd $startdir + + } else { + #todo + if {$ftype eq "file"} { + if {$opt_cksum_meta} { + return [list error unsupported_opts_combo cksum "" opts $opts] + } else { + set cksum [{*}$cksum_command $path] + } + } else { + error "cksum_path unsupported $opts for path type [file type $path]" + } + } + set result [dict create] + dict set result cksum $cksum + dict set result opts $opts_actual + return $result + } + + #dict_path_cksum keyed on path - with value as a dict that must contain cksum key - but can contain other keys + #e.g -cksum_usetar which is one of the keys understood by the punk::mix::base::lib::cksum_path function - or unrelated keys which will also be passed through + #cksum only calculated for keys in dict where cksum is empty - ie return same dict but with empty cksums filled out. + #base can be empty string in which case paths must be absolute + proc fill_relativecksums_from_base_and_relativepathdict {base {dict_path_cksum {}}} { + if {$base eq ""} { + set error_paths [list] + dict for {path pathinfo} $dict_path_cksum { + if {[file pathtype $path] ne "absolute"} { + lappend error_paths $path + } + } + if {[llength $error_paths]} { + puts stderr "get_relativecksums_from_base_and_relativepathdict has empty base - and non-absolute paths in the supplied checksum dict - aborting" + puts stderr "error_paths: $error_paths" + error "fill_relativecksums_from_base_and_relativepathdict error: non-absolute paths when base empty. $error_paths" + } + } else { + if {[file pathtype $base] ne "absolute"} { + error "fill_relativecksums_from_base_and_relativepathdict error: base supplied but was not absolute path. $base" + } + #conversely now we have a base - so we require all paths are relative. + #We will ignore/disallow volume-relative - as these shouldn't be used here either + set error_paths [list] + dict for {path pathinfo} $dict_path_cksum { + if {[file pathtype $path] ne "relative"} { + lappend error_paths $path + } + } + if {[llength $error_paths]} { + puts stderr "fill_relativecksums_from_base_and_relativepathdict has a supplied absolute base path, but some of the paths in the supplied dict are not relative - aborting" + error "fill_relativecksums_from_base_and_relativepathdict error: non-relative paths when base supplied. $error_paths" + } + } + + + dict for {path pathinfo} $dict_path_cksum { + if {![dict exists $pathinfo cksum]} { + dict set pathinfo cksum "" + } else { + if {[dict get $pathinfo cksum] ne "" && ![cksum_is_tag [dict get $pathinfo cksum]]} { + continue ;#already filled with non-tag value + } + } + if {$base ne ""} { + set fullpath [file join $base $path] + } else { + set fullpath $path + } + + set ckopts [cksum_filter_opts {*}$pathinfo] + + if {![file exists $fullpath]} { + dict set dict_path_cksum $path cksum "" + } else { + set ckinfo [cksum_path $fullpath {*}$ckopts] + dict set dict_path_cksum $path cksum [dict get $ckinfo cksum] + dict set dict_path_cksum $path cksum_all_opts [dict get $ckinfo opts] + if {[dict exists $ckinfo error]} { + dict set dict_path_cksum $path cksum_error [dict get $ckinfo error] + } + } + } + + return $dict_path_cksum + } + #whether cksum is e.g + proc cksum_is_tag {cksum} { + expr {[string index $cksum 0] eq "<" && [string index $cksum end] eq ">"} + } + proc cksum_filter_opts {args} { + set ck_opt_names [dict keys [cksum_default_opts]] + set ck_opts [dict create] + dict for {k v} $args { + if {$k in $ck_opt_names} { + dict set ck_opts $k $v + } + } + return $ck_opts + } + + #convenience so caller doesn't have to pre-calculate the relative path from the base + #Note semantic difference from fill_relativecksums_from_base_and_relativepathdict (hence get_ vs fill_) + #Here we will raise an error if cksum exists and is not empty or a tag - whereas the multiple path version will ignore valid-looking prefilled cksum values + #base is the presumed location to store the checksum file. The caller should retain (normalize if relative) + proc get_relativecksum_from_base {base specifiedpath args} { + if {$base ne ""} { + #targetpath ideally should be within same project tree as base if base supplied - but not necessarily below it + #we don't necessarily want to restrict this to use in punk projects though - so we'll allow anything with a common prefix + if {[file pathtype $specifiedpath] eq "relative"} { + if {[file pathtype $base] eq "relative"} { + set normbase [file normalize $base] + set normtarg [file normalize [file join $normbase $specifiedpath]] + set targetpath $normtarg + set storedpath [punk::mix::util::path_relative $normbase $normtarg] + } else { + set targetpath [file join $base $specifiedpath] + set storedpath $specifiedpath + } + } else { + #specifed absolute + if {[file pathtype $base] eq "relative"} { + #relative to cwd or to specifiedpath? For consistency it should arguably be cwd but a case could be made that when one path is relative it is in reference to the other + #there is a strong possibility that allowing this combination will cause confusion - better to disallow + error "get_relativecksum_from_base error: disallowed pathtype combination. Base must be empty or absolute when specified path is absolute" + } + #both absolute - compute relative path if they share a common prefix + set commonprefix [punk::mix::util::path_common_prefix $base $specifiedpath] + if {$commonprefix eq ""} { + #absolute base with no shared prefix doesn't make sense - we could ignore it - but better to error-out and require the caller specify an empty base + error "get_relativecksum_from_base error: base '$base' and specifiedpath '$specifiedpath' don't share a common root. Use empty-string for base if independent absolute path is required" + } + set targetpath $specifiedpath + set storedpath [punk::mix::util::path_relative $base $specifiedpath] + + } + } else { + if {[file type $specifiedpath] eq "relative"} { + #if specifiedpath is relative - and we don't have a base, we now need to convert relative to cwd to an absolute path for storage + set targetpath [file normalize $specifiedpath] + set storedpath $targetpath + } else { + set targetpath $specifiedpath + set storedpath $targetpath + } + } + + # + #NOTE: specifiedpath can be a relative path (to cwd) when base is empty + #OR - a relative path when base itself is relative e.g base: somewhere targetpath somewhere/etc + #possibly also: base: somewhere targetpath: ../elsewhere/etc + # + #todo - write tests + + + if {([llength $args] % 2) != 0} { + error "get_relativecksum_from_base error. args supplied must be in the form of key-value pairs. received '$args' " + } + if {[dict exists $args cksum]} { + if {[dict get $args cksum] ne "" && ![cksum_is_tag [dict get $args cksum]]} { + error "get_relativecksum_from_base called with existing cksum value (and is not a tag or empty-value to be replaced) cksum: [dict get $args cksum] Set cksum to be empty, any tag such as or remove the key and try again." + } + } + + + set ckopts [cksum_filter_opts {*}$args] + set ckinfo [cksum_path $targetpath {*}$ckopts] + + set keyvals $args + dict set keyvals cksum [dict get $ckinfo cksum] + dict set keyvals cksum_all_opts [dict get $ckinfo opts] + if {[dict exists $ckinfo error]} { + dict set keyvals cksum_error [dict get $ckinfo error] + } + + #set relpath [punk::repo::path_strip_alreadynormalized_prefixdepth $fullpath $base] ;#empty base ok noop + #storedpath is relative if possible + return [dict create $storedpath $keyvals] + } + + #calculate the runtime checksum and vfs checksums + proc get_all_vfs_build_cksums {path} { + set buildfolder [get_build_workdir $path] + set cksum_base_folder [file dirname $buildfolder] ;#this is the /src folder - a reasonable base for our vfs cksums + set dict_cksums [dict create] + + set buildrelpath [punk::repo::path_strip_alreadynormalized_prefixdepth $buildfolder $cksum_base_folder] + set vfs_tail_list [glob -nocomplain -dir $cksum_base_folder -type d -tails *.vfs] + + foreach vfstail $vfs_tail_list { + set vname [file rootname $vfstail] + dict set dict_cksums $vfstail [list cksum ""] + dict set dict_cksums [file join $buildrelpath $vname.exe] [list cksum ""] + } + + set fullpath_buildruntime $buildfolder/buildruntime.exe + + set ckinfo_buildruntime [cksum_path $fullpath_buildruntime] + set ck [dict get $ckinfo_buildruntime cksum] + + + set relpath [file join $buildrelpath "buildruntime.exe"] + dict set dict_cksums $relpath [list cksum $ck] + + set dict_cksums [fill_relativecksums_from_base_and_relativepathdict $cksum_base_folder $dict_cksums] + + return $dict_cksums + } + + proc get_vfs_build_cksums_stored {vfsfolder} { + set vfscontainer [file dirname $vfsfolder] + set buildfolder $vfscontainer/_build + set vfs [file tail $vfsfolder] + set vname [file rootname $vfs] + set dict_vfs [list $vname.vfs "" $vname.exe "" buildruntime.exe ""] + set ckfile $buildfolder/$vname.cksums + if {[file exists $ckfile]} { + set data [punk::mix::util::fcat -translation binary $ckfile] + foreach ln [split $data \n] { + if {[string trim $ln] eq ""} {continue} + lassign $ln path cksum + dict set dict_vfs $path $cksum + } + } + return $dict_vfs + } + proc get_all_build_cksums_stored {path} { + set buildfolder [get_build_workdir $path] + + set vfscontainer [file dirname $buildfolder] + set vfslist [glob -nocomplain -dir $vfscontainer -type d -tail *.vfs] + set dict_cksums [dict create] + foreach vfs $vfslist { + set vname [file rootname $vfs] + set dict_vfs [get_vfs_build_cksums_stored $vfscontainer/$vfs] + + dict set dict_cksums $vname $dict_vfs + } + return $dict_cksums + } + + proc store_vfs_build_cksums {vfsfolder} { + if {![file isdirectory $vfsfolder]} { + error "Unable to find supplied vfsfolder: $vfsfolder" + } + set vfscontainer [file dirname $vfsfolder] + set buildfolder $vfscontainer/_build + set dict_vfs [get_vfs_build_cksums $vfsfolder] + set data "" + dict for {path cksum} $dict_vfs { + append data "$path $cksum" \n + } + set fd [open $buildfolder/$vname.cksums w] + chan configure $fd -translation binary + puts $fd $data + close $fd + return $dict_vfs + } + + + + } +} diff --git a/src/bootsupport/modules/punk/mix/cli-0.3.tm b/src/bootsupport/modules/punk/mix/cli-0.3.tm new file mode 100644 index 00000000..69672265 --- /dev/null +++ b/src/bootsupport/modules/punk/mix/cli-0.3.tm @@ -0,0 +1,909 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -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 +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz +package require punk::repo +package require punkcheck ;#checksum and/or timestamp records + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +namespace eval punk::mix::cli { + namespace eval temp_import { + } + namespace ensemble create + + package require punk::overlay + catch { + punk::overlay::import_commandset module . ::punk::mix::commandset::module + } + punk::overlay::import_commandset debug . ::punk::mix::commandset::debug + punk::overlay::import_commandset repo . ::punk::mix::commandset::repo + punk::overlay::import_commandset lib . ::punk::mix::commandset::loadedlib + + catch { + package require punk::mix::commandset::project + punk::overlay::import_commandset project . ::punk::mix::commandset::project + punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection + } + if {[catch { + package require punk::mix::commandset::layout + punk::overlay::import_commandset project.layout . ::punk::mix::commandset::layout + punk::overlay::import_commandset project.layouts . ::punk::mix::commandset::layout::collection + } errM]} { + puts stderr "error loading punk::mix::commandset::layout" + puts stderr $errM + } + if {[catch { + package require punk::mix::commandset::buildsuite + punk::overlay::import_commandset buildsuite . ::punk::mix::commandset::buildsuite + punk::overlay::import_commandset buildsuites . ::punk::mix::commandset::buildsuite::collection + } errM]} { + puts stderr "error loading punk::mix::commandset::buildsuite" + puts stderr $errM + } + punk::overlay::import_commandset scriptwrap . ::punk::mix::commandset::scriptwrap + if {[catch { + package require punk::mix::commandset::doc + punk::overlay::import_commandset doc . ::punk::mix::commandset::doc + punk::overlay::import_commandset "" "" ::punk::mix::commandset::doc::collection + } errM]} { + puts stderr "error loading punk::mix::commandset::doc" + puts stderr $errM + } + + + proc help {args} { + #set basehelp [punk::mix::base::help -extension [namespace current] {*}$args] + set basehelp [punk::mix::base help {*}$args] + #puts stdout "punk::mix help" + return $basehelp + } + + proc stat {{workingdir ""} args} { + dict set args -v 0 + punk::mix::cli::lib::get_status $workingdir {*}$args + } + proc status {{workingdir ""} args} { + dict set args -v 1 + punk::mix::cli::lib::get_status $workingdir {*}$args + } + + + + + + + +} + + +namespace eval punk::mix::cli { + + + #interp alias {} ::punk::mix::cli::project.new {} ::punk::mix::cli::new + + + + + + + + proc make {args} { + set startdir [pwd] + set project_base "" ;#empty for unknown + if {[punk::repo::is_git $startdir]} { + set project_base [punk::repo::find_git] + set sourcefolder $project_base/src + } elseif {[punk::repo::is_fossil $startdir]} { + set project_base [punk::repo::find_fossil] + set sourcefolder $project_base/src + } else { + if {[punk::repo::is_candidate $startdir]} { + set project_base [punk::repo::find_candidate] + set sourcefolder $project_base/src + puts stderr "WARNING - project not under git or fossil control" + puts stderr "Using base folder $project_base" + } else { + set sourcefolder $startdir + } + } + + #review - why can't we be anywhere in the project? + if {([file tail $sourcefolder] ne "src") || (![file exists $sourcefolder/make.tcl])} { + puts stderr "pmix make must be run from src folder containing make.tcl - unable to proceed (cwd: [pwd])" + if {[string length $project_base]} { + if {[file exists $project_base/src] && [string tolower [pwd]] ne [string tolower $project_base/src]} { + puts stderr "Try cd to $project_base/src" + } + } else { + if {[file exists $startdir/Makefile]} { + puts stdout "A Makefile exists at $startdir/Makefile." + if {"windows" eq $::tcl_platform(platform)} { + puts stdout "Try running: msys2 -ucrt64 -here -c \"make build\" or bash -c \"make build\"" + } else { + puts stdout "Try runing: make build" + } + } + } + return false + } + + if {![string length $project_base]} { + puts stderr "WARNING no git or fossil repository detected." + puts stderr "Using base folder $startdir" + set project_base $startdir + } + + set lc_this_exe [string tolower [info nameofexecutable]] + set lc_proj_bin [string tolower $project_base/bin] + set lc_build_bin [string tolower $project_base/src/_build] + + if {"project" in $args} { + set is_own_exe 0 + if {[string match "${lc_proj_bin}*" $lc_this_exe] || [string match "${lc_build_bin}" $lc_this_exe]} { + set is_own_exe 1 + puts stderr "WARNING - running make using executable that may be created by the project being built" + set answer [util::askuser "Do you want to proceed using this executable? (build will probably stop when it is unable to update the executable) Y|N"] + if {[string tolower $answer] ne "y"} { + puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." + return + } + } + } + cd $sourcefolder + #use run so that stdout visible as it goes + if {![catch {run --timeout=5000 -debug [info nameofexecutable] $sourcefolder/make.tcl {*}$args} exitinfo]} { + puts stderr "exitinfo: $exitinfo" + set exitcode [dict get $exitinfo exitcode] + } else { + puts stderr "Error unable to determine exitcode. err: $exitinfo" + cd $startdir + return false + } + + cd $startdir + if {$exitcode != 0} { + puts stderr "FAILED with exitcode $exitcode" + return false + } else { + puts stdout "OK make finished " + return true + } + } + + proc Kettle {args} { + tailcall lib::kettle_call lib {*}$args + } + proc KettleShell {args} { + tailcall lib::kettle_call shell {*}$args + } + + + + namespace eval lib { + namespace path ::punk::mix::util + + + proc module_types {} { + #first in list is default for unspecified -type when creating new module + return [list plain tarjar zipkit] + } + + proc validate_modulename {modulename args} { + set defaults [list\ + -name_description modulename\ + ] + if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"} + set known_opts [dict keys $defaults] + foreach k [dict keys $args] { + if {$k ni $known_opts} { + error "validate_modulename error: unknown option $k. known options: $known_opts" + } + } + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_name_description [dict get $opts -name_description] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + + validate_name_not_empty_or_spaced $modulename -name_description $opt_name_description + set testname [string map [list :: ""] $modulename] + if {[string first : $testname] >=0} { + error "$opt_name_description '$modulename' can only contain paired colons" + } + set badchars [list - "$" "?" "*"] + foreach bc $badchars { + if {[string first $bc $modulename] >= 0} { + error "$opt_name_description '$modulename' can not contain character '$bc'" + } + } + return $modulename + } + + proc validate_projectname {projectname args} { + set defaults [list\ + -name_description projectname\ + ] + if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"} + set known_opts [dict keys $defaults] + foreach k [dict keys $args] { + if {$k ni $known_opts} { + error "validate_modulename error: unknown option $k. known options: $known_opts" + } + } + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_name_description [dict get $opts -name_description] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + validate_name_not_empty_or_spaced $projectname -name_description $opt_name_description + set reserved_words [list etc lib bin modules src doc vendorlib vendormodules embedded runtime _aside _build] + if {$projectname in $reserved_words } { + error "$opt_name_description '$projectname' cannot be one of reserved_words: $reserved_words" + } + if {[string first "::" $projectname] >= 0} { + error "$opt_name_description '$projectname' cannot contain namespace separator '::'" + } + return $projectname + } + proc validate_name_not_empty_or_spaced {name args} { + set defaults [list\ + -name_description projectname\ + ] + if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"} + set known_opts [dict keys $defaults] + foreach k [dict keys $args] { + if {$k ni $known_opts} { + error "validate_modulename error: unknown option $k. known options: $known_opts" + } + } + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_name_description [dict get $opts -name_description] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + if {![string length $name]} { + error "$opt_name_description cannot be empty" + } + if {[string length [string map [list " " "" \n "" \r "" \t ""] $name]] != [string length $name]} { + error "$opt_name_description cannot contain whitespace" + } + return $name + } + + #split modulename (as present in a filename or namespaced name) into name/version ignoring leading namespace path + #ignore trailing .tm .TM if present + #if version doesn't pass validation - treat it as part of the modulename and return empty version string without error + #Up to caller to validate. + proc split_modulename_version {modulename} { + set lastpart [namespace tail $modulename] + set lastpart [file tail $lastpart] ;# should be ok to use file tail now that we've ensured no namespace components + if {[string equal -nocase [file extension $modulename] ".tm"]} { + set fileparts [split [file rootname $lastpart] -] + } else { + set fileparts [split $lastpart -] + } + if {[punk::mix::util::is_valid_tm_version [lindex $fileparts end]]} { + set versionsegment [lindex $fileparts end] + set namesegment [join [lrange $fileparts 0 end-1] -];#re-stitch + } else { + # + set namesegment [join $fileparts -] + set versionsegment "" + } + return [list $namesegment $versionsegment] + } + + proc get_status {{workingdir ""} args} { + set result "" + if {$workingdir ne ""} { + if {[file pathtype $workingdir] ne "absolute"} { + set workingdir [file normalize $workingdir] + } + set active_dir $workingdir + } else { + set active_dir [pwd] + } + set defaults [dict create\ + -v 1\ + ] + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- + set opt_v [dict get $opts -v] + # -- --- --- --- --- --- --- --- --- + + + set repopaths [punk::repo::find_repos [pwd]] + set repos [dict get $repopaths repos] + if {![llength $repos]} { + append result [dict get $repopaths warnings] + } else { + append result [dict get $repopaths warnings] + lassign [lindex $repos 0] repopath repotypes + if {"fossil" in $repotypes} { + #review - multiple process launches to fossil a bit slow on windows.. + #could we query global db in one go instead? + # + set fossil_prog [auto_execok fossil] + append result "FOSSIL project based at $repopath with revision: [punk::repo::fossil_revision $repopath]" \n + set fosinfo [exec {*}$fossil_prog info] + append result [join [punk::repo::grep {repository:*} $fosinfo] \n] \n + + set fosrem [exec {*}$fossil_prog remote ls] + if {[string length $fosrem]} { + append result "Remotes:\n" + append result " " $fosrem \n + } + + + append result [join [punk::repo::grep {tags:*} $fosinfo] \n] \n + + set dbinfo [exec {*}$fossil_prog dbstat] + append result [join [punk::repo::grep {project-name:*} $dbinfo] \n] \n + append result [join [punk::repo::grep {tickets:*} $dbinfo] \n] \n + append result [join [punk::repo::grep {project-age:*} $dbinfo] \n] \n + append result [join [punk::repo::grep {latest-change:*} $dbinfo] \n] \n + append result [join [punk::repo::grep {files:*} $dbinfo] \n] \n + append result [join [punk::repo::grep {check-ins:*} $dbinfo] \n] \n + if {"project" in $repotypes} { + #punk project + if {![catch {package require textblock; package require patternpunk}]} { + set result [textblock::join [textblock::join [>punk . logo] " "] $result] + append result \n + } + } + + set timeline [exec fossil timeline -n 5 -t ci] + set timeline [string map [list \r\n \n] $timeline] + append result $timeline + if {$opt_v} { + set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes fossil] + append result \n [punk::repo::workingdir_state_summary $repostate] + } + + } + #repotypes *could* be both git and fossil - so report both if so + if {"git" in $repotypes} { + append result "GIT project based at $repopath with revision: [punk::repo::git_revision $repopath]" \n + if {[string length [set git_prog [auto_execok git]]]} { + set git_remotes [exec {*}$git_prog remote -v] + append result $git_remotes + if {$opt_v} { + set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes git] + append result \n [punk::repo::workingdir_state_summary $repostate] + } + } + } + + } + + return $result + } + + + proc build_modules_from_source_to_base {srcdir basedir args} { + set antidir [list "#*" "_aside" ".git" ".fossil*"] ;#exact or glob patterns for folders we don't want to search in. + set defaults [list\ + -installer punk::mix::cli::build_modules_from_source_to_base\ + -call-depth-internal 0\ + -max_depth 1000\ + -subdirlist {}\ + -punkcheck_eventobj "\uFFFF"\ + -glob *.tm\ + ] + set opts [dict merge $defaults $args] + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set installername [dict get $opts -installer] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set CALLDEPTH [dict get $opts -call-depth-internal] + set max_depth [dict get $opts -max_depth] + set subdirlist [dict get $opts -subdirlist] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set fileglob [dict get $opts -glob] + if {![string match "*.tm" $fileglob]} { + error "build_modules_from_source_to_base -glob '$fileglob' doesn't seem to target tcl modules." + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_punkcheck_eventobj [dict get $opts -punkcheck_eventobj] + + set magicversion [punk::mix::util::magic_tm_version] ;#deliberately large so given load-preference when testing + set module_list [list] + + if {[file tail [file dirname $srcdir]] ne "src"} { + puts stderr "ERROR build_modules_from_source_to_base can only be called with a srcdir that is a subfolder of your 'src' directory" + puts stderr "The .tm modules are namespaced based on their directory depth - so we need to start at the root" + puts stderr "To build a subtree of your modules - use an appropriate src/modules folder and pass in the -subdirlist." + puts stderr "e.g if your modules are based at /x/src/modules2 and you wish to build only the .tm files at /x/src/modules2/skunkworks/lib" + puts stderr "Use: >build_modules_from_source_to_base /x/src/modules2 /x/modules2 -subdirlist {skunkworks lib}" + exit 2 + } + set srcdirname [file tail $srcdir] + + set build [file dirname $srcdir]/_build/$srcdirname ;#relative to *original* srcdir - not current_source_dir + if {[llength $subdirlist] == 0} { + set target_module_dir $basedir + set current_source_dir $srcdir + } else { + set target_module_dir $basedir/[file join {*}$subdirlist] + set current_source_dir $srcdir/[file join {*}$subdirlist] + } + if {![file exists $target_module_dir]} { + error "build_modules_from_source_to_base from current source dir: '$current_source_dir'. Basedir:'$current_module_dir' doesn't exist or is empty" + } + if {![file exists $current_source_dir]} { + error "build_modules_from_source_to_base from current source dir:'$current_source_dir' doesn't exist or is empty" + } + + #---------------------------------------- + set punkcheck_file [file join $basedir/.punkcheck] + if {$CALLDEPTH == 0} { + + set config [dict create\ + -glob $fileglob\ + -max_depth 0\ + ] + #lassign [punkcheck::start_installer_event $punkcheck_file $installername $srcdir $basedir $config] _eventid punkcheck_eventid _recordset record_list + # -- --- + set installer [punkcheck::installtrack new $installername $punkcheck_file] + $installer set_source_target $srcdir $basedir + set event [$installer start_event $config] + # -- --- + + } else { + set event $opt_punkcheck_eventobj + } + #---------------------------------------- + + + + set src_modules [glob -nocomplain -dir $current_source_dir -type f -tail $fileglob] + + set did_skip 0 ;#flag for stdout/stderr formatting only + foreach m $src_modules { + #puts "build_modules_from_source_to_base >>> module $m" + set fileparts [split [file rootname $m] -] + set tmfile_versionsegment [lindex $fileparts end] + if {$tmfile_versionsegment eq $magicversion} { + #rebuild the .tm from the #tarjar + set basename [join [lrange $fileparts 0 end-1] -] + set versionfile $current_source_dir/$basename-buildversion.txt + set versionfiledata "" + if {![file exists $versionfile]} { + puts stderr "\nWARNING: Missing buildversion text file: $versionfile" + puts stderr "Using version 0.1 - create $versionfile containing the desired version number as the top line to avoid this warning\n" + set module_build_version "0.1" + } else { + set fd [open $versionfile r] + set versionfiledata [read $fd]; close $fd + set ln0 [lindex [split $versionfiledata \n] 0] + set ln0 [string trim $ln0]; set ln0 [string trim $ln0 \r] + if {![util::is_valid_tm_version $ln0]} { + puts stderr "ERROR: build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file" + exit 3 + } + set module_build_version $ln0 + } + + + if {[file exists $current_source_dir/#tarjar-$basename-$magicversion]} { + #TODO + file mkdir $buildfolder + + if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { + + } else { + + } + #REVIEW - should be in same structure/depth as $target_module_dir in _build? + set tmfile $basedir/_build/$basename-$module_build_version.tm + file mkdir $basedir/_build + file delete -force $basedir/_build/#tarjar-$basename-$module_build_version + file delete -force $tmfile + + + file copy -force $current_source_dir/#tarjar-$basename-$magicversion $basedir/_build/#tarjar-$basename-$module_build_version + # + #bsdtar doesn't seem to work.. or I haven't worked out the right options? + #exec tar -cvf $basedir/_build/$basename-$module_build_version.tm $basedir/_build/#tarjar-$basename-$module_build_version + package require tar + tar::create $tmfile $basedir/_build/#tarjar-$basename-$module_build_version + if {![file exists $tmfile]} { + puts stdout "ERROR: Failed to build tarjar file $tmfile" + exit 4 + } + #copy the file? + #set target $target_module_dir/$basename-$module_build_version.tm + #file copy -force $tmfile $target + + lappend module_list $tmfile + } else { + #assume that either the .tm is not a tarjar - or the tarjar dir is capped (trailing #) and the .tm has been manually tarred. + if {[file exists $current_source_dir/#tarjar-$basename-${magicversion}#]} { + puts stderr "\nWarning: found 'capped' folder #tarjar-$basename-${magicversion}# - No attempt being made to update version in description.txt" + } + + #------------------------------ + # + #set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$basename-$module_build_version.tm] + #set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] + $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm + $event targetset_addsource $versionfile + $event targetset_addsource $current_source_dir/$m + + #set changed_list [list] + ## -- --- --- --- --- --- + #set source_relpath [punkcheck::lib::path_relative $basedir $versionfile] + #set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] + ## -- --- --- --- --- --- + #set source_relpath [punkcheck::lib::path_relative $basedir $current_source_dir/$m] + #set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] + ## -- --- --- --- --- --- + #set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] + #set changed_list [dict get $changed_unchanged changed] + + + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ + } { + + #set file_record [punkcheck::installfile_started_install $basedir $file_record] + $event targetset_started + # -- --- --- --- --- --- + set target $target_module_dir/$basename-$module_build_version.tm + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + puts stdout "copying module $current_source_dir/$m to $target as version: $module_build_version ([file tail $target])" + set fd [open $current_source_dir/$m r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd + set data [string map [list $magicversion $module_build_version] $data] + set fdout [open $target w] + fconfigure $fdout -translation binary + puts -nonewline $fdout $data + close $fdout + #file copy -force $srcdir/$m $target + lappend module_list $target + # -- --- --- --- --- --- + #set file_record [punkcheck::installfile_finished_install $basedir $file_record] + $event targetset_end OK + } else { + #puts stdout "skipping module $current_source_dir/$m - no change in sources detected" + puts -nonewline stderr "." + set did_skip 1 + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $event targetset_end SKIPPED + } + + #------------------------------ + + } + + continue + } + + + if {![util::is_valid_tm_version $tmfile_versionsegment]} { + #last segment doesn't look even slightly versiony - fail. + puts stderr "ERROR: Unable to confirm file $current_source_dir/$m is a reasonably versioned .tm module - ABORTING." + exit 1 + } + + ##------------------------------ + ## + #set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$m] + #set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] + #set changed_list [list] + ## -- --- --- --- --- --- + #set source_relpath [punkcheck::lib::path_relative $basedir $current_source_dir/$m] + #set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] + ## -- --- --- --- --- --- + #set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] + #set changed_list [dict get $changed_unchanged changed] + + #---------- + $event targetset_init INSTALL $target_module_dir/$m + $event targetset_addsource $current_source_dir/$m + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ + } { + + #set file_record [punkcheck::installfile_started_install $basedir $file_record] + $event targetset_started + # -- --- --- --- --- --- + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + puts stderr "Copied already versioned module $current_source_dir/$m to $target_module_dir" + lappend module_list $current_source_dir/$m + file copy -force $current_source_dir/$m $target_module_dir + # -- --- --- --- --- --- + #set file_record [punkcheck::installfile_finished_install $basedir $file_record] + $event targetset_end OK -note "already versioned module" + } else { + puts -nonewline stderr "." + set did_skip 1 + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $event targetset_end SKIPPED + } + + } + if {$CALLDEPTH >= $max_depth} { + set subdirs [list] + } else { + set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] + } + #puts stderr "subdirs: $subdirs" + foreach d $subdirs { + set skipdir 0 + foreach dg $antidir { + if {[string match $dg $d]} { + set skipdir 1 + continue + } + } + if {$skipdir} { + continue + } + if {![file exists $target_module_dir/$d]} { + file mkdir $target_module_dir/$d + } + lappend module_list {*}[build_modules_from_source_to_base $srcdir $basedir\ + -call-depth-internal [expr {$CALLDEPTH +1}]\ + -subdirlist [list {*}$subdirlist $d]\ + -punkcheck_eventobj $event\ + -glob $fileglob\ + ] + } + if {$did_skip} { + puts -nonewline stdout \n + } + if {$CALLDEPTH == 0} { + $event destroy + $installer destroy + } + return $module_list + } + + variable kettle_reset_bodies [dict create] + variable kettle_reset_args [dict create] + #We are abusing kettle to run in-process. + # when we change to another project we need recipes to be reloaded. + # Kettle rewrites some of it's own procs - stopping reloading of recipes when we change folders + #kettle_init stores the original proc bodies & args + proc kettle_init {} { + variable kettle_reset_bodies ;#dict + variable kettle_reset_args + set reset_procs [list\ + ::kettle::benchmarks\ + ::kettle::doc\ + ::kettle::figures\ + ::kettle::meta::scan\ + ::kettle::testsuite\ + ] + foreach p $reset_procs { + set b [info body $p] + if {[string match "*Overwrite self*" $b]} { + dict set kettle_reset_bodies $p $b + set argnames [info args $p] + set arglist [list] + foreach a $argnames { + if {[info default $p $a dval]} { + lappend arglist [list $a $dval] + } else { + lappend arglist $a + } + } + dict set kettle_reset_args $p $arglist + } + } + + } + #call kettle_reinit to ensure recipes point to current project + proc kettle_reinit {} { + variable kettle_reset_bodies + variable kettle_reset_args + foreach p [dict keys $kettle_reset_bodies] { + set b [dict get $kettle_reset_bodies $p] + set argl [dict get $kettle_reset_args $p] + uplevel 1 [list ::proc $p $argl $b] + } + #todo - determine standard recipes by examining standard.tcl instead of hard coding? + set standard_recipes [list\ + null\ + forever\ + list-recipes\ + help-recipes\ + help-dump\ + help-recipes\ + help\ + list\ + list-options\ + help-options\ + show-configuration\ + show-state\ + show\ + meta-status\ + gui\ + ] + #set ::kettle::recipe::recipe [dict create] + foreach r [dict keys $::kettle::recipe::recipe] { + if {$r ni $standard_recipes} { + dict unset ::kettle::recipe::recipe $r + } + } + } + proc kettle_call {calltype args} { + variable kettle_reset_bodies + if {$calltype ni [list lib shell]} { + error "pmix kettle_call 1st argument must be one of: 'lib' for direct use of kettle module or 'shell' to call as separate process" + } + if {$calltype eq "shell"} { + set kettleappfile [file dirname [info nameofexecutable]]/kettle + set kettlebatfile [file dirname [info nameofexecutable]]/kettle.bat + + if {(![file exists $kettleappfile]) && (![file exists $kettlebatfile])} { + error "pmix kettle_call unable to find installed kettle application file '$kettleappfile' (or '$kettlebatfile' if on windows)" + } + if {[file exists $kettleappfile]} { + set kettlescript $kettleappfile + } + if {$::tcl_platform(platform) eq "windows"} { + if {[file exists $kettlebatfile]} { + set kettlescript $kettlebatfile + } + } + } + set startdir [pwd] + if {![file exists $startdir/build.tcl]} { + error "pmix kettle must be run from a folder containing build.tcl (cwd: [pwd])" + } + if {[package provide kettle] eq ""} { + puts stdout "Loading kettle package - may be delay on first load ..." + package require kettle + kettle_init ;#store original procs for those kettle procs that rewrite themselves + } else { + if {[dict size $kettle_reset_bodies] == 0} { + #presumably package require kettle was called without calling our kettle_init hack. + kettle_init + } else { + #undo proc rewrites + kettle_reinit + } + } + set first [lindex $args 0] + if {[string match @* $first]} { + error "pmix kettle doesn't support special operations - try calling tclsh kettle directly" + } + if {$first eq "-f"} { + set args [lassign $args __ path] + } else { + set path $startdir/build.tcl + } + set opts [list] + + if {[lindex $args 0] eq "-trace"} { + set args [lrange $args 1 end] + lappend opts --verbose on + } + set goals [list] + + if {$calltype eq "lib"} { + file mkdir ~/.kettle + set dotfile ~/.kettle/config + if {[file exists $dotfile] && + [file isfile $dotfile] && + [file readable $dotfile]} { + ::kettle io trace {Loading dotfile $dotfile ...} + set args [list {*}[::kettle path cat $dotfile] {*}$args] + } + } + + #hardcoded kettle option names (::kettle option names) - retrieved using kettle::option names + #This is done so we don't have to load kettle lib for shell call (both loading as module and running shell are annoyingly SLOW) + #REVIEW - needs to be updated to keep in sync with kettle. + set knownopts [list\ + --exec-prefix --bin-dir --lib-dir --prefix --man-dir --html-dir --markdown-dir --include-dir \ + --ignore-glob --dry --verbose --machine --color --state --config --with-shell --log \ + --log-append --log-mode --with-dia --constraints --file --limitconstraints --tmatch --notfile --single --valgrind --tskip --repeats \ + --iters --collate --match --rmatch --with-doc-destination --with-git --target --test-include \ + ] + + while {[llength $args]} { + set o [lindex $args 0] + switch -glob -- $o { + --* { + #instead of using: kettle option known + if {$o ni $knownopts} { + error "Unable to process unknown option $o." {} [list KETTLE (pmix)] + } + lappend opts $o [lindex $args 1] + #::kettle::option set $o [lindex $args 1] + set args [lrange $args 2 end] + } + default { + lappend goals $o + set args [lrange $args 1 end] + } + } + } + + if {![llength $goals]} { + lappend goals help + } + if {"--prefix" ni [dict keys $opts]} { + dict set opts --prefix [file dirname $startdir] + } + if {$calltype eq "lib"} { + ::kettle status clear + ::kettle::option::set @kettle $startdir + foreach {o v} $opts { + ::kettle option set $o $v + } + ::kettle option set @srcscript $path + ::kettle option set @srcdir [file dirname $path] + ::kettle option set @goals $goals + ::source $path + puts stderr "recipes: [::kettle recipe names]" + ::kettle recipe run {*}[::kettle option get @goals] + + set state [::kettle option get --state] + if {$state ne {}} { + puts stderr "saving kettle state: $state" + ::kettle status save $state + } + + } else { + #shell + puts stdout "Running external kettle process with args: $opts $goals" + run -n tclsh $kettlescript -f $path {*}$opts {*}$goals + } + + } + + } +} + + +namespace eval punk::mix::cli { + proc _cli {args} { + #don't use tailcall - base uses info level to determine caller + ::punk::mix::base::_cli {*}$args + } + variable default_command help + package require punk::mix::base + package require punk::overlay + punk::overlay::custom_from_base [namespace current] ::punk::mix::base +} + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::cli [namespace eval punk::mix::cli { + variable version + set version 0.3 +}] +return diff --git a/src/bootsupport/modules/punk/mix/commandset/buildsuite-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/buildsuite-0.1.0.tm new file mode 100644 index 00000000..883e02d2 --- /dev/null +++ b/src/bootsupport/modules/punk/mix/commandset/buildsuite-0.1.0.tm @@ -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 -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application punk::mix::commandset::buildsuite 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::mix::commandset::buildsuite { + namespace export * + proc projects {suite} { + set pathinfo [punk::repo::find_repos [pwd]] + set projectdir [dict get $pathinfo closest] + set suites_dir [file join $projectdir src buildsuites] + if {![file isdirectory [file join $suites_dir $suite]]} { + puts stderr "suite: $suite not found in buildsuites folder: $suites_dir" + return + } + set suite_dir [file join $suites_dir $suite] + set projects [glob -dir $suite_dir -type d -tails *] + + #use internal du which although breadth-first is generally faster + puts stdout "Examining source folders in $suite_dir." ;#A hint that something is happening in case sources are large + set du_info [punk::du::du -d 1 -b $suite_dir] + set du_sizes [dict create] + set suite_total_size "-" + foreach du_record $du_info { + if {[llength $du_record] != 2} { + #sanity precaution - punk::du::du should always output list of 2 element lists - at least with flags we're using + continue + } + set sz [lindex $du_record 0] + set path_parts [file split [lindex $du_record 1]] ;#should handle spaced-paths ok. + set s [lindex $path_parts end-1] + set p [lindex $path_parts end] + + #This handles case where a project folder is same name as suite e.g src/buildsuites/tcl/tcl + #so we can't just use tail as dict key. We could assume last record is always total - but + if {![string match -nocase $s $suite]} { + if {$s eq "buildsuites" && [string match -nocase $p $suite]} { + set suite_total_size $sz ;#this includes config files in suite base - so we don't really want to use this to report the total source size + } else { + #something else - shouldn't happen + puts stderr "Unexpected output from du in suite_dir: $suite_dir" + puts stderr "$du_record" + #try to continue anyway + } + } else { + dict set du_sizes $p $sz + } + } + + #build another dict for sizes where we ensure exactly one entry for each project exists and exclude total (don't blindly trust du output e.g in case weird filename/permission issue) + set psizes [list] + foreach p $projects { + if {[dict exists $du_sizes $p]} { + dict set psizes $p [dict get $du_sizes $p] + } else { + dict set psizes $p - + } + } + set total_source_size "-" + if {[catch { + set total_source_size [tcl::mathop::+ {*}[dict values $psizes]] + } errM]} { + puts stderr "Failed to calculate total source size. Errmsg: $errM" + } + package require overtype + + set title1 "Projects" + set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $projects] {punk::strlen $v}]] + set col1 [string repeat " " $widest1] + + set size_values [dict values $psizes] + # Title is probably widest - but go through the process anyway! + set title2 "Source Bytes" + set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $size_values] {punk::strlen $v}]] + set col2 [string repeat " " $widest2] + + + set output "" + append output "[overtype::left $col1 $title1] [overtype::right $col2 $title2]" \n + foreach p [lsort $projects] { + #todo - provide some basic info for each - last build time? last time-to-build? + append output "[overtype::left $col1 $p] [overtype::right $col2 [dict get $psizes $p]]" \n + } + append output "Total Source size: $total_source_size bytes" \n + return $output + } + + + namespace eval collection { + namespace export * + proc _default {{glob {}}} { + if {![string length $glob]} { + set glob * + } + #todo - review - we want the furthest not the closest if we are potentially inside a buildsuite project + set pathinfo [punk::repo::find_repos [pwd]] + set projectdir [dict get $pathinfo closest] + set suites_dir [file join $projectdir src buildsuites] + if {![file exists $suites_dir]} { + puts stderr "No buildsuites folder found at $suites_dir" + return + } + set suites [lsort [glob -dir $suites_dir -type d -tails *]] + if {$glob ne "*"} { + set suites [lsearch -all -inline $suites $glob] + } + return $suites + } + } + + +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::commandset::buildsuite [namespace eval punk::mix::commandset::buildsuite { + variable version + set version 0.1.0 +}] +return diff --git a/src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm new file mode 100644 index 00000000..8ed735c1 --- /dev/null +++ b/src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm @@ -0,0 +1,92 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application punk::mix::commandset::debug 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::mix::commandset::debug { + namespace export get paths + namespace path ::punk::mix::cli + + #Except for 'get' - all debug commands should emit to stdout + proc paths {} { + set out "" + puts stdout "find_repos output:" + set pathinfo [punk::repo::find_repos [pwd]] + pdict $pathinfo + + set projectdir [dict get $pathinfo closest] + set modulefolders [lib::find_source_module_paths $projectdir] + puts stdout "modulefolders: $modulefolders" + + set template_base_dict [punk::mix::base::lib::get_template_basefolders] + puts stdout "get_template_basefolders output:" + pdict $template_base_dict + return + } + + #call other debug command - but capture stdout as return value + proc get {args} { + set nm [lindex $args 0] + if {$nm eq ""} { + set nscmds [info commands [namespace current]::*] + set cmds [lmap v $nscmds {namespace tail $v}] + error "debug.get missing debug command argument. Try one of: $cmds" + return + } + set nextargs [lrange $args 1 end] + set out "" + if {[info commands [namespace current]::$nm] ne ""} { + append out [runout -n -tcl [namespace current]::$nm {*}$nextargs] \n + } else { + set nscmds [info commands [namespace current]::*] + set cmds [lmap v $nscmds {namespace tail $v}] + error "debug.get invalid debug command '$nm' Try one of: $cmds" + } + return $out + } + namespace eval lib { + + } + + +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::commandset::debug [namespace eval punk::mix::commandset::debug { + variable version + set version 0.1.0 +}] +return diff --git a/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm new file mode 100644 index 00000000..6184a389 --- /dev/null +++ b/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm @@ -0,0 +1,181 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application punk::mix::commandset::doc 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::mix::commandset::doc { + namespace export * + + proc _default {} { + puts "documentation subsystem" + puts "commands: doc.build" + puts " build documentation from src/doc to src/embedded using the kettle build tool" + } + + proc build {} { + puts "build docs" + set projectdir [punk::repo::find_project] + if {$projectdir eq ""} { + puts stderr "No current project dir - unable to build docs" + return + } + if {[file exists $projectdir/src/doc]} { + set original_wd [pwd] + cd $projectdir/src + #---------- + set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] + $installer set_source_target $projectdir/src/doc $projectdir/src/embedded + set event [$installer start_event {-install_step kettledoc}] + #use same virtual id "kettle_build_doc" as project.new - review best way to keep identifiers like this in sync. + $event targetset_init VIRTUAL kettle_build_doc ;#VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated + $event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source + #---------- + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + } { + $event targetset_started + # -- --- --- --- --- --- + puts stdout "BUILDING DOCS at $projectdir/src/embedded from src/doc" + if {[catch { + + punk::mix::cli::lib::kettle_call lib doc + #Kettle doc + + } errM]} { + $event targetset_end FAILED -note "kettle_build_doc failed: $errM" + } else { + $event targetset_end OK + } + # -- --- --- --- --- --- + } else { + puts stderr "No change detected in src/doc" + $event targetset_end SKIPPED + } + $event end + $event destroy + $installer destroy + cd $original_wd + } else { + puts stderr "No doc folder found at $projectdir/src/doc" + } + } + proc status {} { + set projectdir [punk::repo::find_project] + if {$projectdir eq ""} { + puts stderr "No current project dir - unable to check doc status" + return + } + if {![file exists $projectdir/src/doc]} { + set result "No documentation source found. Expected .man files in doctools format at $projectdir/src/doc" + return $result + } + set original_wd [pwd] + cd $projectdir/src + puts stdout "Testing status of doctools source location $projectdir/src/doc ..." + flush stdout + #---------- + set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] + $installer set_source_target $projectdir/src/doc $projectdir/src/embedded + set event [$installer start_event {-install_step kettledoc}] + #use same virtual id "kettle_build_doc" as project.new - review best way to keep identifiers like this in sync. + $event targetset_init QUERY kettle_build_doc ;#usually VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated - but here we use QUERY to ensure no writes to .punkcheck + set last_completion [$event targetset_last_complete] + + if {[llength $last_completion]} { + #adding a source causes it to be checksummed + $event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source + #---------- + set changeinfo [$event targetset_source_changes] + if {\ + [llength [dict get $changeinfo changed]]\ + } { + puts stdout "changed" + puts stdout $changeinfo + } else { + puts stdout "No changes detected in $projectdir/src/doc tree" + } + } else { + #no previous completion-record for this target - must assume changed - no need to trigger checksumming + puts stdout "No existing record of doc build in .punkcheck. Assume it needs to be rebuilt." + } + + + $event destroy + $installer destroy + + cd $original_wd + } + proc validate {} { + set projectdir [punk::repo::find_project] + if {$projectdir eq ""} { + puts stderr "No current project dir - unable to check doc status" + return + } + if {![file exists $projectdir/src/doc]} { + set result "No documentation source found. Expected .man files in doctools format at $projectdir/src/doc" + return $result + } + set original_wd [pwd] + cd $projectdir/src + + punk::mix::cli::lib::kettle_call lib validate-doc + + cd $original_wd + } + + namespace eval collection { + variable pkg + set pkg punk::mix::commandset::doc + + namespace export * + namespace path [namespace parent] + + } + + namespace eval lib { + variable pkg + set pkg punk::mix::commandset::doc + + } +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::commandset::doc [namespace eval punk::mix::commandset::doc { + variable pkg punk::mix::commandset::doc + variable version + set version 0.1.0 +}] +return \ No newline at end of file diff --git a/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm new file mode 100644 index 00000000..1ca4cc14 --- /dev/null +++ b/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm @@ -0,0 +1,185 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application punk::mix::commandset::layout 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + +#sort of a circular dependency when commandset loaded by punk::mix::cli - that's ok, but this could theoretically be loaded by another cli and with another base +package require punk::mix +package require punk::mix::base + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::mix::commandset::layout { + namespace export * + + #per layout functions + proc files {layout} { + set allfiles [lib::layout_all_files $layout] + return [join $allfiles \n] + } + proc templatefiles {layout} { + set templatefiles [lib::layout_scan_for_template_files $layout] + return [join $templatefiles \n] + } + proc templatefiles.relative {layout} { + set template_base_dict [punk::mix::base::lib::get_template_basefolders] + + set bases_containing_layout [list] + dict for {tbase folderinfo} $template_base_dict { + if {[file exists $tbase/layouts/$layout]} { + lappend bases_containing_layout $tbase + } + } + if {![llength $bases_containing_layout]} { + puts stderr "Unable to locate folder for layout '$layout'" + puts stderr "searched [dict size $template_base_dict] template folders" + return + } + set tpldir [lindex $bases_containing_layout end] + + set layout_base $tpldir/layouts + set layout_dir [file join $layout_base $layout] + + set stripprefix [file normalize $layout_dir] + set templatefiles [lib::layout_scan_for_template_files $layout] + set tails [list] + foreach templatefullpath $templatefiles { + lappend tails [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] + } + return [join $tails \n] + } + + #layout collection functions - to be imported with punk::overlay::import_commandset separately + namespace eval collection { + namespace export * + proc _default {{glob {}}} { + if {![string length $glob]} { + set glob * + } + set layouts [list] + #set tplfolderdict [punk::cap::templates::folders] + set tplfolderdict [punk::mix::base::lib::get_template_basefolders] + dict for {tdir folderinfo} $tplfolderdict { + set layout_base $tdir/layouts + #collect all layouts and use lsearch glob rather than the filesystem glob (avoid issues with dotted folder names) + set all_layouts [lsort [glob -nocomplain -dir $layout_base -type d -tail *]] + foreach match [lsearch -all -inline $all_layouts $glob] { + lappend layouts [list $match $folderinfo] + } + } + return [join [lsort -index 0 $layouts] \n] + } + + } + namespace eval lib { + proc layout_all_files {layout} { + set tplbasedict [punk::mix::base::lib::get_template_basefolders] + set layouts_found [list] + dict for {tplbase folderinfo} $tplbasedict { + if {[file isdirectory $tplbase/layouts/$layout]} { + lappend layouts_found $tplbase/layouts/$layout + } + } + if {![llength $layouts_found]} { + puts stderr "layout '$layout' not found." + puts stderr "searched [dict size $tplbasedict] template folders" + dict for {tplbase pkg} $tplbasedict { + puts stderr " - $tplbase $pkg" + } + return + } + set layoutfolder [lindex $layouts_found end] + + if {![file isdirectory $layoutfolder]} { + puts stderr "layout '$layout' not found in /layouts within one of template_folders. (get_template_folder returned: $tplbasedict)" + } + set file_list [list] + util::foreach-file $layoutfolder path { + lappend file_list $path + } + + return $file_list + } + + # + #todo - allow specifying which package the layout is from: e.g "punk::mix::templates project" ?? + proc layout_scan_for_template_files {layout {tags {}}} { + #equivalent for projects? punk::mix::commandset::module::lib::templates_dict -scriptpath "" + set tplbasedict [punk::mix::base::lib::get_template_basefolders] + set layouts_found [list] + dict for {tpldir pkg} $tplbasedict { + if {[file isdirectory $tpldir/layouts/$layout]} { + lappend layouts_found $tpldir/layouts/$layout + } + } + if {![llength $layouts_found]} { + puts stderr "layout '$layout' not found." + puts stderr "searched [dict size $tplbasedict] template folders" + dict for {tpldir pkg} $tplbasedict { + puts stderr " - $tpldir $pkg" + } + return + } + set layoutfolder [lindex $layouts_found end] + + #use last matching layout found. review silent if multiple? + if {![llength $tags]} { + #todo - get standard tags from somewhere + set tags [list %project%] + } + set file_list [list] + util::foreach-file $layoutfolder path { + set fd [open $path r] + fconfigure $fd -translation binary + set data [read $fd] + close $fd + foreach tag $tags { + if {[string match "*$tag*" $data]} { + lappend file_list $path + } + } + } + + return $file_list + } + } + + +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::commandset::layout [namespace eval punk::mix::commandset::layout { + variable version + set version 0.1.0 +}] +return diff --git a/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm new file mode 100644 index 00000000..0028c439 --- /dev/null +++ b/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm @@ -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 -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application punk::mix::commandset::loadedlib 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz +package require punk::ns + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::mix::commandset::loadedlib { + namespace export * + #search automatically wrapped in * * - can contain inner * ? globs + proc search {searchstring} { + catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything + if {[catch {package require natsort}]} { + set has_natsort 0 + } else { + set has_natsort 1 + } + if {[regexp {[?*]} $searchstring]} { + #caller has specified specific glob pattern - use it + #todo - respect supplied case only if uppers present? require another flag? + set matches [lsearch -all -inline -nocase [package names] $searchstring] + } else { + #make it easy to search for anything + set matches [lsearch -all -inline -nocase [package names] "*$searchstring*"] + } + + set matchinfo [list] + foreach m $matches { + set versions [package versions $m] + if {$has_natsort} { + set versions [natsort::sort $versions] + } else { + set versions [lsort $versions] + } + lappend matchinfo [list $m $versions] + } + return [join [lsort $matchinfo] \n] + } + proc loaded.search {searchstring} { + set search_result [search $searchstring] + set all_libs [split $search_result \n] + set col1items [list] + set col2items [list] + set col3items [list] + foreach libinfo $all_libs { + if {[string trim $libinfo] eq ""} { + continue + } + set versions [lassign $libinfo libname] + if {[set ver [package provide $libname]] ne ""} { + lappend col1items $libname + lappend col2items $versions + lappend col3items $ver + } + } + + package require overtype + set title1 "Library" + set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1items] {string length $v}]] + set col1 [string repeat " " $widest1] + set title2 "Versions Avail." + set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {string length $v}]] + set col2 [string repeat " " $widest2] + set title3 "Loaded Version" + set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {string length $v}]] + set col3 [string repeat " " $widest3] + + + set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3}] + + set table "" + append table [string repeat - $tablewidth] \n + append table "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]" \n + append table [string repeat - $tablewidth] \n + foreach c1 $col1items c2 $col2items c3 $col3items { + append table "[overtype::left $col1 $c1] [overtype::left $col2 $c2] [overtype::left $col3 $c3]" \n + } + + return $table + + + set loaded_libs [list] + foreach libinfo $all_libs { + if {[string trim $libinfo] eq ""} { + continue + } + set versions [lassign $libinfo libname] + if {[set ver [package provide $libname]] ne ""} { + lappend loaded_libs "$libname $versions (loaded $ver)" + } + } + return [join $loaded_libs \n] + } + + proc info {libname} { + if {[catch {package require natsort}]} { + set has_natsort 0 + } else { + set has_natsort 1 + } + catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything + set pkgsknown [package names] + if {[set posn [lsearch $pkgsknown $libname]] >= 0} { + puts stdout "Found package [lindex $pkgsknown $posn]" + } else { + puts stderr "Package not found as available library/module - check tcl::tm::list and \$auto_path" + } + set versions [package versions [lindex $libname 0]] + if {$has_natsort} { + set versions [natsort::sort $versions] + } else { + set versions [lsort $versions] + } + if {![llength $versions]} { + puts stderr "No version numbers found for library/module $libname" + return false + } + puts stdout "Versions of $libname found: $versions" + set alphaposn [lsearch $versions "999999.*"] + if {$alphaposn >= 0} { + set alpha [lindex $versions $alphaposn] + #remove and tack onto beginning.. + set versions [lreplace $versions $alphaposn $alphaposn] + set versions [list $alpha {*}$versions] + } + foreach ver $versions { + set loadinfo [package ifneeded $libname $ver] + puts stdout "$libname $ver" + puts stdout "--- 'package ifneeded' script ---" + puts stdout $loadinfo + puts stdout "---" + } + return + } + + proc copyasmodule {library modulefoldername args} { + set defaults [list -askme 1] + set opts [dict merge $defaults $args] + set opt_askme [dict get $opts -askme] + + if {[catch {package require natsort}]} { + set has_natsort 0 + } else { + set has_natsort 1 + } + + catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything + + if {[file pathtype $modulefoldername] eq "absolute"} { + if {![file exists $modulefoldername]} { + error "Path '$modulefoldername' not found. Enter a fully qualified path, or just the tail such as 'modules' if you are within the project to use /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 ; more stuff" from "package require 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 + 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 + #or package require ??... + set lib_diversion_name [lindex $line1 2] + #check not an exact match - but is a -nocase match - i.e differs in case only + if {($lib_diversion_name ne $libfound) && [string match -nocase $lib_diversion_name $libfound]} { + set requiredversions [lrange $line1 3 end] + if {$ver in $requiredversions} { + set is_package_require_self_recased 1 + } + } + } + } + } + } + + if {$is_package_require_self_recased && [string length $lib_diversion_name]} { + #we only follow one level of package require redirection - seems unlikely/imprudent to follow arbitrarily in a while loop(?) + set libfound $lib_diversion_name + set loadinfo [package ifneeded $libfound $ver] + set loadinfo [string map [list \r\n \n] $loadinfo] + set loadinfo_lines [split $loadinfo \n] + if {[catch {llength $loadinfo}]} { + set loadinfo_is_listshaped 0 + } else { + set loadinfo_is_listshaped 1 + } + + + } else { + if {$is_package_require_diversion} { + #single + #for now - we'll abort and tell the user to run again with specified pkg/version + #We could automate - but it seems likely to be surprising. + puts stderr "Loadinfo for $libfound seems to be diverting to another pkg/version: $loadinfo_lines" + puts stderr "Review and consider trying with the pkg/version described in the result above." + return + } + } + + + if {$loadinfo_is_listshaped && ([llength $loadinfo] == 2 && [lindex $loadinfo 0] eq "source")} { + set source_file [lindex $loadinfo 1] + } elseif {[string match "*source*" $loadinfo]} { + set parts [list] + foreach ln $loadinfo_lines { + if {![string length $ln]} {continue} + lappend parts {*}[split $ln ";"] + } + set sources_found [list] + set loads_found [list] + set dependencies [list] + set incomplete_lines [list] + foreach p $parts { + set p [string trim $p] + if {![string length $p]} { + continue ;#empty line or trailing colon + } + if {[string match "*tclPkgSetup*" $p]} { + puts stderr "Unable to process load script for library $libfound" + puts stderr "The library appears to use the deprecated tcl library support utility 'tclPkgSetup'" + return false + } + if {![::info complete $p]} { + # + #probably a perfectly valid script - but slightly more complicated than we can handle + #better to defer to manual processing + lappend incomplete_lines $p + continue + } + if {[lindex $p 0] eq "source"} { + #may have args.. e.g -encoding utf-8 + lappend sources_found [lindex $p end] + } + if {[lindex $p 0] eq "load"} { + lappend loads_found [lrange $p 1 end] + } + if {[lrange $p 0 1] eq "package require"} { + lappend dependencies [lrange $p 2 end] + } + } + if {[llength $incomplete_lines]} { + puts stderr "unable to interpret load script for library $libfound" + puts stderr "Load info: $loadinfo" + return false + } + if {[llength $loads_found]} { + puts stderr "package $libfound appears to have binary components" + foreach l $loads_found { + puts stderr " binary - $l" + } + foreach s $sources_found { + puts stderr " script - $s" + } + puts stderr "Unable to automatically copy binary libraries to your module folder." + return false + } + + if {[llength $sources_found] != 1} { + puts stderr "sorry - unable to interpret source library location" + puts stderr "Only 1 source supported for now" + puts stderr "Load info: $loadinfo" + return false + } + if {[llength $dependencies]} { + #todo - check/ignore if dependency is Tcl ? + puts stderr "WARNING the package appears to depend on at least one other. Review and copy dependencies if required." + foreach d $dependencies { + puts stderr " - $d" + } + } + + set source_file [lindex $sources_found 0] + } else { + puts stderr "sorry - unable to interpret source library location" + puts stderr "Load info: $loadinfo" + return false + } + + # -- --------------------------------------- + #Analyse source file + if {![file exists $source_file]} { + error "Unable to verify source file existence at: $source_file" + } + set source_data [fcat $source_file -translation binary] + if {![string match "*package provide*" $source_data]} { + puts stderr "Sorry - unable to verify source file contains 'package provide' statement of some sort - copy manually" + return false + } else { + if {![string match "*$libfound*" $source_data]} { + # as an exception - look for the specific 'package provide $pkg $version' as occurs in the auto-name auto-version modules + #e.g anyname-0.1.tm example + if {![string match "*package provide \$pkg \$version*" $source_data]} { + puts stderr "Sorry - unable to verify source file contains 'package provide' and '$libfound' - copy manually" + return false + } + } + } + + + if {[string match "*lappend ::auto_path*" $source_data] || [string match "*lappend auto_path*" $source_data] || [string match "*set ::auto_path*" $source_data]} { + puts stderr "Sorry - '$libfound' source file '$source_file' appears to rely on ::auto_path and can't be automatically copied as a .tm module" + puts stderr "Copy the library across to a lib folder instead" + return false + } + # -- --------------------------------------- + + set moduleprefix [punk::ns::nsprefix $libfound] + if {[string length $moduleprefix]} { + set moduleprefix_parts [punk::ns::nsparts $moduleprefix] + set relative_path [file join {*}$moduleprefix_parts] + } else { + set relative_path "" + } + set pkgtail [punk::ns::nstail $libfound] + set target_path [file join $modulefolder_path $relative_path ${pkgtail}-${ver}.tm] + + if {$opt_askme} { + puts stdout "WARNING - you should check that there aren't extra required files for the library/modules" + puts stdout "" + puts stdout "This is not intended for binary modules - use at own risk and check results" + puts stdout "" + puts stdout "Base module path: $modulefolder_path" + puts stdout "Target path : $target_path" + puts stdout "results of 'package ifneeded $libfound'" + puts stdout "---" + puts stdout "$loadinfo" + puts stdout "---" + puts stdout "Proceed to create ${pkgtail}-${ver}.tm module? Y|N" + set stdin_state [fconfigure stdin] + fconfigure stdin -blocking 1 + set answer [string tolower [gets stdin]] + fconfigure stdin -blocking [dict get $stdin_state -blocking] + if {$answer ne "y"} { + puts stderr "mix libcopy.asmodule aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." + return + } + } + + if {![file exists $modulefolder_path]} { + puts stdout "Creating module base folder at $modulefolder_path" + file mkdir $modulefolder_path + } + if {![file exists [file dirname $target_path]]} { + puts stdout "Creating relative folder at [file dirname $target_path]" + file mkdir [file dirname $target_path] + } + + if {[file exists $target_path]} { + puts stdout "WARNING - module already exists at $target_path" + if {$opt_askme} { + puts stdout "Copy anyway? Y|N" + set stdin_state [fconfigure stdin] + fconfigure stdin -blocking 1 + set answer [string tolower [gets stdin]] + fconfigure stdin -blocking [dict get $stdin_state -blocking] + if {$answer ne "y"} { + puts stderr "mix libcopy.asmodule aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." + return + } + } + } + + file copy -force $source_file $target_path + + return $target_path + } + + + +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::commandset::loadedlib [namespace eval punk::mix::commandset::loadedlib { + variable version + set version 0.1.0 +}] +return diff --git a/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm new file mode 100644 index 00000000..4c1994f1 --- /dev/null +++ b/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm @@ -0,0 +1,419 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application punk::mix::commandset::module 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::mix::commandset::module { + namespace export * + + proc paths {} { + set roots [punk::repo::find_repos ""] + set project [lindex [dict get $roots project] 0] + if {$project ne ""} { + set is_project 1 + set searchbase $project + } else { + set is_project 0 + set searchbase [pwd] + } + + if {[catch { + set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $searchbase] + } errMsg]} { + set source_module_folderlist [list] + } + + set tm_folders [tcl::tm::list] + package require overtype + + set result "" + if {$is_project} { + append result "Project module source paths:" \n + foreach f $source_module_folderlist { + append result "$f" \n + } + } + append result \n + append result "tcl::tm::list" \n + foreach f $tm_folders { + if {$is_project} { + if {[punk::mix::cli::lib::path_a_aboveorat_b $project $f]} { + set pinfo "(within project)" + } else { + set pinfo "" + } + } else { + set pinfo "" + } + set warning "" + if {![file isdirectory $f]} { + set warning "(PATH NOT FOUND)" + } + append result "$f $pinfo $warning" \n + } + + + return $result + } + #require current dir when calling to be the projectdir, or + proc templates {args} { + set tdict [templates_dict {*}$args] + + package require overtype + set paths [dict values $tdict] + set names [dict keys $tdict] + + set title1 "Path" + set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $paths] {punk::strlen $v}]] + set col1 [string repeat " " $widest1] + + set title2 "Template Name" + set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $names] {punk::strlen $v}]] + set col2 [string repeat " " $widest2] + + set tablewidth [expr {$widest1 + 1 + $widest2}] + set table "" + append table [string repeat - $tablewidth] \n + append table "[overtype::left $col1 $title1] [overtype::left $col2 $title2]" \n + append table [string repeat - $tablewidth] \n + + foreach p $paths n $names { + append table "[overtype::left $col1 $p] [overtype::left $col2 $n]" \n + } + + return $table + } + #return all module templates with repeated ones suffixed with .2 .3 etc + proc templates_dict {args} { + tailcall lib::templates_dict {*}$args + } + proc new {module args} { + set year [clock format [clock seconds] -format %Y] + set defaults [list\ + -project \uFFFF\ + -version \uFFFF\ + -license \ + -template module-0.0.1.tm\ + -type \uFFFF\ + -force 0\ + ] + set opts [dict merge $defaults $args] + + #todo - review compatibility between -template and -type + #-type is the wrapping technology e.g 'plain' for none or tarjar/zipkit etc (consider also snappy/snappy-tcl) + #-template may be a folder - but only if the selected -type suports it + + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # option -version + # we need this value before looking at the named argument + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_version_supplied [dict get $opts -version] + if {$opt_version_supplied eq "\uFFFF"} { + set opt_version "0.1.0" + } else { + set opt_version $opt_version_supplied + if {![util::is_valid_tm_version $opt_version]} { + error "pmix module.new error - supplied -version $opt_version doesn't appear to be a valid Tcl module version" + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #named argument + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set mversion_supplied "" ;#version supplied directly in module argument + if {[string first - $module]> 0} { + #if it has a dash then version is required to be valid + lassign [punk::mix::cli::lib::split_modulename_version $module] modulename mversion + if {![util::is_valid_tm_version $mversion]} { + error "pmix module.new error - unable to determine modulename-version from supplied value '$module'" + } + set mversion_supplied $mversion ;#record as may need to compare to version from templatefile name + set vcompare_is_mversion_bigger [package vcompare $mversion $opt_version] + if {$vcompare_is_mversion_bigger > 0} { + set opt_version $mversion; #module parameter has higher value than -version + set vmsg "from module argument: $module" + } else { + set vmsg "from -version option: $opt_version_supplied" + } + if {$opt_version_supplied ne "\uFFFF"} { + if {$vcompare_is_mversion_bigger != 0} { + #is bigger or smaller + puts stderr "module.new WARNING: version supplied in module argument as well as -version option. Using the higher version number $vmsg" + } + } + } else { + set modulename $module + } + punk::mix::cli::lib::validate_modulename $modulename -name_description "mix module.new name" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #options + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_project [dict get $opts -project] + set testdir [pwd] + if {![string length [set projectdir [punk::repo::find_project $testdir]]]} { + if {![string length [set projectdir [punk::repo::find_candidate $testdir]]]} { + set msg [punkc::repo::is_candidate_root_requirements_msg] + error "module.new unable to create module in projectdir:$projectdir - directory doesn't appear to meet basic standards $msg" + } + } + if {$opt_project == "\uFFFF"} { + set projectname [file tail $projectdir] + } else { + set projectname $opt_project + if {$projectname ne [file tail $projectdir]} { + error "module.new -project '$opt_project' doesn't match detected projectname '$projectname' at path: $projectdir" + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_license [dict get $opts -license] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_template [dict get $opts -template] + + set templates_dict [templates_dict] ;#possibly suffixed with .2 .3 etc + #todo - allow versionless name - pick latest which isn't suffixed with .2 etc + if {![dict exists $templates_dict $opt_template]} { + error "module.new unable to find template '$opt_template'. Known templates: [dict keys $templates_dict]" + } + set templatefile [dict get $templates_dict $opt_template] + set tpldir [file dirname $templatefile] ;#use same folder for modulename_buildversion.txt, modulename_description.txt if they exist + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_type [dict get $opts -type] + if {$opt_type eq "\uFFFF"} { + set opt_type [lindex [punk::mix::cli::lib::module_types] 0] ;#default to plain + } + if {$opt_type ni [punk::mix::cli::lib::module_types]} { + error "module.new - error - unknown -type '$opt_type' known-types: [punk::mix::cli::lib::module_types]" + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + + + + + set subpath [punk::mix::cli::lib::module_subpath $modulename] ;#commonly empty string for simple modulename e.g "mymodule" but x::mymodule has subpath 'x' and x::y::mymodule has subpath 'x/y' + if {![string length $subpath]} { + set modulefolder $projectdir/src/modules + } else { + set modulefolder $projectdir/src/modules/$subpath + } + file mkdir $modulefolder + + set moduletail [namespace tail $modulename] + set magicversion [punk::mix::util::magic_tm_version] ;#deliberately large so given load-preference when testing + + + + + set template_tail [file tail $templatefile] ;#convert template_xxx-version.tm.x to {xxx version} + set template_tail [string range $template_tail [string length template_] end] + set ext [string tolower [file extension $template_tail]] + if {$ext eq ".tm"} { + set template_modulename_part [file rootname $template_tail] + } elseif {[string is integer -strict [string range $ext 1 end]]} { + #something like modulename-0.0.1.tm.2 + #strip of last 2 dotted parts + set shortened [file rootname $template_tail] + if {![string equal -nocase [file extension $shortened] ".tm"]} { + error "module.new error: Unable to interpret filename components of template file '$templatefile' (expected .tm as second-last or last component)" + } + set template_modulename_part [file rootname $shortened] + } else { + error "module.new error: Unable to interpret filename components of template file '$templatefile'" + } + lassign [punk::mix::cli::lib::split_modulename_version $template_modulename_part] t_mname t_version + #t_version may be empty string if template is unversioned e.g template_whatever.tm + + set fd [open $templatefile r]; set template_filedata [read $fd]; close $fd + if {[string match "*$magicversion*" $template_filedata]} { + set use_magic 1 + set build_version $opt_version + set infile_version $magicversion + } else { + set use_magic 0 + if {$opt_version_supplied ne "\uFFFF"} { + set build_version $opt_version + } else { + if {[util::is_valid_tm_version $t_version]} { + if {$mversion_supplied eq ""} { + set build_version $t_version + } else { + #we have a version from the named argument 'module' + if {[package vcompare $mversion_supplied $t_version] > 0} { + set build_version $mversion_supplied + } else { + set build_version $t_version + } + } + } else { + #probably an unversioned module template + #use opt_version default from above + set build_version $opt_version + } + } + set infile_version $build_version + } + + set template_filedata [string map [list %pkg% $modulename %year% $year %license% $opt_license %version% $infile_version] $template_filedata] + + set modulefile $modulefolder/${moduletail}-$infile_version.tm + if {[file exists $modulefile]} { + set errmsg "module.new error: module file $modulefile already exists - aborting" + if {[string match "*$magicversion*" $modulefile]} { + append errmsg \n "If you are attempting to create a module file with a specific version in the source-file name - you will need to use a template that doesn't contain the string '$magicversion' e.g the provided template moduleexactversion-0.0.1.tm" + } + error $errmsg + } + + + if {[file exists $tpldir/modulename_buildversion.txt]} { + set fd [open $tpldir/modulename_buildversion.txt r]; set buildversion_filedata [read $fd]; close $fd + } else { + #mix_templates_dir warns of deprecation - review + set lib_tpldir [file join [punk::mix::cli::lib::mix_templates_dir] modules];#fallback for modulename_buildversion.txt, modulename_description.txt + set fd [open $lib_tpldir/modulename_buildversion.txt r]; set buildversion_filedata [read $fd]; close $fd + } + set buildversionfile [file join $modulefolder ${moduletail}-buildversion.txt] + set existing_build_version "" + if {[file exists $buildversionfile]} { + set buildversiondata [punk::mix::util::fcat $buildversionfile] + set lines [split $buildversiondata \n] + set existing_build_version [string trim [lindex $lines 0]] + if {[package vcompare $existing_build_version $build_version] >= 0} { + #existing version in -buildversion.txt file is lower than the module version we are creating + error "module.new error: there is an existing buildversion file $buildversionfile with version $existing_build_version equal to or higher than $build_version - unable to continue" + } + } + + set existing_versions [glob -nocomplain -dir $modulefolder -tails ${moduletail}-*.tm] + #it shouldn't be possible to overmatch with the glob - because '-' is not valid in a Tcl module name + if {[llength $existing_versions]} { + set name_version_pairs [list] + lappend name_version_pairs [list $moduletail $infile_version] + foreach existing $existing_versions { + lappend name_version_pairs [punk::mix::cli::lib::split_modulename_version $existing] ;# .tm is stripped and ignored + } + set name_version_pairs [lsort -command {package vcompare} -index 1 $name_version_pairs] ;#while plain lsort will often work with versions - it can get order wrong with some - so use package vcompare + if {[lindex $name_version_pairs end] ne [list $moduletail $infile_version]} { + set thisposn [lsearch -index 1 $name_version_pairs $infile_version] + set name_version_pairs [lreplace $name_version_pairs $thisposn $thisposn] + set other_versions [lsearch -all -inline -index 1 -subindices $name_version_pairs *] + set errmsg "module.new error: There are existing modules in the target folder with higher versions than $infile_version." + append errmsg \n "Other versions found: $other_versions" + if {$magicversion in $other_versions} { + append errmsg \n "Existing build version for special source file name: '$magicversion' is: '$existing_build_version'" + append errmsg \n "If '$magicversion' file doesn't represent the latest source it should be removed or the filename and contents adjusted to be a specific version" + } + error $errmsg + } else { + puts stderr "module.new WARNING: There are existing modules in the target folder with lower versions than $infile_version - manual review recommended" + puts stderr "Other versions found: [lsearch -all -inline -index 1 -subindices [lrange $name_version_pairs 0 end-1] *]" + } + } + + + set fd [open $modulefile w] + fconfigure $fd -translation binary + puts -nonewline $fd $template_filedata + close $fd + + + set buildversion_filedata [string map [list %Major.Minor.Level% $build_version] $buildversion_filedata] + set fd [open $buildversionfile w] + fconfigure $fd -translation binary + puts -nonewline $fd $buildversion_filedata + close $fd + + return [list file $modulefile version $build_version] + } + + namespace eval lib { + proc templates_dict {args} { + set defaults [list -scriptpath ""] + set opts [dict merge $defaults $args] + set opt_scriptpath [dict get $opts -scriptpath] + + set module_template_bases [list] + set tbasedict [punk::mix::base::lib::get_template_basefolders $opt_scriptpath] + dict for {tbase folderinfo} $tbasedict { + lappend module_template_bases [file join $tbase modules] + } + + + + set template_files [list] + foreach basefld $module_template_bases { + set matched_files [glob -nocomplain -dir $basefld -type f template_*] + foreach tf $matched_files { + if {[string match ignore* $tf]} { + continue + } + set ext [file extension $tf] + if {$ext in [list ".tm"]} { + lappend template_files $tf + } + } + } + + set tdict [dict create] + set seen_dict [dict create] + foreach fullpath $template_files { + set ftail [file tail $fullpath] + set tname [string range $ftail [string length template_] end] + if {![dict exists $seen_dict $tname]} { + dict set seen_dict $tname 1 + dict set tdict $tname $fullpath ; #first seen of filename gets no number + } else { + set n [dict get $seen_dict $tname] + incr n + dict incr seen_dict $tname + dict set tdict ${tname}.$n $fullpath + } + } + return $tdict + } + } + + + +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::commandset::module [namespace eval punk::mix::commandset::module { + variable version + set version 0.1.0 +}] +return diff --git a/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm new file mode 100644 index 00000000..d7150abc --- /dev/null +++ b/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm @@ -0,0 +1,849 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application punk::mix::commandset::project 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::mix::commandset::project { + namespace export * + + #new project structure - may be dedicated to one module, or contain many. + #create minimal folder structure only by specifying -modules {} + proc new {newprojectpath_or_name args} { + if {[file pathtype $newprojectpath_or_name] eq "absolute"} { + set projectfullpath [file normalize $newprojectpath_or_name] + set projectname [file tail $projectfullpath] + set projectparentdir [file dirname $newprojectpath_or_name] + } else { + set projectfullpath [file join [pwd] $newprojectpath_or_name] + set projectname [file tail $projectfullpath] + set projectparentdir [file dirname $projectfullpath] + } + if {[file type $projectparentdir] ne "directory"} { + error "punk::mix::cli::new error: unable to determine containing folder for '$newprojectpath_or_name'" + } + + punk::mix::cli::lib::validate_projectname $projectname -name_description "punk mix project.new" + + + set defaults [list\ + -type plain\ + -empty 0\ + -force 0\ + -update 0\ + -confirm 1\ + -modules \uFFFF\ + -layout project + ] ;#todo + set known_opts [dict keys $defaults] + foreach {k v} $args { + if {$k ni $known_opts} { + error "project.new error: option '$k' not known. Known options: $known_opts" + } + } + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_type [dict get $opts -type] + if {$opt_type ni [punk::mix::cli::lib::module_types]} { + error "pmix new error - unknown type '$opt_type' known types: [punk::mix::cli::lib::module_types]" + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_force [dict get $opts -force] + set opt_confirm [string tolower [dict get $opts -confirm]] + # -- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_modules [dict get $opts -modules] + if {[llength $opt_modules] == 1 && [lindex $opt_modules 0] eq "\uFFFF"} { + #if not specified - add a single module matching project name + set opt_modules [list $projectname] + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_layout [dict get $opts -layout] + set opt_update [dict get $opts -update] + # -- --- --- --- --- --- --- --- --- --- --- --- --- + + + set fossil_prog [auto_execok fossil] + if {![string length $fossil_prog]} { + puts stderr "The fossil program was not found. A fossil executable is required to use most pmix features." + if {[string length [set scoop_prog [auto_execok scoop]]]} { + #restrict to windows? + set answer [util::askuser "scoop detected. Would you like pmix to install fossil now using scoop? Y|N"] + if {[string tolower $answer] ne "y"} { + puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." + return + } + #we don't assume 'unknown' is configured to run shell commands + if {[string length [package provide shellrun]]} { + set exitinfo [run {*}$scoop_prog install fossil] + #scoop tends to return successful exitcode (0) even when packages not found etc. - so exitinfo not much use. + puts stdout "scoop install fossil ran with result: $exitinfo" + } else { + puts stdout "Please wait while scoop runs - there may be a slight delay and then scoop output will be shown. (use punk shellrun package for )" + set result [exec {*}$scoop_prog install fossil] + puts stdout $result + } + catch {::auto_reset} ;#can be missing (unsure under what circumstances - but I've seen it raise error 'invalid command name "auto_reset"') + if {![string length [auto_execok fossil]]} { + puts stderr "Fossil still not detected. If it was successfully installed, try restarting your punk/tcl shell." + return + } + #todo - ask user if they want to configure fosssil first.. + set answer [util::askuser "Fossil command now appears to be available. You may wish to answer N to exit and customize it - but default config may be ok. Type the word 'continue' to proceed with default configuration."] + if {[string tolower $answer] ne "continue"} { + return + } + + } else { + puts stdout "See: https://fossil-scm.org/home/uv/download.html" + if {"windows" eq $::tcl_platform(platform)} { + puts stdout "Consider using a package manager such as scoop: https://scoop.sh" + puts stdout "(Then: scoop install fossil)" + } + return + } + } + set startdir [pwd] + if {[set in_project [punk::repo::find_project $startdir]] ne ""} { + # use this project as source of templates + puts stdout "-------------------------------------------" + puts stdout "Currently in a project directory '$in_project'" + puts stdout "This project will be searched for templates" + puts stdout "-------------------------------------------" + } + set template_base_dict [punk::mix::base::lib::get_template_basefolders] + set template_bases_containing_layout [list] + dict for {tbase folderinfo} $template_base_dict { + if {[file exists $tbase/layouts/$opt_layout]} { + lappend template_bases_containing_layout $tbase + } + } + if {![llength $template_bases_containing_layout]} { + puts stderr "layout '$opt_layout' was not found in template dirs" + puts stderr "searched [dict size $template_base_dict] template folders" + dict for {tbase folderinfo} $template_base_dict { + puts stderr " - $tbase $folderinfo" + } + return + } + #review: silently use last entry which had the layout (?) + set templatebase [lindex $template_bases_containing_layout end] + + + + #todo - detect whether inside cwd-project or inside a different project + set projectdir $projectparentdir/$projectname + if {[set target_in_project [punk::repo::find_project $projectparentdir]] ne ""} { + puts stderr "Target location for new project is already within a project: $target_in_project" + error "Nested projects not yet supported aborting" + } + + + + if {[punk::repo::is_git $projectparentdir]} { + puts stderr "mix new WARNING: target project location is within a git repo based at [punk::repo::find_git $projectparentdir]" + puts stderr "The new project will create a fossil repository (which you are free to ignore - but but will be used to confirm project base)" + puts stderr "If you intend to use both git and fossil in the same project space - you should research and understand the details and any possible interactions/issues" + set answer [util::askuser "Do you want to proceed to create a project based at: $projectdir? Y|N"] + if {[string tolower $answer] ne "y"} { + puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." + return + } + } + set is_nested_fossil 0 ;#default assumption + if {[punk::repo::is_fossil $projectparentdir]} { + puts stderr "mix new WARNING: target project location is within an open fossil repo based at [punk::repo::find_fossil $projectparentdir] NESTED fossil repository" + if {$opt_confirm ni [list 0 no false]} { + puts stderr "If you proceed - the new project's fossil repo will be created using the --nested flag" + set answer [util::askuser "Do you want to proceed to create a NESTED project based at: $projectdir? Y|N"] + if {[string tolower $answer] ne "y"} { + puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." + return + } + set is_nested_fossil 1 + } + } + + + set project_dir_exists [file exists $projectdir] + if {$project_dir_exists && !($opt_force || $opt_update)} { + puts stderr "Unable to create new project at $projectdir - file/folder already exists use -update 1 to fill in missing items from template use -force 1 to overwrite from template" + return + } elseif {$project_dir_exists && $opt_force} { + puts stderr "mix new WARNING: -force 1 was supplied. Will copy layout $templatebase/layouts/$opt_layout using -force option to overwrite from template" + if {$opt_confirm ni [list 0 no false]} { + set answer [util::askuser "Do you want to proceed to possibly overwrite existing files in $projectdir? Y|N"] + if {[string tolower $answer] ne "y"} { + puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." + return + } + } + } elseif {$project_dir_exists && $opt_update} { + puts stderr "mix new WARNING: -update 1 was supplied. Will copy layout $templatebase/layouts/$opt_layout using -update option to add missing items" + } + + set fossil_repo_file "" + set is_fossil_root 0 + if {$project_dir_exists && [punk::repo::is_fossil_root $projectdir]} { + set is_fossil_root 1 + set fossil_repo_file [punk::repo::fossil_get_repository_file $projectdir] + if {$fossil_repo_file ne ""} { + set repodb_folder [file dirname $fossil_repo_file] + } + } + + if {$fossil_repo_file eq ""} { + set repodb_folder [punk::repo::fossil_get_repository_folder_for_project $projectname -parentfolder $startdir] + if {![string length $repodb_folder]} { + puts stderr "No usable repository database folder selected for $projectname.fossil file" + return + } + } + if {[file exists $repodb_folder/$projectname.fossil]} { + puts stdout "NOTICE: $repodb_folder/$projectname.fossil already exists" + if {!($opt_force || $opt_update)} { + puts stderr "-force 1 or -update 1 not specified - aborting" + return + } + } + + if {$fossil_repo_file eq ""} { + puts stdout "Initialising fossil repo: $repodb_folder/$projectname.fossil" + set fossilinit [runx -n {*}$fossil_prog init $repodb_folder/$projectname.fossil -project-name $projectname] + if {[dict get $fossilinit exitcode] != 0} { + puts stderr "fossil init failed:" + puts stderr [dict get $fossilinit stderr] + return + } else { + puts stdout "fossil init result:" + puts stdout [dict get $fossilinit stdout] + } + } + + file mkdir $projectdir + + set layout_dir $templatebase/layouts/$opt_layout + puts stdout ">>> about to call punkcheck::install $layout_dir $projectdir" + set resultdict [dict create] + set unpublish [list\ + src/doc/*\ + src/doc/include/*\ + ] + + #default antiglob_dir_core will stop .fossil* from being updated - which is generally desirable as these are likely to be customized + if {$opt_force} { + puts stdout "copying layout files - with force applied - overwrite all-targets" + set resultdict [punkcheck::install $layout_dir $projectdir -installer project.new -overwrite ALL-TARGETS -unpublish_paths $unpublish] + #file copy -force $layout_dir $projectdir + } else { + puts stdout "copying layout files - (if source file changed)" + set resultdict [punkcheck::install $layout_dir $projectdir -installer project.new -overwrite installedsourcechanged-targets -unpublish_paths $unpublish] + } + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + + puts stdout "copying layout src/doc files (if target missing)" + set resultdict [punkcheck::install $layout_dir/src/doc $projectdir/src/doc -punkcheck_folder $projectdir -installer project.new -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + + #target folders .fossil-custom and .fossil-settings may not exist. use -createdir 1 to ensure existence. + #In this case we need to override the default dir antiglob - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized. + ## default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"] + set override_antiglob_dir_core [list #* _aside .git] + puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)" + set resultdict [punkcheck::install $layout_dir/.fossil-custom $projectdir/.fossil-custom -createdir 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + + puts stdout "copying layout src/.fossil-settings files (if target missing or uncustomised)" + set resultdict [punkcheck::install $layout_dir/.fossil-settings $projectdir/.fossil-settings -createdir 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + + + + + #lappend substfiles $projectdir/README.md + #lappend substfiles $projectdir/src/README.md + #lappend substfiles $projectdir/src/doc/main.man + #expect this in all templates? - todo make these substitutions independent of specific paths and filenames? + #scan all files in template + # + #TODO - pmix command to substitute templates? + set templatefiles [punk::mix::commandset::layout::lib::layout_scan_for_template_files $opt_layout] + set stripprefix [file normalize $layout_dir] + + foreach templatefullpath $templatefiles { + set templatetail [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] + + set fpath [file join $projectdir $templatetail] + if {[file exists $fpath]} { + set fd [open $fpath r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd + set data2 [string map [list %project% $projectname] $data] + if {$data2 ne $data} { + puts stdout "updated template file: $fpath" + set fdout [open $fpath w]; fconfigure $fdout -translation binary; puts -nonewline $fdout $data2; close $fdout + } + } else { + puts stderr "warning: Missing template file $fpath" + } + } + #todo - tag substitutions in src/doc tree + + + cd $projectdir + + if {[file exists $projectdir/src/modules]} { + foreach m $opt_modules { + if {![file exists $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm]} { + punk::mix::commandset::module::new $m -project $projectname -type $opt_type + } else { + if {$opt_force} { + punk::mix::commandset::module::new $m -project $projectname -type $opt_type -force 1 + } + } + } + } else { + puts stderr "project.new WARNING template hasn't created src/modules - skipping creation of new module(s) for project" + } + + #generate www/man/md output in 'embedded' folder which should be checked into repo for online documentation + if {[file exists $projectdir/src]} { + cd $projectdir/src + #---------- + set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] + $installer set_source_target $projectdir/src/doc $projectdir/src/embedded + set event [$installer start_event {-install_step kettledoc}] + $event targetset_init VIRTUAL kettle_build_doc ;#VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated + $event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source + #---------- + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + } { + $event targetset_started + # -- --- --- --- --- --- + puts stdout "BUILDING DOCS at src/embedded from src/doc" + if {[catch { + + punk::mix::cli::lib::kettle_call lib doc + #Kettle doc + + } errM]} { + $event targetset_end FAILED -note "kettle_build_doc failed: $errM" + } else { + $event targetset_end OK + } + # -- --- --- --- --- --- + } else { + puts stderr "No change detected in src/doc" + $event targetset_end SKIPPED + } + $event end + $event destroy + $installer destroy + } + + cd $projectdir + + if {![punk::repo::is_fossil_root $projectdir]} { + set first_fossil 1 + #-k = keep. (only modify the manifest file(s)) + if {$is_nested_fossil} { + set fossilopen [runx -n {*}$fossil_prog open --nested $repodb_folder/$projectname.fossil -k --workdir $projectdir] + } else { + set fossilopen [runx -n {*}$fossil_prog open $repodb_folder/$projectname.fossil -k --workdir $projectdir] + } + if {[file exists $projectdir/_FOSSIL_] && ![file exists $projectdir/.fslckout]} { + file rename $projectdir/_FOSSIL_ $projectdir/.fslckout + } + if {[dict get $fossilopen exitcode] != 0} { + puts stderr "fossil open in project workdir '$projectdir' FAILED:" + puts stderr [dict get $fossilopen stderr] + return + } else { + puts stdout "fossil open in project workdir '$projectdir' OK:" + puts stdout [dict get $fossilopen stdout] + } + } else { + set first_fossil 0 + } + set fossiladd [runx -n {*}$fossil_prog add --dotfiles $projectdir] + if {[dict get $fossiladd exitcode] != 0} { + puts stderr "fossil add workfiles in workdir '$projectdir' FAILED:" + puts stderr [dict get $fossiladd stderr] + return + } else { + puts stdout "fossil add workfiles in workdir '$projectdir' OK:" + puts stdout [dict get $fossiladd stdout] + } + if {$first_fossil} { + #fossil commit may prompt user for input.. runx runout etc will pause with no prompts + util::do_in_path $projectdir { + set fossilcommit [run -n {*}$fossil_prog commit -m "initial project commit"] + } + if {[dict get $fossilcommit exitcode] != 0} { + puts stderr "fossil commit in workdir '$projectdir' FAILED" + return + } else { + puts stdout "fossil commit in workdir '$projectdir' OK" + } + } + + puts stdout "-done- project:$projectname projectdir: $projectdir" + } + + + namespace eval collection { + namespace export * + namespace path [namespace parent] + + #e.g imported as 'projects' + proc _default {{glob {}} args} { + package require overtype + set db_projects [lib::get_projects $glob] + set col1items [lsearch -all -inline -index 0 -subindices $db_projects *] + set col2items [lsearch -all -inline -index 1 -subindices $db_projects *] + set checkouts [lsearch -all -inline -index 2 -subindices $db_projects *] + set col3items [lmap v $checkouts {llength $v}] + + set title1 "Fossil DB" + set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1items] {punk::strlen $v}]] + set col1 [string repeat " " $widest1] + set title2 "File Name" + set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {punk::strlen $v}]] + set col2 [string repeat " " $widest2] + set title3 "Checkouts" + set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {punk::strlen $v}]] + set col3 [string repeat " " $widest3] + set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3}] + + + append msg "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]" \n + append msg [string repeat "=" $tablewidth] \n + foreach p $col1items n $col2items c $col3items { + append msg "[overtype::left $col1 $p] [overtype::left $col2 $n] [overtype::right $col3 $c]" \n + } + return $msg + #return [list_as_lines [lib::get_projects $glob]] + } + proc detail {{glob {}} args} { + package require overtype + package require textutil + set defaults [dict create\ + -description 0\ + ] + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- + set opt_description [dict get $opts -description] + # -- --- --- --- --- --- --- + + + set db_projects [lib::get_projects $glob] + set col1_dbfiles [lsearch -all -inline -index 0 -subindices $db_projects *] + set col2items [lsearch -all -inline -index 1 -subindices $db_projects *] + set checkouts [lsearch -all -inline -index 2 -subindices $db_projects *] + set col3items [lmap v $checkouts {llength $v}] + + set col4_pnames [list] + set col5_pcodes [list] + set col6_dupids [list] + set col7_pdescs [list] + set codes [dict create] + foreach dbfile $col1_dbfiles { + set project_name "" + set project_code "" + set project_desc "" + sqlite3 dbp $dbfile + dbp eval {select name,value from config where name like 'project-%';} r { + if {$r(name) eq "project-name"} { + set project_name $r(value) + } elseif {$r(name) eq "project-code"} { + set project_code $r(value) + } elseif {$r(name) eq "project-description"} { + set project_desc $r(value) + } + } + dbp close + lappend col4_pnames $project_name + lappend col5_pcodes $project_code + dict lappend codes $project_code $dbfile + lappend col7_pdescs $project_desc + } + + set setid 1 + set codeset [dict create] + dict for {code dbs} $codes { + if {[llength $dbs]>1} { + dict set codeset $code setid $setid + dict set codeset $code count [llength $dbs] + dict set codeset $code seen 0 + incr setid + } + } + set dupid 1 + foreach pc $col5_pcodes { + if {[dict exists $codeset $pc]} { + set seen [dict get $codeset $pc seen] + set this_seen [expr {$seen + 1}] + dict set codeset $pc seen $this_seen + lappend col6_dupids "[dict get $codeset $pc setid].${this_seen}/[dict get $codeset $pc count]" + } else { + lappend col6_dupids "" + } + } + + set title1 "Fossil DB" + set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1_dbfiles] {punk::strlen $v}]] + set col1 [string repeat " " $widest1] + set title2 "File Name" + set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {punk::strlen $v}]] + set col2 [string repeat " " $widest2] + set title3 "Checkouts" + set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {punk::strlen $v}]] + set col3 [string repeat " " $widest3] + set title4 "Project Name" + set widest4 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col4_pnames] {punk::strlen $v}]] + set col4 [string repeat " " $widest4] + set title5 "Project Code" + set widest5 [tcl::mathfunc::max {*}[lmap v [concat [list $title5] $col5_pcodes] {punk::strlen $v}]] + set col5 [string repeat " " $widest5] + set title6 "Dup" + set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col6_dupids] {punk::strlen $v}]] + set col6 [string repeat " " $widest6] + set title7 "Description" + #set widest7 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col7_pdescs] {punk::strlen $v}]] + set widest7 35 + set col7 [string repeat " " $widest7] + + + set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3 +1 + $widest4 + 1 + $widest5 + 1 + $widest6}] + + append msg "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]\ + [overtype::left $col4 $title4] [overtype::left $col5 $title5] [overtype::left $col6 $title6]" + if {!$opt_description} { + append msg \n + } else { + append msg "[overtype::left $col7 $title7]" \n + set tablewidth [expr {$tablewidth + 1 + $widest7}] + } + + append msg [string repeat "=" $tablewidth] \n + foreach p $col1_dbfiles n $col2items c $col3items pn $col4_pnames pc $col5_pcodes dup $col6_dupids desc $col7_pdescs { + set desclines [split [textutil::adjust $desc -length $widest7] \n] + set desc1 [lindex $desclines 0] + append msg "[overtype::left $col1 $p] [overtype::left $col2 $n] [overtype::right $col3 $c]\ + [overtype::left $col4 $pn] [overtype::left $col5 $pc] [overtype::left $col6 $dup]" + if {!$opt_description} { + append msg \n + } else { + append msg " [overtype::left $col7 $desc1]" \n + foreach dline [lrange $desclines 1 end] { + append msg "$col1 $col2 $col3 $col4 $col5 $col6 [overtype::left $col7 $dline]" \n + } + } + } + return $msg + #return [list_as_lines [lib::get_projects $glob]] + } + proc cd {{glob {}} args} { + dict set args -cd 1 + work $glob {*}$args + } + proc work {{glob {}} args} { + package require sqlite3 + set db_projects [lib::get_projects $glob] + #list of lists of the form: + #{fosdb fname workdirlist} + set defaults [dict create\ + -cd 0\ + ] + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- + set opt_cd [dict get $opts -cd] + # -- --- --- --- --- --- --- + set workdir_dict [dict create] + set all_workdirs [list] + foreach pinfo $db_projects { + lassign $pinfo fosdb name workdirs + foreach wdir $workdirs { + dict set workdir_dict $wdir $pinfo + lappend all_workdirs $wdir + } + } + set col_rowids [list] + set workdirs [lsort -index 0 $all_workdirs] + set col_dupids [list] + set col_fnames [list] + set col_pnames [list] + set col_pcodes [list] + set col_dupids [list] + + set fosdb_count [dict create] + set fosdb_dupset [dict create] + set fosdb_cache [dict create] + set dupset 0 + set rowid 1 + foreach wd $workdirs { + set wdinfo [dict get $workdir_dict $wd] + lassign $wdinfo fosdb nm siblingworkdirs + dict incr fosdb_count $fosdb + set dbcount [dict get $fosdb_count $fosdb] + if {[llength $siblingworkdirs] > 1} { + if {![dict exists $fosdb_dupset $fosdb]} { + #first time this multi-checkout fosdb seen + dict set fosdb_dupset $fosdb [incr dupset] + } + set dupid "[dict get $fosdb_dupset $fosdb].$dbcount/[llength $siblingworkdirs]" + } else { + set dupid "" + } + if {$dbcount == 1} { + set pname "" + set pcode "" + if {[file exists $fosdb]} { + if {[catch { + sqlite3 fdb $fosdb + set pname [lindex [fdb eval {select value from config where name = 'project-name'}] 0] + set pcode [lindex [fdb eval {select value from config where name = 'project-code'}] 0] + fdb close + dict set fosdb_cache $fosdb [list name $pname code $pcode] + } errM]} { + puts stderr "!!! problem with fossil db: $fosdb when examining workdir $wd" + puts stderr "!!! error: $errM" + } + } else { + puts stderr "!!! missing fossil db $fosdb" + } + } else { + set info [dict get $fosdb_cache $fosdb] + lassign $info _name pname _code pcode + } + lappend col_rowids $rowid + lappend col_fnames $nm + lappend col_dupids $dupid + lappend col_pnames $pname + lappend col_pcodes [string range $pcode 0 9] + incr rowid + } + + set col_states [list] + set state_title "" + #if only one set of fossil checkouts in the resultset - retrieve workingdir state for each co + if {[llength [dict keys $fosdb_cache]] == 1} { + puts stderr "Result is a single project - gathering file state for each checkout folder" + set c_rev [list] + set c_unchanged [list] + set c_changed [list] + set c_new [list] + set c_missing [list] + set c_extra [list] + foreach wd $workdirs { + set wd_state [punk::repo::workingdir_state $wd] + set state_dict [punk::repo::workingdir_state_summary_dict $wd_state] + lappend c_rev [string range [dict get $state_dict revision] 0 9] + lappend c_unchanged [dict get $state_dict unchanged] + lappend c_changed [dict get $state_dict changed] + lappend c_new [dict get $state_dict new] + lappend c_missing [dict get $state_dict missing] + lappend c_extra [dict get $state_dict extra] + puts -nonewline stderr "." + } + puts -nonewline stderr \n + set t0 "Revision" + set w0 [tcl::mathfunc::max {*}[lmap v [concat [list $t0] $c_rev] {string length $v}]] + set c0 [string repeat " " $w0] + set t1 "Unch" + set w1 [tcl::mathfunc::max {*}[lmap v [concat [list $t1] $c_unchanged] {string length $v}]] + set c1 [string repeat " " $w1] + set t2 "Chgd" + set w2 [tcl::mathfunc::max {*}[lmap v [concat [list $t2] $c_changed] {string length $v}]] + set c2 [string repeat " " $w2] + set t3 "New" + set w3 [tcl::mathfunc::max {*}[lmap v [concat [list $t3] $c_new] {string length $v}]] + set c3 [string repeat " " $w3] + set t4 "Miss" + set w4 [tcl::mathfunc::max {*}[lmap v [concat [list $t4] $c_missing] {string length $v}]] + set c4 [string repeat " " $w4] + set t5 "Extr" + set w5 [tcl::mathfunc::max {*}[lmap v [concat [list $t5] $c_extra] {string length $v}]] + set c5 [string repeat " " $w5] + + set state_title "[overtype::left $c0 $t0] [overtype::right $c1 $t1] [overtype::right $c2 $t2] [overtype::right $c3 $t3] [overtype::right $c4 $t4] [overtype::right $c5 $t5]" + foreach r $c_rev u $c_unchanged c $c_changed n $c_new m $c_missing e $c_extra { + lappend col_states "[overtype::left $c0 $r] [overtype::right $c1 $u] [overtype::right $c2 $c] [overtype::right $c3 $n] [overtype::right $c4 $m] [overtype::right $c5 $e]" + } + } + + set msg "" + if {$opt_cd} { + set title0 "CD" + } else { + set title0 "" + } + set widest0 [tcl::mathfunc::max {*}[lmap v [concat [list $title0] $col_rowids] {punk::strlen $v}]] + set col0 [string repeat " " $widest0] + set title1 "Checkout dir" + set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $workdirs] {punk::strlen $v}]] + set col1 [string repeat " " $widest1] + set title2 "Db name" + set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col_fnames] {string length $v}]] + set col2 [string repeat " " $widest2] + set title3 "CO dup" + set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col_dupids] {string length $v}]] + set col3 [string repeat " " $widest3] + set title4 "Project Name" + set widest4 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col_pnames] {string length $v}]] + set col4 [string repeat " " $widest4] + set title5 "Project Code" + set widest5 [tcl::mathfunc::max {*}[lmap v [concat [list $title5] $col_pcodes] {string length $v}]] + set col5 [string repeat " " $widest5] + + set tablewidth [expr {$widest0 + 1 + $widest1 + 1 + $widest2 + 1 + $widest3 +1 + $widest4 + 1 + $widest5}] + append msg "[overtype::right $col0 $title0] [overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3] [overtype::left $col4 $title4] [overtype::left $col5 $title5]" + + if {[llength $col_states]} { + set title6 $state_title + set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col_states] {string length $v}]] + set col6 [string repeat " " $widest6] + incr tablewidth [expr {$widest6 + 1}] + append msg " [overtype::left $col6 $title6]" \n + } else { + append msg \n + } + append msg [string repeat "=" $tablewidth] \n + + if {[llength $col_states]} { + foreach row $col_rowids wd $workdirs db $col_fnames dup $col_dupids pname $col_pnames pcode $col_pcodes s $col_states { + append msg "[overtype::right $col0 $row] [overtype::left $col1 $wd] [overtype::left $col2 $db] [overtype::right $col3 $dup] [overtype::left $col4 $pname] [overtype::left $col5 $pcode] [overtype::left $col6 $s]" \n + } + } else { + foreach row $col_rowids wd $workdirs db $col_fnames dup $col_dupids pname $col_pnames pcode $col_pcodes { + append msg "[overtype::right $col0 $row] [overtype::left $col1 $wd] [overtype::left $col2 $db] [overtype::right $col3 $dup] [overtype::left $col4 $pname] [overtype::left $col5 $pcode]" \n + } + } + set numrows [llength $col_rowids] + if {$opt_cd && $numrows >= 1} { + puts stdout $msg + if {$numrows == 1} { + set workingdir [lindex $workdirs 0] + puts stdout "1 result. Changing dir to $workingdir" + if {[file exists $workingdir]} { + cd $workingdir + return $workingdir + } else { + puts stderr "path $workingdir doesn't appear to exist" + return [pwd] + } + } else { + set answer [util::askuser "Change directory to working folder - select a number from 1 to [llength $col_rowids] or any other key to cancel."] + if {[string trim $answer] in $col_rowids} { + set index [expr {$answer - 1}] + set workingdir [lindex $workdirs $index] + cd $workingdir + puts stdout [pmix stat] + return $workingdir + } + } + } + return $msg + } + } + + namespace eval lib { + #get project info only by opening the central confg-db + #(will not have proper project-name etc) + proc get_projects {{globlist {}} args} { + if {![llength $globlist]} { + set globlist [list *] + } + set fossil_prog [auto_execok fossil] + + set fossilinfo [exec {*}$fossil_prog info] ;#will give us the necessary config-db info whether in a project folder or not + set matching_lines [punk::repo::grep {config-db:*} $fossilinfo] + if {[llength $matching_lines] != 1} { + puts stderr "Unable to find config-db info from fossil. Check your fossil installation." + puts stderr "Fossil output was:" + puts stderr "-------------" + puts stderr "$fossilinfo" + puts stderr "-------------" + puts stderr "config-db info:" + puts stderr "$matching_lines" + return + } + set ln [lindex $matching_lines 0] + set configdb [string trim [string range $ln [string length "config-db: "] end]] + if {![file exists $configdb]} { + error "config-db not found at path $configdb" + } + package require sqlite3 + ::sqlite3 fosconf $configdb + #set testresult [fosconf eval {select name,value from global_config;}] + #puts stderr $testresult + set project_repos [fosconf eval {select name from global_config where name like 'repo:%';}] + set paths_and_names [list] + foreach pr $project_repos { + set path [string trim [string range $pr 5 end]] + set nm [file rootname [file tail $path]] + set ckouts [fosconf eval {select name from global_config where value = $path;}] + set checkout_paths [list] + #strip "ckout:" + foreach ck $ckouts { + lappend checkout_paths [string trim [string range $ck 6 end]] + } + lappend paths_and_names [list $path $nm $checkout_paths] + } + set filtered_list [list] + foreach glob $globlist { + set matches [lsearch -all -inline -index 1 $paths_and_names $glob] + foreach m $matches { + if {$m ni $filtered_list} { + lappend filtered_list $m + } + } + } + set projects [lsort -index 1 $filtered_list] + return $projects + } + + } + + + + + +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::commandset::project [namespace eval punk::mix::commandset::project { + variable version + set version 0.1.0 +}] +return diff --git a/src/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm new file mode 100644 index 00000000..abfb0e55 --- /dev/null +++ b/src/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm @@ -0,0 +1,92 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application punk::mix::commandset::repo 0.1.0 +# Meta platform tcl +# Meta license +# @@ 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 -t t)" \n + append result [exec fossil timeline -n 10 -t t] + + return $result + } + + proc fossilize { args} { + #check if project already managed by fossil.. initialise and check in if not. + puts stderr "unimplemented" + } + + proc unfossilize {projectname args} { + #remove/archive .fossil + puts stderr "unimplemented" + } + proc state {} { + set result "" + set repopaths [punk::repo::find_repos [pwd]] + set repos [dict get $repopaths repos] + if {![llength $repos]} { + append result [dict get $repopaths warnings] + } else { + append result [dict get $repopaths warnings] + lassign [lindex $repos 0] repopath repotypes + if {"fossil" in $repotypes} { + append result \n "Fossil repo based at $repopath" + set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes fossil] + append result \n [punk::repo::workingdir_state_summary $repostate] + } + if {"git" in $repotypes} { + append result \n "Git repo based at $repopath" + set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes git] + append result \n [punk::repo::workingdir_state_summary $repostate] + } + } + return $result + } +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::commandset::repo [namespace eval punk::mix::commandset::repo { + variable version + set version 0.1.0 +}] +return diff --git a/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm new file mode 100644 index 00000000..b78323ca --- /dev/null +++ b/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm @@ -0,0 +1,634 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application punk::mix::commandset::scriptwrap 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + +package require punk::mix +package require punk::mix::base + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::mix::commandset::scriptwrap { + namespace export * + + + #scriptpath allows templates command to use same custom template set as when multishell pointed to a filepath + #it may or may not be within a project + #by using the same folder or path, the same project root will be discovered. REVIEW. + proc templates_dict {args} { + set defaults [list -scriptpath ""] + set opts [dict merge $defaults $args] + set opt_scriptpath [dict get $opts -scriptpath] + + set wrapper_folders [lib::get_wrapper_folders $opt_scriptpath] + + set wrapper_templates [list] + foreach fld $wrapper_folders { + set templates [glob -nocomplain -dir $fld -type f *] + foreach tf $templates { + if {[string match ignore* $tf]} { + continue + } + set ext [file extension $tf] + if {$ext in [list "" ".bat" ".cmd" ".sh"]} { + lappend wrapper_templates $tf + } + } + } + + set tdict [dict create] + set seen_dict [dict create] + foreach fullpath $wrapper_templates { + set ftail [file tail $fullpath] + if {![dict exists $seen_dict $ftail]} { + dict set seen_dict $ftail 1 + dict set tdict $ftail $fullpath ; #first seen of filename gets no number + } else { + set n [dict get $seen_dict $ftail] + incr n + dict incr seen_dict $ftail + dict set tdict ${ftail}.$n $fullpath + } + } + return $tdict + } + proc templates {args} { + package require overtype + set tdict [templates_dict {*}$args] + + + set paths [dict values $tdict] + set names [dict keys $tdict] + + set title1 "Path" + set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $paths] {punk::strlen $v}]] + set col1 [string repeat " " $widest1] + + set title2 "Template Name" + set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $names] {punk::strlen $v}]] + set col2 [string repeat " " $widest2] + + set tablewidth [expr {$widest1 + 1 + $widest2}] + set table "" + append table [string repeat - $tablewidth] \n + append table "[overtype::left $col1 $title1] [overtype::left $col2 $title2]" \n + append table [string repeat - $tablewidth] \n + + foreach p $paths n $names { + append table "[overtype::left $col1 $p] [overtype::left $col2 $n]" \n + } + + + return $table + } + #specific filepath to just wrap one script at the tcl-payload or xxx-payload-pre-tcl site + #scriptset name to substiture multiple scriptset.xxx files at the default locations - or as specified in scriptset.wrapconf + proc multishell {filepath_or_scriptset args} { + set defaults [list -askme 1 -template \uFFFF] + set opts [dict merge $defaults $args] + set opt_askme [dict get $opts -askme] + set opt_template [dict get $opts -template] + set ext [file extension $filepath_or_scriptset] + set startdir [pwd] + + set usage "" + append usage "Use directly with the script file to wrap, or supply the name of a scriptset" \n + append usage "The scriptset name will be used to search for yourname.sh|tcl|ps1 or names as you specify in yourname.wrapconfig if it exists" \n + append usage "If no template is specified in a .wrapconfig and no -template argument is supplied, it will default to punk-multishell.cmd" \n + if {![string length $filepath_or_scriptset]} { + puts stderr "No filepath_or_scriptset specified" + puts stderr $usage + return false + } + + + #first check if relative or absolute path matches a file + if {[file pathtype $filepath_or_scriptset] eq "absolute"} { + set specified_path $filepath_or_scriptset + } else { + set specified_path [file join $startdir $filepath_or_scriptset] + } + + set ext [string trim [file extension $filepath_or_scriptset] .] + set allowed_extensions [list wrapconfig tcl ps1 sh bash] + #set allowed_extensions [list tcl] + set found_script 0 + if {[file exists $specified_path]} { + set found_script 1 + } else { + foreach e $allowed_extensions { + if {[file exists $filepath_or_scriptset.$e]} { + set found_script 1 + break + } + } + } + + #TODO! - use get_wrapper_folders - multishell should use same available templates as the 'templates' function + set scriptset [file rootname [file tail $specified_path]] + if {$found_script} { + if {[file type $specified_path] eq "file"} { + set specified_root [file dirname $specified_path] + set pathinfo [punk::repo::find_repos [file dirname $specified_path]] + set projectroot [dict get $pathinfo closest] + if {[string length $projectroot]} { + #use the specified files folder - but use the main scriptapps/wrappers folder if specified one has no wrappers subfolder + set scriptroot [file dirname $specified_path] + if {[file exists $scriptroot/wrappers]} { + set customwrapper_folder $scriptroot/wrappers + } else { + set customwrapper_folder $projectroot/src/scriptapps/wrappers + } + } else { + #outside of any project + set scriptroot [file dirname $specified_path] + if {[file exists $scriptroot/wrappers]} { + set customwrapper_folder $scriptroot/wrappers + } else { + #no customwrapper folder available + set customwrapper_folder "" + } + } + } else { + puts stderr "wrap_in_multishell doesn't currently support a directory as the path." + puts stderr $usage + return false + } + } else { + set pathinfo [punk::repo::find_repos $startdir] + set projectroot [dict get $pathinfo closest] + if {[string length $projectroot]} { + if {[llength [file split $filepath_or_scriptset]] > 1} { + puts stderr "filepath_or_scriptset looks like a path - but doesn't seem to point to a file" + puts stderr "Ensure you are within a project and use just the name of the scriptset, or pass in the full correct path or relative path to current directory" + puts stderr $usage + return false + } else { + #we've already ruled out empty string - so must have a single element representing scriptset - possibly with file extension + set scriptroot $projectroot/src/scriptapps + set customwrapper_folder $projectroot/src/scriptapps/wrappers + #check something matches the scriptset.. + set something_found "" + if {[file exists $scriptroot/$scriptset]} { + set found_script 1 + set something_found $scriptroot/$scriptset ;#extensionless file - that's ok too + } else { + foreach e $allowed_extensions { + if {[file exists $scriptroot/$scriptset.$e]} { + set found_script 1 + set something_found $scriptroot/$scriptset.$e + break + } + } + } + if {!$found_script} { + puts stderr "Searched within $scriptroot" + puts stderr "Unable to find a file matching $scriptset or one of the extensions: $allowed_extensions" + puts stderr $usage + return false + } else { + if {[file pathtype $something_found] ne "file"} { + puts stderr "wrap_in_multishell doesn't currently support a directory as the path." + puts stderr $usage + return false + } + } + } + + } else { + puts stderr "filepath_or_scriptset parameter doesn't seem to refer to a file, and you are not within a directory where projectroot and src/scriptapps/wrappers can be determined" + puts stderr $usage + return false + } + } + #assert - customwrapper_folder var exists - but might be empty + + + if {[string length $ext]} { + #If there was an explicitly supplied extension - then that file should exist + if {![file exists $scriptroot/$scriptset.$ext]} { + puts stderr "Explicit extension .$ext was supplied - but matching file not found." + puts stderr $usage + return false + } else { + if {$ext eq "wrapconfig"} { + set process_extensions ALLFOUNDORCONFIGURED + } else { + set process_extensions $ext + } + } + } else { + #no explicit extension - process all for scriptset + set process_extensions ALLFOUNDORCONFIGURED + } + #process_extensions - either a single one - or all found or as per .wrapconfig + + if {$opt_template eq "\uFFFF"} { + set templatename punk-multishell.cmd + } else { + set templatename $opt_template + } + + + + set template_base_dict [punk::mix::base::lib::get_template_basefolders] + set tpldirs [list] + dict for {tdir tsourceinfo} $template_base_dict { + if {[file exists $tdir/utility/scriptappwrappers/$templatename]} { + lappend tpldirs $tdir + } + } + + if {[string length $customwrapper_folder] && [file exists [file join $customwrapper_folder $templatename] ]} { + set wrapper_template [file join $customwrapper_folder $templatename] + } else { + if {![llength $tpldirs]} { + set msg "No template named '$templatename' found in src/scriptapps/wrappers or in template dirs from packages" + append msg \n "Searched [dict size $template_base_dict] template dirs" + error $msg + } + + #last pkg with templates cap which was loaded has highest precedence + set wrapper_template "" + foreach tdir [lreverse $tpldirs] { + set ftest [file join $tdir utility scriptappwrappers $templatename] + if {[file exists $ftest]} { + set wrapper_template $ftest + break + } + } + } + + if {$wrapper_template eq "" || ![file exists $wrapper_template]} { + error "wrap_in_multishell: unable to find multishell template $templatename in template folders [concat $tpldirs $customwrapper_folder]" + } + + + #todo + #output_file extension depends on the template being used.. + + + set output_file $scriptset.cmd + if {[file exists $output_file]} { + error "wrap_in_multishell: target file $output_file already exists.. aborting" + } + + + set fdt [open $wrapper_template r] + fconfigure $fdt -translation binary + set template_data [read $fdt] + close $fdt + puts stdout "Read [string length $template_data] bytes of template data.." + set template_lines [split $template_data \n] + puts stdout "Displaying first 3 lines of template between dashed lines..." + puts stdout "-----------------------------------------------" + foreach ln [lrange $template_lines 0 3] { + puts stdout $ln + } + puts stdout "-----------------------------------------------\n" + #foreach ln $template_lines { + #} + + set list_input_files [list] + if {$process_extensions eq "ALLFOUNDORCONFIGURED"} { + #todo - look for .wrapconfig or all extensions for the scriptset + puts stderr "Sorry - only single input file supported - implementation incomplete" + return false + } else { + lappend list_input_files $scriptroot/$scriptset.$ext + } + + #todo - split template at each 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 "#*" $ln]} { + set start_idx $line_idx + } elseif {[string match "#*" $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 # and # on separate lines" + } + set existing_string [join $existing_payload \n] + if {[string length [string trim $existing_string]]} { + puts stdout "EXISTING PAYLOAD!!" + puts stdout "-----------------------------------------------\n" + puts stdout $existing_string + puts stdout "-----------------------------------------------\n" + error "wrap_in_multishell found existing payload.. aborting." + #todo - allow overwrite only in files outside of punkshell distribution? + if 0 { + puts stderr "Found existing payload.. overwrite?" + if {$opt_askme} { + set answer [util::askuser "Are you sure you want to replace the tcl payload shown above? Y|N"] + if {[string tolower $answer] ne "y"} { + puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." + return + } + } + } + } + + set tpl_head_lines [lrange $template_lines 0 $start_idx] ;#include tag line + set tpl_tail_lines [lrange $template_lines $end_idx end] + set newscript [join $tpl_head_lines \n]\n[join $script_lines \n]\n[join $tpl_tail_lines \n] + puts stdout "New script is [string length $newscript] bytes" + puts stdout $newscript + set fdtarget [open $output_file w] + fconfigure $fdtarget -translation binary + puts -nonewline $fdtarget $newscript + close $fdtarget + puts stdout "Wrote script file at $output_file" + puts stdout "-done-" + return $output_file + } + + namespace eval lib { + + #get_wrapper_folders + # scriptpath - file or folder + # It represents the base point from which to search for /wrapper folders either directly above the scriptpath or in the containing project if any + # The cwd will also be searched for /wrapper folder and project - but with lower precedence in the resultset (later in list) + proc get_wrapper_folders {{scriptpath ""}} { + set wrapper_folders [list] + if {$scriptpath ne ""} { + if {[file type $scriptpath] eq "file"} { + set searchbase [file dirname $scriptpath] + } else { + set searchbase $scriptpath + } + if {[file isdirectory [file join $searchbase wrappers]]} { + lappend wrapper_folders [file join $searchbase wrappers] + } + set pathinfo [punk::repo::find_repos $searchbase] + set scriptpath_projectroot [dict get $pathinfo closest] + if {$scriptpath_projectroot ne ""} { + set fld [file join $scriptpath_projectroot src/scriptapps/wrappers] + if {[file isdirectory $fld]} { + if {$fld ni $wrapper_folders} { + lappend wrapper_folders $fld + } + } + } + } + set searchbase [pwd] + set fld [file join $searchbase wrappers] + if {[file isdirectory $fld]} { + if {$fld ni $wrapper_folders} { + lappend wrapper_folders $fld + } + } + set pathinfo [punk::repo::find_repos $searchbase] + set pwd_projectroot [dict get $pathinfo closest] + if {$pwd_projectroot ne ""} { + set fld [file join $pwd_projectroot src/scriptapps/wrappers] + if {[file isdirectory $fld]} { + if {$fld ni $wrapper_folders} { + lappend wrapper_folders $fld + } + } + } + + set template_base_dict [punk::mix::base::lib::get_template_basefolders] + set tpldirs [list] + dict for {tdir tsourceinfo} $template_base_dict { + if {[file exists $tdir/utility/scriptappwrappers]} { + lappend tpldirs $tdir + } + } + foreach tpldir $tpldirs { + set fld [file join $tpldir utility scriptappwrappers] + if {[file isdirectory $fld]} { + if {$fld ni $wrapper_folders} { + lappend wrapper_folders $fld + } + } + } + return $wrapper_folders + } + proc _scriptapp_tag_from_line {line} { + set result [list istag 0 raw ""] ;#default assumption. All + #---- + set startc [string first "#" $line] ;#tags must be commented + #todo - review. next line is valid - note # doesn't have to be the only one before + # @REM # etc < blah # etc + #--- + #fix - we should use a regexp on at least 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#\n ...\n# 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 # 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" & :: # + #The .wrapconfig might contain + # tag line {@set "nextshell=tclsh" & :: @} + # + proc scriptapp_wrapper_get_tags {wrapperdata} { + set wrapperdata [string map [list \r\n \n] $wrapperdata] + set lines [split $wrapperdata \n] + #set tags_in_data [dict create];#active tags - list of lines accumulating. supports nested tags + set status 0 + set tags [dict create] + set errors [list] + set errortags [dict create] ;#mark names invalid on first error so that more than 2 tags can't obscure config problem + set linenum 1 ;#editors and other utils use 1-based indexing when referencing files - we should too to avoid confusion, despite it being less natural for lindex operations on the result. + foreach ln $lines { + set lntrim [string trim $ln] + if {![string length $lntrim]} { + incr linenum + continue + } + if {[string match "*#*<*>*" $lntrim]} { + set taginfo [_scriptapp_tag_from_line $ln] ;#use untrimmed line - to get indent + if {[dict get $taginfo istag]} { + set nm [dict get $taginfo name] + if {[dict exists $errortags $nm]} { + #tag is already in error condition - + } else { + set tp [dict get $taginfo type] ;# type singular - related to just one line + #set raw [dict get $taginfo raw] #equivalent to $ln + if {[dict exists $tags $nm]} { + #already seen tag name + #tags dict has types key *plural* - need to track whether we have type open and type close (or openclose for self-closing tags) + if {[dict get $tags $nm types] ne "open"} { + lappend errors "line: $linenum tag $nm encountered type $tp after existing type [dict get $tags $nm types]" + dict incr errortags $nm + } else { + #we already have open - expect only close + if {$tp ne "close"} { + lappend errors "line: $linenum tag $nm encountered type $tp after existing type [dict get $tags $nm types]" + dict incr errortags $nm + } else { + #close after open + dict set tags $nm types [list open close] + dict set tags $nm end $linenum + set taglines [dict get $tags $nm taglines] + if {[llength $taglines] != 1} { + error "Unexpected result when closing tag $nm. Existing taglines length not 1." + } + dict set tags $nm taglines [concat $taglines $ln] + } + } + } else { + #first seen of tag name + if {$tp eq "close"} { + lappend errors "line: $linenum tag $nm encountered type $p close first" + dict incr errortags $nm + } else { + dict set tags $nm types $tp + dict set tags $nm indent [dict get $taginfo indent] + if {$tp eq "open"} { + dict set tags $nm start $linenum + dict set tags $nm taglines [list $ln] ;#first entry - another will be added on encountering matching closing tag + } elseif {$tp eq "openclose"} { + dict set tags $nm start $linenum + dict set tags $nm end $linenum + dict set tags $nm taglines [list $ln] ;#single entry is final result for self-closing tag + } + } + } + } + } else { + #looks like it should be a tag.. but failed to even parse for some reason.. just add to errorlist + lappend errors "line: $linenum tag parse failure reason: [dict get $taginfo reason] raw line: [dict get $taginfo raw]" + } + } + #whether the line is tag or not append to any tags_in_data + #foreach t [dict keys $tags_in_data] { + # dict lappend tags_in_data $t $ln ;#accumulate raw lines - written to the tag entry in tags only on encountering a closing tag, then removed from tags_in_data + #} + incr linenum + } + #assert [expr {$linenum -1 == [llength $lines]}] + if {[llength $errors]} { + set status 0 + } else { + set status 1 + } + if {$linenum == 0} { + + } + return [dict create ok $status linecount [llength $lines] data $tags errors $errors] + } + + + } + + +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::commandset::scriptwrap [namespace eval punk::mix::commandset::scriptwrap { + variable version + set version 0.1.0 +}] +return diff --git a/src/bootsupport/modules/punk/mix/templates-0.1.0.tm b/src/bootsupport/modules/punk/mix/templates-0.1.0.tm new file mode 100644 index 00000000..d4847541 --- /dev/null +++ b/src/bootsupport/modules/punk/mix/templates-0.1.0.tm @@ -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 -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application punk::mix::templates 0.1.0 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz +package require punk::cap + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::mix::templates { + punk::cap::register_package punk::mix::templates [list\ + {templates {relpath ../templates}}\ + ] + +} + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::templates [namespace eval punk::mix::templates { + variable version + set version 0.1.0 +}] +return \ No newline at end of file diff --git a/src/bootsupport/modules/punk/mix/util-0.1.0.tm b/src/bootsupport/modules/punk/mix/util-0.1.0.tm new file mode 100644 index 00000000..8dbb5823 --- /dev/null +++ b/src/bootsupport/modules/punk/mix/util-0.1.0.tm @@ -0,0 +1,427 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application punk::mix::util 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + +namespace eval punk::mix::util { + variable has_winpath 0 +} + +if {"windows" eq $::tcl_platform(platform)} { + if {![catch {package require punk::winpath}]} { + set punk::mix::util::has_winpath 1 + } +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::mix::util { + variable tmpfile_counter 0 ;#additional tmpfile collision avoidance + + namespace export * + + + proc fcat {args} { + variable has_winpath + + if {$::tcl_platform(platform) ne "windows"} { + return [fileutil::cat {*}$args] + } + + set knownopts [list -eofchar -translation -encoding --] + set last_opt 0 + for {set i 0} {$i < [llength $args]} {incr i} { + set ival [lindex $args $i] + #puts stdout "i:$i a: $ival known: [expr {$ival in $knownopts}]" + if {$ival eq "--"} { + set last_opt $i + break + } else { + if {$ival in $knownopts} { + #puts ">known at $i : [lindex $args $i]" + if {($i % 2) != 0} { + error "unexpected option at index $i. known options: $knownopts must come in -opt val pairs." + } + incr i + set last_opt $i + } else { + set last_opt [expr {$i - 1}] + break + } + } + } + set first_non_opt [expr {$last_opt + 1}] + + #puts stderr "first_non_opt: $first_non_opt" + set opts [lrange $args -1 $first_non_opt-1] + set paths [lrange $args $first_non_opt end] + if {![llength $paths]} { + error "Unable to find file in the supplied arguments: $args. Ensure options are all -opt val pairs and that file name(s) follow" + } + #puts stderr "opts: $opts paths: $paths" + set finalpaths [list] + foreach p $paths { + if {$has_winpath && [punk::winpath::illegalname_test $p]} { + lappend finalpaths [punk::winpath::illegalname_fix $p] + } else { + lappend finalpaths $p + } + } + fileutil::cat {*}$opts {*}$finalpaths + } + + #---------------------------------------- + namespace eval internal { + proc path_common_prefix_pop {varname} { + upvar 1 $varname var + set var [lassign $var head] + return $head + } + } + proc path_common_prefix {args} { + set dirs $args + set parts [file split [internal::path_common_prefix_pop dirs]] + while {[llength $dirs]} { + set r {} + foreach cmp $parts elt [file split [internal::path_common_prefix_pop dirs]] { + if {$cmp ne $elt} break + lappend r $cmp + } + set parts $r + } + if {[llength $parts]} { + return [file join {*}$parts] + } else { + return "" + } + } + + #retains case from first argument only - caseless comparison + proc path_common_prefix_nocase {args} { + set dirs $args + set parts [file split [internal::path_common_prefix_pop dirs]] + while {[llength $dirs]} { + set r {} + foreach cmp $parts elt [file split [internal::path_common_prefix_pop dirs]] { + if {![string equal -nocase $cmp $elt]} break + lappend r $cmp + } + set parts $r + } + if {[llength $parts]} { + return [file join {*}$parts] + } else { + return "" + } + } + #---------------------------------------- + + #maint warning - also in punkcheck + proc path_relative {base dst} { + #see also kettle + # Modified copy of ::fileutil::relative (tcllib) + # Adapted to 8.5 ({*}). + # + # Taking two _directory_ paths, a base and a destination, computes the path + # of the destination relative to the base. + # + # Arguments: + # base The path to make the destination relative to. + # dst The destination path + # + # Results: + # The path of the destination, relative to the base. + + # Ensure that the link to directory 'dst' is properly done relative to + # the directory 'base'. + + #review - check volume info on windows.. UNC paths? + if {[file pathtype $base] ne [file pathtype $dst]} { + return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)" + } + + #avoid normalizing if possible (file normalize *very* expensive on windows) + set do_normalize 0 + if {[file pathtype $base] eq "relative"} { + #if base is relative so is dst + if {[regexp {[.]{2}} [list $base $dst]]} { + set do_normalize 1 + } + if {[regexp {[.]/} [list $base $dst]]} { + set do_normalize 1 + } + } else { + set do_normalize 1 + } + if {$do_normalize} { + set base [file normalize $base] + set dst [file normalize $dst] + } + + set save $dst + set base [file split $base] + set dst [file split $dst] + + while {[lindex $dst 0] eq [lindex $base 0]} { + set dst [lrange $dst 1 end] + set base [lrange $base 1 end] + if {![llength $dst]} {break} + } + + set dstlen [llength $dst] + set baselen [llength $base] + + if {($dstlen == 0) && ($baselen == 0)} { + # Cases: + # (a) base == dst + + set dst . + } else { + # Cases: + # (b) base is: base/sub = sub + # dst is: base = {} + + # (c) base is: base = {} + # dst is: base/sub = sub + + while {$baselen > 0} { + set dst [linsert $dst 0 ..] + incr baselen -1 + } + set dst [file join {*}$dst] + } + + return $dst + } + #namespace import ::punk::ns::nsimport_noclobber + + proc namespace_import_pattern_to_namespace_noclobber {pattern ns} { + set source_ns [namespace qualifiers $pattern] + if {![namespace exists $source_ns]} { + error "namespace_import_pattern_to_namespace_noclobber error namespace $source_ns not found" + } + if {![string match ::* $ns]} { + set nscaller [uplevel 1 {namespace current}] + set ns [punk::nsjoin $nscaller $ns] + } + set a_export_patterns [namespace eval $source_ns {namespace export}] + set a_commands [info commands $pattern] + set a_tails [lmap v $a_commands {namespace tail $v}] + set a_exported_tails [list] + foreach pattern $a_export_patterns { + set matches [lsearch -all -inline $a_tails $pattern] + foreach m $matches { + if {$m ni $a_exported_tails} { + lappend a_exported_tails $m + } + } + } + set imported_commands [list] + foreach e $a_exported_tails { + set imported [namespace eval $ns [string map [list $e $source_ns] { + set cmd "" + if {![catch {namespace import ::}]} { + set cmd + } + set cmd + }]] + if {[string length $imported]} { + lappend imported_commands $imported + } + } + return $imported_commands + } + + proc askuser {question} { + puts stdout $question + flush stdout + set stdin_state [fconfigure stdin] + fconfigure stdin -blocking 1 + set answer [gets stdin] + fconfigure stdin -blocking [dict get $stdin_state -blocking] + return $answer + } + + proc do_in_path {path script} { + #from ::kettle::path::in + set here [pwd] + try { + cd $path + uplevel 1 $script + } finally { + cd $here + } + } + + proc foreach-file {path script_pathvariable script} { + upvar 1 $script_pathvariable thepath + + set known {} + lappend waiting $path + while {[llength $waiting]} { + set pending $waiting + set waiting {} + set at 0 + while {$at < [llength $pending]} { + set current [lindex $pending $at] + incr at + + # Do not follow into parent. + if {[string match *.. $current]} continue + + # Ignore what we have visited already. + set c [file dirname [file normalize $current/___]] + if {[dict exists $known $c]} continue + dict set known $c . + + if {[file tail $c] eq ".git"} { + continue + } + + # Expand directories. + if {[file isdirectory $c]} { + lappend waiting {*}[lsort -unique [glob -directory $c * .*]] + continue + } + + # Handle files as per the user's will. + set thepath $current + switch -exact -- [catch { uplevel 1 $script } result] { + 0 - 4 { + # ok, continue - nothing + } + 2 { + # return, abort, rethrow + return -code return + } + 3 { + # break, abort + return + } + 1 - default { + # error, any thing else - rethrow + return -code error $result + } + } + } + } + return + } + + proc is_valid_tm_version {versionpart} { + #Needs to be suitable for use with Tcl's 'package vcompare' + if {![catch [list package vcompare $versionpart $versionpart]]} { + return 1 + } else { + return 0 + } + } + #Note that semver only has a small overlap with tcl tm versions. + #todo - work out what overlap and whether it's even useful + #see also TIP #439: Semantic Versioning (tcl 9??) + proc semver {versionstring} { + set re {^(0|[1-9]\d*)\.(0|[1-9]\d*)\.(0|[1-9]\d*)(?:-((?:0|[1-9]\d*|\d*[a-zA-Z-][0-9a-zA-Z-]*)(?:\.(?:0|[1-9]\d*|\d*[a-zA-Z-][0-9a-zA-Z-]*))*))?(?:\+([0-9a-zA-Z-]+(?:\.[0-9a-zA-Z-]+)*))?$} + } + #todo - semver conversion/validation for other systems? + proc magic_tm_version {} { + set magicbase 999999 ;#deliberately large so given load-preference when testing! + #we split the literal to avoid the literal appearing here - reduce risk of accidentally converting to a release version + return ${magicbase}.0a1.0 + } + + + + proc tmpfile {{prefix tmp_}} { + #note risk of collision if pregenerating a list of tmpfile names + #we will maintain an icrementing id so the caller doesn't have to bear that in mind + variable tmpfile_counter + global tcl_platform + return .punkutil_$prefix[pid]_[clock microseconds]_[incr tmpfile_counter]_[info hostname]_$tcl_platform(user) + } + + proc tmpdir {} { + # Taken from tcllib fileutil. + global tcl_platform env + + set attempdirs [list] + set problems {} + + foreach tmp {TEMP TMP TMPDIR} { + if { [info exists env($tmp)] } { + lappend attempdirs $env($tmp) + } else { + lappend problems "No environment variable $tmp" + } + } + + switch $tcl_platform(platform) { + windows { + lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP" + } + macintosh { + lappend attempdirs $env(TRASH_FOLDER) ;# a better place? + } + default { + lappend attempdirs \ + [file join / tmp] \ + [file join / var tmp] \ + [file join / usr tmp] + } + } + + lappend attempdirs [pwd] + + foreach tmp $attempdirs { + if { [file isdirectory $tmp] && + [file writable $tmp] } { + return [file normalize $tmp] + } elseif { ![file isdirectory $tmp] } { + lappend problems "Not a directory: $tmp" + } else { + lappend problems "Not writable: $tmp" + } + } + + # Fail if nothing worked. + return -code error "Unable to determine a proper directory for temporary files\n[join $problems \n]" + } + + + +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::util [namespace eval punk::mix::util { + variable version + set version 0.1.0 +}] +return diff --git a/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/bootsupport/modules/punk/ns-0.1.0.tm new file mode 100644 index 00000000..28ac8ac3 --- /dev/null +++ b/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -0,0 +1,1694 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -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::ns 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + + +namespace eval ::punk_dynamic::ns { + +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::ns { + variable ns_current "::" + variable ns_re_cache [dict create] ;#cache regular expressions used in globmatchns + namespace export nsjoin nsprefix nstail nsparts nseval nsimport_noclobber corp + + #leading colon makes it hard (impossible?) to call directly if not within the namespace + proc ns/ {v {ns_or_glob ""} args} { + variable ns_current ;#change active ns of repl by setting ns_current + + set ns_caller [uplevel 1 {::namespace current}] + #puts stderr "ns_cur:$ns_current ns_call:$ns_caller" + + + set types [list all] + set nspathcommands 0 + if {$v eq "/"} { + set types [list children] + } + if {$v eq "///"} { + set nspathcommands 1 + } + + #todo - cooperate with repl? + set out "" + if {$ns_or_glob eq ""} { + set is_absolute 1 + set ns_queried $ns_current + set out [nslist [nsjoin $ns_current *] -types $types -nspathcommands $nspathcommands] + } else { + set is_absolute [string match ::* $ns_or_glob] + set has_globchars [regexp {[*?]} $ns_or_glob] + if {$is_absolute} { + if {!$has_globchars} { + if {![namespace exists $ns_or_glob]} { + error "cannot change to namespace $ns_or_glob" + } + set ns_current $ns_or_glob + set ns_queried $ns_current + tailcall ns/ $v "" + } else { + set ns_queried $ns_or_glob + set out [nslist $ns_or_glob -types $types -nspathcommands $nspathcommands] + } + } else { + if {!$has_globchars} { + set nsnext [nsjoin $ns_current $ns_or_glob] + if {![namespace exists $nsnext]} { + error "cannot change to namespace $ns_or_glob" + } + set ns_current $nsnext + set ns_queried $nsnext + set out [nslist [nsjoin $nsnext *] -types $types -nspathcommands $nspathcommands] + } else { + set ns_queried [nsjoin $ns_current $ns_or_glob] + set out [nslist [nsjoin $ns_current $ns_or_glob] -types $types -nspathcommands $nspathcommands] + } + } + } + set ns_display "\n$ns_queried" + if {$ns_current eq $ns_queried} { + if {$ns_current in [info commands $ns_current] } { + if {![catch [list namespace ensemble configure $ns_current] ensemble_info]} { + if {[llength $ensemble_info] > 0} { + #this namespace happens to match ensemble command. + #todo - keep cache of encountered ensembles from commands.. and examine namespace in the configure info. + set ns_display "\n[a+ yellow bold]$ns_current (ensemble)[a+]" + } + } + } + } + append out $ns_display + return $out + + + } + + + #create possibly nested namespace structure - but only if not already existant + proc n/new {args} { + variable ns_current + if {![llength $args]} { + error "usage: :/new \[ ...\]" + } + set a1 [lindex $args 0] + set is_absolute [string match ::* $a1] + if {$is_absolute} { + set nspath [nsjoinall {*}$args] + } else { + if {[string match :* $a1]} { + puts stderr "n/new WARNING namespace with leading colon '$a1' is likely to have unexpected results" + } + set nspath [nsjoinall $ns_current {*}$args] + } + + set ns_exists [nseval [nsprefix $nspath] [list ::namespace exists [nstail $nspath] ]] + + if {$ns_exists} { + error "Namespace $nspath already exists" + } + #namespace eval [nsprefix $nspath] [list namespace eval [nstail $nspath] {}] + nseval [nsprefix $nspath] [list ::namespace eval [nstail $nspath] {}] + n/ $nspath + } + + + #nn/ ::/ nsup/ - back up one namespace level + proc nsup/ {v args} { + variable ns_current + if {$ns_current eq "::"} { + puts stderr "Already at global namespace '::'" + } else { + set out "" + set nsq [nsprefix $ns_current] + if {$v eq "/"} { + set out [get_nslist -match [nsjoin $nsq *] -types [list children]] + } else { + set out [get_nslist -match [nsjoin $nsq *] -types [list all]] + } + #set out [nslist [nsjoin $nsq *]] + set ns_current $nsq + append out "\n$ns_current" + return $out + } + } + + #todo - walk up each ns - testing for possibly weirdly named namespaces + #review - do we even need it. + proc nsexists {nspath} { + error "unimplemented" + } + + #recursive nseval - for introspection of weird namespace trees + #approx 10x slower than normal namespace eval - but still only a few microseconds.. fine for repl introspection + proc nseval_script {location} { + set parts [nsparts $location] + if {[lindex $parts 0] eq ""} { + lset parts 0 :: + } + if {[lindex $parts end] eq ""} { + set parts [lrange $parts 0 end-1] + } + + set body "" + set i 0 + set tails [lrepeat [llength $parts] ""] + foreach ns $parts { + set cmdlist [list ::namespace eval $ns] + set t "" + if {$i > 0} { + append body " " + } + append body $cmdlist + if {$i == ([llength $parts] -1)} { + append body "