From df78ff9bb55d81355b691529b2a3fd3268855f23 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Fri, 3 Jul 2026 03:15:07 +1000 Subject: [PATCH] make.tcl bootstrapping fix, punkcheck refactor and tests --- scriptlib/exit.tcl | 2 + src/AGENTS.md | 1 + src/bootsupport/AGENTS.md | 25 + src/bootsupport/modules/punk/ansi-0.1.1.tm | 7 + src/bootsupport/modules/punk/mix/cli-0.3.1.tm | 14 +- src/bootsupport/modules/punk/mix/cli-0.4.0.tm | 1427 ++++++++++ .../modules/punk/mix/commandset/doc-0.1.1.tm | 324 +++ .../punk/mix/commandset/project-0.1.1.tm | 1178 ++++++++ .../punk/mix/commandset/project-0.2.0.tm | 1178 ++++++++ src/bootsupport/modules/punk/path-0.1.0.tm | 70 +- src/bootsupport/modules/punk/path-0.2.0.tm | 1611 +++++++++++ src/bootsupport/modules/punkcheck-0.2.0.tm | 2479 +++++++++++++++++ src/make.tcl | 178 +- src/modules/AGENTS.md | 17 +- src/modules/punk/AGENTS.md | 1 + src/modules/punk/ansi-999999.0a1.0.tm | 7 + .../templates/layouts/project/src/make.tcl | 14 +- src/modules/punk/mix/cli-999999.0a1.0.tm | 14 +- src/modules/punk/mix/cli-buildversion.txt | 3 +- .../punk/mix/commandset/doc-999999.0a1.0.tm | 2 +- .../punk/mix/commandset/doc-buildversion.txt | 3 +- .../mix/commandset/project-999999.0a1.0.tm | 23 +- .../mix/commandset/project-buildversion.txt | 4 +- src/modules/punk/path-999999.0a1.0.tm | 91 +- src/modules/punk/path-buildversion.txt | 4 +- src/modules/punkcheck-999999.0a1.0.tm | 333 +-- src/modules/punkcheck-buildversion.txt | 6 +- .../custom/_project/punk.basic/src/make.tcl | 178 +- .../bootsupport/modules/punk/ansi-0.1.1.tm | 7 + .../bootsupport/modules/punk/mix/cli-0.3.1.tm | 14 +- .../bootsupport/modules/punk/mix/cli-0.4.0.tm | 1427 ++++++++++ .../modules/punk/mix/commandset/doc-0.1.1.tm | 324 +++ .../punk/mix/commandset/project-0.1.1.tm | 1178 ++++++++ .../punk/mix/commandset/project-0.2.0.tm | 1178 ++++++++ .../bootsupport/modules/punk/path-0.1.0.tm | 70 +- .../bootsupport/modules/punk/path-0.2.0.tm | 1611 +++++++++++ .../bootsupport/modules/punkcheck-0.2.0.tm | 2479 +++++++++++++++++ .../_project/punk.project-0.1/src/make.tcl | 178 +- .../bootsupport/modules/punk/ansi-0.1.1.tm | 7 + .../bootsupport/modules/punk/mix/cli-0.3.1.tm | 14 +- .../bootsupport/modules/punk/mix/cli-0.4.0.tm | 1427 ++++++++++ .../modules/punk/mix/commandset/doc-0.1.1.tm | 324 +++ .../punk/mix/commandset/project-0.1.1.tm | 1178 ++++++++ .../punk/mix/commandset/project-0.2.0.tm | 1178 ++++++++ .../bootsupport/modules/punk/path-0.1.0.tm | 70 +- .../bootsupport/modules/punk/path-0.2.0.tm | 1611 +++++++++++ .../bootsupport/modules/punkcheck-0.2.0.tm | 2479 +++++++++++++++++ .../_project/punk.shell-0.1/src/make.tcl | 178 +- src/tests/modules/AGENTS.md | 2 + .../punk/path/testsuites/tests/path.test | 94 +- .../testsuites/punkcheck/install.test | 684 +++++ .../testsuites/punkcheck/installtrack.test | 613 ++++ src/tests/runtests.tcl | 1 + .../modules/commandstack-0.3.tm | 518 ---- src/vfs/_vfscommon.vfs/modules/oolib-0.1.2.tm | 201 -- .../_vfscommon.vfs/modules/punk/ansi-0.1.1.tm | 7 + .../modules/punk/mix/cli-0.3.1.tm | 14 +- .../modules/punk/mix/cli-0.4.0.tm | 1427 ++++++++++ .../modules/punk/mix/commandset/doc-0.1.1.tm | 324 +++ .../punk/mix/commandset/project-0.1.1.tm | 1178 ++++++++ .../punk/mix/commandset/project-0.2.0.tm | 1178 ++++++++ .../modules/punk/mix/templates-0.1.3.tm | Bin 73101 -> 73097 bytes .../_vfscommon.vfs/modules/punk/path-0.1.0.tm | 70 +- .../_vfscommon.vfs/modules/punk/path-0.2.0.tm | 1611 +++++++++++ .../_vfscommon.vfs/modules/punkcheck-0.2.0.tm | 2479 +++++++++++++++++ 65 files changed, 35312 insertions(+), 1215 deletions(-) create mode 100644 scriptlib/exit.tcl create mode 100644 src/bootsupport/modules/punk/mix/cli-0.4.0.tm create mode 100644 src/bootsupport/modules/punk/mix/commandset/doc-0.1.1.tm create mode 100644 src/bootsupport/modules/punk/mix/commandset/project-0.1.1.tm create mode 100644 src/bootsupport/modules/punk/mix/commandset/project-0.2.0.tm create mode 100644 src/bootsupport/modules/punk/path-0.2.0.tm create mode 100644 src/bootsupport/modules/punkcheck-0.2.0.tm create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.4.0.tm create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.1.tm create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.1.tm create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.2.0.tm create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.2.0.tm create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck-0.2.0.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.4.0.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.1.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.1.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.2.0.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.2.0.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck-0.2.0.tm create mode 100644 src/tests/modules/punkcheck/testsuites/punkcheck/install.test create mode 100644 src/tests/modules/punkcheck/testsuites/punkcheck/installtrack.test delete mode 100644 src/vfs/_vfscommon.vfs/modules/commandstack-0.3.tm delete mode 100644 src/vfs/_vfscommon.vfs/modules/oolib-0.1.2.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.4.0.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/doc-0.1.1.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/project-0.1.1.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/project-0.2.0.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/punk/path-0.2.0.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/punkcheck-0.2.0.tm diff --git a/scriptlib/exit.tcl b/scriptlib/exit.tcl new file mode 100644 index 00000000..bed1ee27 --- /dev/null +++ b/scriptlib/exit.tcl @@ -0,0 +1,2 @@ +#call exit with whatever we pass in. +exit {*}$::argv \ No newline at end of file diff --git a/src/AGENTS.md b/src/AGENTS.md index 6869e51f..f0b0cfbb 100644 --- a/src/AGENTS.md +++ b/src/AGENTS.md @@ -72,6 +72,7 @@ Recovery after a wrong path guess: - Review VS Code Tcl lint diagnostics before submitting new agent-produced Tcl code, but do not use lint tooling to reformat existing code. - When touching VFS payloads, describe regeneration steps in durable docs if the workflow changes. - When a tool summary reports cleanup issues such as `git diff --check` whitespace errors, verify against exact command output and exit code before running secondary scans or reporting the issue. +- `make.tcl` performs version-aware bootsupport staleness detection: major bumps abort, minor bumps prompt (y/N), patch bumps warn-and-proceed. See `src/bootsupport/AGENTS.md` "Bootsupport Staleness Handling" for the full contract and the version-bump discipline agents must follow. ## Verification diff --git a/src/bootsupport/AGENTS.md b/src/bootsupport/AGENTS.md index 0787c7c9..13bb1073 100644 --- a/src/bootsupport/AGENTS.md +++ b/src/bootsupport/AGENTS.md @@ -17,6 +17,31 @@ Modules and libraries required during the build/bootstrap/make process before th - The `include_modules.config` file controls which vendormodules are pulled into bootsupport. - Bootsupport snapshots do not use the `999999.0a1.0` source-module magic version unless explicitly copied from a source module with the prescribed workflow. +## Bootsupport Staleness Handling + +`src/make.tcl` compares each tracked bootsupport module's highest `.tm` version against the corresponding `src/modules/<...>-buildversion.txt` for these runtime-critical packages: `punkcheck`, `punk::repo`, `punk::mix`, `punk::tdl`. When the source version is higher than the bootsupport version, `make.tcl` classifies the bump level from the version delta and reacts as follows (except for the `check` command, which only reports staleness at the end of its output): + +- **Major bump** (e.g 1.x -> 2.x): abort unconditionally. Breaking change means the old bootsupport snapshot will not work. +- **Minor bump** (e.g 0.1 -> 0.2): prompt the user (y/N, default No) whether to proceed. Backward-compat aliases *should* keep old bootsupport functional, but the user must opt in. +- **Patch bump** (e.g 0.1.1 -> 0.1.2): warn and proceed. No prompt. + +The prompt is self-contained Tcl (modeled on `punk::lib::askuser` via `::punkboot::lib::bootsupport_prompt_yesno`) because it runs in the early boot phase before punk packages are guaranteed loaded. The classifier is `::punkboot::lib::bootsupport_bump_level`. + +### Version-Bump Discipline (agent-relevant) + +Because the staleness classifier keys off the version delta, under-bumping a module (e.g recording a patch bump when the call-site API actually changed) will cause `make.tcl` to mis-classify the bump and either wrongly proceed without prompting or wrongly abort. This discipline applies specifically to the four files the classifier reads — `punkcheck-buildversion.txt`, `punk/repo-buildversion.txt`, `punk/mix-buildversion.txt` (top-level `punk::mix` only, not its submodules), and `punk/tdl-buildversion.txt`. Follow the rules in `src/modules/AGENTS.md` "Versioning And Releases" exactly: + +- Call-site API change (new flags, renamed flags, changed call shapes) -> at least a **minor** bump, even if the module's own interface is unchanged. +- Backward-compatible API additions (new procs, new flags with defaults) -> **minor**. +- Bug fixes, internal refactors, docs-only updates -> **patch**. +- Breaking API changes (removed flags, changed return shapes, renamed procs without aliases) -> **major**. + +For modules outside this tracked set (including `punk::mix::util`, `punk::mix::cli`, and other `punk::mix` submodules), ordinary SemVer judgement applies instead — see `src/modules/AGENTS.md` "Versioning And Releases". `make.tcl` does not read their versions, so a behavior-preserving call-site change there is a patch, not a forced minor. + +If the set of runtime-critical packages in `make.tcl`'s `_runtime_deps` list ever grows, update this list (and the matching one in `src/modules/AGENTS.md`) so the two stay in sync. + +After changing any build-critical module (`punkcheck`, `punk::repo`, `punk::mix`, `punk::tdl`), rebuild bootsupport with `cd src && tclsh make.tcl modules && tclsh make.tcl bootsupport` so the snapshot matches the source version and staleness does not trip. + ## Work Guidance - Verify boot functionality by running `tclsh src/make.tcl packages` after any change. diff --git a/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/bootsupport/modules/punk/ansi-0.1.1.tm index 778709bb..0d105eaf 100644 --- a/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -1325,6 +1325,13 @@ tcl::namespace::eval punk::ansi { grepstr -r m -C 2 {cancelid} [s ::after] ;#with 2 lines of context and no break indicators. }]} + To match a literal string that contains regex special characters, it is in some cases easier to use the Tcl regex + quoting switch (?q) to quote the string rather than escaping each special character with a backslash. + ${[punk::args::helpers::example -syntax none { + #The following example matches a literal string that is the Tcl expansion operator {*} + grepstr "(?q){*}" $sometext + }]} + } @leaders -min 0 -max 0 diff --git a/src/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/bootsupport/modules/punk/mix/cli-0.3.1.tm index e29dd871..f952ed09 100644 --- a/src/bootsupport/modules/punk/mix/cli-0.3.1.tm +++ b/src/bootsupport/modules/punk/mix/cli-0.3.1.tm @@ -474,7 +474,7 @@ namespace eval punk::mix::cli { set defaults [list {*}{ -installer punk::mix::cli::build_modules_from_source_to_base -call-depth-internal 0 - -max_depth 1000 + -max-depth 1000 -subdirlist {} -punkcheck_eventobj "\uFFFF" -glob *.tm @@ -487,7 +487,7 @@ namespace eval punk::mix::cli { set installername [dict get $opts -installer] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set CALLDEPTH [dict get $opts -call-depth-internal] - set max_depth [dict get $opts -max_depth] + set max_depth [dict get $opts -max-depth] set subdirlist [dict get $opts -subdirlist] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set fileglob [dict get $opts -glob] @@ -533,7 +533,7 @@ namespace eval punk::mix::cli { set config [dict create {*}{ -glob $fileglob - -max_depth 0 + -max-depth 0 }] #lassign [punkcheck::start_installer_event $punkcheck_file $installername $srcdir $basedir $config] _eventid punkcheck_eventid _recordset record_list # -- --- @@ -628,11 +628,11 @@ namespace eval punk::mix::cli { # -- --- set config [dict create {*}{ -glob * - -max_depth 100 + -max-depth 100 }] set had_error 0 - # -max_depth -1 for no limit + # -max-depth -1 for no limit set build_installername pods_in_$current_source_dir set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck] #set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck stderr] ;#with debugchannel @@ -829,11 +829,11 @@ namespace eval punk::mix::cli { # -- --- set config [dict create {*}{ -glob * - -max_depth 100 + -max-depth 100 }] set had_error 0 - # -max_depth -1 for no limit + # -max-depth -1 for no limit set build_installername tarjars_in_$current_source_dir set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck] $build_installer set_source_target $current_source_dir/$modpath $buildfolder diff --git a/src/bootsupport/modules/punk/mix/cli-0.4.0.tm b/src/bootsupport/modules/punk/mix/cli-0.4.0.tm new file mode 100644 index 00000000..c3ba6efb --- /dev/null +++ b/src/bootsupport/modules/punk/mix/cli-0.4.0.tm @@ -0,0 +1,1427 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'deck 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.4.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz +package require punk::repo +package require punk::ansi +package require punkcheck ;#checksum and/or timestamp records + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#review +#deck - rename to dev +namespace eval punk::mix::cli { + namespace eval temp_import { + } + namespace ensemble create + variable initialised 0 + + #lazy _init - called by punk::mix::base::_cli when ensemble used + proc _init {args} { + variable initialised + if {$initialised} { + return + } + puts stderr "punk::mix::cli::init $args" + package require punk::overlay + namespace eval ::punk::mix::cli { + 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 + } + } + set initialised 1 + } + + 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 + } + } + + #for externally launched tclsh or punkshell running src/make.tcl the cwd + #needs to be such that make.tcl can find required bootsupport libraries without relying on auto_path or tcl::tm::list mechanisms. + #we can change directory during the run, and change back again afterwards. + + #also - if no make.tcl - can we use the running shell's make.tcl ? (after prompting user?) + + if {([file tail $sourcefolder] ne "src") || (![file exists $sourcefolder/make.tcl])} { + puts stderr "dev make must be run from src folder containing make.tcl or from within a project containing src/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 { + #review - intended usecase? + 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 + } + } + } + + #if {![catch {run --timeout=150000 -debug [info nameofexecutable] $sourcefolder/make.tcl {*}$args} exitinfo]} { + # #todo - notify if exit because of timeout! + # puts stderr "exitinfo: $exitinfo" + # set exitcode [dict get $exitinfo exitcode] + #} else { + # puts stderr "Error unable to determine exitcode. err: $exitinfo" + # #cd $startdir + # return false + #} + + #use run so that stdout visible as it goes + #review - is setting a timeout here useful? It will just be annoying if the project really does need the time. + #review - on timeout what happens? (implemented in shellfilter) + # - if just stderr/stdout redirection channels closed - what happens with stdin? + # e.g 'for dev make shell' - we just get no further responses but stdin still consuming keystrokes? + try { + #cd $sourcefolder ;#dev paths can overide bootsupport modules + cd $project_base ;#bootsupport modules only + set exitinfo [run --timeout=150000 -debug [info nameofexecutable] $sourcefolder/make.tcl {*}$args] + } trap {} {emsg eopts} { + puts stderr "Error, unable to determine exitcode. err: $emsg" + return false + } finally { + cd $startdir + } + puts stderr "exitinfo: $exitinfo" + set exitcode [dict get $exitinfo exitcode] + + 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] + return [list plain tarjar zip] + } + + proc validate_modulename {modulename args} { + set opts [list {*}{ + -errorprefix validate_modulename + -strict 0 + }] + if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"} + foreach {k v} $args { + switch -- $k { + -errorprefix - -strict { + dict set opts $k $v + } + default { + error "validate_modulename error: unknown option '$k'. known options: [dict keys $opts]" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_errorprefix [dict get $opts -errorprefix] + set opt_strict [dict get $opts -strict] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + if {$opt_strict} { + if {[regexp {[A-Z]} $modulename]} { + error "$opt_errorprefix '$modulename' contains uppercase which is not recommended as per tip 590, and option -strict is set to 1" + } + } + + validate_name_not_empty_or_spaced $modulename -errorprefix $opt_errorprefix + set testname [string map {:: {}} $modulename] + if {[string first : $testname] >=0} { + error "$opt_errorprefix '$modulename' can only contain paired colons" + } + set badchars [list - "$" "?" "*"] + foreach bc $badchars { + if {[string first $bc $modulename] >= 0} { + error "$opt_errorprefix '$modulename' can not contain character '$bc'" + } + } + return $modulename + } + proc confirm_modulename {modulename} { + set finalised 0 + set aborted 0 + while {!$finalised && !$aborted} { + #first validate with -strict 0 to confirm acceptable while ignoring case issues. + #uppercase is generally valid but not recommended - so has separate prompting. + if {[catch {validate_modulename $modulename -strict 0} errM]} { + set msg "Chosen name didn't pass validation\n" + append msg "reason: $errM\n" + append msg "Please retype the modulename. You will be given a further prompt to confirm or abort." + set modulename [util::askuser $msg] + } elseif {[regexp {[A-Z]} $modulename]} { + set msg "module names containing uppercase are not recommended (see tip 590).\n" + append msg "Please retype the module name '$modulename' to proceed.\n" + append msg "If you type it exactly as it was you will be allowed to proceed with uppercase anyway\n" + append msg "Retype it all in lowercase to use recommended naming" + set answer [util::askuser $msg] + if {[regexp {[A-Z]} $answer]} { + if {$answer eq $modulename} { + #ok - user insists + set finalised 1 + } else { + #user supplied a different uppercase name - don't set finalised so we bug them again to type it two times the same way to proceed + puts stdout "A different uppercase name was supplied - reconfirmation required." + } + set modulename $answer + } else { + #user has resupplied modulename all as lowercase + if {$answer eq [string tolower $modulename]} { + set finalised 1 + } else { + #.. but it doesn't match original - require rerun + } + set modulename $answer + } + } else { + set answer [util::askuser "Proceed with the module name '$modulename'? Y to continue N to abort"] + if {[string tolower $answer] eq "y"} { + set finalised 1 + } else { + set aborted 1 + } + } + } + if {$aborted} { + return [dict create status error reason errmsg] + } else { + return [dict create status ok modulename $modulename] + } + } + + proc validate_projectname {projectname args} { + set defaults [list {*}{ + -errorprefix projectname + }] + if {[llength $args] %2 != 0} {error "validate_projectname 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_projectname error: unknown option $k. known options: $known_opts" + } + } + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_errorprefix [dict get $opts -errorprefix] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + validate_name_not_empty_or_spaced $projectname -errorprefix $opt_errorprefix + set reserved_words [list etc lib bin modules src doc vendorlib vendormodules embedded runtime _aside _build] + if {$projectname in $reserved_words } { + error "$opt_errorprefix '$projectname' cannot be one of reserved_words: $reserved_words" + } + if {[string first "::" $projectname] >= 0} { + error "$opt_errorprefix '$projectname' cannot contain namespace separator '::'" + } + return $projectname + } + proc validate_name_not_empty_or_spaced {name args} { + set opts [list {*}{ + -errorprefix projectname + }] + if {[llength $args] %2 != 0} {error "validate_name_not_empty_or_spaced args must be name-value pairs: received '$args'"} + foreach {k v} $args { + switch -- $k { + -errorprefix { + dict set opts $k $v + } + default { + error "validate_name_not_empty_or_spaced error: unknown option $k. known options: [dict keys $opts]" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_errorprefix [dict get $opts -errorprefix] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + if {![string length $name]} { + error "$opt_errorprefix cannot be empty" + } + if {[string length [string map [list " " "" \n "" \r "" \t ""] $name]] != [string length $name]} { + error "$opt_errorprefix cannot contain whitespace" + } + return $name + } + + + 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 [punk::ansi::a+ bold yellow][dict get $repopaths warnings][punk::ansi::a] + } else { + append result [punk::ansi::a+ bold yellow][dict get $repopaths warnings][punk::ansi::a] + 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 -- [>punk . logo] " " $result] + append result \n + } + } + + set timeline [exec fossil timeline -n 5 -t ci] + set timeline [string map {\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 "\nGIT 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 "#*" "_build" "_aside" ".git" ".fossil*"] ;#exact or glob patterns for folders (at any level) we don't want to search in or copy. + 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 + -podglob #modpod-* + -tarjarglob #tarjar-* + }] + 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] + set podglob [dict get $opts -podglob] + set tarjarglob [dict get $opts -tarjarglob] + 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::tm_version_magic] ;#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] + #set installer [punkcheck::installtrack new $installername $punkcheck_file stderr] ;#with debugchannel + $installer set_source_target $srcdir $basedir + set event [$installer start_event $config] + # -- --- + + } else { + set event $opt_punkcheck_eventobj + } + #---------------------------------------- + + + set process_modules [dict create] + #put pods first in processing order + set src_pods [glob -nocomplain -dir $current_source_dir -type d -tail -- $podglob] + foreach podpath $src_pods { + dict set process_modules $podpath [dict create -type pod] + } + set src_tarjars [glob -nocomplain -dir $current_source_dir -type d -tail -- $tarjarglob] + foreach tarjarpath $src_tarjars { + dict set process_modules $tarjarpath [dict create -type tarjar] + } + set src_modules [glob -nocomplain -dir $current_source_dir -type f -tail -- $fileglob] + foreach modulepath $src_modules { + dict set process_modules $modulepath [dict create -type file] + } + + set did_skip 0 ;#flag for stdout/stderr formatting only + dict for {modpath modinfo} $process_modules { + set modtype [dict get $modinfo -type] + + set is_interesting 0 + if {[string match "foobar" $current_source_dir]} { + set is_interesting 1 + } + + #debug for issues on non-windows platforms. + #if {$::tcl_platform(platform) ne "windows"} { + # set is_interesting 1 + #} + + if {$is_interesting} { + puts "build_modules_from_source_to_base >>> module $current_source_dir/$modpath" + } + set fileparts [split [file rootname $modpath] -] + #set tmfile_versionsegment [lindex $fileparts end] + lassign [split_modulename_version $modpath] basename tmfile_versionsegment + if {$tmfile_versionsegment eq ""} { + #split_modulename_version version part will be empty if not valid tcl version + #last segment doesn't look even slightly versiony - fail. + puts stderr "ERROR: Unable to confirm file $current_source_dir/$modpath is a reasonably versioned .tm module - ABORTING." + flush stderr + after 1000 + exit 1 + } + switch -- $modtype { + pod { + puts -nonewline stderr "p-" + #basename still contains leading #modpod- + if {[string match #modpod-* $basename]} { + set basename [string range $basename 8 end] + } else { + error "build_modules_from_source_to_base, pod, unexpected basename $basename" ;#shouldn't be possible with default podglob - review - why is podglob configurable? + } + set versionfile $current_source_dir/$basename-buildversion.txt ;#needs to be added in targetset_addsource to trigger rebuild if changed (only when magicversion in use) + if {$tmfile_versionsegment eq $magicversion} { + 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 + } + } else { + set module_build_version $tmfile_versionsegment + } + + set buildfolder $current_source_dir/_build + file mkdir $buildfolder + # -- --- + set config [dict create {*}{ + -glob * + -max-depth 100 + }] + set had_error 0 + + # -max-depth -1 for no limit + set build_installername pods_in_$current_source_dir + set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck] + #set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck stderr] ;#with debugchannel + $build_installer set_source_target $current_source_dir/$modpath $buildfolder + set build_event [$build_installer start_event $config] + # -- --- + set podtree_copy $buildfolder/#modpod-$basename-$module_build_version + set modulefile $buildfolder/$basename-$module_build_version.tm + + #todo - use modpod version as a source for change detection + #package require modpod + + $build_event targetset_init INSTALL $podtree_copy + $build_event targetset_addsource $current_source_dir/$modpath + if {$tmfile_versionsegment eq $magicversion} { + $build_event targetset_addsource $versionfile + } + if {\ + [llength [dict get [$build_event targetset_source_changes] changed]]\ + || [llength [$build_event get_targets_exist]] < [llength [$build_event get_targets]]\ + } { + $build_event targetset_started + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + + set delete_failed 0 + if {[file exists $buildfolder/]} { + puts stderr "deleting existing _build copy at $podtree_copy" + if {[catch { + file delete -force $podtree_copy + } errMsg]} { + puts stderr "[punk::ansi::a+ red]deletion of _build copy at $podtree_copy failed: $errMsg[punk::ansi::a]" + set delete_failed 1 + } + } + if {!$delete_failed} { + puts stdout "copying.." + puts stdout "$current_source_dir/$modpath" + puts stdout "to:" + puts stdout "$podtree_copy" + flush stdout + file copy $current_source_dir/$modpath $podtree_copy + if {$tmfile_versionsegment eq $magicversion} { + set tmfile $buildfolder/#modpod-$basename-$module_build_version/$basename-$magicversion.tm + if {[file exists $tmfile]} { + set newname $buildfolder/#modpod-$basename-$module_build_version/$basename-$module_build_version.tm + file rename $tmfile $newname + set tmfile $newname + } + set fd [open $tmfile r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd + set data [string map [list $magicversion $module_build_version] $data] + set fdout [open $tmfile w] + fconfigure $fdout -translation binary + puts -nonewline $fdout $data + close $fdout + } + #delete and regenerate zip and modpod stubbed zip + set notes [list] + if {[catch { + file delete $buildfolder/$basename-$module_build_version.zip + } err] } { + set had_error 1 + lappend notes "zip_delete_failed" + } + if {[catch { + file delete $buildfolder/$basename-$module_build_version.tm + } err]} { + set had_error 1 + lappend notes "tm_delete_failed" + } + #create ordinary zip file without using external executable + package require punk::zip + set zipfile $buildfolder/$basename-$module_build_version.zip ;#ordinary zip file (deflate) + + #zipfs mkzip does exactly what we need anyway in this case + #unfortunately it's not available in all Tclsh versions we might be running.. + if {[llength [info commands zipfs]]} { + #zipfs mkzip (2025) doesn't add entries for folders. + #(Therefore no timestamps) + #zip reading utils generally intuit their existence and display them - but often an editor can't add comments to them + set wd [pwd] + cd $buildfolder + puts "zipfs mkzip $zipfile #modpod-$basename-$module_build_version" + zipfs mkzip $zipfile #modpod-$basename-$module_build_version + cd $wd + + } else { + #use -base $buildfolder so that -directory is included in the archive - the modpod stub relies on this - and extraction would be potentially messy otherwise + #put in an archive-level comment to aid in debugging + #punk + punk::zip::mkzip -base $buildfolder -directory $buildfolder/#modpod-$basename-$module_build_version -- $zipfile * + #punk::zip::mkzip stores permissions - (unix style) - which zipfs mkzip doesn't + #Directory ident in zipfs relies on folders ending with trailing slash - if missing, it misidentifies dirs as files. + #(ie it can't use permissions/attributes alone to determine directory vs file) + #TODO - review punk::zip::mkzip and/or external zip to provide a fallback? + #JMN25 + + #set had_error 1 + #lappend notes "zipfs_unavailable" + #puts stderr "WARNING: zipfs unavailable can't build $modulefile" + } + if {!$had_error && [file exists $zipfile]} { + package require modpod + modpod::lib::make_zip_modpod $zipfile $modulefile + } + + + if {$had_error} { + $build_event targetset_end FAILED -note [join $notes ,] + } else { + # -- ---------- + $build_event targetset_end OK + # -- ---------- + } + } else { + $build_event targetset_end FAILED -note "could not delete $podtree_copy" + } + + } else { + puts -nonewline stderr "Z" + set did_skip 1 + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $build_event targetset_end SKIPPED + } + $build_event destroy + $build_installer destroy + + #JMN - review + if {!$had_error} { + $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm + $event targetset_addsource $modulefile + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ + } { + + $event targetset_started + # -- --- --- --- --- --- + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + lappend module_list $modulefile + if {[catch { + file copy -force $modulefile $target_module_dir + } errMsg]} { + puts stderr "[punk::ansi::a+ red]FAILED to copy zip modpod module $modulefile to $target_module_dir[punk::ansi::a]" + $event targetset_end FAILED -note "could not copy $modulefile" + } else { + puts stderr "[punk::ansi::a+ green]Copied zip modpod module $modulefile to $target_module_dir[punk::ansi::a]" + # -- --- --- --- --- --- + $event targetset_end OK -note "zip modpod" + } + } else { + puts -nonewline stderr "z" + set did_skip 1 + if {$is_interesting} { + puts stderr "$modulefile [$event targetset_source_changes]" + } + $event targetset_end SKIPPED + } + } + } + tarjar { + puts -nonewline stderr "t-" + #maint - overall code structure same as pod - refactor? + #basename may still contain #tarjar- + #to be obsoleted - update modpod to (optionally) use vfs::tar ? + if {[string match #tarjar-* $basename]} { + set basename [string range $basename 8 end] + } else { + error "build_modules_from_source_to_base, tarjar, unexpected basename $basename" ;#shouldn't be possible with default tarjarglob - review - why is tarjarglob configurable? + } + set versionfile $current_source_dir/$basename-buildversion.txt ;#needs to be added in targetset_addsource to trigger rebuild if changed (only when magicversion in use) + if {$tmfile_versionsegment eq $magicversion} { + set versionfiledata "" + if {![file exists $versionfile]} { + puts stderr "\n[punk::ansi::a+ brightyellow]WARNING: Missing buildversion text file: $versionfile[punk::ansi::a]" + 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:[punk::ansi::a+ red] build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file[punk::ansi::a]" + exit 3 + } + set module_build_version $ln0 + } + } else { + set module_build_version $tmfile_versionsegment + } + + set buildfolder $current_source_dir/_build + file mkdir $buildfolder + # -- --- + set config [dict create {*}{ + -glob * + -max-depth 100 + }] + set had_error 0 + + # -max-depth -1 for no limit + set build_installername tarjars_in_$current_source_dir + set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck] + $build_installer set_source_target $current_source_dir/$modpath $buildfolder + set build_event [$build_installer start_event $config] + # -- --- + set podtree_copy $buildfolder/#tarjar-$basename-$module_build_version + set modulefile $buildfolder/$basename-$module_build_version.tm + + + $build_event targetset_init INSTALL $podtree_copy + $build_event targetset_addsource $current_source_dir/$modpath + if {$tmfile_versionsegment eq $magicversion} { + $build_event targetset_addsource $versionfile + } + if {\ + [llength [dict get [$build_event targetset_source_changes] changed]]\ + || [llength [$build_event get_targets_exist]] < [llength [$build_event get_targets]]\ + } { + $build_event targetset_started + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + + set delete_failed 0 + if {[file exists $buildfolder/]} { + puts stderr "deleting existing _build copy at $podtree_copy" + if {[catch { + file delete -force $podtree_copy + } errMsg]} { + puts stderr "[punk::ansi::a+ red]deletion of _build copy at $podtree_copy failed: $errMsg[punk::ansi::a]" + set delete_failed 1 + } + } + if {!$delete_failed} { + puts stdout "copying.." + puts stdout "$current_source_dir/$modpath" + puts stdout "to:" + puts stdout "$podtree_copy" + file copy $current_source_dir/$modpath $podtree_copy + if {$tmfile_versionsegment eq $magicversion} { + set tmfile $buildfolder/#tarjar-$basename-$module_build_version/#tarjar-loadscript-$basename.tcl + #we don't need to modify version or name of the loadscript + if {![file exists $tmfile]} { + set had_error 1 + lappend notes "tarjar_loadscript_missing" + } else { + #the loadscript must end in a line starting with # and ending with backslash - with no linefeed + set fd [open $tmfile r] + chan configure $fd -translation binary + #last line must be less than 1k long + chan seek $fd -1024 end + set script_tail [read $fd] + set lastlf [string last \n $script_tail] + set lastline [string range $script_tail $lastlf+1 end] + set lastline [string trimleft $lastline] ;#lhs whitespace is ok + if {[string index $lastline 0] ne "#" || [string index $lastline end] ne "\\" } { + set had_error 1 + lappend notes "tarjar_loadscript_badtail" + } + } + } + #delete and regenerate .tm + set notes [list] + if {[catch { + file delete $buildfolder/$basename-$module_build_version.tm + } err]} { + set had_error 1 + lappend notes "tm_delete_failed" + } + #create ordinary tar file without using external executable + package require tar ;#tcllib + set tarfile $buildfolder/$basename-$module_build_version.tm ;#ordinary tar file (no compression - store) + set wd [pwd] + cd $buildfolder + puts "tar::create $tarfile #tarjar-$basename-$module_build_version" + if {[catch { + tar::create $tarfile #tarjar-$basename-$module_build_version + } errMsg]} { + set had_error 1 + puts stderr "tar::create $tarfile failed with msg\n $errMsg" + lappend notes "tar_create_failed" + } + cd $wd + + if {![file exists $tarfile]} { + set had_error 1 + lappend notes "tar_result_missing" + } + + + if {$had_error} { + $build_event targetset_end FAILED -note [join $notes ,] + } else { + # -- ---------- + $build_event targetset_end OK + # -- ---------- + } + } else { + $build_event targetset_end FAILED -note "could not delete $podtree_copy" + } + + } else { + puts -nonewline stderr "T" + set did_skip 1 + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $build_event targetset_end SKIPPED + } + $build_event destroy + $build_installer destroy + + #JMN - review + if {!$had_error} { + $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm + $event targetset_addsource $modulefile + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ + } { + + $event targetset_started + # -- --- --- --- --- --- + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + lappend module_list $modulefile + if {[catch { + file copy -force $modulefile $target_module_dir + } errMsg]} { + puts stderr "[punk::ansi::a+ red]FAILED to copy tarjar module $modulefile to $target_module_dir[punk::ansi::a]" + $event targetset_end FAILED -note "could not copy $modulefile" + } else { + puts stderr "[punk::ansi::a+ green]Copied tarjar module $modulefile to $target_module_dir[punk::ansi::a]" + # -- --- --- --- --- --- + $event targetset_end OK -note "tarjar" + } + } else { + puts -nonewline stderr "t" + set did_skip 1 + if {$is_interesting} { + puts stderr "$modulefile [$event targetset_source_changes]" + } + $event targetset_end SKIPPED + } + } + + } + file { + puts -nonewline stderr "f-" + set m $modpath + if {$tmfile_versionsegment eq $magicversion} { + #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]} { + #rebuilding the .tm from the #tarjar already handled above + puts -nonewline stderr "-" + + #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? + + ##TODO + #set buildfolder $current_sourcedir/_build + #file mkdir $buildfolder + + #set tmfile $buildfolder/$basename-$module_build_version.tm + #file delete -force $buildfolder/#tarjar-$basename-$module_build_version + #file delete -force $tmfile + + + #file copy -force $current_source_dir/#tarjar-$basename-$magicversion $buildfolder/#tarjar-$basename-$module_build_version + ## + ##bsdtar doesn't seem to work.. or I haven't worked out the right options? + ##exec tar -cvf $buildfolder/$basename-$module_build_version.tm $buildfolder/#tarjar-$basename-$module_build_version + #package require tar + #tar::create $tmfile $buildfolder/#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 { + if {$is_interesting} { + puts stdout "skipping module $current_source_dir/$m - no change in sources detected" + } + puts -nonewline stderr "m" + set did_skip 1 + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $event targetset_end SKIPPED + } + + #------------------------------ + + } + + continue + } + ##------------------------------ + ## + #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} + lappend module_list $current_source_dir/$m + file copy -force $current_source_dir/$m $target_module_dir + puts stderr "Copied already versioned module $current_source_dir/$m to $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 "f" + set did_skip 1 + if {$is_interesting} { + puts stderr "$current_source_dir/$m [$event targetset_source_changes]" + } + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $event targetset_end SKIPPED + } + } + } + } ;#end dict for {modpath modinfo} $process_modules + + + if {$CALLDEPTH >= $max_depth} { + set subdirs [list] + } else { + set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] + set targets_existing [glob -nocomplain -dir $target_module_dir -type d -tail {*}$subdirs] + } + #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 + #} + if {$d ni $targets_existing} { + 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\ + -podglob $podglob\ + ] + } + 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 + dict for {p b} $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] + dict for {r -} $::kettle::recipe::recipe { + if {$r ni $standard_recipes} { + dict unset ::kettle::recipe::recipe $r + } + } + } + proc kettle_call {calltype args} { + variable kettle_reset_bodies + switch -- $calltype { + lib {} + shell { + #on windows - could be kettle.bat or kettle.cmd - use auto_execok to find, whatever the platform. + #for now, restrict to version sitting next to exe - REVIEW + set exedir [file dirname [info nameofexecutable]] + set kettlescript [auto_execok $exedir/kettle] + if {$kettlescript eq ""} { + error "kettle_call unable to find installed kettle application file in '$exedir'" + } + + #set kettleappfile [file dirname [info nameofexecutable]]/kettle + #set kettlebatfile [file dirname [info nameofexecutable]]/kettle.bat + + #if {(![file exists $kettleappfile]) && (![file exists $kettlebatfile])} { + # error "deck 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 + # } + #} + } + default { + error "deck kettle_call 1st argument must be one of: 'lib' for direct use of kettle module or 'shell' to call as separate process" + } + } + set startdir [pwd] + if {![file exists $startdir/build.tcl]} { + error "deck 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 "deck 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 (deck)] + } + 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 + #load standard recipes as listed in build.tcl + ::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 + } + + } + proc kettle_punk_recipes {} { + set txtdst ... + } + + } +} + + +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 + if {[catch { + punk::overlay::custom_from_base [namespace current] ::punk::mix::base + } errM]} { + puts stderr "punk::mix::cli load error: Failed to overlay punk::mix::base $errM" + error "punk::mix::cli error: $errM" + } +} + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::cli [namespace eval punk::mix::cli { + variable version + set version 0.4.0 +}] +return diff --git a/src/bootsupport/modules/punk/mix/commandset/doc-0.1.1.tm b/src/bootsupport/modules/punk/mix/commandset/doc-0.1.1.tm new file mode 100644 index 00000000..379adbae --- /dev/null +++ b/src/bootsupport/modules/punk/mix/commandset/doc-0.1.1.tm @@ -0,0 +1,324 @@ +# -*- 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.1 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + +package require punk::path ;# for treefilenames, relative +package require punk::repo +package require punk::docgen ;#inline doctools - generate doctools .man files at src/docgen prior to using kettle to producing .html .md etc +package require punk::mix::cli ;#punk::mix::cli::lib used for kettle_call +#package require punkcheck ;#for path_relative + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +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" + puts "commands: doc.status" + } + + 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 + } + #user may delete the comment containing "--- punk::docgen::overwrites" and then manually edit, and we won't overwrite + #we still generate output in src/docgen so user can diff and manually update if thats what they prefer + set oldfiles [punk::path::treefilenames -dir $projectdir/src/doc _module_*.man] + foreach maybedoomed $oldfiles { + set fd [open $maybedoomed r] + chan conf $fd -translation binary + set data [read $fd] + close $fd + if {[string match "*--- punk::docgen overwrites *" $data]} { + file delete -force $maybedoomed + } + } + set generated [lib::do_docgen modules] + if {[dict get $generated count] > 0} { + #review + set doclist [dict get $generated docs] + set source_base [dict get $generated base] + set target_base $projectdir/src/doc + foreach dinfo $doclist { + lassign $dinfo module fpath + set relpath [punk::path::relative $source_base $fpath] + set relfolder [file dirname $relpath] + if {$relfolder eq "."} { + set relfolder "" + } + file mkdir [file join $target_base $relfolder] + set target [file join $target_base $relfolder _module_[file tail $fpath]] + puts stderr "target --> $target" + if {![file exists $target]} { + file copy $fpath $target + } + } + } + + 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 { + if {"::meta" eq [info commands ::meta]} { + puts stderr "There appears to be a leftover ::meta command which is presumed to be from doctools. Destroying object" + ::meta destroy + } + 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 {args} { + set argd [punk::args::parse $args withdef { + @id -id ::punk::mix::commandset::doc::validate + -- -type none -optional 1 -help "end of options marker --" + -individual -type boolean -default 1 + @values -min 0 -max -1 + patterns -default {*.man} -type any -multiple 1 + }] + set opt_individual [tcl::dict::get $argd opts -individual] + set patterns [tcl::dict::get $argd values patterns] + + + #todo - run and validate punk::docgen output + 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] + set docroot $projectdir/src/doc + cd $docroot + + if {!$opt_individual && "*.man" in $patterns} { + if {[catch { + dtplite validate $docroot + } errM]} { + puts stderr "commandset::doc::validate failed for projectdir '$projectdir'" + puts stderr "docroot '$docroot'" + puts stderr "dtplite error was: $errM" + } + } else { + foreach p $patterns { + set treefiles [punk::path::treefilenames $p] + foreach path $treefiles { + puts stdout "dtplite validate $path" + dtplite validate $path + } + } + } + + #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 + proc do_docgen {{project_subpath modules}} { + #Extract doctools comments from source code + set projectdir [punk::repo::find_project] + set output_base [file join $projectdir src docgen] + set codesource_path [file join $projectdir $project_subpath] + if {![file isdirectory $codesource_path]} { + puts stderr "WARNING punk::mix::commandset::doc unable to find codesource_path $codesource_path during do_docgen - skipping inline doctools generation" + return + } + if {[file isdirectory $output_base]} { + if {[catch { + file delete -force $output_base + }]} { + error "do_docgen failed to delete existing output base folder: $output_base" + } + } + file mkdir $output_base + + set matched_paths [punk::path::treefilenames -dir $codesource_path -exclude-paths {**/mix/templates/** **/project_layouts/** **/decktemplates/** **/_aside **/_aside/**} *.tm] + set count 0 + set newdocs [list] + set docgen_header_comments "" + append docgen_header_comments {[comment {--- punk::docgen generated from inline doctools comments ---}]} \n + append docgen_header_comments {[comment {--- punk::docgen DO NOT EDIT DOCS HERE UNLESS YOU REMOVE THESE COMMENT LINES ---}]} \n + append docgen_header_comments {[comment {--- punk::docgen overwrites this file ---}]} \n + foreach fullpath $matched_paths { + puts stdout "do_docgen processing: $fullpath" + set doctools [punk::docgen::get_doctools_comments $fullpath] + if {$doctools ne ""} { + set fname [file tail $fullpath] + set mod_tail [file rootname $fname] + set relpath [punk::path::relative $codesource_path [file dirname $fullpath]] + if {$relpath eq "."} { + set relpath "" + } + set tailsegs [file split $relpath] + set module_fullname [join $tailsegs ::]::$mod_tail + set target_docname $fname.man + set this_outdir [file join $output_base $relpath] + + if {[string length $fname] > 99} { + #output needs to be tarballed to do checksum change tests in a reasonably straightforward and not-too-terribly slow way. + #hack - review. Determine exact limit - test if tcllib tar fixed or if it's a limit of the particular tar format + #work around tcllib tar filename length limit ( somewhere around 100?) This seems to be a limit on the length of a particular segment in the path.. not whole path length? + #this case only came up because docgen used to path munge to long filenames - but left because we know there is a limit and renaming fixes it - even if it's ugly - but still allows doc generation. + #review - if we're checking fname - should also test length of whole path and determine limits for tar + package require md5 + if {[package vsatisfies [package present md5] 2- ] } { + set md5opt "-hex" + } else { + set md5opt "" + } + set target_docname [md5::md5 {*}$md5opt [encoding convertto utf-8 $fullpath]]_overlongfilename.man + puts stderr "WARNING - overlong file name - renaming $fullpath" + puts stderr " to [file dirname $fullpath]/$target_docname" + } + + file mkdir $this_outdir + puts stdout "saving [string length $doctools] bytes of doctools output from file $relpath/$fname" + set outfile [file join $this_outdir $target_docname] + set fd [open $outfile w] + fconfigure $fd -translation binary + puts -nonewline $fd $docgen_header_comments$doctools + close $fd + incr count + lappend newdocs [list $module_fullname $outfile] + } + } + return [list count $count docs $newdocs base $output_base] + } + + } +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## 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.1 +}] +return \ No newline at end of file diff --git a/src/bootsupport/modules/punk/mix/commandset/project-0.1.1.tm b/src/bootsupport/modules/punk/mix/commandset/project-0.1.1.tm new file mode 100644 index 00000000..cb395eaa --- /dev/null +++ b/src/bootsupport/modules/punk/mix/commandset/project-0.1.1.tm @@ -0,0 +1,1178 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'deck 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.1 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::mix::commandset::project 0 0.1.1] +#[copyright "2023"] +#[titledesc {dec commandset - project}] [comment {-- Name section and table of contents description --}] +#[moddesc {deck CLI commandset - project}] [comment {-- Description at end of page heading --}] +#[require punk::mix::commandset::project] +#[description] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::mix::commandset::project +#[para]Import into an ensemble namespace similarly to the way it is done with punk::mix::cli e.g +#[example { +# namespace eval myproject::cli { +# namespace export * +# namespace ensemble create +# package require punk::overlay +# +# 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 +# } +#}] +#[para] Where the . in the above example is the prefix/command separator +#[para]The prefix ('project' in the above example) can be any string desired to disambiguate commands imported from other commandsets. +#[para]The above results in the availability of the ensemble command: ::myproject::cli project.new, which is implemented in ::punk::mix::commandset::project::new +#[para]Similarly, procs under ::punk::mix::commandset::project::collection will be available as subcommands of the ensemble as projects. +#[para] +#[subsection Concepts] +#[para] see punk::overlay + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::mix::commandset::project +#[list_begin itemized] + +package require Tcl 8.6- +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package punk::ns] +#[item] [package sqlite3] (binary) +#[item] [package overtype] +#[item] [package textutil] (tcllib) + + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::mix::commandset::project { + namespace export * + #*** !doctools + #[subsection {Namespace punk::mix::commandset::project}] + #[para] core commandset functions for punk::mix::commandset::project + #[list_begin definitions] + + proc _default {} { + package require punk::ns + set dispatched_to [lindex [info level 2] 0] ;#e.g ::punk::mix::cli::project + set dispatch_tail [punk::ns::nstail $dispatched_to] + set dispatch_ensemble [punk::ns::nsprefix $dispatched_to] ;#e.g ::punk::mix::cli + set sibling_commands [namespace eval $dispatch_ensemble {namespace export}] + #todo - get separator? + set sep "." + set result [list] + foreach sib $sibling_commands { + if {[string match ${dispatch_tail}${sep}* $sib]} { + lappend result $sib + } + } + return [lsort $result] + } + + + namespace eval argdoc { + set layout_dict [punk::cap::call_handler punk.templates get_itemdict_projectlayouts] + variable LAYOUTNAMES [dict keys $layout_dict] + } + punk::args::define { + @id -id ::punk::mix::commandset::project::new + @cmd -name "punk::mix::commandset::project::new" -help\ + "" + @leaders -min 1 -max 1 + project -type string -help\ + "Project name or path. + If just a name is given ... (todo)" + @opts + -type -default plain + -empty -default 0 -type boolean + -force -default 0 -type boolean + -update -default 0 -type boolean + -confirm -default 1 -type boolean + -layout -default "punk.project" -choices {${$::punk::mix::commandset::project::argdoc::LAYOUTNAMES}} + } + + proc new {newprojectpath_or_name args} { + #*** !doctools + # [call [fun new] [arg newprojectpath_or_name] [opt args]] + #new project structure - may be dedicated to one module, or contain many. + #create minimal folder structure only by specifying in args: -modules {} + 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 -errorprefix "punk mix project.new" + + + set defaults [list\ + -type plain\ + -empty 0\ + -force 0\ + -update 0\ + -confirm 1\ + -modules \uFFFF\ + -layout punk.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 "deck 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_layout [dict get $opts -layout] + set opt_update [dict get $opts -update] + # -- --- --- --- --- --- --- --- --- --- --- --- --- + 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 + if {$opt_force || $opt_update} { + #generally undesirable to add default project module during an update. + #user can use dev module.new manually or supply module name in -modules + set opt_modules [list] + } else { + set opt_modules [list [string tolower $projectname]] ;#default modules to lowercase as is the modern (tip 590) recommendation for Tcl + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- + + + #todo - install support binaries on a per-project basis in a way that doesn't impact machine (e.g not added to path) - cache in user config dir if possible, supply mechanism to clear cache + # + 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 deck features." + if {[string length [set scoop_prog [auto_execok scoop]]]} { + #restrict to windows? + set answer [util::askuser "scoop detected. Would you like deck 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 "-------------------------------------------" + } + + + package require punk::cap + if {[punk::cap::capability_has_handler punk.templates]} { + set layout_dict [punk::cap::call_handler punk.templates get_itemdict_projectlayouts] + } else { + put stderr "commandset::project::new WARNING - no handler available for the 'punk.templates' capability - template providers will be unable to provide layout locations" + return + } + if {[dict exists $layout_dict $opt_layout]} { + set layout_name $opt_layout + set layout_info [dict get $layout_dict $layout_name] + set layout_path [dict get $layout_info path] + set layout_sourceinfo [dict get $layout_info sourceinfo] + } else { + puts stderr "commandset::project::new - no exact match for specified layout-name $opt_layout found" + puts stderr "layout names found: [dict keys $layout_dict]" + return + + #todo - pick highest version layout that matches opt_layout if version not specified but multiple exist + + #set layout_name ... + #set layout_info .. + #set layout_path ... + } + + + + #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 $layout_path 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} { + set warnmsg "mix new WARNING: -update 1 was supplied. Will copy layout $layout_path using -update option to add missing items" + if {$opt_confirm} { + puts stderr $warnmsg + set msg "Do you want to proceed to possibly overwrite some existing files in $projectdir? Y|N" + set answer [util::askuser $msg] + 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 prompt." + return + } + } + puts stderr $warnmsg + } + + 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 + } + #review + set fossil_repo_file $repodb_folder/$projectname.fossil + } + + 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 + + puts stdout ">>> about to call punkcheck::install $layout_path $projectdir" + set resultdict [dict create] + set antipaths [list {*}{ + src/doc/* + src/doc/include/* + src/PROJECT_LAYOUTS_* + }] + + #set exclude_paths [list {*}{ + # _ignore_* + # **/_ignore_* + #}] + set exclude_paths [list {*}{ + }] + + #default -exclude-paths-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_path $projectdir -installer project.new -createempty 1 -overwrite ALL-TARGETS -exclude-paths [concat $antipaths $exclude_paths]] + } else { + puts stdout "copying layout files - (if source file changed)" + set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite installedsourcechanged-targets -exclude-paths [concat $antipaths $exclude_paths]] + } + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + + if {[file exists $layout_path/src/doc]} { + puts stdout "copying layout src/doc files (if target missing)" + set resultdict [punkcheck::install $layout_path/src/doc $projectdir/src/doc -createdir 1 -punkcheck-folder $projectdir -installer project.new -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no src/doc in source template - update not required" + } + + #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 exclude-paths_core - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized. + ## default_excludepaths_core [list "#*" "**/#*" "_aside" "**/_aside" "_build" "**/_build" ".git" "**/.git" ".fossil*" "**/.fossil*"] + set override_excludepaths_core [list #* **/#* _aside **/_aside .git **/.git] + if {[file exists $layout_path/.fossil-custom]} { + puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)" + set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -createempty 1 -punkcheck-folder $projectdir -installer project.new -exclude-paths-core $override_excludepaths_core -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no .fossil-custom in source template - update not required" + } + + if {[file exists $layout_path/.fossil-settings]} { + puts stdout "copying layout src/.fossil-settings files (if target missing or uncustomised)" + set resultdict [punkcheck::install $layout_path/.fossil-settings $projectdir/.fossil-settings -createdir 1 -createempty 1 -punkcheck-folder $projectdir -installer project.new -exclude-paths-core $override_excludepaths_core -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no .fossil-settings in source template - update not required" + } + + #scan all files in template + # + #TODO - deck command to substitute templates? + set templateinfo_list [punk::mix::commandset::layout::lib::layout_scan_for_template_files $opt_layout] + set stripprefix [file normalize $layout_path] + + set tagmap [list [lib::template_tag project] $projectname] + if {[llength $templateinfo_list]} { + puts stdout "Filling template file placeholders with the following tag map:" + foreach {placeholder value} $tagmap { + puts stdout " $placeholder -> $value" + } + } + foreach templateinfo $templateinfo_list { + lassign $templateinfo templatefullpath template_tagnames_found + set templatetail [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] + set fpath [file join $projectdir $templatetail] + foreach t $template_tagnames_found { + if {"%$t%" ni [dict keys $tagmap]} { + puts stderr "warning: No substitution available for tag: %$t% in $fpath" + } + } + + if {[file exists $fpath]} { + set fd [open $fpath r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd + set data2 [string map $tagmap $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" + } + } + + ::cd $projectdir + + if {[file exists $projectdir/src/modules]} { + foreach m $opt_modules { + #check if mod-ver.tm file or #modpod-mod-ver folder exist + set tmfile $projectdir/src/modules/$m-[punk::mix::util::tm_version_magic].tm + set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::tm_version_magic]/$m-[punk::mix::util::tm_version_magic].tm + + set has_tm [file exists $tmfile] + set has_pod [file exists $podfile] + #puts stderr "=====> has_tm: $has_tm has_pod: $has_pod" + if {!$has_tm && !$has_pod} { + #todo - option for -module_template - and check existence at top? or change opt_modules to be a list of dicts with configuration info -template -type etc + punk::mix::commandset::module::new -project $projectname -type $opt_type $m + } else { + #we should rarely if ever want to force any src/modules to be overwritten + if {$opt_force} { + if {$has_pod} { + set answer [util::askuser "OVERWRITE the src/modules file $podfile ?? (generally not desirable) Y|N"] + set overwrite_type zip + } else { + set answer [util::askuser "OVERWRITE the src/modules file $tmfile ?? (generally not desirable) Y|N"] + set overwrite_type $opt_type + } + if {[string tolower $answer] eq "y"} { + #REVIEW - all pods zip - for now + punk::mix::commandset::module::new -project $projectname -type $overwrite_type -force 1 $m + } + } + } + } + } 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" + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::mix::commandset::project ---}] + + namespace eval collection { + #*** !doctools + #[subsection {Namespace punk::mix::commandset::project::collection}] + #[para] commandset functions for operating with multiple projects. + #[para] It would usually be imported with the prefix "projects" and separator "." to result in commands such as: projects.detail + #[list_begin definitions] + namespace export * + namespace path [namespace parent] + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::_default + @cmd -name "punk::mix::commandset::project::collection::_default"\ + -summary\ + "List projects under fossil managment."\ + -help\ + "List projects under fossil management, showing fossil db location and number of checkouts" + @values -min 0 -max -1 + glob -type string -multiple 1 -default * + } + #e.g imported as 'projects' + proc _default {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::_default] + set globlist [dict get $argd values glob] + + #*** !doctools + #[call [fun _default] [arg glob...]] + #[para]List projects under fossil management, showing fossil db location and number of checkouts + #[para]The glob argument is optional unless option/value pairs are also supplied, in which case * should be explicitly supplied + #[para]glob restricts output based on the name of the fossil db file e.g s* for all projects beginning with s + #[para]The _default function is made available in the ensemble by the name of the prefix used when importing the commandset. + #[para]e.g + #[para] punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection + #[para]Will result in the command being available as projects + package require overtype + set db_projects [lib::get_projects {*}$globlist] + 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 Repo 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] {string length $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] + set file_idx 0 + foreach dbfile $col1_dbfiles { + set project_name "" + set project_code "" + set project_desc "" + set db_error "" + if {[file exists $dbfile]} { + if {[catch { + 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) + } + } + } errM]} { + set db_error $errM + } + catch {dbp close} + } else { + set db_error "fossil file $dbfile missing" + } + lappend col4_pnames $project_name + lappend col5_pcodes $project_code + dict lappend codes $project_code $dbfile + lappend col7_pdescs $project_desc + if {$db_error ne ""} { + lset col1_dbfiles $file_idx "[a+ web-red]$dbfile[a]" + } + incr file_idx + } + + 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 Repo 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] {string length $v}]] + set col3 [string repeat " " $widest3] + set title4 "Project Name" + set widest4 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col4_pnames] {string length $v}]] + set col4 [string repeat " " $widest4] + set title5 "Project Code" + set widest5 [tcl::mathfunc::max {*}[lmap v [concat [list $title5] $col5_pcodes] {string length $v}]] + set col5 [string repeat " " $widest5] + set title6 "Dup" + set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col6_dupids] {string length $v}]] + set col6 [string repeat " " $widest6] + set title7 "Description" + #set widest7 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col7_pdescs] {string length $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]] + } + + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::work + @cmd -name punk::mix::commandset::project::collection::work\ + -summary\ + "List projects with checkout directories."\ + -help\ + "Get project info by opening the central fossil config-db to determine + fossil database files for each project, and the known checkout folders. + If -detail is true, a second operation gathers file state information + for each checkout folder." + @leaders -min 0 -max 0 + -cd -type none -help\ + "If this flag is provided, after lsting, prompt the user to enter + the row number of the checkout to 'cd' into, or an option to cancel. + If there is only one project with only a single checkout, the + cd operation will occur without prompting unless -prompt was + also supplied." + -prompt -type none -help\ + "If there is only one checkout in the result, cause a prompt to be + raised instead of automatically peforming the cd operation. + Has no effect if -cd was not supplied, or if -cd is supplied and + there are multiple checkouts, in which case user is always prompted." + -detail -type boolean -default 0 -help\ + "Include file state information for each checkout in the resulting + table. This includes information such as which files are changed, + unchanged,new,missing or extra and can take a little more time to + gather as it must examine the filesystem for each checkout folder. + + Note that although the default is false - if only a single project + matches the glob pattern(s) then file state will be gathered for + each of its checkouts. Use an explicit -detail 0 if this is not + desired." + @values -min 0 -max -1 + glob -type string -multiple 1 -default * -optional 1 -help\ + "glob patterns used to search for project. The glob is applied against + the names of the fossil repository database files - not the project-name, + which is not available in the central fossil config-db. + Case insensitive." + } + proc work {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] + lassign [dict values $argd] leaders opts values received + package require sqlite3 + set globlist [dict get $values glob] + + set db_projects [lib::get_projects {*}$globlist] + #list of lists of the form: + #{fosdb fname workdirlist} + if {[llength $db_projects] == 0} { + puts stderr "::punk::mix::commandset::project::work No Repo DB name matches found for '$globlist'" + return "" + } + # -- --- --- --- --- --- --- + set opt_cd [dict exists $received -cd] + # -- --- --- --- --- --- --- + set opt_detail [dict get $opts -detail] + if {[dict exists $received -detail] && !$opt_detail} { + set opt_detail_explicit_zero 1 + } else { + set opt_detail_explicit_zero 0 + } + set opt_prompt [dict exists $received -prompt] + # -- --- --- --- --- --- --- + 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 and opt_detail is 0 and not explicit - retrieve workingdir state for each co + if {([llength [dict keys $fosdb_cache]] == 1)} { + if {!$opt_detail_explicit_zero} { + set opt_detail 1 + } + puts stderr "Result is from a single repo db [dict keys $fosdb_cache]" + } + if {$opt_detail} { + if {!$opt_detail_explicit_zero} { + set detailmsg "Use -detail 0 to omit file state" + } else { + set detailmsg "" + } + puts stderr "Gathering file state for [llength $workdirs] checkout folder(s). $detailmsg" + set c_rev [list] + set c_rev_iso [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_rev_iso [dict get $state_dict revision_iso8601] + 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 t0b "Revision iso8601" + set w0b [tcl::mathfunc::max {*}[lmap v [concat [list $t0] $c_rev_iso] {string length $v}]] + set c0b [string repeat " " $w0b] + 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::left $c0b $t0b] [overtype::right $c1 $t1] [overtype::right $c2 $t2] [overtype::right $c3 $t3] [overtype::right $c4 $t4] [overtype::right $c5 $t5]" + foreach r $c_rev iso $c_rev_iso u $c_unchanged c $c_changed n $c_new m $c_missing e $c_extra { + lappend col_states "[overtype::left $c0 $r] [overtype::left $c0b $iso] [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 "Repo 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 { + if {![file exists $wd]} { + set row [punk::ansi::a+ strike red]$row[a] + set wd [punk::ansi::a+ red]$wd[a] + } + 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 { + if {![file exists $wd]} { + set row [punk::ansi::a+ strike red]$row[a] + set wd [punk::ansi::a+ red]$wd[a] + } + 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 && !$opt_prompt} { + 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 [deck stat] + return $workingdir + } + } + } + return $msg + } + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::cd + @cmd -name punk::mix::commandset::project::collection::cd\ + -summary\ + "List projects with checkout directories and prompt for which checkout to cd to."\ + -help\ + "List projects with checkout directories and prompt for which checkout to cd to." + @leaders -min 0 -max 0 + }\ + [punk::args::resolved_def -types opts ::punk::mix::commandset::project::collection::work -detail]\ + { + -prompt -type none -help\ + "Prompt even when result contains only one checkout location as a possible cd target. + User will always be prompted if result contains more than one checkout." + @values -min 0 -max -1 + }\ + [punk::args::resolved_def -types values ::punk::mix::commandset::project::collection::work glob] + + proc cd {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] + work -cd {*}$args + } + + #*** !doctools + #[list_end] [comment {-- end collection namespace definitions --}] + } + + namespace eval lib { + proc template_tag {tagname} { + #todo - support different tagwrappers - it shouldn't be so likely to collide with common code idioms etc. + #we need to detect presence of tags intended for punk::mix system + #consider using punk::cap to enable multiple template-substitution providers with their own set of tagnames and/or tag wrappers, where substitution providers are all run + return [string cat % $tagname %] + } + punk::args::define { + @id -id ::punk::mix::commandset::project::lib::get_projects + @cmd -name punk::mix::commandset::project::lib::get_projects\ + -summary\ + "Return a 3-element list of projects referred to by central fossil config-db."\ + -help\ + "Get project info only by opening the central fossil config-db. + Each member of the returned list is a 3-element list of: + + The shortname is simply the name based on the root name of the fossil database, + it is not necessarily the project-name by which the project is referred to in the fossil + checkout databases." + @values -min 0 -max -1 + glob -type string -multiple 1 -default * -optional 1 -help\ + "case insensitive glob for the name of the fossil database." + } + proc get_projects {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::lib::get_projects] + set globlist [dict get $argd values glob] + + set fossil_prog [auto_execok fossil] + + set configdb [punk::repo::fossil_get_configdb] + + package require sqlite3 + ::sqlite3 fosconf $configdb + #set testresult [fosconf eval {select name,value from global_config;}] + #puts stderr $testresult + #list of repositories of the form repo: + #eg repo:C:/Users/someone/.fossils/tcl.fossil + + #the command: + # fossil all ignore /repo.fossil + #will remove the {repo:/repo.fossil 1} record from global_config + #but it leaves {ckout: /repo.fossil} records, even if such checkouts are closed + #when the folder itself at is removed - then commands such as 'fossil all ls -c' automatically remove the corresponding ckout: record. + + 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;}] + #list of entries like "ckout:C:/buildtcl/2024zig/tcl90/" + 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 -nocase -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 + } + + } + + + +} + + +#*** !doctools +#[manpage_end] + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::commandset::project [namespace eval punk::mix::commandset::project { + variable version + set version 0.1.1 +}] +return diff --git a/src/bootsupport/modules/punk/mix/commandset/project-0.2.0.tm b/src/bootsupport/modules/punk/mix/commandset/project-0.2.0.tm new file mode 100644 index 00000000..c48c95b9 --- /dev/null +++ b/src/bootsupport/modules/punk/mix/commandset/project-0.2.0.tm @@ -0,0 +1,1178 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'deck 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.2.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::mix::commandset::project 0 0.2.0] +#[copyright "2023"] +#[titledesc {dec commandset - project}] [comment {-- Name section and table of contents description --}] +#[moddesc {deck CLI commandset - project}] [comment {-- Description at end of page heading --}] +#[require punk::mix::commandset::project] +#[description] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::mix::commandset::project +#[para]Import into an ensemble namespace similarly to the way it is done with punk::mix::cli e.g +#[example { +# namespace eval myproject::cli { +# namespace export * +# namespace ensemble create +# package require punk::overlay +# +# 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 +# } +#}] +#[para] Where the . in the above example is the prefix/command separator +#[para]The prefix ('project' in the above example) can be any string desired to disambiguate commands imported from other commandsets. +#[para]The above results in the availability of the ensemble command: ::myproject::cli project.new, which is implemented in ::punk::mix::commandset::project::new +#[para]Similarly, procs under ::punk::mix::commandset::project::collection will be available as subcommands of the ensemble as projects. +#[para] +#[subsection Concepts] +#[para] see punk::overlay + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::mix::commandset::project +#[list_begin itemized] + +package require Tcl 8.6- +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package punk::ns] +#[item] [package sqlite3] (binary) +#[item] [package overtype] +#[item] [package textutil] (tcllib) + + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::mix::commandset::project { + namespace export * + #*** !doctools + #[subsection {Namespace punk::mix::commandset::project}] + #[para] core commandset functions for punk::mix::commandset::project + #[list_begin definitions] + + proc _default {} { + package require punk::ns + set dispatched_to [lindex [info level 2] 0] ;#e.g ::punk::mix::cli::project + set dispatch_tail [punk::ns::nstail $dispatched_to] + set dispatch_ensemble [punk::ns::nsprefix $dispatched_to] ;#e.g ::punk::mix::cli + set sibling_commands [namespace eval $dispatch_ensemble {namespace export}] + #todo - get separator? + set sep "." + set result [list] + foreach sib $sibling_commands { + if {[string match ${dispatch_tail}${sep}* $sib]} { + lappend result $sib + } + } + return [lsort $result] + } + + + namespace eval argdoc { + set layout_dict [punk::cap::call_handler punk.templates get_itemdict_projectlayouts] + variable LAYOUTNAMES [dict keys $layout_dict] + } + punk::args::define { + @id -id ::punk::mix::commandset::project::new + @cmd -name "punk::mix::commandset::project::new" -help\ + "" + @leaders -min 1 -max 1 + project -type string -help\ + "Project name or path. + If just a name is given ... (todo)" + @opts + -type -default plain + -empty -default 0 -type boolean + -force -default 0 -type boolean + -update -default 0 -type boolean + -confirm -default 1 -type boolean + -layout -default "punk.project" -choices {${$::punk::mix::commandset::project::argdoc::LAYOUTNAMES}} + } + + proc new {newprojectpath_or_name args} { + #*** !doctools + # [call [fun new] [arg newprojectpath_or_name] [opt args]] + #new project structure - may be dedicated to one module, or contain many. + #create minimal folder structure only by specifying in args: -modules {} + 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 -errorprefix "punk mix project.new" + + + set defaults [list\ + -type plain\ + -empty 0\ + -force 0\ + -update 0\ + -confirm 1\ + -modules \uFFFF\ + -layout punk.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 "deck 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_layout [dict get $opts -layout] + set opt_update [dict get $opts -update] + # -- --- --- --- --- --- --- --- --- --- --- --- --- + 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 + if {$opt_force || $opt_update} { + #generally undesirable to add default project module during an update. + #user can use dev module.new manually or supply module name in -modules + set opt_modules [list] + } else { + set opt_modules [list [string tolower $projectname]] ;#default modules to lowercase as is the modern (tip 590) recommendation for Tcl + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- + + + #todo - install support binaries on a per-project basis in a way that doesn't impact machine (e.g not added to path) - cache in user config dir if possible, supply mechanism to clear cache + # + 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 deck features." + if {[string length [set scoop_prog [auto_execok scoop]]]} { + #restrict to windows? + set answer [util::askuser "scoop detected. Would you like deck 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 "-------------------------------------------" + } + + + package require punk::cap + if {[punk::cap::capability_has_handler punk.templates]} { + set layout_dict [punk::cap::call_handler punk.templates get_itemdict_projectlayouts] + } else { + put stderr "commandset::project::new WARNING - no handler available for the 'punk.templates' capability - template providers will be unable to provide layout locations" + return + } + if {[dict exists $layout_dict $opt_layout]} { + set layout_name $opt_layout + set layout_info [dict get $layout_dict $layout_name] + set layout_path [dict get $layout_info path] + set layout_sourceinfo [dict get $layout_info sourceinfo] + } else { + puts stderr "commandset::project::new - no exact match for specified layout-name $opt_layout found" + puts stderr "layout names found: [dict keys $layout_dict]" + return + + #todo - pick highest version layout that matches opt_layout if version not specified but multiple exist + + #set layout_name ... + #set layout_info .. + #set layout_path ... + } + + + + #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 $layout_path 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} { + set warnmsg "mix new WARNING: -update 1 was supplied. Will copy layout $layout_path using -update option to add missing items" + if {$opt_confirm} { + puts stderr $warnmsg + set msg "Do you want to proceed to possibly overwrite some existing files in $projectdir? Y|N" + set answer [util::askuser $msg] + 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 prompt." + return + } + } + puts stderr $warnmsg + } + + 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 + } + #review + set fossil_repo_file $repodb_folder/$projectname.fossil + } + + 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 + + puts stdout ">>> about to call punkcheck::install $layout_path $projectdir" + set resultdict [dict create] + set antipaths [list {*}{ + src/doc/* + src/doc/include/* + src/PROJECT_LAYOUTS_* + }] + + #set exclude_paths [list {*}{ + # _ignore_* + # **/_ignore_* + #}] + set exclude_paths [list {*}{ + }] + + #default -exclude-paths-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_path $projectdir -installer project.new -createempty 1 -overwrite ALL-TARGETS -exclude-paths [concat $antipaths $exclude_paths]] + } else { + puts stdout "copying layout files - (if source file changed)" + set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite installedsourcechanged-targets -exclude-paths [concat $antipaths $exclude_paths]] + } + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + + if {[file exists $layout_path/src/doc]} { + puts stdout "copying layout src/doc files (if target missing)" + set resultdict [punkcheck::install $layout_path/src/doc $projectdir/src/doc -createdir 1 -punkcheck-folder $projectdir -installer project.new -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no src/doc in source template - update not required" + } + + #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 exclude-paths_core - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized. + ## default_excludepaths_core [list "#*" "**/#*" "_aside" "**/_aside" "_build" "**/_build" ".git" "**/.git" ".fossil*" "**/.fossil*"] + set override_excludepaths_core [list #* **/#* _aside **/_aside .git **/.git] + if {[file exists $layout_path/.fossil-custom]} { + puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)" + set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -createempty 1 -punkcheck-folder $projectdir -installer project.new -exclude-paths-core $override_excludepaths_core -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no .fossil-custom in source template - update not required" + } + + if {[file exists $layout_path/.fossil-settings]} { + puts stdout "copying layout src/.fossil-settings files (if target missing or uncustomised)" + set resultdict [punkcheck::install $layout_path/.fossil-settings $projectdir/.fossil-settings -createdir 1 -createempty 1 -punkcheck-folder $projectdir -installer project.new -exclude-paths-core $override_excludepaths_core -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no .fossil-settings in source template - update not required" + } + + #scan all files in template + # + #TODO - deck command to substitute templates? + set templateinfo_list [punk::mix::commandset::layout::lib::layout_scan_for_template_files $opt_layout] + set stripprefix [file normalize $layout_path] + + set tagmap [list [lib::template_tag project] $projectname] + if {[llength $templateinfo_list]} { + puts stdout "Filling template file placeholders with the following tag map:" + foreach {placeholder value} $tagmap { + puts stdout " $placeholder -> $value" + } + } + foreach templateinfo $templateinfo_list { + lassign $templateinfo templatefullpath template_tagnames_found + set templatetail [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] + set fpath [file join $projectdir $templatetail] + foreach t $template_tagnames_found { + if {"%$t%" ni [dict keys $tagmap]} { + puts stderr "warning: No substitution available for tag: %$t% in $fpath" + } + } + + if {[file exists $fpath]} { + set fd [open $fpath r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd + set data2 [string map $tagmap $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" + } + } + + ::cd $projectdir + + if {[file exists $projectdir/src/modules]} { + foreach m $opt_modules { + #check if mod-ver.tm file or #modpod-mod-ver folder exist + set tmfile $projectdir/src/modules/$m-[punk::mix::util::tm_version_magic].tm + set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::tm_version_magic]/$m-[punk::mix::util::tm_version_magic].tm + + set has_tm [file exists $tmfile] + set has_pod [file exists $podfile] + #puts stderr "=====> has_tm: $has_tm has_pod: $has_pod" + if {!$has_tm && !$has_pod} { + #todo - option for -module_template - and check existence at top? or change opt_modules to be a list of dicts with configuration info -template -type etc + punk::mix::commandset::module::new -project $projectname -type $opt_type $m + } else { + #we should rarely if ever want to force any src/modules to be overwritten + if {$opt_force} { + if {$has_pod} { + set answer [util::askuser "OVERWRITE the src/modules file $podfile ?? (generally not desirable) Y|N"] + set overwrite_type zip + } else { + set answer [util::askuser "OVERWRITE the src/modules file $tmfile ?? (generally not desirable) Y|N"] + set overwrite_type $opt_type + } + if {[string tolower $answer] eq "y"} { + #REVIEW - all pods zip - for now + punk::mix::commandset::module::new -project $projectname -type $overwrite_type -force 1 $m + } + } + } + } + } 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" + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::mix::commandset::project ---}] + + namespace eval collection { + #*** !doctools + #[subsection {Namespace punk::mix::commandset::project::collection}] + #[para] commandset functions for operating with multiple projects. + #[para] It would usually be imported with the prefix "projects" and separator "." to result in commands such as: projects.detail + #[list_begin definitions] + namespace export * + namespace path [namespace parent] + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::_default + @cmd -name "punk::mix::commandset::project::collection::_default"\ + -summary\ + "List projects under fossil managment."\ + -help\ + "List projects under fossil management, showing fossil db location and number of checkouts" + @values -min 0 -max -1 + glob -type string -multiple 1 -default * + } + #e.g imported as 'projects' + proc _default {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::_default] + set globlist [dict get $argd values glob] + + #*** !doctools + #[call [fun _default] [arg glob...]] + #[para]List projects under fossil management, showing fossil db location and number of checkouts + #[para]The glob argument is optional unless option/value pairs are also supplied, in which case * should be explicitly supplied + #[para]glob restricts output based on the name of the fossil db file e.g s* for all projects beginning with s + #[para]The _default function is made available in the ensemble by the name of the prefix used when importing the commandset. + #[para]e.g + #[para] punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection + #[para]Will result in the command being available as projects + package require overtype + set db_projects [lib::get_projects {*}$globlist] + 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 Repo 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] {string length $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] + set file_idx 0 + foreach dbfile $col1_dbfiles { + set project_name "" + set project_code "" + set project_desc "" + set db_error "" + if {[file exists $dbfile]} { + if {[catch { + 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) + } + } + } errM]} { + set db_error $errM + } + catch {dbp close} + } else { + set db_error "fossil file $dbfile missing" + } + lappend col4_pnames $project_name + lappend col5_pcodes $project_code + dict lappend codes $project_code $dbfile + lappend col7_pdescs $project_desc + if {$db_error ne ""} { + lset col1_dbfiles $file_idx "[a+ web-red]$dbfile[a]" + } + incr file_idx + } + + 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 Repo 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] {string length $v}]] + set col3 [string repeat " " $widest3] + set title4 "Project Name" + set widest4 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col4_pnames] {string length $v}]] + set col4 [string repeat " " $widest4] + set title5 "Project Code" + set widest5 [tcl::mathfunc::max {*}[lmap v [concat [list $title5] $col5_pcodes] {string length $v}]] + set col5 [string repeat " " $widest5] + set title6 "Dup" + set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col6_dupids] {string length $v}]] + set col6 [string repeat " " $widest6] + set title7 "Description" + #set widest7 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col7_pdescs] {string length $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]] + } + + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::work + @cmd -name punk::mix::commandset::project::collection::work\ + -summary\ + "List projects with checkout directories."\ + -help\ + "Get project info by opening the central fossil config-db to determine + fossil database files for each project, and the known checkout folders. + If -detail is true, a second operation gathers file state information + for each checkout folder." + @leaders -min 0 -max 0 + -cd -type none -help\ + "If this flag is provided, after lsting, prompt the user to enter + the row number of the checkout to 'cd' into, or an option to cancel. + If there is only one project with only a single checkout, the + cd operation will occur without prompting unless -prompt was + also supplied." + -prompt -type none -help\ + "If there is only one checkout in the result, cause a prompt to be + raised instead of automatically peforming the cd operation. + Has no effect if -cd was not supplied, or if -cd is supplied and + there are multiple checkouts, in which case user is always prompted." + -detail -type boolean -default 0 -help\ + "Include file state information for each checkout in the resulting + table. This includes information such as which files are changed, + unchanged,new,missing or extra and can take a little more time to + gather as it must examine the filesystem for each checkout folder. + + Note that although the default is false - if only a single project + matches the glob pattern(s) then file state will be gathered for + each of its checkouts. Use an explicit -detail 0 if this is not + desired." + @values -min 0 -max -1 + glob -type string -multiple 1 -default * -optional 1 -help\ + "glob patterns used to search for project. The glob is applied against + the names of the fossil repository database files - not the project-name, + which is not available in the central fossil config-db. + Case insensitive." + } + proc work {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] + lassign [dict values $argd] leaders opts values received + package require sqlite3 + set globlist [dict get $values glob] + + set db_projects [lib::get_projects {*}$globlist] + #list of lists of the form: + #{fosdb fname workdirlist} + if {[llength $db_projects] == 0} { + puts stderr "::punk::mix::commandset::project::work No Repo DB name matches found for '$globlist'" + return "" + } + # -- --- --- --- --- --- --- + set opt_cd [dict exists $received -cd] + # -- --- --- --- --- --- --- + set opt_detail [dict get $opts -detail] + if {[dict exists $received -detail] && !$opt_detail} { + set opt_detail_explicit_zero 1 + } else { + set opt_detail_explicit_zero 0 + } + set opt_prompt [dict exists $received -prompt] + # -- --- --- --- --- --- --- + 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 and opt_detail is 0 and not explicit - retrieve workingdir state for each co + if {([llength [dict keys $fosdb_cache]] == 1)} { + if {!$opt_detail_explicit_zero} { + set opt_detail 1 + } + puts stderr "Result is from a single repo db [dict keys $fosdb_cache]" + } + if {$opt_detail} { + if {!$opt_detail_explicit_zero} { + set detailmsg "Use -detail 0 to omit file state" + } else { + set detailmsg "" + } + puts stderr "Gathering file state for [llength $workdirs] checkout folder(s). $detailmsg" + set c_rev [list] + set c_rev_iso [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_rev_iso [dict get $state_dict revision_iso8601] + 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 t0b "Revision iso8601" + set w0b [tcl::mathfunc::max {*}[lmap v [concat [list $t0] $c_rev_iso] {string length $v}]] + set c0b [string repeat " " $w0b] + 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::left $c0b $t0b] [overtype::right $c1 $t1] [overtype::right $c2 $t2] [overtype::right $c3 $t3] [overtype::right $c4 $t4] [overtype::right $c5 $t5]" + foreach r $c_rev iso $c_rev_iso u $c_unchanged c $c_changed n $c_new m $c_missing e $c_extra { + lappend col_states "[overtype::left $c0 $r] [overtype::left $c0b $iso] [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 "Repo 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 { + if {![file exists $wd]} { + set row [punk::ansi::a+ strike red]$row[a] + set wd [punk::ansi::a+ red]$wd[a] + } + 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 { + if {![file exists $wd]} { + set row [punk::ansi::a+ strike red]$row[a] + set wd [punk::ansi::a+ red]$wd[a] + } + 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 && !$opt_prompt} { + 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 [deck stat] + return $workingdir + } + } + } + return $msg + } + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::cd + @cmd -name punk::mix::commandset::project::collection::cd\ + -summary\ + "List projects with checkout directories and prompt for which checkout to cd to."\ + -help\ + "List projects with checkout directories and prompt for which checkout to cd to." + @leaders -min 0 -max 0 + }\ + [punk::args::resolved_def -types opts ::punk::mix::commandset::project::collection::work -detail]\ + { + -prompt -type none -help\ + "Prompt even when result contains only one checkout location as a possible cd target. + User will always be prompted if result contains more than one checkout." + @values -min 0 -max -1 + }\ + [punk::args::resolved_def -types values ::punk::mix::commandset::project::collection::work glob] + + proc cd {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] + work -cd {*}$args + } + + #*** !doctools + #[list_end] [comment {-- end collection namespace definitions --}] + } + + namespace eval lib { + proc template_tag {tagname} { + #todo - support different tagwrappers - it shouldn't be so likely to collide with common code idioms etc. + #we need to detect presence of tags intended for punk::mix system + #consider using punk::cap to enable multiple template-substitution providers with their own set of tagnames and/or tag wrappers, where substitution providers are all run + return [string cat % $tagname %] + } + punk::args::define { + @id -id ::punk::mix::commandset::project::lib::get_projects + @cmd -name punk::mix::commandset::project::lib::get_projects\ + -summary\ + "Return a 3-element list of projects referred to by central fossil config-db."\ + -help\ + "Get project info only by opening the central fossil config-db. + Each member of the returned list is a 3-element list of: + + The shortname is simply the name based on the root name of the fossil database, + it is not necessarily the project-name by which the project is referred to in the fossil + checkout databases." + @values -min 0 -max -1 + glob -type string -multiple 1 -default * -optional 1 -help\ + "case insensitive glob for the name of the fossil database." + } + proc get_projects {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::lib::get_projects] + set globlist [dict get $argd values glob] + + set fossil_prog [auto_execok fossil] + + set configdb [punk::repo::fossil_get_configdb] + + package require sqlite3 + ::sqlite3 fosconf $configdb + #set testresult [fosconf eval {select name,value from global_config;}] + #puts stderr $testresult + #list of repositories of the form repo: + #eg repo:C:/Users/someone/.fossils/tcl.fossil + + #the command: + # fossil all ignore /repo.fossil + #will remove the {repo:/repo.fossil 1} record from global_config + #but it leaves {ckout: /repo.fossil} records, even if such checkouts are closed + #when the folder itself at is removed - then commands such as 'fossil all ls -c' automatically remove the corresponding ckout: record. + + 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;}] + #list of entries like "ckout:C:/buildtcl/2024zig/tcl90/" + 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 -nocase -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 + } + + } + + + +} + + +#*** !doctools +#[manpage_end] + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::commandset::project [namespace eval punk::mix::commandset::project { + variable version + set version 0.2.0 +}] +return diff --git a/src/bootsupport/modules/punk/path-0.1.0.tm b/src/bootsupport/modules/punk/path-0.1.0.tm index 230bad31..fa63e4fb 100644 --- a/src/bootsupport/modules/punk/path-0.1.0.tm +++ b/src/bootsupport/modules/punk/path-0.1.0.tm @@ -1444,52 +1444,34 @@ namespace eval punk::path { return [treefile_priv::walk_treefilenames_zipfs $state] } + punk::args::define { + @id -id ::punk::path::relative + @cmd -name punk::path::relative\ + -summary\ + "Compute the relative path from a reference path to a location path."\ + -help\ + "Taking two directory paths, a reference and a location, computes the path + of the location relative to the reference. + + Will return a single dot '.' if the paths are the same. + + Both paths must be the same type - ie both absolute or both relative. + + Matching is case sensitive. On windows, the drive-letter component (only) is + not case sensitive, so punk::path::relative c:/etc C:/etc returns '.'. + The part following the driveletter is case sensitive, so + punk::path::relative c:/etc C:/Etc returns ../Etc. + + On windows, if the paths are absolute and specify different volumes, + only the location will be returned." + @leaders -min 2 -max 2 + reference -type string -help\ + "The path from which the relative path to location is determined." + location -type string -help\ + "The location path which may be above or below the reference path." + } #maint warning - also in punkcheck proc relative {reference location} { - #*** !doctools - #[call [fun relative] [arg reference] [arg location]] - #[para] Taking two directory paths, a reference and a location, computes the path - # of the location relative to the reference. - #[list_begin itemized] - #[item] - #[para] Arguments: - # [list_begin arguments] - # [arg_def string reference] The path from which the relative path to location is determined. - # [arg_def string location] The location path which may be above or below the reference path - # [list_end] - #[item] - #[para] Results: - #[para] The relative path of the location to the reference path. - #[para] Will return a single dot "." if the paths are the same - #[item] - #[para] Notes: - #[para] Both paths must be the same type - ie both absolute or both relative - #[para] Case sensitive. ie punk::path::relative /etc /etC - # will return ../etC - #[para] On windows, the drive-letter component (only) is not case sensitive - #[example_begin] - # P% punk::path::relative c:/etc C:/etc - # - . - #[example_end] - #[para] The part following the driveletter is case sensitive so in the following cases it recognises the driveletter matches but not the tail - #[example_begin] - # P% punk::path::relative c:/etc C:/Etc - # - ../Etc - #[example_end] - #[para] On windows, if the paths are absolute and specifiy different volumes, only the location will be returned. - #[example_begin] - # P% punk::path::relative c:/etc d:/etc/blah - # - d:/etc/blah - #[example_end] - #[para] Unix-like examples: - #[example_begin] - # P% punk::path::relative /usr/local/etc/ /usr/local/etc/somewhere/below - # - somewhere/below - # P% punk::path::relative /usr/local/etc/somewhere /usr/local/lib/here - # - ../../lib/here - #[example_end] - #[list_end] - #see also kettle # Modified copy of ::fileutil::relative (tcllib) # Adapted to 8.5 ({*}). diff --git a/src/bootsupport/modules/punk/path-0.2.0.tm b/src/bootsupport/modules/punk/path-0.2.0.tm new file mode 100644 index 00000000..68f0b744 --- /dev/null +++ b/src/bootsupport/modules/punk/path-0.2.0.tm @@ -0,0 +1,1611 @@ +# -*- 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::path 0.2.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::path 0 0.2.0] +#[copyright "2023"] +#[titledesc {Filesystem path utilities}] [comment {-- Name section and table of contents description --}] +#[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}] +#[require punk::path] +#[description] +#[keywords module path filesystem] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::path +#[para] Filesystem path utility functions +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::path +#[list_begin itemized] + +package require Tcl 8.6- +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {punk::args}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#namespace eval punk::path::class { + #*** !doctools + #[subsection {Namespace punk::path::class}] + #[para] class definitions + #if {[info commands [namespace current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + #} +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::path { + namespace export {[a-z]*} + #variable xyz + + #*** !doctools + #[subsection {Namespace punk::path}] + #[para] Core API functions for punk::path + #[list_begin definitions] + + # -- --- + #punk::path::normjoin + # - simplify . and .. segments as far as possible whilst respecting specific types of root. + # -- --- + #a form of file normalize that supports //xxx to be treated as server path names + #(ie regardless of unices ignoring (generally) leading double slashes, and regardless of windows volumerelative path syntax) + #(sometimes //server.com used as a short form for urls - which doesn't seem too incompatible with this anyway) + # -- --- + #This is intended to be purely a string analysis - without reference to filesystem volumes or vfs or zipfs mountpoints etc + #(but this also means we won't be able to resolve windows shortnames or dos device paths - so we will preserve those as they are) - review + #(It also means we can't resolve per drive working directories on windows - so we will preserve c: as is rather than converting to absolute - review) + # + #TODO - option for caller to provide a -base below which we can't backtrack. + #This is preferable to setting policy here for example regarding forcing no trackback below //servername/share + #Our default is to allow trackback to: + # :// + # :/ + # //./ (dos device volume) + # //server (while normalizing //./UNC/server to same) + # / (ordinary unix root) + # ./../ - (track back indefinitely on relpath as we are not resolving to anything physical and can't fully simplify the leading backtracks) + # + #The caller should do the file/vfs operations to determine this - not us. + # -- --- + #simplify path with respect to /./ & /../ elements - independent of platform + #NOTE: "anomalies" in standard tcl processing on windows: + #e.g file normalize {//host} -> c:/host (or e.g d:/host if we happen to be on another volume) + #file normalize {//host/share} -> //host/share + #This is because //host is treated as volume-relative in cmd/powershell and Tcl quite reasonably follows suit. + #This prevents cwd and windows commandlines from pointing to the server (above the share) + #Explorer however does allow pointing to the //server level and seeing shares as if they are directory entries. + #we are more interested in supporting the explorer-like behaviour - as while volumerelative paths are also useful on windows - they are lesser known. + #REVIEW. + #To get back to some consistent cross platform behaviour - we will treat //something as a root/volume i.e we can't backtrack above it with ".." + #note too that file split on UNC paths doesn't give a clear indication of the root + # file split //./UNC/server/share/subpath -> //./UNC server share subpath + # file split //server/share/subpath -> //server/share subpath + #TODO - disallow all change of root or change from relative path to absolute result. + #e.g normjoin relpath/../d:/secret should not return d:/secret - but ./d:/secret + # ================ + #known issues: + #1) + # normjoin d://a//b//c -> d://a/b/c + # This is because we don't detect specific schemes. ie it's treated the same as https://a/b/c -> https://a/b/c + # Not considered a problem - just potentially surprising. + # To avoid it we would have to enumerate possible schemes. + # As it stands a unix system could define a 'scheme' that happens to match windows style driveletters. Consider a 'feature' ? review. + # won't fix? + #2) + # normjoin https:///real.com/../fake.com -> https:///fake.com + # The extra slash means effectively our servername is empty - this is potentially confusing but probably the right thing to do here. + # It's a concern only if upstream treats the tripple slash in this case as valid and maps it to https:// - which would probably be bad anyway. + # won't fix (review) + #3) + #similarly + # normjoin //./UNC//server/share/subpath -> ///server/share/subpath (when 2 or more slashes directly after UNC) + # normjoin ///server/share -> ///server/share + #This is effectively an empty servername in the input with 'server' being pushed one level down - and the output is consistent + # possibly won't fix - review + #4) inconsistency + # we return normalized //server/share for //./UNC/server share + # but other dos device paths are maintained + # e.g //./c:/etc + # This is because such paths could contain alternate segment names (windows shortnames) which we aren't in a position to resolve. + # caller should + # #as with 'case' below - caller will need to run a post 'file normalize' + #5) we don't normalize case like file normalize does on windows platform. + # This is intentional. It could only be done with reference to underlying filesystem which we don't want here. + # + # ================ + # + #relpaths all end up with leading . - while not always the simplest form, this is ok. (helps stop inadvertent conversions to absolutes) + # Tests - TODO + # normjoin /d:/..//vfs:/test -> /vfs:/test (good - not converted to //vfs:/test) + + #normjoin c: should theoretically return current per drive working directory on c: + # - would need to use win32 GetFullPathName to resolve this. + proc normjoin {args} { + set args [lmap a $args {string map "\\\\ /" $a}] + set path [plainjoin {*}$args] + switch -exact -- $path { + "" { + return "" + } + / - // { + #treated in unixlike manner - (but leading doubleslashes with subsequent data are server indication) + #// not considered a servername indicator - but /// (for consistency) is. (empty servername?) + return / + } + /// { + #if this is effectively //$emptyservername/ + #then for consistency we should trail //=3 + #todo - shortcircuit that here? + } + } + # /// + set doubleslash1_posn [string first // $path] + + # -- --- --- temp warning on windows only - no x-platform difference in result + #on windows //host is of type volumerelative + # whereas //host/share is of type absolute + if {"windows" eq $::tcl_platform(platform) && [file pathtype $path] eq "volumerelative"} { + #volumerelative probably only occurs on windows anyway + if {$doubleslash1_posn == 0} { + #e.g //something where no further slashes + #review - eventually get rid of this warning and require upstream to know the appropriate usecase + puts stderr "Warning - ambiguous path $path - treating as server path - not 'volumerelative'" + } else { + # /something/etc + # /mnt/c/stuff + #output will retain leading / as if on unix. + #on windows - the result would still be interpreted as volumerelative if the caller normalizes it + } + } + # -- --- --- + + set is_relpath 0 + + #set path [string map [list \\ /] $path] + set finalparts [list] + set is_nonunc_dosdevice 0 + if {[punk::winpath::is_dos_device_path $path]} { + #review + if {[string range $path 4 6] eq "UNC"} { + #convert to 'standard' //server/... path for processing + set path "/[string range $path 7 end]" ;# //server/... + } else { + #error "normjoin non-UNC dos device path '$path' not supported" + #first segment after //./ or //?/ represents the volume or drive. + #not applicable to unix - but unlikely to conflict with a genuine usecase there (review) + #we should pass through and stop navigation below //./vol + #!!! + #not anomaly in tcl (continues in tcl9) + #file exists //./c:/test -> 0 + #file exists //?/c:/test -> 1 + #file exists //./BootPartition/Windows -> 1 + #file exists //?/BootPartition/Windows -> 0 + set is_nonunc_dosdevice 1 + } + } + + if {$is_nonunc_dosdevice} { + #dosdevice prefix //./ or //?/ - preserve it (without trailing slash which will be put back in with join) + set prefix [string range $path 0 2] + set tail [string range $path 4 end] + set tailparts [split $tail /] + set parts [concat [list $prefix] $tailparts] + set rootindex 1 ;#disallow backtrack below //./ + } else { + #note use of ordinary ::split vs file split is deliberate. + if {$doubleslash1_posn == 0} { + #this is handled differently on different platforms as far as 'file split' is concerned. + #e.g for file split //sharehost/share/path/etc + #e.g on windows: -> //sharehost/share path + #e.g on freebsd: -> / sharehost share path etc + #however..also on windows: file split //sharehost -> / sharehost + #normalize by dropping leading slash before split - and then treating first 2 segments as a root + #set parts [file split [string range $path 1 end]] + set parts [split $path /] + #assert parts here has {} {} as first 2 entries + set rootindex 2 + #currently prefer can backtrack to the //zipfs:/ scheme (below the mountpoint - to browse other mounts) + #alternative handling for //zipfs:/path - don't go below mountpoint + #but we can't determine just from string if mountpoint is direct subpath or a lower one e.g //zipfs:/arbitraryname/actualmountpoint + #review - more generally //:/path ? + #todo - make an option for zipfs and others to determine the 'base' + #if {"zipfs:" eq [lindex $parts 2]} { + # set rootindex 3 + #} + } else { + #path may or may not begin with a single slash here. + #treat same on unix and windows + set rootindex 0 + #set parts [file split $path] + set parts [::split $path /] + #e.g /a/b/c -> {} a b c + #or relative path a/b/c -> a b c + #or c:/a/b/c -> c: a b c + if {[string match *: [lindex $parts 0]]} { + if {[lindex $parts 1] eq ""} { + #scheme://x splits to scheme: {} x + set parts [concat [list [lindex $parts 0]/] [lrange $parts 2 end]] + #e.g {scheme:/ x} + set rootindex 1 ;#disallow below first element of scheme + } else { + set rootindex 0 + } + } elseif {[lindex $parts 0] ne ""} { + #relpath a/b/c + #set parts [linsert $parts 0 .] + ledit parts -1 -1 . + set rootindex 0 + #allow backtracking arbitrarily for leading .. entries - simplify where possible + #also need to stop possible conversion to absolute path + set is_relpath 1 + } + } + } + set baseparts [lrange $parts 0 $rootindex] ;#base below which we can't retreat via ".." + #puts stderr "-->baseparts:$baseparts" + #ensure that if our rootindex already spans a dotted segment (after the first one) we remove it + #must maintain initial . for relpaths to stop them converting to absolute via backtrack + # + set finalparts [list [lindex $baseparts 0]] + foreach b [lrange $baseparts 1 end] { + if {$b ni {. ..}} { + lappend finalparts $b + } + } + set baselen [expr {$rootindex + 1}] + if {$is_relpath} { + set i [expr {$rootindex+1}] + foreach p [lrange $parts $i end] { + switch -exact -- $p { + . - "" {} + .. { + switch -exact -- [lindex $finalparts end] { + . - .. { + lappend finalparts .. + } + default { + #lpop finalparts + ledit finalparts end end + } + } + } + default { + lappend finalparts $p + } + } + incr i + } + } else { + foreach p [lrange $parts $rootindex+1 end] { + if {[llength $finalparts] <= $baselen} { + if {$p ni {. .. ""}} { + lappend finalparts $p + } + } else { + switch -exact -- $p { + . - "" {} + .. { + #lpop finalparts ;#uses punk::lib::compat::lpop if on < 8.7 + ledit finalparts end end ;#uses punk::lib::compat::ledit if on < 8.7 + } + default { + lappend finalparts $p + } + } + } + } + } + #puts "==>finalparts: '$finalparts'" + # using join - {"" "" server share} -> //server/share and {a b} -> a/b + if {[llength $finalparts] == 1 && [lindex $finalparts 0] eq ""} { + #backtracking on unix-style path can end up with empty string as only member of finalparts + #e.g /x/.. + return / + } + set result [::join $finalparts /] + #normalize volumes and mountschemes to have trailing slash if no subpath + #e.g c: -> c:/ + #//zipfs: -> //zipfs:/ + if {[set lastchar [string index $result end]] eq ":"} { + if {$result eq "//zipfs:"} { + set result "//zipfs:/" + } else { + if {[string first / $result] < 0} { + set result $result/ + } + } + } elseif {[string match //* $result]} { + if {![punk::winpath::is_dos_device_path $result]} { + #server + set tail [string range $result 2 end] + set tailparts [split $tail /] + if {[llength $tailparts] <=1} { + #empty // or //servername + append result / + } + } + } elseif {[llength $finalparts] == 2} { + if {[string range [lindex $finalparts 0] end-1 end] eq ":/"} { + #e.g https://server/ -> finalparts {https:/ server} + #e.g https:/// -> finalparts {https:/ ""} + #scheme based path should always return trailing slash after server component - even if server component empty. + lappend finalparts "" ;#force trailing / + return [join $finalparts /] + } + } + if {[file extension [lindex $finalparts end]] eq ".lnk"} { + if {![catch {package require punk::winlnk}]} { + if {![catch {punk::winlnk::target $result} path]} { + return $path + } + } + } + return $result + } + + proc trim_final_slash {str} { + if {[string index $str end] eq "/"} { + return [string range $str 0 end-1] + } + return $str + } + + + #x-platform - punk::path::pathtype - can be used in safe interps - different concept of pathtypes to 'file pathtype' + # - no volumerelative + # - no lookup of file volumes (volume is a windows concept - but with //zipfs:/ somewhat applicable to other platforms) + # - /* as absolute (covers also //zipfs:/ (volume), //server , //./etc , //./UNC) + # - xxx:// as absolute (scheme) + # - xxx:/ or x:/ as absolute + # - x: xxx: -> as absolute (volume-basic or volume-extended) + + #note also on windows - legacy name for COM devices + # COM1 = COM1: + # //./COM1 ?? review + + proc pathtype {str} { + set str [string map "\\\\ /" $str] + if {[string index $str 0] eq "/"} { + #todo - look for //xxx:/ prefix (generalisation of //zipfs:/) as a 'volume' specifically {volume mount} ?? - review + # look for //server prefix as {absolute server} + # look for //./UNC/server or //?/UNC/server as {absolute server UNC} ? + # look for //./ as {absolute dosdevice} + return absolute + } + + #only firstsegment with single colon at last position (after some non empty string) counts as volume or scheme - review + #e.g a:b:/.. or a::/.. or :/.. is not treated as volume/scheme whereas ab:/ is. + set firstslash [string first / $str] + if {$firstslash == -1} { + set firstsegment $str + } else { + set firstsegment [string range $str 0 $firstslash-1] + } + if {[set firstc [string first : $firstsegment]] > 0} { + set lhs_firstsegment [string range $firstsegment 0 $firstc-1] + set rhs_firstsegment [string range $firstsegment $firstc+1 end] ;#exclude a:b/ etc + if {$rhs_firstsegment eq ""} { + set rhs_entire_path [string range $str $firstc+1 end] + #assert lhs_firstsegment not empty since firstc > 0 + #count following / sequence + set i 0 + set slashes_after_firstsegment "" ;#run of slashes *directly* following first segment + while {$i < [string length $rhs_entire_path]} { + if {[string index $rhs_entire_path $i] eq "/"} { + append slashes_after_firstsegment / + } else { + break + } + incr i + } + switch -exact -- $slashes_after_firstsegment { + "" - / { + if {[string length $lhs_firstsegment] == 1} { + return {absolute volume basic} + } else { + return {absolute volume extended} + } + } + default { + #2 or more / + #this will return 'scheme' even for c:// - even though that may look like a windows volume - review + return {absolute scheme} + } + } + } + } + #assert first element of any return has been absolute or relative + return relative + } + + + proc plain {str} { + set str [string map "\\\\ /" $str] + set pathinfo [punk::path::pathtype $str] + if {[lindex $pathinfo 0] eq "relative" && ![string match ./* $str]} { + set str ./$str + } + if {[string index $str end] eq "/"} { + if {[string map {/ ""} $str] eq ""} { + #all slash segment + return $str + } else { + if {[lindex $pathinfo 1] ni {volume scheme}} { + return [string range $str 0 end-1] + } + } + } + return $str + } + #purely string based - no reference to filesystem knowledge + #unix-style forward slash only + proc plainjoin {args} { + set args [lmap a $args {string map "\\\\ /" $a}] + #if {[llength $args] == 1} { + # return [lindex $args 0] + #} + set out "" + foreach a $args { + if {![string length $out]} { + append out [plain $a] + } else { + set a [plain $a] + if {[string map {/ ""} $out] eq ""} { + set out [string range $out 0 end-1] + } + + if {[string map {/ ""} $a] eq ""} { + #all / segment + append out [string range $a 0 end-1] + } else { + if {[string length $a] > 2 && [string match "./*" $a]} { + set a [string range $a 2 end] + } + if {[string index $out end] eq "/"} { + append out $a + } else { + append out / $a + } + } + } + } + return $out + } + proc plainjoin1 {args} { + if {[llength $args] == 1} { + return [lindex $args 0] + } + set out [trim_final_slash [lindex $args 0]] + foreach a [lrange $args 1 end] { + set a [trim_final_slash $a] + append out / $a + } + return $out + } + + #intention? + #proc filepath_dotted_dirname {path} { + #} + + proc strip_prefixdepth {path prefix} { + if {$prefix eq ""} { + return [norm $path] + } + return [file join {*}{ + } {*}[lrange {*}{ + } [file split [norm $path]] {*}{ + } [llength [file split [norm $prefix]]] {*}{ + } end + ] + ] + } + + + ## for comparison + #proc nsglob_as_re {glob} { + # #any segment that is not just * must match exactly one segment in the path + # set pats [list] + # foreach seg [nsparts_cached $glob] { + # switch -exact -- $seg { + # "" { + # lappend pats "" + # } + # * { + # #review - ::g*t will not find ::got:it (won't match single inner colon) - this should be fixed + # #lappend pats {[^:]*} + # #negative lookahead + # #any number of chars not followed by ::, followed by any number of non : + # lappend pats {(?:.(?!::))*[^:]*} + # } + # ** { + # lappend pats {.*} + # } + # default { + # set seg [string map {. [.]} $seg] + # if {[regexp {[*?]} $seg]} { + # #set pat [string map [list ** {.*} * {[^:]*} ? {[^:]}] $seg] + # set pat [string map [list ** {.*} * {(?:.(?!::))*[^:]*} ? {[^:]}] $seg] + # lappend pats "$pat" + # } else { + # lappend pats "$seg" + # } + # } + # } + # } + # return "^[join $pats ::]\$" + #} + proc pathglob_as_re {pathglob} { + #*** !doctools + #[call [fun pathglob_as_re] [arg pathglob]] + #[para] Returns a regular expression for matching a path to a glob pattern which can contain glob chars *|? in any segment of the path structure + #[para] Does not support square bracket globs or character classes. + #[para] ** matches any number of subdirectories. + #[para] e.g /etc/**/*.txt will match any .txt files at any depth below /etc (except directly within /etc itself) + #[para] e.g /etc/**.txt will match any .txt files at any depth below /etc + #[para] any segment that does not contain ** must match exactly one segment in the path + #[para] e.g the glob /etc/*/*.doc - will match any .doc files that are exactly one tree level below /etc + #[para] The pathglob doesn't have to contain glob characters, in which case the returned regex will match the pathglob exactly as specified. + #[para] Regular expression syntax is deliberateley not supported within the pathglob string so that supplied regex characters will be treated as literals + + + #todo - consider whether a way to escape the glob chars ? * is practical - to allow literals ? * + # - would require counting immediately-preceding backslashes + set pats [list] + foreach seg [file split $pathglob] { + if {[string range $seg end end] eq "/"} { + set seg [string range $seg 0 end-1] ;# e.g c:/ -> c: / -> "" so that join at end doesn't double up + } + switch -- $seg { + * {lappend pats {[^/]*}} + ** {lappend pats {.*}} + default { + set seg [string map [list ^ {\^} $ {\$} \[ {\[} \] {\]} ( {\(} ) {\)} \{ \\\{ \\ {\\}] $seg] ;#treat regex characters (or tcl glob square bracket chars) in the input as literals + #set seg [string map [list . {[.]}] $seg] + set seg [string map {. [.]} $seg] + if {[regexp {[*?]} $seg]} { + set pat [string map [list ** {.*} * {[^/]*} ? {[^/]}] $seg] + lappend pats "$pat" + } else { + lappend pats "$seg" + } + } + } + } + return "^[join $pats /]\$" + } + + punk::args::define { + @id -id ::punk::path::globmatchpath + @cmd -name punk::path::globmatchpath\ + -summary\ + "Match path to *|**|? glob patterns"\ + -help\ + "Return a boolean indicating whether the path matches the specialised glob pattern. + A pattern such as /usr/*/bin will match any path that has /usr as the first segment and bin as the third segment, + with any single segment in between. + A pattern such as /usr/**/bin will match any path that has /usr as the first segment and bin as the last segment, + with 1 or more segments in between (so it will not match /usr/bin). + A pattern such as /usr/** will match any path that has /usr as the first segment, with 1 or more segments + following (so it will not match /usr itself). + A pattern such as **/*.txt will match any path that ends with .txt, with 1 or more leading segments + (so it will not match test.txt or .txt). + A pattern such as ** will match any path. + The glob characters * and ? are the only special characters in the pathglob syntax. + - they are treated as glob characters regardless of where they appear in the pathglob string. + Note that this is different from other Tcl glob contexts where square brackets can be used. + The pathglob syntax treats other characters, including square brackets as literals. + For example, the pattern /usr/te?t will match /usr/test and /usr/text but not /usr/texxt, and the pattern /usr/te*t + will match /usr/test, /usr/teat, and /usr/teeeet but not /usr/te/t. + The pathglob syntax does not support escaping of glob characters - any glob characters in the pathglob are treated + as glob characters. For example, the pattern /usr/* will match any path that has /usr as the first segment and any + single segment as the second segment, but there is no way to specify a pattern that matches any path that has /usr + as the first segment and a literal * as the second segment. + Caller must ensure that file separator is forward slash. (e.g use file normalize on windows) + + options: + -nocase 0|1 (default 0 - case sensitive) + If -nocase is not supplied - default to case sensitive *except for driveletter* + ie - the driveletter alone in paths such as c:/etc will still be case insensitive. (ie c:/ETC/* will match C:/ETC/blah but not C:/etc/blah) + Explicitly specifying -nocase 0 will require the entire case to match including the driveletter. + " + @leaders + pathglob -type string -help "glob pattern to match path against. See [fun pathglob_as_re] for syntax of glob patterns" + path -type string -help "path to match against glob pattern" + @opts + -nocase -type boolean -default 0 -help\ + "case insensitive matching (default false - case sensitive) + - except for driveletter on windows which is always case insensitive + unless -nocase 0 is explicitly specified" + @values -min 0 -max 0 + } + # -id + proc globmatchpath {pathglob path args} { + #*** !doctools + #[call [fun globmatchpath] [arg pathglob] [arg path] [opt {option value...}]] + #[para] Return true if the pathglob matches the path + #[para] see [fun pathglob_as_re] for pathglob description + #[para] Caller must ensure that file separator is forward slash. (e.g use file normalize on windows) + #[para] + #[para] Known options: + #[para] -nocase 0|1 (default 0 - case sensitive) + #[para] If -nocase is not supplied - default to case sensitive *except for driveletter* + #[para] ie - the driveletter alone in paths such as c:/etc will still be case insensitive. (ie c:/ETC/* will match C:/ETC/blah but not C:/etc/blah) + #[para] Explicitly specifying -nocase 0 will require the entire case to match including the driveletter. + + set opts [dict create {*}{ + -nocase \uFFFF + }] + foreach {k v} $args { + switch -- $k { + -nocase { + dict set opts $k $v + } + default { + error "Unrecognised option '$k'. Known-options: [dict keys $opts]" + } + } + } + # -- --- --- --- --- --- + set opt_nocase [dict get $opts -nocase] + set explicit_nocase 1 ;#default to disprove + if {$opt_nocase eq "\uFFFF"} { + set opt_nocase 0 + set explicit_nocase 0 + } + # -- --- --- --- --- --- + if {$opt_nocase} { + return [regexp -nocase [pathglob_as_re $pathglob] $path] + } else { + set re [pathglob_as_re $pathglob] + if {$explicit_nocase} { + set ismatch [regexp $re $path] ;#explicit -nocase 0 - require exact match of path literals including driveletter + } else { + #caller is using default for -nocase - which indicates case sensitivity - but we have an exception for the driveletter. + set re_segments [file split $re] ;#Note that file split c:/etc gives {c:/ etc} but file split ^c:/etc gives {^c: etc} + set first_seg [lindex $re_segments 0] + if {[regexp {^\^(.{1}):$} $first_seg _match driveletter]} { + #first part of re is like "^c:" i.e a drive letter + set chars [string tolower $driveletter][string toupper $driveletter] + set re [join [concat "^\[$chars\]:" [lrange $re_segments 1 end]] /] ;#rebuild re with case insensitive driveletter only - use join - not file join. file join will misinterpret leading re segment. + } + #puts stderr "-->re: $re" + set ismatch [regexp $re $path] + } + } + return $ismatch + } + punk::args::define { + @id -id ::punk::path::subfolders1 + @cmd -name punk::path::subfolders1\ + -summary\ + "Listing of directories below supplied path."\ + -help\ + "List of folders below path. + The resulting list is unsorted." + @opts + -recursive -type none -help\ + "" + -exclude-paths -type list -default {} -help\ + "list of path patterns to exclude from results. + May include * and ** path segments e.g /usr/** + A single /*/ will match any single segment in the path, and a single /**/ will match any number of segments in the path. + + e.g to exclude any path with _aside as a segment in the middle: -exclude-paths **/_aside/** + i.e this would exclude /usr/_aside/etc and /usr/x/_aside/etc but not /usr/x/_aside or _aside/etc + + To exclude all paths with _aside as a segment anywhere: -exclude-paths { **/_aside/** **/_aside _aside/**} + " + #todo -depth + @values -min 0 -max 1 + path -type directory -optional 1 -help\ + "Path of folder. If not supplied current directory is used. + This may be a relative or absolute path. Relative paths are treated as relative to current directory. + When using relative paths - the result will also be relative paths with the same relative prefix. + (e.g if path is ../test - the results will be ../test/subfolder1 ../test/subfolder2 etc) + Patterns in -exclude-paths are matched against the resulting paths + (so should be written to match the same relative prefix if path is relative)" + } + + proc subfolders1 {args} { + #NOTE - this algorithm based on omit_only_patterns and prune_base_patterns was suggested by a 2026 AI model - it is apparent to this programmer that it is inadequate for the purpose. + #e.g consider subfolders1 -recursion -exclude {**/vfs/** **/src/**} + #This can still return something like c:/repo/etc/src/vfs - which should be excluded by the pattern **/src/** + #todo - review and fix properly. + set argd [punk::args::parse $args withid ::punk::path::subfolders1] + lassign [dict values $argd] leaders opts values received + set do_recursion [dict exists $received -recursive] + set exclude_paths [dict get $opts -exclude-paths] + if {"**" in $exclude_paths} { + #if ** is in exclude_paths - then we can skip all glob matching and just return empty list + #This is likely user error - so we'll be loud about it for now but will still return empty list rather than erroring. + #If user code is building exclude_paths dynamically - they can check for this case themselves and avoid the call to subfolders1 to suppress this message. + puts stderr "punk::path::subfolders1 Warning - exclude_paths contains '**' - all paths will be excluded" + return [list] + } + if {[dict exists $received path]} { + set path [dict get $values path] + } else { + set path [pwd] + } + + set all_subfolders [glob -nocomplain -directory $path -types d *] + + + #example of expected exclude_paths pattern behaviour when recursion is enabled: + # **/dirname -> omit /x/y/dirname, but still visit /x/y/dirname/* + + # **/dirname/* -> include /x/y/dirname and /x/y/dirname/a/b but omit directories that are a single level below /x/y/dirname such as /x/y/dirname/a + + #c:/** - would exclude all subfolders below c: but not c: itself + + # **/test/** - would exclude any path with test as a segment and all its subfolders + #- but not paths with test as a segment that is the final segment + + set folders [list] + set recurse_subdirs [list] + + foreach f $all_subfolders { + set include_in_results 1 + set allow_recurse 1 + foreach pat $exclude_paths { + set pat_parts [file split $pat] ;#note file split c:/test gives {c:/ test} but file split **/test gives {** test} + #also note that file split on windows treats forward slashes and backslashes the same. + #by using file split, we gain some flexibility in syntax of paths and patterns, + #but lose the ability to use backslashes as escapes to allow literal glob characters in path segments. + #This is almost always a non-issue on windows since * and ? are not valid in path segments there, and is rarely an issue on unix even though + # * and ? are technically valid in path segments, but it is inadvisable there anyway for compatibility with shells etc. + if {[llength $pat_parts] >= 2 && [lindex $pat_parts end] eq "**"} { + set base_pat [file join {*}[lrange $pat_parts 0 end-1]] + if {[globmatchpath $pat $f]} { + set include_in_results 0 + set allow_recurse 0 + } elseif {[globmatchpath $base_pat $f]} { + set allow_recurse 0 + } + } elseif {[globmatchpath $pat $f]} { + set include_in_results 0 + } + if {!$include_in_results && !$allow_recurse} { + break + } + } + if {$include_in_results} { + lappend folders $f + } + if {$allow_recurse} { + lappend recurse_subdirs $f + } + } + if {$do_recursion} { + foreach subdir $recurse_subdirs { + lappend folders {*}[subfolders1 -exclude-paths $exclude_paths -recursive $subdir] + } + } + return $folders + } + + namespace eval subfolder_priv { + proc classify_exclude_pattern {pat} { + set parts [file split $pat] + if {[llength $parts] >= 2 && [lindex $parts end] eq "**"} { + set boundary_pat [file join {*}[lrange $parts 0 end-1]] + return [dict create {*}{ + } pattern $pat {*}{ + } kind subtree {*}{ + } boundary_pat $boundary_pat {*}{ + } descend_pat $pat {*}{ + } + ] + } + if {[llength $parts] >= 2 && [lindex $parts end] eq "*"} { + return [dict create {*}{ + } pattern $pat {*}{ + } kind child_only {*}{ + } match_pat $pat {*}{ + } + ] + } + return [dict create {*}{ + } pattern $pat {*}{ + } kind exact {*}{ + } match_pat $pat {*}{ + } + ] + } + + proc compile_exclude_rules {exclude_paths} { + set rules [list] + foreach pat $exclude_paths { + lappend rules [classify_exclude_pattern $pat] + } + return $rules + } + + proc match_rule_at_node {rule path} { + set kind [dict get $rule kind] + switch -- $kind { + exact - child_only { + if {[::punk::path::globmatchpath [dict get $rule match_pat] $path]} { + return [dict create include_current 0 recurse_below 1 child_rules [list $rule]] + } + return [dict create include_current 1 recurse_below 1 child_rules [list $rule]] + } + subtree { + set descend_pat [dict get $rule descend_pat] + set boundary_pat [dict get $rule boundary_pat] + if {[::punk::path::globmatchpath $descend_pat $path]} { + return [dict create include_current 0 recurse_below 0 child_rules [list]] + } + if {[::punk::path::globmatchpath $boundary_pat $path]} { + return [dict create include_current 1 recurse_below 0 child_rules [list]] + } + return [dict create include_current 1 recurse_below 1 child_rules [list $rule]] + } + default { + error "Unknown exclude rule kind '$kind'" + } + } + } + + proc walk_subfolders {path rules do_recursion} { + set all_subfolders [glob -nocomplain -directory $path -types d *] + set folders [list] + foreach f $all_subfolders { + set include_current 1 + set recurse_below $do_recursion + set child_rules [list] + foreach rule $rules { + set outcome [match_rule_at_node $rule $f] + if {![dict get $outcome include_current]} { + set include_current 0 + } + if {![dict get $outcome recurse_below]} { + set recurse_below 0 + } + if {$do_recursion} { + lappend child_rules {*}[dict get $outcome child_rules] + } + if {!$include_current && !$recurse_below} { + break + } + } + if {$include_current} { + lappend folders $f + } + if {$do_recursion && $recurse_below} { + lappend folders {*}[walk_subfolders $f $child_rules $do_recursion] + } + } + return $folders + } + } + + punk::args::define { + @id -id ::punk::path::subfolders + @cmd -name punk::path::subfolders\ + -summary\ + "Listing of directories below supplied path."\ + -help\ + "List of folders below path. + The resulting list is unsorted. + " + @opts + -recursive -type none -help\ + "" + -exclude-paths -type list -default {} -help\ + "list of path patterns to exclude from results. + May include * and ** path segments e.g /usr/** + A single /*/ will match any single segment in the path, and a single /**/ will match any number of segments in the path. + + e.g to exclude any path with _aside as a segment in the middle: -exclude-paths **/_aside/** + i.e this would exclude /usr/_aside/etc and /usr/x/_aside/etc but not /usr/x/_aside or _aside/etc + + To exclude all paths with _aside as a segment anywhere: -exclude-paths { **/_aside/** **/_aside ./_aside/**} + " + #todo -depth + @values -min 0 -max 1 + path -type directory -optional 1 -help\ + "Path of base folder. If not supplied current directory is used. + This may be a relative or absolute path. Relative paths are treated as relative to current directory. + When using relative paths - the result will also be relative paths with the same relative prefix. + (e.g if path is ../test - the results will be ../test/subfolder1 ../test/subfolder2 etc) + Patterns in -exclude-paths are matched against the resulting paths + (so should be written to match the same relative prefix if path is relative)" + } + + proc subfolders {args} { + set argd [punk::args::parse $args withid ::punk::path::subfolders] + lassign [dict values $argd] leaders opts values received + set do_recursion [dict exists $received -recursive] + set exclude_paths [dict get $opts -exclude-paths] + if {"**" in $exclude_paths} { + puts stderr "punk::path::subfolders Warning - exclude_paths contains '**' - all paths will be excluded" + return [list] + } + if {[dict exists $received path]} { + set path [dict get $values path] + } else { + set path [pwd] + } + set compiled_rules [subfolder_priv::compile_exclude_rules $exclude_paths] + return [subfolder_priv::walk_subfolders $path $compiled_rules $do_recursion] + } + + namespace eval treefile_priv { + proc _path_segment_matches {pattern_segment path_segment} { + if {[::punk::path::globmatchpath $pattern_segment $path_segment]} { + return 1 + } + if {[string range $pattern_segment end end] eq "/" && [string range $path_segment end end] eq "/"} { + set root_probe __punk_path_root_probe__ + return [::punk::path::globmatchpath [file join $pattern_segment $root_probe] [file join $path_segment $root_probe]] + } + return 0 + } + + proc _pattern_prefix_viable_parts {pattern_parts path_parts} { + if {![llength $path_parts]} { + return 1 + } + if {![llength $pattern_parts]} { + return 0 + } + + set pattern_head [lindex $pattern_parts 0] + set path_head [lindex $path_parts 0] + + if {$pattern_head eq "**"} { + if {[_pattern_prefix_viable_parts [lrange $pattern_parts 1 end] $path_parts]} { + return 1 + } + return [_pattern_prefix_viable_parts $pattern_parts [lrange $path_parts 1 end]] + } + + if {[_path_segment_matches $pattern_head $path_head]} { + return [_pattern_prefix_viable_parts [lrange $pattern_parts 1 end] [lrange $path_parts 1 end]] + } + return 0 + } + + proc pattern_prefix_viable {pattern path} { + return [_pattern_prefix_viable_parts [file split $pattern] [file split $path]] + } + + proc pattern_boundary {pattern} { + set parts [file split $pattern] + if {[llength $parts] >= 2 && [lindex $parts end] eq "**"} { + return [file join {*}[lrange $parts 0 end-1]] + } + return "" + } + + proc directory_state {glob_paths path inherited_allbelow} { + if {$inherited_allbelow} { + return [dict create include_files 1 recurse_below 1 next_allbelow 1] + } + + set include_files 0 + set recurse_below 0 + set next_allbelow 0 + + foreach gp $glob_paths { + if {[::punk::path::globmatchpath $gp $path]} { + set include_files 1 + set recurse_below 1 + set next_allbelow 1 + break + } + + set boundary [pattern_boundary $gp] + if {$boundary ne "" && [::punk::path::globmatchpath $boundary $path]} { + set recurse_below 1 + set next_allbelow 1 + continue + } + + if {[pattern_prefix_viable $gp $path]} { + set recurse_below 1 + } + } + + return [dict create {*}{ + } include_files $include_files {*}{ + } recurse_below $recurse_below {*}{ + } next_allbelow $next_allbelow {*}{ + } + ] + } + + proc child_path_state {glob_paths child_path inherited_allbelow} { + if {$inherited_allbelow} { + return 1 + } + foreach gp $glob_paths { + if {[pattern_prefix_viable $gp $child_path]} { + return 1 + } + } + return 0 + } + + proc _sort_paths {paths sortmode} { + switch -- $sortmode { + ascii { + return [lsort $paths] + } + dictionary { + return [lsort -dictionary $paths] + } + natural { + return [natsort::sort $paths] + } + default { + return $paths + } + } + } + + proc _path_matches_any {patterns path} { + foreach pattern $patterns { + if {[::punk::path::globmatchpath $pattern $path]} { + return 1 + } + } + return 0 + } + + proc _tailbase_relative {tailbase path} { + if {$tailbase eq ""} { + return $path + } + return [::punk::path::relative $tailbase $path] + } + + proc _tailbase_match_path {tailbase path} { + set match_path [_tailbase_relative $tailbase $path] + if {$match_path eq "."} { + return "" + } + return $match_path + } + + proc _tailbase_relative_list {tailbase paths} { + if {$tailbase eq ""} { + return $paths + } + set relative_paths [list] + foreach path $paths { + lappend relative_paths [_tailbase_relative $tailbase $path] + } + return $relative_paths + } + + proc _retain_files {matches exclude_files sortmode} { + set retained [list] + foreach match $matches { + set skip 0 + set file_tail [file tail $match] + foreach anti $exclude_files { + if {[string match $anti $file_tail]} { + set skip 1 + break + } + } + if {!$skip} { + lappend retained $match + } + } + return [_sort_paths $retained $sortmode] + } + + proc _state_from_argd {argd} { + set opts [dict get $argd opts] + set values [dict get $argd values] + set received [dict get $argd received] + + if {[dict exists $received -directory]} { + set directory [dict get $opts -directory] + } else { + set directory [pwd] + } + + set glob_paths [dict get $opts -include-paths] + if {"*" in $glob_paths} { + set glob_paths {*} + } + + set sortmode [dict get $opts -sort] + if {$sortmode eq "natural"} { + package require natsort + } + + return [dict create {*}{ + depth 0 + subvector {} + allbelow 0 + } sort $sortmode {*}{ + } directory $directory {*}{ + } tailbase [dict get $opts -tailbase] {*}{ + } exclude_paths [dict get $opts -exclude-paths] {*}{ + } exclude_files [dict get $opts -exclude-files] {*}{ + } glob_paths $glob_paths {*}{ + } tailglobs [dict get $values tailglobs] {*}{ + } + ] + } + + proc walk_treefilenames {state} { + set opt_dir [dict get $state directory] + set opt_tailbase [dict get $state tailbase] + set depth [dict get $state depth] + set subvector [dict get $state subvector] + set callallbelow [dict get $state allbelow] + set opt_sort [dict get $state sort] + set opt_exclude_paths [dict get $state exclude_paths] + set opt_exclude_files [dict get $state exclude_files] + set opt_glob_paths [dict get $state glob_paths] + set tailglobs [dict get $state tailglobs] + + if {![file isdirectory $opt_dir]} { + return [list] + } + if {[string match //zipfs:/* $opt_dir]} { + return [walk_treefilenames_zipfs $state] + } + set opt_dir_match [_tailbase_match_path $opt_tailbase $opt_dir] + if {[_path_matches_any $opt_exclude_paths $opt_dir_match]} { + return [list] + } + + set files [list] + set dir_state [directory_state $opt_glob_paths $opt_dir_match $callallbelow] + if {[dict get $dir_state include_files]} { + if {[catch {glob -nocomplain -dir $opt_dir -type f -- {*}$tailglobs} matches]} { + puts stderr "treefilenames error while listing files in dir $opt_dir\n $matches" + set dirfiles [list] + } else { + #also match hidden files (e.g dotfiles on windows where glob -type f misses them) + if {![catch {glob -nocomplain -dir $opt_dir -types {hidden f} -- {*}$tailglobs} hidden_matches]} { + foreach h $hidden_matches { + if {$h ni $matches} { + lappend matches $h + } + } + } + set dirfiles [_retain_files $matches $opt_exclude_files $opt_sort] + } + lappend files {*}[_tailbase_relative_list $opt_tailbase $dirfiles] + } + + if {![dict get $dir_state recurse_below]} { + return $files + } + + if {[catch {glob -nocomplain -dir $opt_dir -type d *} dirdirs]} { + puts stderr "treefilenames error while listing subdirs in dir $opt_dir\n $dirdirs" + set dirdirs [list] + } + #also match hidden directories + if {![catch {glob -nocomplain -dir $opt_dir -types {hidden d} *} hidden_dirdirs]} { + foreach h $hidden_dirdirs { + switch -- $h { + "." - ".." {continue} + default { + if {$h ni $dirdirs} { + lappend dirdirs $h + } + } + } + } + } + set okdirs [list] + foreach dir $dirdirs { + if {![_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $dir]]} { + lappend okdirs $dir + } + } + + if {$opt_glob_paths eq "*"} { + set matchdirs $okdirs + } else { + set matchdirs [list] + foreach dir $okdirs { + if {$callallbelow || [child_path_state $opt_glob_paths [_tailbase_match_path $opt_tailbase $dir] $callallbelow]} { + lappend matchdirs $dir + } + } + } + + set finaldirs [_sort_paths $matchdirs $opt_sort] + set childallbelow [expr {$callallbelow || [dict get $dir_state next_allbelow]}] + set nextsubvector [list {*}$subvector [file tail $opt_dir]] + foreach dir $finaldirs { + set child_state [dict merge $state [dict create {*}{ + } directory $dir {*}{ + } depth [expr {$depth + 1}] {*}{ + } subvector $nextsubvector {*}{ + } allbelow $childallbelow {*}{ + } + ]] + lappend files {*}[walk_treefilenames $child_state] + } + return $files + } + + proc walk_treefilenames_zipfs {state} { + set opt_dir [dict get $state directory] + set opt_tailbase [dict get $state tailbase] + set opt_exclude_paths [dict get $state exclude_paths] + set opt_exclude_files [dict get $state exclude_files] + set opt_glob_paths [dict get $state glob_paths] + set opt_sort [dict get $state sort] + set tailglobs [dict get $state tailglobs] + + if {![string match [zipfs root]* $opt_dir]} { + error "treefilenames_zipfs can only be used on paths beginning with [zipfs root] on this systems" + } + set dir [string trimright $opt_dir "/"] + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $dir]]} { + return [list] + } + set dirlen [string length $dir] + set subpaths [zipfs list $dir/*] + set dirlist [list] + set skipdirs [list] + set filelist [list] + foreach sub $subpaths { + set tail [string range $sub $dirlen+1 end] + set tailparts [file split $tail] + set accum "" + set skipdir 0 + foreach tailpart [lrange $tailparts 0 end-1] { + append accum "/$tailpart" + set superpath "${dir}${accum}" + if {$superpath in $skipdirs} { + set skipdir 1 + break + } + if {$superpath ni $dirlist} { + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $superpath]]} { + lappend skipdirs $superpath + set skipdir 1 + break + } else { + lappend dirlist $superpath + } + } + } + if {!$skipdir} { + append accum "/[lindex $tailparts end]" + set finalpart "${dir}${accum}" + if {$finalpart ni $dirlist} { + if {[file type $finalpart] eq "file"} { + set file_tail [lindex $tailparts end] + set match 0 + if {"*" ni $tailglobs} { + foreach tailglob $tailglobs { + if {[string match $tailglob $file_tail]} { + set match 1 + break + } + } + } else { + set match 1 + } + if {$match && $opt_glob_paths ne "*"} { + set file_dir_match [_tailbase_match_path $opt_tailbase [file dirname $finalpart]] + set file_dir_state [directory_state $opt_glob_paths $file_dir_match 0] + set match [dict get $file_dir_state include_files] + } + if {$match} { + set skipfile 0 + foreach anti $opt_exclude_files { + if {[string match $anti $file_tail]} { + set skipfile 1 + break + } + } + if {!$skipfile} { + lappend filelist [_tailbase_relative $opt_tailbase $finalpart] + } + } + } else { + if {$finalpart ni $dirlist} { + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $finalpart]]} { + lappend skipdirs $finalpart + } else { + lappend dirlist $finalpart + } + } + } + } + } + } + return [_sort_paths $filelist $opt_sort] + } + } + + #todo - treefolders with similar search caps as treefilenames + + punk::args::define { + @id -id ::punk::path::treefilenames + @cmd -name punk::path::treefilenames\ + -summary\ + "List of filenames below supplied path."\ + -help\ + "List of filenames below path. + The resulting list is unsorted. + + The path globbing syntax supports *, ** and ? as glob characters in any segment of the path, with the following semantics: + * matches any single segment in the path + ** matches 1 or more segments in the path (so /usr/**/bin will match /usr/x/bin and user/x/y/bin but not /usr/bin ) + ? matches any single character in a single segment of the path (so /usr/te?t will match /usr/test and /usr/text but not /usr/texxt) + " + -directory -type directory -help\ + "folder in which to begin recursive scan for files." + -tailbase -type string -default "" -help\ + "if supplied, only the relative path compared to the tailbase will be returned for each file. + So if tailbase is /usr and a file is found at /usr/x/y/file.txt, the returned path for that file would be x/y/file.txt. + If tailbase is not supplied, the full path to each file will be returned. + + If tailbase is supplied, it should be a prefix of the directory supplied (or the directory itself) + The patterns in -exclude-paths should be written to match the returned paths (i.e with the tailbase prefix removed) if -tailbase is supplied. + If the tailbase is not a prefix of the directory supplied, the resulting paths may have /../ components in them to account for the difference, + but the behaviour is not well defined in this case and it is recommended to ensure tailbase is a prefix of the directory supplied if using -tailbase. + + see: punk::path::relative to compute relative paths + " + -sort -type any -default natural -choices {none ascii dictionary natural} + -exclude-paths -default {} -help\ + "list of path patterns to exclude + may include * and ** path segments e.g + /usr/** (exclude subfolders based at /usr but not + files within /usr itself) + **/_aside (exclude files where _aside is last segment) + **/_aside/* (exclude folders one below an _aside folder) + **/_aside/** (exclude files in all folders with _aside as a segment)" + -exclude-files -default {} + -include-paths -default {**} -help\ + "list of path patterns to include + may include * and ** path segments e.g + /usr/** (include files in subfolders based at /usr but not + files within /usr itself) + **/_aside (include files where _aside is last segment in the folder) + **/_aside/* (include files in folders one below an _aside folder) + **/_aside/** (include all files in folders with _aside as a segment)" + @values -min 0 -max -1 -optional 1 -type string + tailglobs -default * -multiple 1 -help\ + "Patterns to match against filename portion (last segment) of each file path + within the directory tree being searched." + } + + #todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/ + #then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase) + proc treefilenames {args} { + set argd [punk::args::parse $args withid ::punk::path::treefilenames] + set state [treefile_priv::_state_from_argd $argd] + return [treefile_priv::walk_treefilenames $state] + } + punk::args::set_idalias ::punk::path::treefilenames_zipfs ::punk::path::treefilenames + proc treefilenames_zipfs {args} { + #seems to be 2 or 3 times faster than treefilenames for //zipfs:/ paths - REVIEW + # is sort order the same? + set argd [punk::args::parse $args withid ::punk::path::treefilenames] + set state [treefile_priv::_state_from_argd $argd] + if {![file isdirectory [dict get $state directory]]} { + return [list] + } + return [treefile_priv::walk_treefilenames_zipfs $state] + } + + punk::args::define { + @id -id ::punk::path::relative + @cmd -name punk::path::relative\ + -summary\ + "Compute the relative path from a reference path to a location path."\ + -help\ + "Taking two directory paths, a reference and a location, computes the path + of the location relative to the reference. + + Will return a single dot '.' if the paths are the same. + + Both paths must be the same type - ie both absolute or both relative. + + Matching is case sensitive. On windows, the drive-letter component (only) is + not case sensitive, so punk::path::relative c:/etc C:/etc returns '.'. + The part following the driveletter is case sensitive, so + punk::path::relative c:/etc C:/Etc returns ../Etc. + + On windows, if the paths are absolute and specify different volumes, + only the location will be returned." + @leaders -min 2 -max 2 + reference -type string -help\ + "The path from which the relative path to location is determined." + location -type string -help\ + "The location path which may be above or below the reference path." + } + #maint warning - also in punkcheck + proc relative {reference location} { + #see also kettle + # Modified copy of ::fileutil::relative (tcllib) + # Adapted to 8.5 ({*}). + + #review - check volume info on windows.. UNC paths? + if {[file pathtype $reference] ne [file pathtype $location]} { + return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $reference] vs. [file pathtype $location], ($reference vs. $location)" + } + + #avoid normalizing if possible (file normalize *very* expensive on windows) + set do_normalize 0 + if {[file pathtype $reference] eq "relative"} { + #if reference is relative so is location + if {[regexp {[.]{2}} [list $reference $location]]} { + set do_normalize 1 + } + if {[regexp {[.]/} [list $reference $location]]} { + set do_normalize 1 + } + } else { + set do_normalize 1 + } + if {$do_normalize} { + set reference [file normalize $reference] + set location [file normalize $location] + } + + set save $location + set reference [file split $reference] + set location [file split $location] + + while {[lindex $location 0] eq [lindex $reference 0]} { + set location [lrange $location 1 end] + set reference [lrange $reference 1 end] + if {![llength $location]} {break} + } + + set location_len [llength $location] + set reference_len [llength $reference] + + if {($location_len == 0) && ($reference_len == 0)} { + # Cases: + # (a) reference == location + + set location . + } else { + # Cases: + # (b) ref is: ref/sub = sub + # loc is: ref = {} + + # (c) ref is: ref = {} + # loc is: ref/sub = sub + + while {$reference_len > 0} { + #set location [linsert $location 0 ..] + ledit location -1 -1 .. + incr reference_len -1 + } + set location [file join {*}$location] + } + return $location + } + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::path ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::path::lib { + namespace export * + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace punk::path::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::path::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +namespace eval punk::path::system { + #*** !doctools + #[subsection {Namespace punk::path::system}] + #[para] Internal functions that are not part of the API + + + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::path [namespace eval punk::path { + variable pkg punk::path + variable version + set version 0.2.0 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/bootsupport/modules/punkcheck-0.2.0.tm b/src/bootsupport/modules/punkcheck-0.2.0.tm new file mode 100644 index 00000000..351647d0 --- /dev/null +++ b/src/bootsupport/modules/punkcheck-0.2.0.tm @@ -0,0 +1,2479 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'dev 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 punkcheck 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + +package require punk::tdl +package require punk::path +package require punk::repo +package require punk::mix::util + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Punkcheck uses the TDL format which is a list of lists in Tcl format +# It is intended primarily for source build/distribution tracking within a punk project or single filesystem - with relative paths. +# +#see following article regarding the many problems with using mtime for build-decisions: https://apenwarr.ca/log/20181113 +# +namespace eval punkcheck { + namespace export {*}{ + uuid + installtrack + install + install_tm_files + install_non_tm_files + summarize_install_resultdict + } + + #exclude-paths entries match against the full relative path using globmatchpath. + #They may include ** to match across path segments and / to match within a segment. + #Each dir-seg pattern is expanded to both top-level and nested (**/) forms to preserve + #the "matches at any directory level" semantics of the former dir-seg mechanism. + variable default_excludepaths_core [list "#*" "**/#*" "_aside" "**/_aside" "_build" "**/_build" ".git" "**/.git" ".fossil*" "**/.fossil*"] + variable default_excludefiletail_core "" + #backward-compat: retained for callers that still read default_excludedirseg_core + variable default_excludedirseg_core [list "#*" "_aside" "_build" ".git" ".fossil*"] + + set has_twapi 0 + if {"windows" eq $::tcl_platform(platform)} { + set has_twapi [expr {![catch {package require twapi}]}] + } + if {$has_twapi} { + interp alias "" ::punkcheck::uuid "" ::twapi::new_uuid + } else { + catch {package require uuid} + interp alias "" ::punkcheck::uuid "" ::uuid::uuid generate + } + + proc default_excludepaths_core {} { + variable default_excludepaths_core + return $default_excludepaths_core + } + #backward-compat alias for the former segment-based default + proc default_excludedirseg_core {} { + variable default_excludedirseg_core + return $default_excludedirseg_core + } + proc default_excludefiletail_core {} { + variable default_excludefiletail_core + if {$default_excludefiletail_core eq ""} { + set default_excludefiletail_core [list "*.swp" "*[punk::mix::util::tm_version_magic]*" "*-buildversion.txt" ".punkcheck"] + } + return $default_excludefiletail_core + } + + + proc load_records_from_file {punkcheck_file} { + set record_list [list] + if {[file exists $punkcheck_file]} { + set tdlscript [punk::mix::util::fcat $punkcheck_file] + if {[catch { + set record_list [punk::tdl::prettyparse $tdlscript] + } errparse]} { + error "punkcheck::load_records_from_file failed to parse '$punkcheck_file'\n error:$errparse" + } + } + return $record_list + } + proc save_records_to_file {recordlist punkcheck_file {trigger {}} {debugchannel ""}} { + set newtdl [punk::tdl::prettyprint $recordlist] + set linecount [llength [split $newtdl \n]] + + if {$debugchannel ne "" && $trigger ne ""} { + puts $debugchannel "\x1b\[36mSaving [llength $recordlist] records as $linecount lines to file '$punkcheck_file' trigger: \x1b\[32m$trigger\x1b\[m" + } + #puts stdout $newtdl + set fd [open $punkcheck_file w] + chan configure $fd -translation binary + puts -nonewline $fd $newtdl + flush $fd + close $fd + return [list recordcount [llength $recordlist] linecount $linecount] + } + + + #todo - work out way to use same punkcheck file for multiple installers running concurrently. Thread? + #an installtrack objects represents an installation path from sourceroot to targetroot + #The source and target folders should be as specific as possible but it is valid to specify for example c:/ -> c:/ (or / -> /) if source and targets within the installation operation are spread around. + # + set objname [namespace current]::installtrack + if {$objname ni [info commands $objname]} { + package require oolib + + #FILEINFO record - target fileset with body records: INSTALL-RECORD,INSTALL-INPROGRESS,INSTALL-SKIPPED,DELETE-RECORD,DELETE-INPROGRESS,MODIFY-INPROGRESS,MODIFY-RECORD + #each FILEINFO body being a list of SOURCE records + oo::class create targetset { + variable o_targets + variable o_keep_installrecords + variable o_keep_skipped + variable o_keep_inprogress + variable o_records + constructor {args} { + #set o_records [oolib::collection create [namespace current]::recordcollection] + set o_records [list] + + } + + method as_record {} { + dict create {*}{ + } tag FILEINFO {*}{ + } -targets $o_targets {*}{ + } -keep_installrecords $o_keep_installrecords {*}{ + } -keep_skipped $o_keep_skipped {*}{ + } -keep_inprogress $o_keep_inprogress {*}{ + } body $o_records {*}{ + } + } + + #retrieve last completed record for the fileset ie exclude SKIPPED,INSTALL-INPROGRESS,DELETE-INPROGRESS,MODIFY-INPROGRESS + method get_last_record {fileset_record} { + set body [dict_getwithdefault $fileset_record body [list]] + set previous_records [lrange $body 0 end-1] + #get last previous that is tagged INSTALL-RECORD,MODIFY-RECORD,DELETE-RECORD + set revlist [lreverse $previous_records] + foreach rec $revlist { + switch -- [dict get $rec tag] { + INSTALL-RECORD - MODIFY-RECORD - DELETE-RECORD - VIRTUAL-RECORD { + return $rec + } + } + } + return [list] + } + } + + #instances created by an installtrack object in method start_event + #also in installtrack constructor - to represent existing events from the .punkcheck data + oo::class create installevent { + variable o_id + variable o_rel_sourceroot + variable o_rel_targetroot + variable o_ts_begin + variable o_ts_end + variable o_types + variable o_configdict + variable o_targets + variable o_operation + variable o_operation_start_ts + variable o_path_cksum_cache + variable o_fileset_record + variable o_installer ;#parent object + variable o_debugchannel + constructor {installer rel_sourceroot rel_targetroot args} { + set o_installer $installer + set o_debugchannel [$installer get_debugchannel] + set o_operation_start_ts "" + set o_path_cksum_cache [dict create] + set o_operation "" + set defaults [dict create {*}{ + -id "" + -tsbegin "" + -config {} + -tsend "" + -types {} + }] + set opts [dict merge $defaults $args] + if {[dict get $opts -id] eq ""} { + set o_id [punkcheck::uuid] + } else { + set o_id [dict get $opts -id] + } + if {[dict get $opts -tsbegin] eq ""} { + set o_ts_begin [clock microseconds] + } else { + set o_ts_begin [dict get $opts -tsbegin] + } + set o_ts_end [dict get $opts -tsend] + set o_types [dict get $opts -types] + set o_configdict [dict get $opts -config] + + set o_rel_sourceroot $rel_sourceroot + set o_rel_targetroot $rel_targetroot + } + destructor { + #puts "[self] destructor called" + } + method as_record {} { + set begin_seconds [expr {$o_ts_begin / 1000000}] + set tsiso_begin [clock format $begin_seconds -format "%Y-%m-%dT%H:%M:%S"] + if {$o_ts_end ne ""} { + set end_seconds [expr {$o_ts_end / 1000000}] + set tsiso_end [clock format $end_seconds -format "%Y-%m-%dT%H:%M:%S"] + } else { + set tsiso_end "" + } + + dict create {*}{ + } tag EVENT {*}{ + } -tsiso_begin $tsiso_begin {*}{ + } -ts_begin $o_ts_begin {*}{ + } -tsiso_end $tsiso_end {*}{ + } -ts_end $o_ts_end {*}{ + } -id $o_id {*}{ + } -source $o_rel_sourceroot {*}{ + } -targets $o_rel_targetroot {*}{ + } -types $o_types {*}{ + } -config $o_configdict {*}{ + } + } + method get_id {} { + return $o_id + } + method get_operation {} { + return $o_operation + } + method get_targets {} { + return $o_targets + } + method get_targets_exist {} { + set punkcheck_folder [file dirname [$o_installer get_checkfile]] + #puts stdout "### punkcheck glob -dir $punkcheck_folder -tails {*}$o_targets" + #targets can be paths such as punk/mix/commandset/module-0.1.0.tm - glob can search levels below supplied -dir + set existing [glob -nocomplain -dir $punkcheck_folder -tails {*}$o_targets] + + return $existing + } + method end {} { + set o_ts_end [clock microseconds] + } + method targetset_dict {} { + punk::records_as_target_dict [$o_installer get_recordlist] + } + + #related - installfile_begin + #call init before we know if we are going to run the operation vs skip + method targetset_init {operation targetset} { + set known_ops [list QUERY INSTALL MODIFY DELETE VIRTUAL] + if {[string toupper $operation] ni $known_ops} { + error "[self] add_target unknown operation '$operation'. Known operations $known_ops" + } + set o_operation [string toupper $operation] + + if {$o_operation_start_ts ne ""} { + error "[self] targetset_init $o_operation operation already in progress. Use targetset_finished or targetset_complete to finish." + } + set o_operation_start_ts [clock microseconds] + set seconds [expr {$o_operation_start_ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] + + set relativepath_targetset [list] + if {$o_operation eq "VIRTUAL"} { + foreach p $targetset { + lappend relativepath_targetset $p + } + } else { + foreach p $targetset { + if {[file pathtype $p] eq "absolute"} { + lappend relativepath_targetset [punkcheck::lib::path_relative $punkcheck_folder $p] + } else { + lappend relativepath_targetset $p + } + } + } + + + set fields [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $o_operation_start_ts {*}{ + } -installer [$o_installer get_name] {*}{ + } -eventid $o_id {*}{ + } + ] + + set o_targets [lsort -dictionary -increasing $relativepath_targetset] ;#exact sort order not critical - but must be consistent + + + set record_list [punkcheck::load_records_from_file $punkcheck_file] + + #--------------------------------------------------------------------------- + #load as dict to test for dupes + #set _targetdict [my targetset_dict] + if {[catch { + set _targetdict [punkcheck::recordlist::records_as_target_dict $record_list] + } errMsg]} { + error "targetset_init operation:$operation error verifying existing records from file $punkcheck_file. Error: $errMsg" + } + #--------------------------------------------------------------------------- + + set extractioninfo [punkcheck::recordlist::extract_or_create_fileset_record $o_targets $record_list] + set o_fileset_record [dict get $extractioninfo record] + set record_list [dict get $extractioninfo recordset] ;#if fileset wasn't present, same as original record_list, otherwise full recordset with the fileset record removed, ready for reinsertion. + set isnew [dict get $extractioninfo isnew] + set oldposition [dict get $extractioninfo oldposition] + unset extractioninfo + + #INSTALL-INPROGRESS will become INSTALL-RECORD or INSTALL-FAILED or INSTALL-SKIPPED upon finalisation + #-installer and -eventid keys are added here + set new_inprogress_record [dict create tag [string toupper $operation]-INPROGRESS {*}$fields -tempcontext [my as_record] body {}] + #set existing_body [dict_getwithdefault $o_fileset_record body [list]] + #todo - look for existing "-INPROGRESS" records - mark as failed or incomplete? + dict lappend o_fileset_record body $new_inprogress_record + + if {$isnew} { + lappend record_list $o_fileset_record + } else { + #set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record] + ledit record_list $oldposition -1 $o_fileset_record + } + if {$o_operation ne "QUERY"} { + punkcheck::save_records_to_file $record_list $punkcheck_file "targetset_init $o_operation [llength $targetset] targets" + } + return $o_fileset_record + + } + #operation has been started + #todo - upgrade .punkcheck format to hold more than just list of SOURCE entries in each record. + # - allow arbitrary targetset_startphase targetset_endphase calls to store timestamps and calculate elapsed time + method targetset_started {} { + set punkcheck_folder [file dirname [$o_installer get_checkfile]] + if {$o_operation eq "QUERY"} { + set fileinfo_body [dict get $o_fileset_record body] ;#body of FILEINFO record + set installing_record [lindex $fileinfo_body end] + + set ts_start [dict get $installing_record -ts] + set ts_now [clock microseconds] + set metadata_us [expr {$ts_now - $ts_start}] + + #?? + #JJJ + #dict set installing_record -metadata_us $metadata_us + dict set installing_record -ts_start_transfer $ts_now + + lset fileinfo_body end $installing_record + + return [dict set o_fileset_record body $fileinfo_body] + } else { + #legacy call + #saves to .punkcheck file + return [set o_fileset_record [punkcheck::installfile_started_install $punkcheck_folder $o_fileset_record]] + } + } + method targetset_end {status args} { + set defaults [dict create {*}{ + -note \uFFFF + }] + set known_opts [dict keys $defaults] + if {[llength $args] % 2} { + error "targetset_end arguments after status must be in the form of -flag value pairs. known flags: $known_opts" + } + set opts [dict merge $defaults $args] + if {[dict get $opts -note] eq "\uFFFF"} { + dict unset opts -note + } + + set status [string toupper $status] + set statusdict [dict create OK RECORD SKIPPED SKIPPED FAILED FAILED] + if {$o_operation_start_ts eq ""} { + error "[self] targetset_end $status - no current operation - call targetset_started first" + } + if {$status ni [dict keys $statusdict]} { + error "[self] targetset_end unrecognized status:$status known values: [dict keys $statusdict]" + } + if {![punkcheck::lib::is_file_record_inprogress $o_fileset_record]} { + error "targetset_end $status error: bad fileset_record - expected FILEINFO with last body element *-INPROGRESS" + } + set targetlist [dict get $o_fileset_record -targets] + if {$targetlist ne $o_targets} { + error "targetset_end $status error. targetlist mismatch between file : $targetlist vs $o_targets" + } + set operation_end_ts [clock microseconds] + set elapsed_us [expr {$operation_end_ts - $o_operation_start_ts}] + set file_record_body [dict get $o_fileset_record body] + set installing_record [lindex $file_record_body end] + set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] + set record_list [punkcheck::load_records_from_file $punkcheck_file] + if {[dict exists $installing_record -ts_start_transfer]} { + set ts_start_transfer [dict get $installing_record -ts_start_transfer] + set transfer_us [expr {$operation_end_ts - $ts_start_transfer}] + dict set installing_record -transfer_us $transfer_us + } + if {[dict exists $opts -note]} { + dict set installing_record -note [dict get $opts -note] + } + + dict set installing_record -elapsed_us $elapsed_us + dict unset installing_record -tempcontext + dict set installing_record tag "${o_operation}-[dict get $statusdict $status]" ;# e.g INSTALL-RECORD, INSTALL-SKIPPED + if {$o_operation in [list INSTALL MODIFY] && [dict get $statusdict $status] eq "RECORD"} { + #only calculate and store post operation target cksums on successful INSTALL or MODIFY, doesn't make sense for DELETE or VIRTUAL operations + set new_targets_cksums [list] ;#ordered list of cksums matching targetset order + set cksum_all_opts "" ;#same cksum opts for each target so we store it once + set ts_begin_cksum [clock microseconds] + foreach p $o_targets { + set tgt_cksum_info [punk::mix::base::lib::cksum_path [file join $punkcheck_folder $p]] + lappend new_targets_cksums [dict get $tgt_cksum_info cksum] + if {$cksum_all_opts eq ""} { + set cksum_all_opts [dict get $tgt_cksum_info opts] + } + } + set cksum_us [expr {[clock microseconds] - $ts_begin_cksum}] + dict set installing_record -targets_cksums $new_targets_cksums + dict set installing_record -cksum_all_opts $cksum_all_opts + dict set installing_record -cksum_us $cksum_us + } + lset file_record_body end $installing_record + dict set o_fileset_record body $file_record_body + set o_fileset_record [punkcheck::recordlist::file_record_prune $o_fileset_record] + + set oldrecordinfo [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $oldrecordinfo position] + if {$old_posn == -1} { + lappend record_list $o_fileset_record + } else { + lset record_list $old_posn $o_fileset_record + } + if {$o_operation ne "QUERY"} { + punkcheck::save_records_to_file $record_list $punkcheck_file "targetset_end $o_operation $status [llength $o_targets] targets" + } + set o_operation_start_ts "" + set o_operation "" + return $o_fileset_record + } + #can supply empty cksum value + # - that will influence the opts used if there is no existing install record + method targetset_cksumcache_set {path_cksum_dict} { + set o_path_cksum_cache $path_cksum_dict + } + method targetset_cksumcache_configure {path {cksuminfodict {}}} { + if {$cksuminfodict eq {}} { + if {[dict exists $o_path_cksum_cache $path]} { + return [dict get $o_path_cksum_cache $path] + } else { + return + } + } + dict for {k v} $cksuminfodict { + switch -- $k { + cksum - opts {} + default { + error "targetset_cksumcache_configure error. Unknown dict value $k. Allowed values {cksum opts}" + } + } + } + dict set o_path_cksum_cache $path $cksuminfodict + } + method targetset_addsource {source_path} { + set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] + if {[file pathtype $source_path] eq "absolute"} { + set rel_source_path [punkcheck::lib::path_relative $punkcheck_folder $source_path] + } else { + set rel_source_path $source_path + } + + #installfile_add_source_and_fetch_metadata accepts list of {cksum opt } dictionaries - although we only have one per path from our configured cksumcache + if {[dict exists $o_path_cksum_cache $rel_source_path]} { + set path_cksum_caches [list [dict get $o_path_cksum_cache $rel_source_path]] + } else { + set path_cksum_caches [list] + } + set o_fileset_record [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $rel_source_path $o_fileset_record $path_cksum_caches] + #JJJ - update -metadata_us here? + + } + method targetset_last_complete {} { + #retrieve last completed record for the fileset ie exclude SKIPPED,INSTALL-INPROGRESS,DELETE-INPROGRESS,MODIFY-INPROGRESS + set body [punkcheck::dict_getwithdefault $o_fileset_record body [list]] + set previous_records [lrange $body 0 end] + #get last that is tagged INSTALL-RECORD,MODIFY-RECORD,DELETE-RECORD + set revlist [lreverse $previous_records] + foreach rec $revlist { + if {[dict get $rec tag] in [list "INSTALL-RECORD" "MODIFY-RECORD" "DELETE-RECORD" "VIRTUAL-RECORD"]} { + return $rec + } + } + return [list] + + } + method targetset_source_changes {} { + punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $o_fileset_record body] end] + } + + } + + + oo::class create installtrack { + variable o_name + variable o_tsiso + variable o_ts + variable o_keep_events + variable o_checkfile + variable o_sourceroot + variable o_rel_sourceroot + variable o_targetroot + variable o_rel_targetroot + variable o_record_list + variable o_active_event + variable o_events + variable o_debugchannel + constructor {installername punkcheck_file {debugchannel ""}} { + set o_debugchannel $debugchannel + set o_active_event "" + set o_name $installername + + set o_checkfile [file normalize $punkcheck_file] + set o_sourceroot "" + set o_targetroot "" + set o_rel_sourceroot "" + set o_rel_targetroot "" + set o_record_list [list] + + #todo - validate punkcheck file location further?? + set punkcheck_folder [file dirname $o_checkfile] + if {![file isdirectory $punkcheck_folder]} { + error "[self] constructor error. Folder for punkcheck_file not found - $o_checkfile" + } + + my load_all_records + if {![llength $o_record_list] && $o_debugchannel ne ""} { + puts $o_debugchannel "\x1b\[32mNo existing records found in punkcheck file '$o_checkfile' for installer '$installername'. Starting with empty record list.\x1b\[m" + } else { + #verify no duplicate installer records for this installer. + #JMN + set sanity_dict [dict create] + set insane "" + foreach rec $o_record_list { + if {[dict get $rec tag] eq "INSTALLER"} { + set name [dict get $rec -name] + if {[dict exists $sanity_dict $name]} { + #todo - warn - duplicate record for same targetlist - shouldn't happen as we should be using get_file_record to find existing records + if {$o_debugchannel ne ""} { + puts $o_debugchannel "\x1b\[31mpunkcheck installtrack - multiple INSTALLER records with same name '$name'\x1b\[m" + } + set insane "$name" + break + } + dict set sanity_dict $name {} + } + } + if {$insane ne ""} { + set msg "Sanity check: punkcheck file '$o_checkfile' contains multiple records for INSTALLER -name '$insane'." + append msg \n "This may indicate a problem such as multiple concurrent installtrack instances using the same punkcheck file," + append msg \n " or a previous installtrack instance that did not complete properly." + append msg \n " Do you want to DELETE the .punkcheck file?" + append msg \n " It is safe to delete .punkcheck files, at the cost of loss of history and checksums used to optimize installs." + append msg \n " They are a record of installation events and checksums used to avoid unnecessary reinstalls." + append msg \n " If not confirmed, an error will be raised - likely aborting the current operation." + append msg \n "confirm deletion and continue by regenerating the file, by typing the 3 letters: 'yes'." + set answer [punk::lib::askuser $msg] + if {[string tolower $answer] ne "yes"} { + error "Failing due to sanity check failure. User did not confirm with 'yes'." + } + if {[file exists $o_checkfile] && [file isfile $o_checkfile]} { + file delete $o_checkfile + } + if {[file exists $o_checkfile]} { + error "Failed to delete punkcheck file '$o_checkfile' after sanity check failure. Please investigate and resolve the issue before proceeding." + } + set o_record_list [list] + } else { + if {$o_debugchannel ne ""} { + puts $o_debugchannel "\x1b\[32mSanity check passed: no duplicate INSTALLER records found for installer '$installername' in punkcheck file '$o_checkfile'.\x1b\[m" + } + } + unset sanity_dict + } + + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + set this_installer_record [punkcheck::recordlist::new_installer_record $o_name] + #set o_record_list [linsert $o_record_list 0 $this_installer_record] + ledit o_record_list -1 -1 $this_installer_record + } else { + set this_installer_record [dict get $resultinfo record] + } + set o_tsiso [dict get $this_installer_record -tsiso] + set o_ts [dict get $this_installer_record -ts] + set o_keep_events [dict get $this_installer_record -keep_events] + + set o_events [oolib::collection create [namespace current]::eventcollection] + set eventlist [punkcheck::dict_getwithdefault $this_installer_record body [list]] + foreach e $eventlist { + set eobj [punkcheck::installevent create [namespace current]::event_[my events count] [self] [dict get $e -source] [dict get $e -targets] {*}$e] + #$o_events add $e [dict get $e -id] + $o_events add $eobj [dict get $e -id] + } + + } + destructor { + #puts "[self] destructor called" + } + method test {} { + return [self] + } + method get_name {} { + return $o_name + } + method get_checkfile {} { + return $o_checkfile + } + method get_debugchannel {} { + return $o_debugchannel + } + + #call set_source_target before calling start_event/end_event + #each event can have different source->target pairs - but may often have same, so set on installtrack as defaults. Only persisted in event records. + method set_source_target {sourceroot targetroot} { + if {[file pathtype $sourceroot] ne "absolute"} { + error "[self] set_source_target error: sourceroot must be absolute path. Received '$sourceroot'" + } + if {[file pathtype $targetroot] ne "absolute"} { + error "[self] set_source_target error: targetroot must be absolute path. Received '$targetroot'" + } + set punkcheck_folder [file dirname $o_checkfile] + set o_sourceroot $sourceroot + set o_targetroot $targetroot + set o_rel_sourceroot [punkcheck::lib::path_relative $punkcheck_folder $sourceroot] + set o_rel_targetroot [punkcheck::lib::path_relative $punkcheck_folder $targetroot] + return [list $o_rel_sourceroot $o_rel_targetroot] + } + #review/fix to allow multiple installtrack objects on same punkcheck file. + method load_all_records {} { + set o_record_list [punkcheck::load_records_from_file $o_checkfile] + } + + #does not include associated FILEINFO records - as a targetset (FILEINFO record) can be associated with events from multiple installers over time. + #e.g a logfile common to installers, or a separate installer that updates a previous output. + method as_record {} { + set eventrecords [list] + foreach eobj [my events items] { + lappend eventrecords [$eobj as_record] + } + set fields [list {*}{ + } -tsiso $o_tsiso {*}{ + } -ts $o_ts {*}{ + } -name $o_name\ {*}{ + } -keep_events $o_keep_events {*}{ + } body $eventrecords {*}{ + } + ] + set record [dict create tag INSTALLER {*}$fields] + } + #open file and save only own records + method save_all_records {} { + my save_installer_record + #todo - save FILEINFO targetset records + } + method save_installer_record {} { + set file_records [punkcheck::load_records_from_file $o_checkfile] + + set this_installer_record [my as_record] + + set persistedinfo [punkcheck::recordlist::get_installer_record $o_name $file_records] + set existing_header_posn [dict get $persistedinfo position] + if {$existing_header_posn == -1} { + #set file_records [linsert $file_records 0 $this_installer_record] + ledit file_records -1 -1 $this_installer_record + } else { + lset file_records $existing_header_posn $this_installer_record + } + punkcheck::save_records_to_file $file_records $o_checkfile "save_installer_record" + } + method events {args} { + tailcall $o_events {*}$args + } + method start_event {configdict} { + if {$o_active_event ne ""} { + error "[self] start_event error - event already started: $o_active_event" + } + if {$o_rel_sourceroot eq "" || $o_rel_targetroot eq ""} { + error "[self] No configured sourceroot or targetroot. Call [self] set_source_target first" + } + + if {[llength $configdict] %2 != 0} { + error "[self] new_event configdict must have an even number of elements" + } + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + error "[self] start_event - installer record missing. installer: $o_name" + } else { + set this_installer_record [dict get $resultinfo record] + } + + set eventobj [punkcheck::installevent create [namespace current]::event_[my events count] [self] $o_rel_sourceroot $o_rel_targetroot -config $configdict] + set eventid [$eventobj get_id] + set event_record [$eventobj as_record] + + set this_installer_record [punkcheck::recordlist::installer_record_add_event $this_installer_record $event_record] + set this_installer_record [punkcheck::recordlist::installer_record_pruneevents $this_installer_record $o_record_list] + + #replace + lset o_record_list $existing_header_posn $this_installer_record + + punkcheck::save_records_to_file $o_record_list $o_checkfile "start_event $eventid" + set o_active_event $eventobj + my events add $eventobj $eventid + return $eventobj + } + method installer_record_from_file {} { + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + } + method get_recordlist {} { + return $o_recordlist + } + method end_event {} { + if {$o_active_event eq ""} { + error "[self] end_event error - no active event" + } + $o_active_event end + } + method get_event {} { + return $o_active_event + } + } + } + proc start_installer_event {punkcheck_file installername from_fullpath to_fullpath config} { + set eventid [punkcheck::uuid] + if {[file pathtype $from_fullpath] ne "absolute"} { + error "start_installer_event error: from_fullpath must be absolute path. Received '$from_fullpath'" + } + if {[file pathtype $to_fullpath] ne "absolute"} { + error "start_installer_event error: to_fullpath must be absolute path. Received '$to_fullpath'" + } + set punkcheck_folder [file dirname $punkcheck_file] + set rel_source [punkcheck::lib::path_relative $punkcheck_folder $from_fullpath] + set rel_target [punkcheck::lib::path_relative $punkcheck_folder $to_fullpath] + + + set record_list [punkcheck::load_records_from_file $punkcheck_file] + set resultinfo [punkcheck::recordlist::get_installer_record $installername $record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + set this_installer_record [punkcheck::recordlist::new_installer_record $installername] + } else { + set this_installer_record [dict get $resultinfo record] + } + + set event_record [punkcheck::recordlist::new_installer_event_record install {*}{ + -id $eventid + -source $rel_source + -targets $rel_target + -config $config + }] + + set this_installer_record [punkcheck::recordlist::installer_record_add_event $this_installer_record $event_record] + set this_installer_record [punkcheck::recordlist::installer_record_pruneevents $this_installer_record $record_list] + + if {$existing_header_posn == -1} { + #not found - prepend + #set record_list [linsert $record_list 0 $this_installer_record] + ledit record_list -1 -1 $this_installer_record + } else { + #replace + lset record_list $existing_header_posn $this_installer_record + } + + punkcheck::save_records_to_file $record_list $punkcheck_file "start_installer_event $eventid" + return [list eventid $eventid recordset $record_list] + } + #----------------------------------------------- + proc installfile_help {} { + set msg "" + append msg "Call in order:" \n + append msg " start_installer_event (get dict with eventid and recordset keys)" + append msg " installfile_begin (to return a new INSTALLING record) - must pass in a valid eventid" \n + append msg " installfile_add_source_and_fetch_metadata (1+ times to update SOURCE record with checksum/timestamp info from source)" \n + append msg " ( - possibly with same algorithm as previous installrecord)" \n + append msg " ( - todo - search/load metadata for this source from other FILEINFO records for same installer)" \n + append msg "Finalize by calling:" \n + append msg " installfile_started_install" \n + append msg " (install the file e.g file copy)" \n + append msg " installfile_finished_install" \n + append msg " OR" \n + append msg " installfile_skipped_install" \n + } + proc installfile_begin {punkcheck_folder target_relpath installername args} { + if {[llength $args] %2 !=0} { + error "punkcheck installfile_begin args must be name-value pairs" + } + set target_relpath [lsort -dictionary -increasing $target_relpath] ;#exact sort order not critical - but must be consistent + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set defaults [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $ts {*}{ + } -installer $installername {*}{ + } -eventid unspecified {*}{ + } + ] + set opts [dict merge $defaults $args] + set opt_eventid [dict get $opts -eventid] + + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set resultinfo [punkcheck::recordlist::get_installer_record $installername $record_list] + set installer_record_position [dict get $resultinfo position] + if {$installer_record_position == -1} { + error "installfile_begin error: Failed to retrieve installer record for installer name:'$installername' - ensure start_installer_event has been called with same installer, and -eventid is passed to installfile_begin" + } + set this_installer_record [dict get $resultinfo record] + set events [dict get $this_installer_record body] + set active_event [list] + foreach evt [lreverse $events] { + if {[dict get $evt -id] eq $opt_eventid} { + set active_event $evt + break + } + } + if {![llength $active_event]} { + error "installfile_begin error: eventid $opt_eventid not found for installer '$installername' - aborting" + } + + + set extractioninfo [punkcheck::recordlist::extract_or_create_fileset_record $target_relpath $record_list] + set file_record [dict get $extractioninfo record] + set record_list [dict get $extractioninfo recordset] + set isnew [dict get $extractioninfo isnew] + set oldposition [dict get $extractioninfo oldposition] + unset extractioninfo + + #INSTALL-INPROGRESS will become INSTALL-RECORD or INSTALL-FAILED or INSTALL-SKIPPED upon finalisation + #-installer and -eventid keys are added here + set new_installing_record [dict create tag INSTALL-INPROGRESS {*}$opts -tempcontext $active_event body {}] + #set existing_body [dict_getwithdefault $file_record body [list]] + #todo - look for existing "INSTALL-INPROGRESS" records - mark as failed? + dict lappend file_record body $new_installing_record + + if {$isnew} { + lappend record_list $file_record + } else { + #set record_list [linsert $record_list[unset record_list] $oldposition $file_record] + ledit record_list $oldposition -1 $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_begin $installername $opt_eventid $target_relpath" + return $file_record + } + + #todo - ensure that removing a dependency is noticed as a change + #e.g previous installrecord had 2 source records - but we now only depend on one. + #The files we depended on for the previous record haven't changed themselves - but the list of files has (reduced by one) + #cached_cksums is list of dicts with keys cksum & opts + #Will only be used if any opts values present match those from file_record's -cksum_all_opts (in last install record) or first cached_cksum will be used if no last install record values + proc installfile_add_source_and_fetch_metadata {punkcheck_folder source_relpath file_record {cached_cksums {}}} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_add_source_and_fetch_metadata error: bad file_record - expected FILEINFO with last body element *-INPROGRESS ($file_record)" + } + #validate any passed cached_cksums + foreach cacheinfo $cached_cksums { + if {[llength $cacheinfo] % 2 != 0} { + error "installfile_add_source_and_fetch_metadata error.If cached_cksums is supplied, it must be a list of dicts containing keys cksum & opts" + } + dict for {k v} $cacheinfo { + switch -- $k { + cksum {} + opts { + #todo - validate $v keys + } + default { + error "installfile_add_source_and_fetch_metadata error. Unrecognised key $k. Known keys {cksum opts}" + } + } + + } + } + set ts_start [clock microseconds] + set last_installrecord [lib::file_record_get_last_installrecord $file_record] + set prev_ftype "" + set prev_fsize "" + set prev_cksum "" + set prev_cksum_opts "" + if {[llength $last_installrecord]} { + set src [lib::install_record_get_matching_source_record $last_installrecord $source_relpath] + if {[llength $src]} { + if {[dict_getwithdefault $src -path ""] eq $source_relpath} { + set prev_ftype [dict_getwithdefault $src -type ""] + set prev_fsize [dict_getwithdefault $src -size ""] + set prev_cksum [dict_getwithdefault $src -cksum ""] + set prev_cksum_opts [dict_getwithdefault $src -cksum_all_opts ""] + } + } + } + #check that this relpath not already added as child of *-INPROGRESS + set file_record_body [dict_getwithdefault $file_record body [list]] ;#new file_record may have no body + set installing_record [lindex $file_record_body end] + set already_present_record [lib::install_record_get_matching_source_record $installing_record $source_relpath] + if {[llength $already_present_record]} { + error "installfile_add_source_and_fetch_metadata error: source path $source_relpath already exists in the file_record - cannot add again" + } + + set use_cache 0 + if {$prev_cksum_opts ne ""} { + set cksum_opts $prev_cksum_opts + #find first cached_cksum that is compatible with cksum opts used in latest install record + foreach cacheinfo $cached_cksums { + set cachedopts [dict get $cacheinfo opts] + set cache_is_match 1 + dict for {k v} $cachedopts { + if {[dict exists $prev_cksum_opts $k] && $v ne [dict get $prev_cksum_opts $k]} { + set cache_is_match 0 + break + } + } + if {$cache_is_match} { + set use_cache_record $cacheinfo + set use_cache 1 + break + } + } + + } else { + #no cksum opts available from an install record + set cksum_opts "" + #use first entry in cached_cksums if we can + if {[llength $cached_cksums]} { + set use_cache 1 + set use_cache_record [lindex $cached_cksums 0] + } + } + + #todo - accept argument of cached source cksum info (for client calling multiple targets with same source in quick succession e.g when building .vfs kits with multiple runtimes) + #if same cksum_opts - then use cached data instead of checksumming here. + + #allow nonexistant as a source + set fpath [file join $punkcheck_folder $source_relpath] + #windows: file exist + file type = 2ms vs 500ms for 2x glob + set floc [file dirname $fpath] + set fname [file tail $fpath] + set file_set [glob -nocomplain -dir $floc -type f -tails -- $fname] + set dir_set [glob -nocomplain -dir $floc -type d -tails -- $fname] + set link_set [glob -nocomplain -dir $floc -type l -tails -- $fname] + if {[llength $file_set] == 0 && [llength $dir_set] == 0 && [llength $link_set] == 0} { + #could also theoretically exist as less common types, b,c,p,s (block,char,pipe,socket) + #- we don't expect them here - REVIEW - ever possible? + #- installing/examining such things an unlikely usecase and would require special handling anyway. + set ftype "missing" + set fsize "" + } else { + if {[llength $dir_set]} { + set ftype "directory" + set fsize "NA" + } elseif {[llength $link_set]} { + set ftype "link" + set fsize 0 + } else { + set ftype "file" + #todo - optionally use mtime instead of cksum (for files only)? + #mtime is not reliable across platforms and filesystems though.. see article linked at top. + set fsize [file size $fpath] + } + } + + #if {![file exists $fpath]} { + # set ftype "missing" + # set fsize "" + #} else { + # set ftype [file type $fpath] + # if {$ftype eq "directory"} { + # set fsize "NA" + # } else { + # #todo - optionally use mtime instead of cksum (for files only)? + # #mtime is not reliable across platforms and filesystems though.. see article linked at top. + # set fsize [file size $fpath] + # } + #} + #get_relativecksum_from_base and fill_relativecksums_from_base_and_relativepathdict will set cksum to if fpath doesn't exist + if {$use_cache} { + set source_cksum_info [punk::mix::base::lib::fill_relativecksums_from_base_and_relativepathdict $punkcheck_folder [dict create $source_relpath $use_cache_record]] + } else { + set source_cksum_info [punk::mix::base::lib::get_relativecksum_from_base $punkcheck_folder $source_relpath {*}$cksum_opts] + } + + + lassign $source_cksum_info pathkey ckinfo + if {$pathkey ne $source_relpath} { + error "installfile_add_source_and_fetch_metadata error: cksum returned wrong path info '$pathkey' expected '$source_relpath'" + } + set cksum [dict get $ckinfo cksum] + #set cksum_all_opts [dict get $ckinfo cksum_all_opts] + set cksum_all_opts [dict get $ckinfo opts] + if {$cksum ne $prev_cksum || $ftype ne $prev_ftype || $fsize ne $prev_fsize} { + set changed 1 + } else { + set changed 0 + } + set installing_record_sources [dict_getwithdefault $installing_record body [list]] + set ts_now [clock microseconds] ;#gathering metadata - especially checksums on folder can take some time - calc and store elapsed us for time taken to gather metadata + set metadata_us [expr {$ts_now - $ts_start}] + set this_source_record [dict create tag SOURCE -type $ftype -size $fsize -path $source_relpath -cksum $cksum -cksum_all_opts $cksum_all_opts -changed $changed -metadata_us $metadata_us] + lappend installing_record_sources $this_source_record + dict set installing_record body $installing_record_sources + + lset file_record_body end $installing_record + + dict set file_record body $file_record_body + return $file_record + } + + #write back to punkcheck - don't accept recordset - invalid to update anything other than the installing_record at this time + proc installfile_started_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_started_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set ts_now [clock microseconds] + set metadata_us [expr {$ts_now - $ts_start}] + + dict set installing_record -metadata_us $metadata_us + dict set installing_record -ts_start_transfer $ts_now + + lset file_record_body end $installing_record + + dict set file_record body $file_record_body + + + set getresult [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $getresult position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_started_install [llength $targetlist] targets" + return $file_record + } + proc installfile_finished_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_finished_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set ts_start_transfer [dict get $installing_record -ts_start_transfer] + set ts_now [clock microseconds] + set elapsed_us [expr {$ts_now - $ts_start}] + set transfer_us [expr {$ts_now - $ts_start_transfer}] + dict set installing_record -transfer_us $transfer_us + dict set installing_record -elapsed_us $elapsed_us + dict unset installing_record -tempcontext + dict set installing_record tag "INSTALL-RECORD" + + lset file_record_body end $installing_record + dict set file_record body $file_record_body + + set file_record [punkcheck::recordlist::file_record_prune $file_record] + + set oldrecordinfo [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $oldrecordinfo position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_finished_install [llength $targetlist] targets" + return $file_record + } + proc installfile_skipped_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + set msg "installfile_skipped_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + append msg \n "received:" + append msg \n $file_record + error $msg + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set tsnow [clock microseconds] + set elapsed_us [expr {$tsnow - $ts_start}] + dict set installing_record -elapsed_us $elapsed_us + dict set installing_record tag "INSTALL-SKIPPED" + + lset file_record_body end $installing_record + dict set file_record body $file_record_body + + set file_record [punkcheck::recordlist::file_record_prune $file_record] + + set getresult [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $getresult position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_skipped_install [llength $targetlist] targets" + return $file_record + } + #----------------------------------------------- + #then: file_record_add_installrecord + + namespace eval lib { + set pkg punkcheck + namespace path ::punkcheck + proc is_file_record_inprogress {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + return 0 + } + set installing_record [lindex [dict_getwithdefault $file_record body [list]] end] + if {[dict_getwithdefault $installing_record tag [list]] ni [list QUERY-INPROGRESS INSTALL-INPROGRESS MODIFY-INPROGRESS DELETE-INPROGRESS VIRTUAL-INPROGRESS]} { + return 0 + } + return 1 + } + proc is_file_record_installing {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + return 0 + } + set installing_record [lindex [dict_getwithdefault $file_record body [list]] end] + if {[dict_getwithdefault $installing_record tag [list]] ne "INSTALL-INPROGRESS"} { + return 0 + } + return 1 + } + proc file_record_get_last_installrecord {file_record} { + set body [dict_getwithdefault $file_record body [list]] + set previous_install_records [lrange $body 0 end-1] + #get last previous that is tagged INSTALL-RECORD,MODIFY-RECORD,VIRTUAL-RECORD + #REVIEW DELETERECORD ??? + set revlist [lreverse $previous_install_records] + foreach rec $revlist { + if {[dict get $rec tag] in [list "INSTALL-RECORD" "MODIFY-RECORD" "VIRTUAL-RECORD"]} { + return $rec + } + } + return [list] + } + + #should work on *-INPROGRESS or INSTALL(etc) record - don't restrict tag to INSTALL + proc install_record_get_matching_source_record {install_record source_relpath} { + set body [dict_getwithdefault $install_record body [list]] + foreach src $body { + if {[dict get $src tag] eq "SOURCE"} { + if {[dict_getwithdefault $src -path ""] eq $source_relpath} { + return $src + } + } + } + return [list] + } + + + + # Delegate to punk::path::relative (verified equivalent implementation) + proc path_relative {base dst} { + return [punk::path::relative $base $dst] + } + } + #skip writing punkcheck during checksum/timestamp checks + + #todo - punk::args - fetch from punkcheck::install (with overrides) + proc install_tm_files {srcdir basedir args} { + set defaults [list {*}{ + -glob *.tm + -installer punkcheck::install_tm_files + } -exclude-filetails [list "*[punk::mix::util::tm_version_magic]*"] {*}{ + } + ] + set opts [dict merge $defaults $args] + punkcheck::install $srcdir $basedir {*}$opts + } + proc install_non_tm_files {srcdir basedir args} { + #set keys [dict keys $args] + #adjust the default exclude-paths_core entries so that .fossil-custom, .fossil-settings are copied + set excludepaths_core [punkcheck::default_excludepaths_core] + #remove .fossil* entries (both top-level and **/ forms) so fossil folders are not excluded + set excludepaths_core [lsearch -inline -all -not $excludepaths_core ".fossil*"] + set excludepaths_core [lsearch -inline -all -not $excludepaths_core "**/.fossil*"] + set defaults [list {*}{ + } -glob * {*}{ + } -exclude-filetails [list "*.tm" "*-buildversion.txt" "*.exe"] {*}{ + } -exclude-paths-core $excludepaths_core {*}{ + } -installer punkcheck::install_non_tm_files {*}{ + } + ] + set opts [dict merge $defaults $args] + punkcheck::install $srcdir $basedir {*}$opts + } + + #for tcl8.6 - tcl8.7+ has dict getwithdefault (dict getdef) + proc dict_getwithdefault {dictValue args} { + if {[llength $args] < 2} { + error {wrong # args: should be "dict_getdef dictionary ?key ...? key default"} + } + set keys [lrange $args 0 end-1] + if {[dict exists $dictValue {*}$keys]} { + return [dict get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + lappend PUNKARGS [list { + @id -id ::punkcheck::install + @cmd -name ::punkcheck::install -help\ + "Unidirectional file transfer to possibly non-empty target folder. + This is the simpler form of the API, performing a transfer from one + directory tree to another, copying each file when changes in the source + file are detected. + Changes are detected by content checksum. The first install will record + source checksums in a .punkcheck file (ideally located at the root of the + target folder). Subsequent installs will compare stored checksums with + the current checksums of the source files. + For more advanced install operations, the object command installtrack + can be used to define install operations. e.g when the transfer is not + one-to-one and a target file depends on multiple source files." + @leaders -min 2 -max 2 + srcdir -type directory + tgtdir -type directory + -call-depth-internal -type integer -default 0 -help "(internal recursion tracker)" + -subdirlist -type list -default "" -help "(primarily internal - length generally matching -call-depth-internal)" + -max-depth -type integer -default 1000 -help\ + "Deepest subdirectory - use -1 for no limit." + -createdir -type boolean -default 0 -help\ + "Whether to create the folder at tgtdir. + Any required subdirectories are created regardless of this setting." + -createempty -type boolean -default 0 -help\ + "Whether to create folders at target that had no matches for our glob" + -glob -type string -default "*" -help\ + "Pattern matching for source file(s) to copy. Can be glob based or exact match." + -exclude-filetails-core -default {${[::punkcheck::default_excludefiletail_core]}} -help\ + "Non-overridable default file-tail exclusion patterns. + These are applied in addition to -exclude-filetails and cannot be + disabled by the caller - they can only be replaced by passing + -exclude-filetails-core with a different list. + Patterns use string match against the file tail (basename) at any + level in the tree. They must not contain path separators." + -exclude-filetails -default "" -help\ + "List of glob patterns to match against file tails (basenames). + Patterns use string match and must not contain path separators. + e.g {*.swp *.tmp} excludes swap and temp files at any level." + -exclude-paths-core -default {${[::punkcheck::default_excludepaths_core]}} -help\ + "Non-overridable default path-glob exclusion patterns. + These are applied in addition to -exclude-paths and cannot be + disabled by the caller - they can only be replaced by passing + -exclude-paths-core with a different list. + Patterns are matched against the full relative source path using + punk::path::globmatchpath." + -exclude-paths -default {} -help\ + "List of path-glob patterns to exclude from installation. + Patterns are matched against the full relative source path using + punk::path::globmatchpath, so they may include ** to match across + path segments and / to match within a segment. + e.g to exclude all AGENTS.md files at any depth: {AGENTS.md **/AGENTS.md}" + #backward-compat aliases (accepted but deprecated - converted internally to -exclude-paths) + -exclude-dirsegments-core -default {${[::punkcheck::default_excludedirseg_core]}} -help\ + "DEPRECATED: use -exclude-paths-core instead. + Legacy segment-glob patterns matched against directory tail names. + Converted internally to path-glob form by expanding each segment + S to {S **/S}." + -exclude-dirsegments -default "" -help\ + "DEPRECATED: use -exclude-paths instead. + Legacy segment-glob patterns matched against directory tail names + at any level. Each pattern must not contain path separators." + -antiglob-paths -default {} -help\ + "DEPRECATED: use -exclude-paths instead. + Legacy path-glob patterns matched against the full relative source + path using punk::path::globmatchpath. Merged into -exclude-paths + internally." + -overwrite -default no-targets\ + -choices {no-targets newer-targets older-targets all-targets installedsourcechanged-targets synced-targets}\ + -choicecolumns 1\ + -choicelabels { + no-targets "only copy files that are missing at the target" + newer-targets "copy files with older source timestamp over newer + target timestamp and those missing at the target + (a form of 'restore' operation)" + older-targets "copy files with newer source timestamp over older + target timestamp and those missing at the target" + all-targets "copy regardless of timestamp at target" + installedsourcechanged-targets "copy if the target doesn't exist or the source changed" + synced-targets "copy if the target doesn't exist or the source changed + and the target cksum is the same as the last INSTALL-RECORD -targets_cksums entry" + } + -source-checksum -default comparestore -choicecolumns 3 -choices {compare store comparestore false true} -help\ + "Checksum behavior for source files. + compare: checksum and compare against last record, but do not store. + store: checksum and store, but do not compare against last record. + comparestore: checksum, compare against last record, and store. + false: do not checksum (not recommended - changes cannot be detected). + true: same as comparestore." + -punkcheck-folder -default target -choices {target source project} -choicerestricted 0 -help\ + "The location of the .punkcheck file to track installations and checksums. + The default value 'target' is generally recommended. + Can also be an absolute path to a folder." + -punkcheck-eventid -default "" -help\ + "Event ID for the install operation. When empty (default), a new UUID + is generated automatically. Pass a specific ID to group multiple + install calls under the same event in the .punkcheck file." + -punkcheck-records -default "" -help\ + "Empty string or a parsed TDL records structure. + e.g + {tag FILEINFO - ... body { + {tag INSTALL-RECORD - ... body {}} + ... + }... + }" + -installer -default "punkcheck::install" -help\ + "A user nominated string that is stored in the .punkcheck file + This might be the name of a script or installation process." + -progresschannel -default none -type string -help\ + "Name of channel e.g stderr, stdout to which progress messages are written. + This includes the tree-like output consisting of dots (or green U) for each + file processed. As the number of files in a tree is not known beforehand, + it isn't useful for a percentage-based progress meter, but it could potentially + be used to drive a spinner if the textual data is not desired. + Setting to none or an invalid channel will deactivate the output." + }] + ## unidirectional file transfer to possibly non empty folder + #default of -overwrite no-targets will only copy files that are missing at the target + # -overwrite newer-targets will copy files with older source timestamp over newer target timestamp and those missing at the target (a form of 'restore' operation) + # -overwrite older-targets will copy files with newer source timestamp over older target timestamp and those missing at the target + # -overwrite all-targets will copy regardless of timestamp at target + # -overwrite installedsourcechanged-targets will copy if the target doesn't exist or the source changed + # -overwrite synced-targets will copy if the target doesn't exist or the source changed and the target cksum is the same as the last INSTALL-RECORD -targets_cksums entry + # review - timestamps unreliable + # - what about slightly mismatched system clocks and mounted filesystems? caller responsibility to verify first? + # if timestamp exactly equal - should we check content-hash? This is presumably only likely to occur deliberately(maliciously?) + # e.g some process that digitally signs or otherwise modifies a file and preserves update timestmp? + # if such a content-mismatch - what default behaviour and what options would make sense? + # probably it's reasonable that only all-targets would overwrite such files. + # consider -source_fudge_seconds +-X ?, -source_override_timestamp ts ??? etc which only adjust timestamp for calculation purposes? Define a specific need/usecase when reviewing. + # + # valid filetypes for src tgt + # src dir tgt dir + # todo - review and consider enabling symlink src and dst + # no need for src file - as we use -glob with no glob characters to match one source file file + # no ability to target file with different name - keep it simpler and caller will have to use an intermediate folder/file if they need to rename something? + # + # todo - determine what happens if mismatch between file type of a src vs target e.g target has dir matching filename at source + # A pre-scan to determine no such conflict - before attempting to copy anything might provide the most integrity at slight cost in speed. + # REVIEW we should only expect dirs to be created as necessary to hold files? i.e target folder won't be created if no source file matches for that folder + # -source-checksum compare|store|comparestore|false|true where true == comparestore + # -punkcheck-folder target|source|project| target is default and is generally recommended + # -punkcheck-records empty string | parsed TDL records ie {tag xxx k v} structure + # install creates FILEINFO records with a single entry in the -targets field (it is legitimate to have a list of targets for an installation operation - the oo interface supports this) + proc install {srcdir tgtdir args} { + # Backward-compat: normalize old underscore flag names to hyphenated forms + set flag_aliases [dict create {*}{ + -max_depth -max-depth + -exclude-filetails_core -exclude-filetails-core + -exclude-paths_core -exclude-paths-core + -exclude-dirsegments_core -exclude-dirsegments-core + -antiglob_paths -antiglob-paths + -source_checksum -source-checksum + -punkcheck_folder -punkcheck-folder + -punkcheck_eventid -punkcheck-eventid + -punkcheck_records -punkcheck-records + }] + if {[llength $args]} { + set normalized [list] + foreach {k v} $args { + if {[dict exists $flag_aliases $k]} { + lappend normalized [dict get $flag_aliases $k] $v + } else { + lappend normalized $k $v + } + } + set args $normalized + } + + set defaults [list {*}{ + -call-depth-internal 0 + -max-depth 1000 + -subdirlist {} + -createdir 0 + -createempty 0 + -glob * + -exclude-filetails-core "\uFFFF" + -exclude-filetails "" + -exclude-paths-core "\uFFFF" + -exclude-paths {} + -exclude-dirsegments-core "\uFFFF" + -exclude-dirsegments {} + -antiglob-paths {} + -overwrite no-targets + -source-checksum comparestore + -punkcheck-folder target + -punkcheck-eventid "\uFFFF" + -punkcheck-records "" + -installer punkcheck::install + -progresschannel none + }] + + if {([llength $args] %2) != 0} { + error "punkcheck::install requires option-style arguments to be in pairs. Received args: $args" + } + foreach {k -} $args { + if {$k ni [dict keys $defaults]} { + error "punkcheck::install unrecognised option '$k' known options: '[dict keys $defaults]'" + } + } + set opts [dict merge $defaults $args] + + #The choice to recurse using the original values of srcdir & tgtdir, and passing the subpath down as a list in -subdirlist seems an odd one. + #(as opposed to a more 'standard' mechanism of adjusting srcdir & tgtdir as we move down the tree) + #It comes from build_modules_from_source_to_base where we need to keep track of position relative to our targetdir starting point to handle submodules e.g pkg::something::mypkg-0.1.tm + #It could have been handled with some other parameter such as -depth, but this -subdirlist mechanism, whilst perhaps not beautiful, is straightforward enough + #and may be less error prone than doing slightly more opaque path manipulations at each recursion level to determine where we started + #For consistency - we'll use the same mechanism in various recursive directory walking procedures such as this one. + set CALLDEPTH [dict get $opts -call-depth-internal] ;#added for extra debug/sanity checking - clearer test for initial function call ie CALLDEPTH = 0 + set max_depth [dict get $opts -max-depth] ;# -1 for no limit + set subdirlist [dict get $opts -subdirlist] ;# generally should be same length as CALLDEPTH - but user could prefill + set fileglob [dict get $opts -glob] + set createdir [dict get $opts -createdir] ;#defaults to zero to help avoid mistakes with initial target dir - required target subdirs are created regardless of this setting + set opt_createempty [dict get $opts -createempty] + set opt_progresschannel [dict get $opts -progresschannel] + if {$opt_progresschannel in {"" none} || [catch {chan configure $opt_progresschannel}]} { + set opt_progresschannel "" + } + + if {$CALLDEPTH == 0} { + #expensive to normalize but we need to do it at least once + set srcdir [file normalize $srcdir] + set tgtdir [file normalize $tgtdir] + if {$createdir} { + file mkdir $tgtdir + } else { + if {![file exists $tgtdir]} { + error "punkcheck::install base target dir:'$tgtdir' doesn't exist (srcdir:$srcdir tgtdir:$tgtdir args:'$args')" + } + } + if {([file type $srcdir] ni [list directory]) || ([file type $tgtdir] ni [list directory])} { + error "punkcheck::install requires source and target dirs to be of type 'directory' type current source: [file type $srcdir] type current target: [file type $tgtdir]" + } + #now the values we build from these will be properly cased + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_excludefiletail_core [dict get $opts -exclude-filetails-core] + if {$opt_excludefiletail_core eq "\uFFFF"} { + set opt_excludefiletail_core [default_excludefiletail_core] + dict set opts -exclude-filetails-core $opt_excludefiletail_core + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_excludefiletail [dict get $opts -exclude-filetails] + #validate no path seps + foreach af $opt_excludefiletail { + if {[llength [file split $af]] > 1} { + error "punkcheck::install received invalid -exclude-filetails entry '$af'. -exclude-filetails entries are meant to match to a file name at any level so cannot contain path separators" + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # Unified -exclude-paths initialization (replaces -exclude-dirsegments + -antiglob-paths) + # Precedence: -exclude-paths-core > -exclude-dirsegments-core (legacy) > default + set opt_excludepaths_core [dict get $opts -exclude-paths-core] + set legacy_excludedirseg_core [dict get $opts -exclude-dirsegments-core] + if {$opt_excludepaths_core ne "\uFFFF"} { + # User explicitly passed -exclude-paths-core → use as-is (path-glob form) + } elseif {$legacy_excludedirseg_core ne "\uFFFF"} { + # User explicitly passed legacy -exclude-dirsegments-core → convert to path-glob form + set opt_excludepaths_core [list] + foreach seg $legacy_excludedirseg_core { + lappend opt_excludepaths_core $seg + lappend opt_excludepaths_core **/$seg + } + dict set opts -exclude-paths-core $opt_excludepaths_core + } else { + # Neither passed → use new default + set opt_excludepaths_core [default_excludepaths_core] + dict set opts -exclude-paths-core $opt_excludepaths_core + } + set opt_excludepaths [dict get $opts -exclude-paths] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # Backward-compat: convert legacy -exclude-dirsegments to path-glob form and merge + # Each segment-glob S is expanded to {S **/S} to match at any directory level, + # preserving the former string-match-against-tail semantics. + set opt_excludedirseg_core $legacy_excludedirseg_core + if {$opt_excludedirseg_core eq "\uFFFF"} { + set opt_excludedirseg_core [default_excludedirseg_core] + dict set opts -exclude-dirsegments-core $opt_excludedirseg_core + } + set opt_excludedirseg [dict get $opts -exclude-dirsegments] + #validate no path seps + foreach ad $opt_excludedirseg { + if {[llength [file split $ad]] > 1} { + error "punkcheck::install received invalid -exclude-dirsegments entry '$ad'. -exclude-dirsegments entries are meant to match to a directory name at any level so cannot contain path separators" + } + } + #convert legacy dir-seg user globs (NOT core) to path-glob form and append to opt_excludepaths + foreach seg $opt_excludedirseg { + lappend opt_excludepaths $seg + lappend opt_excludepaths **/$seg + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # Backward-compat: merge legacy -antiglob-paths into opt_excludepaths + set opt_antiglob_paths [dict get $opts -antiglob-paths] ;#todo - combine with config file in source tree .punkcheckpublish (?) + #antiglob_paths will usually contain file separators - and may contain glob patterns within each segment + foreach ap $opt_antiglob_paths { + lappend opt_excludepaths $ap + } + set antiglob_paths_matched [list] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set known_whats [list no-targets newer-targets older-targets all-targets installedsourcechanged-targets synced-targets] + set overwrite_what [string tolower [dict get $opts -overwrite]]; #accept any case for value to allow emphasis by caller e.g -overwrite NEWER-TARGETS + if {$overwrite_what ni $known_whats} { + error "punkcheck::install received unrecognised value for -overwrite. Received value '$overwrite_what' vs known values '$known_whats'" + } + if {$overwrite_what in [list newer-targets older-targets]} { + error "punkcheck::install newer-target, older-targets not implemented - sorry" + #TODO - check crossplatform availability of ctime (on windows it still seems to be creation time, but on bsd/linux it's last attribute mod time) + # external pkg? use twapi and ctime only on other platforms? + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_source_checksum [dict get $opts -source-checksum] + if {[string is boolean $opt_source_checksum]} { + if {$opt_source_checksum} { + set opt_source_checksum "comparestore" + } else { + set opt_source_checksum 0 + } + dict set opts -source-checksum $opt_source_checksum + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_punkcheck_folder [dict get $opts -punkcheck-folder] + if {$opt_punkcheck_folder eq "target"} { + set punkcheck_folder $tgtdir + } elseif {$opt_punkcheck_folder eq "source"} { + set punkcheck_folder $srcdir + } elseif {$opt_punkcheck_folder eq "project"} { + set sourceprojectinfo [punk::repo::find_repos $srcdir] + set targetprojectinfo [punk::repo::find_repos $tgtdir] + set srcproj [lindex [dict get $sourceprojectinfo project] 0] + set tgtproj [lindex [dict get $targetprojectinfo project] 0] + if {$srcproj eq $tgtproj} { + set punkcheck_folder $tgtproj + } else { + error "copy_files_from_source_to_target error: Unable to find common project dir for source and target folder - use absolutepath for -punkcheck-folder if source and target are not within same project" + } + } else { + set punkcheck_folder $opt_punkcheck_folder + } + if {$punkcheck_folder ne ""} { + if {[file pathtype $punkcheck_folder] ne "absolute"} { + error "copy_files_from_source_to_target error: -punkcheck-folder '$punkcheck_folder' must be an absolute path, or one of: target|source|project" + } + if {![file isdirectory $punkcheck_folder]} { + error "copy_files_from_source_to_target error: -punkcheck-folder '$punkcheck_folder' not found" + } + } else { + #review - leave empty? use pwd? + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set punkcheck_records [dict get $opts -punkcheck-records] + set punkcheck_records_init $punkcheck_records ;#change-detection + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_installer [dict get $opts -installer] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_punkcheck_eventid [dict get $opts -punkcheck-eventid] + + + + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + + if {$CALLDEPTH == 0} { + set punkcheck_eventid "" + if {$punkcheck_folder ne ""} { + set config $opts + dict unset config -call-depth-internal + dict unset config -max-depth + dict unset config -subdirlist + dict unset config -progresschannel + tcl::dict::for {k v} $config { + if {$v eq "\uFFFF"} { + dict unset config $k + } + } + lassign [punkcheck::start_installer_event $punkcheck_file $opt_installer $srcdir $tgtdir $config] _eventid punkcheck_eventid _recordset punkcheck_records + } + } else { + set punkcheck_eventid $opt_punkcheck_eventid + } + + + + if {$opt_source_checksum != 0} { + #we need to read the file even if only set to store (or we would overwrite entries) + set compare_cksums 1 + } else { + set compare_cksums 0 + } + + if {[string match *store* $opt_source_checksum]} { + set store_source_cksums 1 + } else { + set store_source_cksums 0 + } + + + + + + if {[llength $subdirlist] == 0} { + set current_source_dir $srcdir + set current_target_dir $tgtdir + } else { + set current_source_dir $srcdir/[file join {*}$subdirlist] + set current_target_dir $tgtdir/[file join {*}$subdirlist] + } + + + set relative_target_dir [lib::path_relative $tgtdir $current_target_dir] + if {$relative_target_dir eq "."} { + set relative_target_dir "" + } + set relative_source_dir [lib::path_relative $srcdir $current_source_dir] + if {$relative_source_dir eq "."} { + set relative_source_dir "" + } + set target_relative_to_punkcheck_dir [lib::path_relative $punkcheck_folder $current_target_dir] + if {$target_relative_to_punkcheck_dir eq "."} { + set target_relative_to_punkcheck_dir "" + } + foreach unpub $opt_antiglob_paths { + #puts "testing folder - globmatchpath $unpub $relative_source_dir" + if {[punk::path::globmatchpath $unpub $relative_source_dir]} { + lappend antiglob_paths_matched $current_source_dir + return [list files_copied {} files_skipped {} sources_unchanged {} punkcheck_records $punkcheck_records antiglob_paths_matched $antiglob_paths_matched srcdir $srcdir tgtdir $tgtdir punkcheck_folder $punkcheck_folder] + } + } + + + if {![file exists $current_source_dir]} { + error "punkcheck::install current source dir:'$current_source_dir' doesn't exist (srcdir:$srcdir tgtdir:$tgtdir args:'$args')" + } + + set files_copied [list] + set files_skipped [list] + set sources_unchanged [list] + + + set candidate_list [glob -nocomplain -dir $current_source_dir -type f -tail -- $fileglob] + set hidden_candidate_list [glob -nocomplain -dir $current_source_dir -types {hidden f} -tail -- $fileglob] + foreach h $hidden_candidate_list { + if {$h ni $candidate_list} { + lappend candidate_list $h + } + } + set match_list [list] + foreach m $candidate_list { + set suppress 0 + foreach anti [concat $opt_excludefiletail_core $opt_excludefiletail] { + if {[string match $anti $m]} { + #puts stderr "anti: $anti vs m:$m" + set suppress 1 + break + } + } + if {$suppress == 0} { + lappend match_list $m + } + } + + #sample .punkcheck file record (raw form) to make the code clearer + #punk::tdl converts to dict form e.g: tag FILEINFO -targets filename body sublist + #Valid installrecord types are INSTALL-RECORD SKIPPED INSTALL-INPROGRESS, MODIFY-RECORD MODIFY-INPROGRESS DELETE-RECORD DELETE-INPROGRESS + # + #FILEINFO -targets jjjetc-0.1.0.tm -keep_installrecords 2 -keep_skipped 1 -keep_inprogress 2 { + # INSTALL-RECORD -tsiso 2023-09-20T07:30:30 -ts 1695159030266610 -installer punk::mix::cli::build_modules_from_source_to_base -metadata_us 18426 -ts_start_transfer 1695159030285036 -transfer_us 10194 -elapsed_us 28620 { + # SOURCE -type file -path ../src/modules/jjjetc-buildversion.txt -cksum c7c71839c36b3d21c8370fed106192fcd659eca9 -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 3423 + # SOURCE -type file -path ../src/modules/jjjetc-0.2.0.tm -cksum b646fc2ee88cbd068d2e946fe929b7aea96bd39d -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 3413 + # } + # INSTALL-SKIPPED -tsiso 2023-09-20T08:14:26 -ts 1695161666087880 -installer punk::mix::cli::build_modules_from_source_to_base -elapsed_us 18914 { + # SOURCE -type file -path ../src/modules/jjjetc-buildversion.txt -cksum c7c71839c36b3d21c8370fed106192fcd659eca9 -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 0 -metadata_us 3435 + # SOURCE -type file -path ../src/modules/jjjetc-0.2.0.tm -cksum b646fc2ee88cbd068d2e946fe929b7aea96bd39d -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 0 -metadata_us 3338 + # } + #} + + if {[llength $match_list]} { + #example - target dir has a file where there is a directory at the source + if {[file exists $current_target_dir] && ([file type $current_target_dir] ni [list directory])} { + error "punkcheck::install target subfolder $current_target_dir exists but is not of type 'directory'. Type current target folder: [file type $current_target_dir]" + } + } + + #proc get_relativecksum_from_base_and_fullpath {base fullpath args} + + + #puts stdout "Current target dir: $current_target_dir" + set last_depth "" + foreach m $match_list { + set new_tgt_cksum_info [list] + set relative_target_path [file join $relative_target_dir $m] + set relative_source_path [file join $relative_source_dir $m] + set punkcheck_target_relpath [file join $target_relative_to_punkcheck_dir $m] + set is_antipath 0 + foreach pathglob [concat $opt_excludepaths_core $opt_excludepaths] { + #puts "testing file - globmatchpath $pathglob vs $relative_source_path" + if {[punk::path::globmatchpath $pathglob $relative_source_path]} { + lappend antiglob_paths_matched $current_source_dir + set is_antipath 1 + break + } + } + if {$is_antipath} { + continue + } + + set ts_start [clock microseconds] + set seconds [expr {$ts_start / 1000000}] + set ts_start_iso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + + + #puts stdout " rel_target: $punkcheck_target_relpath" + + set fetch_filerec_result [punkcheck::recordlist::get_file_record $punkcheck_target_relpath $punkcheck_records] + #change to use extract_or_create_fileset_record ? + set existing_filerec_posn [dict get $fetch_filerec_result position] + if {$existing_filerec_posn == -1} { + if {$opt_progresschannel ne ""} { + puts stdout "\nNO existing record for $punkcheck_target_relpath" + } + set has_filerec 0 + set new_filerec [dict create tag FILEINFO -targets $punkcheck_target_relpath] + set filerec $new_filerec + } else { + set has_filerec 1 + #puts stdout " TDL existing FILEINFO record for $punkcheck_target_relpath" + #puts stdout " $existing_install_record" + set filerec [dict get $fetch_filerec_result record] + } + set filerec [punkcheck::recordlist::file_record_set_defaults $filerec] + + #new INSTALLREC must be tagged as INSTALL-INPROGRESS to use recordlist::installfile_ method + set new_install_record [dict create tag INSTALL-INPROGRESS -tsiso $ts_start_iso -ts $ts_start -installer $opt_installer -eventid $punkcheck_eventid] + dict lappend filerec body $new_install_record ;#can't use recordlist::file_record_add_installrecord as '*-INPROGRESS' isn't a final tag - so pruning would be mucked up. No need to prune now anyway. + unset new_install_record + + + if {$opt_progresschannel ne ""} { + if {$last_depth ne $CALLDEPTH} { + if {$CALLDEPTH <=1} { + puts -nonewline $opt_progresschannel \n[string repeat " " $CALLDEPTH][file tail $relative_source_dir] + } + flush $opt_progresschannel + ##set last_depth $CALLDEPTH ;# done down below + } + } + + + + set relative_source_path [lib::path_relative $punkcheck_folder $current_source_dir/$m] + #puts stdout " rel_source: $relative_source_path" + #if {[file pathtype $relative_source_path] ne "relative"} { + #REVIEW + #different volume or root + #} + #Note this isn't a recordlist function - so it doesn't purely operate on the records + #this hits the filesystem for the sourcepath - gets checksums/timestamps depending on config. + #It doesn't save to .punkcheck (the only punkcheck::installfile_ method which doesn't) + set ts1 [clock milliseconds] + set filerec [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $relative_source_path $filerec] + set ts2 [clock milliseconds] + set diff [expr {$ts2 - $ts1}] + if {$diff > 100} { + #todo -errorchannel + set errprefix ">>> punkcheck:" + puts stderr "\n$errprefix performance warning: fetch_metadata for $m took $diff ms." + set lb [lindex [dict get $filerec body] end] + #puts stderr "$errprefix filerec last body record:$lb" + set records [dict get $lb body] + set lr [lindex $records end] + set alg [dict get $lr -cksum_all_opts -cksum_algorithm] + if {$alg eq "sha1"} { + puts stderr "$errprefix cksum_algorithm: sha1 (accelerators: [::sha1::Implementations])" + puts stderr "$errprefix sha1 from: [package ifneeded sha1 [package present sha1]]" + } else { + puts stderr "$errprefix cksum_algorithm: $alg" + } + } + + + + #changeinfo comes from last record in body - which is the record we are working on and so will always exist + set changeinfo [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $filerec body] end]] + set changed [dict get $changeinfo changed] + set unchanged [dict get $changeinfo unchanged] + + if {[llength $unchanged]} { + lappend sources_unchanged $current_source_dir/$m + } + + set is_skip 0 + set is_new 0 + if {$overwrite_what eq "all-targets"} { + file mkdir $current_target_dir + #-------------------------------------------- + #sometimes we get the error: 'error copying "file1" to "file2": invalid argument' + #-------------------------------------------- + puts stderr "punkcheck: about to: file copy -force $current_source_dir/$m $current_target_dir" + file copy -force $current_source_dir/$m $current_target_dir + lappend files_copied $current_source_dir/$m + } else { + if {![file exists $current_target_dir/$m]} { + #puts stderr "punkcheck: first copy to $current_target_dir/$m " + file mkdir $current_target_dir + puts stderr "punkcheck: about to: file copy $current_source_dir/$m $current_target_dir" + file copy $current_source_dir/$m $current_target_dir + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + lappend files_copied $current_source_dir/$m + incr filecount_new + set is_new 1 + } else { + switch -- $overwrite_what { + installedsourcechanged-targets { + if {[llength $changed]} { + #An unrecorded installation is considered a source change (from unknown/unrecorded source to recorded) + puts -nonewline stderr "punkcheck: about to: file copy -force $current_source_dir/$m $current_target_dir" + set ts1 [clock milliseconds] + file mkdir $current_target_dir + file copy -force $current_source_dir/$m $current_target_dir + set ts2 [clock milliseconds] + puts -nonewline stderr " (copy time [expr {$ts2 - $ts1}] ms)" + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + set ts3 [clock milliseconds] + puts stderr " (cksum time [expr {$ts2 - $ts1}] ms)" + lappend files_copied $current_source_dir/$m + } else { + set is_skip 1 + lappend files_skipped $current_source_dir/$m + } + } + synced-targets { + #disallow overwriting of target that has been modified by some other mechanism + #review + if {[llength $changed]} { + #only overwrite if the target file checksum equals the last installed checksum (ie target is in sync with previous source-set and so hasn't been customized) + set existing_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + set is_target_unmodified_since_install 0 + set target_cksum_compare "unknown" + set latest_install_record [punkcheck::recordlist::file_record_latest_installrecord $filerec] ;#may be no such record - in which case we get an empty list + if {[dict exists $latest_install_record -targets_cksums]} { + set last_install_cksum [dict get $latest_install_record -targets_cksums] ;#in this case we know there is only one as 'install' always uses targetset size of 1. (FILEINFO record per file in source folder) + if {[dict get $existing_tgt_cksum_info cksum] eq $last_install_cksum} { + set is_target_unmodified_since_install 1 + set target_cksum_compare "match" + } else { + set target_cksum_compare "nomatch" + } + } else { + set target_cksum_compare "norecord" + } + if {$is_target_unmodified_since_install} { + file mkdir $current_target_dir + puts stderr "punkcheck: synced-targets about to: file copy -force $current_source_dir/$m $current_target_dir" + file copy -force $current_source_dir/$m $current_target_dir + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + lappend files_copied $current_source_dir/$m + } else { + #either cksum is different or we were unable to verify the record. Either way we can't know if the target is in sync so we must skip it + set is_skip 1 + puts stderr "Skipping file copy $m target $current_target_dir/$m - require synced_target to overwrite - current target cksum compared to previous install: $target_cksum_compare" + lappend files_skipped $current_source_dir/$m + } + } else { + set is_skip 1 + lappend files_skipped $current_source_dir/$m + } + } + default { + set is_skip 1 + puts stderr "Skipping file copy $m target $current_target_dir/$m already exists (use -overwrite all-targets to overwrite)" + #TODO! implement newer-targets older-targets? (note ctimes/mtimes are unreliable - may not be worth implementing) + lappend files_skipped $current_source_dir/$m + } + } + } + } + #target dir was created as necessary if files matched above + #now ensure target dir exists if -createempty true + if {$opt_createempty && ![file exists $current_target_dir]} { + file mkdir $current_target_dir + } + + + + + set ts_now [clock microseconds] + set elapsed_us [expr {$ts_now - $ts_start}] + + #if {$store_source_cksums} { + #} + + set install_records [dict get $filerec body] + set current_install_record [lindex $install_records end] + #change the tag from *-INPROGRESS to INSTALL-RECORD/SKIPPED + if {$is_skip} { + set tag INSTALL-SKIPPED + } else { + set tag INSTALL-RECORD + } + dict set current_install_record tag $tag + dict set current_install_record -elapsed_us $elapsed_us + if {[llength $new_tgt_cksum_info]} { + dict set current_install_record -targets_cksums [list [dict get $new_tgt_cksum_info cksum]] + dict set current_install_record -cksum_all_opts [dict get $new_tgt_cksum_info opts] + } + lset install_records end $current_install_record + dict set filerec body $install_records + set filerec [punkcheck::recordlist::file_record_prune $filerec] ;#prune now that tag is finalized + if {!$has_filerec} { + #not found in original recordlist - append + lappend punkcheck_records $filerec + } else { + lset punkcheck_records $existing_filerec_posn $filerec + } + + + #------------------------------------------------------------ + if {$is_skip} { + set mark . + } else { + if {$is_new} { + set mark \x1b\[32\;1mN\x1b\[m + } else { + #updated + set mark \x1b\[32\;1mU\x1b\[m + } + } + if {$opt_progresschannel ne ""} { + if {$last_depth ne $CALLDEPTH} { + puts -nonewline $opt_progresschannel \n[string repeat " " $CALLDEPTH]$mark + flush $opt_progresschannel + set last_depth $CALLDEPTH + } else { + puts -nonewline $opt_progresschannel $mark + } + } + #------------------------------------------------------------ + + } + + if {$max_depth != -1 && $CALLDEPTH >= $max_depth} { + #don't process any more subdirs + #sometimes deliberately called with max_depth 1 - so don't warn here. review + #puts stderr "punkcheck::install warning - reached max_depth $max_depth" + set subdirs [list] + } else { + set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] + set hiddensubdirs [glob -nocomplain -dir $current_source_dir -type {hidden d} -tail *] + foreach h $hiddensubdirs { + switch -- $h { + "." - ".." { + continue + } + default { + if {$h ni $subdirs} { + lappend subdirs $h + } + } + } + } + } + #puts stderr "subdirs: $subdirs" + foreach d $subdirs { + set relative_source_path [file join $relative_source_dir $d] + set skipd 0 + foreach pathglob [concat $opt_excludepaths_core $opt_excludepaths] { + #puts "testing folder - globmatchpath $pathglob vs $relative_source_path" + if {[punk::path::globmatchpath $pathglob $relative_source_path]} { + lappend antiglob_paths_matched [file join $current_source_dir $d] + #puts stdout "SKIPPING FOLDER $relative_source_path due to exclude-path-match: $pathglob " + set skipd 1 + break + } + } + if {$skipd} { + continue + } + + #if {![file exists $current_target_dir/$d]} { + # file mkdir $current_target_dir/$d + #} + + + set sub_opts_1 [list {*}{ + } -call-depth-internal [expr {$CALLDEPTH + 1}] {*}{ + } -subdirlist [list {*}$subdirlist $d] {*}{ + } -glob $fileglob {*}{ + } -exclude-filetails-core $opt_excludefiletail_core {*}{ + } -exclude-filetails $opt_excludefiletail {*}{ + } -exclude-paths-core $opt_excludepaths_core {*}{ + } -exclude-paths $opt_excludepaths {*}{ + } -overwrite $overwrite_what {*}{ + } -source-checksum $opt_source_checksum {*}{ + } -punkcheck-folder $punkcheck_folder {*}{ + } -punkcheck-eventid $punkcheck_eventid {*}{ + } -punkcheck-records $punkcheck_records {*}{ + } -installer $opt_installer {*}{ + } + ] + set sub_opts [list {*}{ + } -call-depth-internal [expr {$CALLDEPTH + 1}] {*}{ + } -subdirlist [list {*}$subdirlist $d] {*}{ + } -punkcheck-folder $punkcheck_folder {*}{ + } -punkcheck-eventid $punkcheck_eventid {*}{ + } -punkcheck-records $punkcheck_records {*}{ + } -progresschannel $opt_progresschannel {*}{ + } + ] + set sub_opts [dict merge $opts $sub_opts] + set sub_result [punkcheck::install $srcdir $tgtdir {*}$sub_opts] + + lappend files_copied {*}[dict get $sub_result files_copied] + lappend files_skipped {*}[dict get $sub_result files_skipped] + lappend sources_unchanged {*}[dict get $sub_result sources_unchanged] + lappend antiglob_paths_matched {*}[dict get $sub_result antiglob_paths_matched] + set punkcheck_records [dict get $sub_result punkcheck_records] + } + + if {[string match *store* $opt_source_checksum]} { + #puts "subdirlist: $subdirlist" + if {$CALLDEPTH == 0} { + if {[llength $files_copied] || [llength $files_skipped]} { + #puts stdout ">>>>>>>>>>>>>>>>>>>" + set saveresult [punkcheck::save_records_to_file $punkcheck_records $punkcheck_file "install $srcdir to $tgtdir"] + puts stdout "\npunkcheck::install [dict get $saveresult recordcount] records saved as [dict get $saveresult linecount] lines to $punkcheck_file copied: [llength $files_copied] skipped: [llength $files_skipped]" + #puts stdout ">>>>>>>>>>>>>>>>>>>" + } else { + #todo - write db INSTALLER record if -debug true + + } + #puts stdout "sources_unchanged" + #puts stdout "$sources_unchanged" + #puts stdout "- -- --- --- --- ---" + } + } + + return [list files_copied $files_copied files_skipped $files_skipped sources_unchanged $sources_unchanged antiglob_paths_matched $antiglob_paths_matched punkcheck_records $punkcheck_records punkcheck_folder $punkcheck_folder srcdir $srcdir tgtdir $tgtdir] + } + + + lappend PUNKARGS [list { + @id -id ::punkcheck::summarize_install_resultdict + @cmd -name punkcheck::summarize_install_resultdict -help\ + "Emits a string summarizing a punkcheck resultdict, showing + how many items were copied, and the source, target locations" + @opts + -title -type string -default "" + -forcecolour -type boolean -default 0 -help\ + "When true, passes the forcecolour tag to punk::ansi functions. + This enables ANSI sgr colours even when colour + is off. (ignoring env(NO_COLOR)) + To disable colour - ensure the NO_COLOR env var is set, + or use: + namespace eval ::punk::console {variable colour_disabled 1}" + @values -min 1 -max 1 + resultdict -type dict + }] + proc summarize_install_resultdict {args} { + set argd [punk::args::parse $args withid ::punkcheck::summarize_install_resultdict] + lassign [dict values $argd] leaders opts values received + set title [dict get $opts -title] + set forcecolour [dict get $opts -forcecolour] + set resultdict [dict get $values resultdict] + + set has_ansi [expr {![catch {package require punk::ansi}]}] + if {$has_ansi} { + if {$forcecolour} { + set fc "forcecolour" + } else { + set fc "" + } + set R [punk::ansi::a] ;#reset + set LINE_COLOUR [punk::ansi::a+ {*}$forcecolour bold cyan] + set LOW_COLOUR [punk::ansi::a+ {*}$forcecolour bold green] + set HIGH_COLOUR [punk::ansi::a+ {*}$forcecolour bold yellow] + } else { + set R "" + set LINE_COLOUR "" + set LOW_COLOUR "" + set HIGH_COLOUR "" + } + + set msg "" + if {[dict size $resultdict]} { + set copied [dict get $resultdict files_copied] + if {[llength $copied] == 0} { + set HIGHLIGHT $LOW_COLOUR + } else { + set HIGHLIGHT $HIGH_COLOUR + } + set ruler $LINE_COLOUR[string repeat - 78]$R + if {$title ne ""} { + append msg $ruler \n + append msg $title \n + } + append msg $ruler \n + #append msg "[dict keys $resultdict]" \n + set tgtdir [dict get $resultdict tgtdir] + set checkfolder [dict get $resultdict punkcheck_folder] + append msg "${HIGHLIGHT}Copied [llength $copied] files from [dict get $resultdict srcdir] to [dict get $resultdict tgtdir]$R" \n + foreach f $copied { + append msg "COPIED [punkcheck::lib::path_relative $checkfolder $f]" \n + append msg " TO $tgtdir" \n + } + append msg "[llength [dict get $resultdict sources_unchanged]] unchanged source files" \n + append msg "[llength [dict get $resultdict files_skipped]] skipped files" \n + append msg $ruler \n + } + return $msg + } + + namespace eval recordlist { + set pkg punkcheck + namespace path ::punkcheck + + proc records_as_target_dict {record_list} { + set result [dict create] + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + set tgtlist [dict get $rec -targets] + if {[dict exists $result $tgtlist]} { + #todo - warn - duplicate record for same targetlist - shouldn't happen as we should be using get_file_record to find existing records + error "punkcheck::recordlist::records_as_target_dict - multiple records with same targetlist '$tgtlist'" + } + dict set result $tgtlist $rec + } + } + return $result + } + + + #will only match if same base was used.. and same targetlist + proc get_file_record {targetlist record_list} { + set posn 0 + set found_posn -1 + set record "" + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + if {[dict get $rec -targets] eq $targetlist} { + set found_posn $posn + set record $rec + break + } + } + incr posn + } + return [list position $found_posn record $record] + } + proc file_install_record_source_changes {install_record} { + #reject INSTALLFAILED items ? + switch -- [dict get $install_record tag] { + "QUERY-INPROGRESS" - + "INSTALL-RECORD" - + "INSTALL-SKIPPED" - + "INSTALL-INPROGRESS" - + "MODIFY-INPROGRESS" - + "MODIFY-RECORD" - + "MODIFY-SKIPPED" - + "VIRTUAL-INPROGRESS" - + "VIRTUAL-RECORD" - + "VIRTUAL-SKIPPED" - + "DELETE-RECORD" - + "DELETE-INPROGRESS" - + "DELETE-SKIPPED" { + } + default { + error "file_install_record_source_changes bad install record: tag '[dict get $install_record tag]' not INSTALL-RECORD|SKIPPED|INSTALL-INPROGRESS|MODIFY-RECORD|MODIFY-INPROGRESS|VIRTUAL-RECORD|VIRTUAL-INPROGRESS|DELETE-RECORD|DELETE-INPROGRESS" + } + } + set source_list [dict_getwithdefault $install_record body [list]] + set changed [list] + set unchanged [list] + foreach src $source_list { + if {[dict exists $src -changed]} { + if {[dict get $src -changed] !=0} { + lappend changed [dict get $src -path] + } else { + lappend unchanged [dict get $src -path] + } + } else { + lappend changed [dict get $src -path] + } + } + return [dict create changed $changed unchanged $unchanged] + } + + #assume only one for name - use first encountered? + proc get_installer_record {name record_list} { + set posn 0 + set found_posns [list] + set record "" + #puts ">>>> checking [llength $record_list] punkcheck records" + foreach rec $record_list { + if {[dict get $rec tag] eq "INSTALLER"} { + if {[dict get $rec -name] eq $name} { + set found_posn $posn + set record $rec + lappend found_posns $posn + } + } + incr posn + } + if {[llength $found_posns] > 1} { + error "punkcheck::recordlist::get_installer_record - multiple installer records with name '$name' found at positions $found_posns" + } elseif {[llength $found_posns] == 0} { + return [list position -1 record ""] + } else { + #single record found + return [list position [lindex $found_posn 0] record $record] + } + + } + + proc new_installer_record {name args} { + if {[llength $args] %2 !=0} { + error "punkcheck new_installer_record args must be name-value pairs" + } + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + + #put -tsiso first so it lines up with -tsiso in event records + set defaults [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $ts {*}{ + } -name $name {*}{ + } -keep_events 5 {*}{ + } + ] + set opts [dict merge $defaults $args] + + #set this_installer_record_list [punk::tdl::prettyparse [list INSTALLER name $opt_installer ts $ts tsiso $tsiso keep_events 5 {}]] + #set this_installer_record [lindex $this_installer_record_list 0] + + set record [dict create tag INSTALLER {*}$opts body {}] + + + return $record + } + proc new_installer_event_record {type args} { + if {[llength $args] %2 !=0} { + error "punkcheck new_installer_event_record args must be name-value pairs" + } + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set defaults [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $ts {*}{ + } -type $type {*}{ + } + ] + set opts [dict merge $defaults $args] + + set record [dict create tag EVENT {*}$opts] + } + #need to scan entire set if filerecords to check if event is still referenced + proc installer_record_pruneevents {installer_record record_list} { + set keep 5 + if {[dict exists $installer_record -keep_events]} { + set keep [dict get $installer_record -keep_events] + } + + if {[dict exists $installer_record body]} { + set body_items [dict get $installer_record body] + } else { + set body_items [list] + } + set kept_body_items [list] + set kcount 0 + foreach item [lreverse $body_items] { + if {[dict get $item tag] eq "EVENT"} { + incr kcount + if {$keep < 0 || $kcount <= $keep} { + lappend kept_body_items $item + } else { + set eventid "" + if {[dict exists $item -id]} { + set eventid [dict get $item -id] + } + if {$eventid ne "" && $eventid ne "unspecified"} { + #keep if referenced, discard if not, or if eventid empty/unspecified + set is_referenced 0 + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + if {[dict exists $rec body]} { + foreach install [dict get $rec body] { + if {[dict exists $install -eventid] && [dict get $install -eventid] eq $eventid} { + set is_referenced 1 + break + } + } + } + } + if {$is_referenced} { + break + } + } + if {$is_referenced} { + lappend kept_body_items $item + } + } + } + } else { + lappend kept_body_items $item + } + } + set kept_body_items [lreverse $kept_body_items] + dict set installer_record body $kept_body_items + return $installer_record + } + proc installer_record_add_event {installer_record event} { + if {[dict get $installer_record tag] ne "INSTALLER"} { + error "installer_record_add_event bad installer record: tag not INSTALLER" + } + if {[dict get $event tag] ne "EVENT"} { + error "installer_record_add_event bad event record: tag not EVENT" + } + if {[dict exists $installer_record body]} { + set body_items [dict get $installer_record body] + } else { + set body_items [list] + } + lappend body_items $event + dict set installer_record body $body_items + return $installer_record + } + proc file_record_latest_installrecord {file_record} { + tailcall file_record_latest_operationrecord INSTALL $file_record + } + proc file_record_latest_operationrecord {operation file_record} { + set operation [string toupper $operation] + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_latest_operationrecord bad file_record: tag not FILEINFO" + } + if {![dict exists $file_record body]} { + return [list] + } + set body_items [dict get $file_record body] + foreach item [lreverse $body_items] { + if {[dict get $item tag] eq "$operation-RECORD"} { + return $item + } + } + return [list] + } + + + proc file_record_set_defaults {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_set_defaults bad file_record: tag not FILEINFO" + } + set defaults [list -keep_installrecords 3 -keep_skipped 1 -keep_inprogress 2] + foreach {k v} $defaults { + if {![dict exists $file_record $k]} { + dict set file_record $k $v + } + } + return $file_record + } + + #negative keep_ value will keep all + proc file_record_prune {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_prune bad file_record: tag not FILEINFO" + } + set file_record [file_record_set_defaults $file_record] + set kmap [list -keep_installrecords *-RECORD -keep_skipped *-SKIPPED -keep_inprogress *-INPROGRESS] + foreach {key rtype} $kmap { + set keep [dict get $file_record $key] + if {[dict exists $file_record body]} { + set body_items [dict get $file_record body] + } else { + set body_items [list] + } + set kept_body_items [list] + set kcount 0 + foreach item [lreverse $body_items] { + if {[string match $rtype [dict get $item tag]]} { + incr kcount + if {$keep < 0 || $kcount <= $keep} { + lappend kept_body_items $item + } + } else { + lappend kept_body_items $item + } + } + set kept_body_items [lreverse $kept_body_items] + dict set file_record body $kept_body_items + } + return $file_record + } + + #extract new or existing filerecord for path given + #REVIEW - locking/concurrency + proc extract_or_create_fileset_record {relative_target_paths recordset} { + set fetch_record_result [punkcheck::recordlist::get_file_record $relative_target_paths $recordset] + set existing_posn [dict get $fetch_record_result position] + if {$existing_posn == -1} { + puts stdout "punkcheck NO existing record for $relative_target_paths" + set isnew 1 + set fileset_record [dict create tag FILEINFO -targets $relative_target_paths body {}] + } else { + #set recordset [lreplace $recordset[unset recordset] $existing_posn $existing_posn] + #set recordset [lreplace $recordset[set recordset {}] $existing_posn $existing_posn] + ledit recordset $existing_posn $existing_posn + set isnew 0 + set fileset_record [dict get $fetch_record_result record] + } + return [list record $fileset_record recordset $recordset isnew $isnew oldposition $existing_posn] + } + + } + +} + + + + +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punkcheck +} + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punkcheck [namespace eval punkcheck { + set pkg punkcheck + variable version + set version 0.2.0 +}] +return diff --git a/src/make.tcl b/src/make.tcl index 1d74becb..334600ad 100644 --- a/src/make.tcl +++ b/src/make.tcl @@ -282,6 +282,52 @@ namespace eval ::punkboot::lib { } +#------------------------------------------------------------------------------ +# Bootsupport staleness helpers — self-contained Tcl, no punk package deps. +# These run in the early boot phase before punk packages are guaranteed loaded +# (modeled on punk::lib::askuser but without punk::console / raw-mode deps). +#------------------------------------------------------------------------------ + +# Classify the version delta between an old (bootsupport) and new (source) +# semver as "major", "minor", or "patch". +# Caller must verify new_ver > old_ver via `package vcompare` first. +proc ::punkboot::lib::bootsupport_bump_level {old_ver new_ver} { + set op [split $old_ver .] + set np [split $new_ver .] + while {[llength $op] < 3} {lappend op 0} + while {[llength $np] < 3} {lappend np 0} + set op [lmap s $op { + set n [scan $s %d] + expr {[string is integer -strict $n] ? $n : 0} + }] + set np [lmap s $np { + set n [scan $s %d] + expr {[string is integer -strict $n] ? $n : 0} + }] + lassign $op o_major o_minor o_patch + lassign $np n_major n_minor n_patch + if {$n_major > $o_major} {return "major"} + if {$n_minor > $o_minor} {return "minor"} + return "patch" +} + +# Self-contained y/N prompt. Returns 1 for y/yes (case-insensitive), 0 otherwise. +# Used by the staleness abort path to ask the user whether to proceed past a +# minor-version bump. Default is No (Enter = abort) so accidental Enter is safe. +proc ::punkboot::lib::bootsupport_prompt_yesno {prompt} { + puts stdout $prompt + puts -nonewline stdout "Proceed anyway? (y/N) " + flush stdout + set stdin_state [chan configure stdin] + try { + chan configure stdin -blocking 1 + set answer [string tolower [string trim [gets stdin]]] + } finally { + chan configure stdin -blocking [dict get $stdin_state -blocking] + } + return [expr {$answer eq "y" || $answer eq "yes"}] +} + if {"::try" ni [info commands ::try]} { puts stderr "Tcl interpreter possibly too old - need at least tcl 8.6 - 'try' command not found - aborting" exit 1 @@ -469,6 +515,52 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} { #package forget punk::repo #package forget punkcheck + #------------------------------------------------------------------ + # Bootsupport staleness check + # When make.tcl is run from project root (not from src/), bootsupport + # modules are loaded in preference to source modules. If the source + # modules have been updated (e.g API changes) but bootsupport hasn't + # been rebuilt, make.tcl will fail with obscure errors from the stale + # bootsupport versions. This check compares buildversion.txt in source + # against the highest .tm version in bootsupport and warns the caller. + #------------------------------------------------------------------ + if {[file tail $startdir] ne "src"} { + set _runtime_deps [list {*}{ + } punkcheck punkcheck-buildversion.txt punkcheck-*.tm {*}{ + } punk::repo punk/repo-buildversion.txt punk/repo-*.tm {*}{ + } punk::mix punk/mix-buildversion.txt punk/mix-*.tm {*}{ + } punk::tdl punk/tdl-buildversion.txt punk/tdl-*.tm {*}{ + }] + set _stale_modules [list] + foreach {pkg buildversion_rel bootsupport_glob} $_runtime_deps { + set _src_bv_file [file join $::punkboot::scriptfolder modules $buildversion_rel] + set _bs_glob_dir [file dirname [file join $::punkboot::scriptfolder bootsupport modules $bootsupport_glob]] + set _bs_glob_pat [file tail $bootsupport_glob] + if {![file exists $_src_bv_file]} {continue} + #read source version (first line of buildversion.txt) + set _fd [open $_src_bv_file r] + set _src_version [string trim [lindex [split [read $_fd] \n] 0]] + close $_fd + #find highest version .tm in bootsupport + set _bs_version "" + set _prefix [string range $_bs_glob_pat 0 [string first "*" $_bs_glob_pat]-1] + foreach _tm [glob -nocomplain -dir $_bs_glob_dir -- $_bs_glob_pat] { + set _v [file rootname [string range [file tail $_tm] [string length $_prefix] end]] + if {$_bs_version eq "" || [package vcompare $_v $_bs_version] == 1} { + set _bs_version $_v + } + } + if {$_bs_version ne "" && $_src_version ne "" && [package vcompare $_src_version $_bs_version] == 1} { + set _bump [::punkboot::lib::bootsupport_bump_level $_bs_version $_src_version] + lappend _stale_modules [list $pkg $_src_version $_bs_version $_bump] + } + } + if {[llength $_stale_modules]} { + set ::punkboot::stale_bootsupport $_stale_modules + } + unset _runtime_deps _stale_modules + } + package require punk::repo ;#todo - push our requirements to a smaller punk::repo::xxx package with minimal dependencies package require punk::mix package require punkcheck @@ -1433,6 +1525,51 @@ if {[lsearch $::argv -k] >= 0} { #puts stdout "::argv $::argv" # ---------------------------------------- +# Abort / prompt if bootsupport modules are stale relative to source. +# Behaviour is version-aware based on the bump level between each stale +# module's bootsupport version and source version: +# - major bump -> abort unconditionally (breaking change, old bootsupport will not work) +# - minor bump -> prompt user; backward-compat aliases *should* keep old bootsupport functional +# - patch bump -> warn and proceed (non-breaking) +# 'check' is exempt in all cases — the warning is shown at the end of its output instead. +if {[info exists ::punkboot::stale_bootsupport] && $::punkboot::command ne "check"} { + set _stale $::punkboot::stale_bootsupport + set _have_major 0 + set _have_minor 0 + set _have_patch 0 + foreach _entry $_stale { + lassign $_entry _pkg _src_ver _bs_ver _bump + switch -- $_bump { + major {incr _have_major} + minor {incr _have_minor} + patch {incr _have_patch} + default {incr _have_patch} + } + } + puts stderr "==============================================================================" + puts stderr "WARNING: bootsupport modules are stale relative to source modules:" + foreach _entry $_stale { + lassign $_entry _pkg _src_ver _bs_ver _bump + puts stderr [format " %-15s bootsupport=%-10s source=%-10s bump=%s" $_pkg $_bs_ver $_src_ver $_bump] + } + puts stderr "" + puts stderr " Recommended fix — update bootsupport before proceeding:" + puts stderr " cd \[projectroot\]/src && tclsh make.tcl modules && tclsh make.tcl bootsupport" + puts stderr "==============================================================================" + if {$_have_major} { + puts stderr "-aborted- (major version bump in stale bootsupport — breaking change, cannot proceed)" + exit 1 + } + if {$_have_minor} { + if {![::punkboot::lib::bootsupport_prompt_yesno "Minor-version staleness — backward-compat aliases should keep old bootsupport functional."]} { + puts stderr "-aborted- by user" + exit 1 + } + puts stderr "-proceeding with stale bootsupport at user's request-" + } + # patch-only staleness: warn and proceed (warning already printed above) +} + set scriptfolder $::punkboot::scriptfolder @@ -1582,6 +1719,19 @@ if {$::punkboot::command eq "check"} { puts stdout $sep catch {package require struct::set} puts stdout ---[package ifneeded struct::set 2.2.3] + # Show bootsupport staleness warning at the end of check output + if {[info exists ::punkboot::stale_bootsupport]} { + puts stderr "==============================================================================" + puts stderr "WARNING: bootsupport modules are stale relative to source modules:" + foreach _entry $::punkboot::stale_bootsupport { + lassign $_entry _pkg _src_ver _bs_ver _bump + puts stderr [format " %-15s bootsupport=%-10s source=%-10s bump=%s" $_pkg $_bs_ver $_src_ver $_bump] + } + puts stderr "" + puts stderr " Run the following to update bootsupport before proceeding:" + puts stderr " cd \[projectroot\]/src && tclsh make.tcl modules && tclsh make.tcl bootsupport" + puts stderr "==============================================================================" + } exit 0 } @@ -2025,7 +2175,7 @@ if {$::punkboot::command eq "bootsupport"} { set resultdict [punkcheck::install $sourcemodules $targetroot\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -installer "punkboot-bootsupport"\ -progresschannel stdout\ ] @@ -2042,7 +2192,7 @@ if {$::punkboot::command eq "bootsupport"} { puts stdout "BOOTSUPPORT layouts/$layoutname: copying from $source_bootscript to $targetroot_bootscript (if source file changed)" set resultdict [punkcheck::install [file dirname $source_bootscript] $targetroot_bootscript\ -glob make.tcl\ - -max_depth 1\ + -max-depth 1\ -createempty 0\ -overwrite installedsourcechanged-targets\ -installer "punkboot-bootsupport"\ @@ -2098,11 +2248,11 @@ if {$::punkboot::command in {project packages modules}} { -overwrite installedsourcechanged-targets -progresschannel stdout -exclude-filetails {AGENTS.md include_modules.config} - -antiglob_paths {README.md} +-exclude-paths {README.md} }] - # -antiglob_paths {README.md AGENTS.md **/AGENTS.md include_modules.config} + # -exclude-paths {README.md AGENTS.md **/AGENTS.md include_modules.config} #-exclude-filetails {AGENTS.md include_modules.config} - #-antiglob_paths {README.md} + #-exclude-paths {README.md} puts stdout [punkcheck::summarize_install_resultdict $resultdict] } if {![llength $vendormodulefolders]} { @@ -2112,7 +2262,7 @@ if {$::punkboot::command in {project packages modules}} { if {$::punkboot::command in {project packages libs}} { #exclude README.md from source folder - but only the root one - #-antiglob_paths takes relative patterns e.g + #-exclude-paths takes relative patterns e.g # */test.txt will only match test.txt exactly one level deep. # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. # **/test.txt will match at any level below the root (but not in the root) @@ -2130,7 +2280,7 @@ if {$::punkboot::command in {project packages libs}} { puts stdout "VENDORLIB: copying tcl-version neutral and platform neutral libraries from $source_lib_folder to $target_lib_folder (if source file changed)" set resultdict [punkcheck::install $source_lib_folder $target_lib_folder\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -2150,7 +2300,7 @@ if {$::punkboot::command in {project packages libs}} { puts stdout "VENDORLIB_$which: copying from $source_lib_folder to $target_lib_folder (if source file changed)" set resultdict [punkcheck::install $source_lib_folder $target_lib_folder\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -2165,7 +2315,7 @@ if {$::punkboot::command in {project packages libs}} { puts stdout "VENDORLIB_$which: copying from $source_lib_folder to $target_lib_folder (if source file changed)" set resultdict [punkcheck::install $source_lib_folder $target_lib_folder\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -2183,7 +2333,7 @@ if {$::punkboot::command in {project packages libs}} { ######################################################## lappend projectlibfolders lib #exclude README.md from source folder - but only the root one - #-antiglob_paths takes relative patterns e.g + #-exclude-paths takes relative patterns e.g # */test.txt will only match test.txt exactly one level deep. # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. # **/test.txt will match at any level below the root (but not in the root) @@ -2200,7 +2350,7 @@ if {$::punkboot::command in {project packages libs}} { puts stdout "PROJECTLIB: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -2219,7 +2369,7 @@ if {$::punkboot::command in {project packages libs}} { puts stdout "PROJECTLIB_$which: copying from $source_lib_folder to $target_lib_folder (if source file changed)" set resultdict [punkcheck::install $source_lib_folder $target_lib_folder\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -2235,7 +2385,7 @@ if {$::punkboot::command in {project packages libs}} { puts stdout "PROJECTLIB_$which: copying from $source_lib_folder to $target_lib_folder (if source file changed)" set resultdict [punkcheck::install $source_lib_folder $target_lib_folder\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -2358,7 +2508,7 @@ if {$::punkboot::command in {project packages modules}} { set resultdict [punkcheck::install_non_tm_files $src_module_dir $target_modules_base\ -installer make.tcl\ -overwrite $overwrite\ - -antiglob_paths {README.md **/AGENTS.md AGENTS.md}\ + -exclude-paths {README.md **/AGENTS.md AGENTS.md}\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] diff --git a/src/modules/AGENTS.md b/src/modules/AGENTS.md index 3ceedd8b..8c0a41a6 100644 --- a/src/modules/AGENTS.md +++ b/src/modules/AGENTS.md @@ -293,12 +293,25 @@ return - Stick to semantic versioning: `major.minor.patch`. - Use the magic version `999999.0a1.0` for source modules and add or update the actual version number in the associated `-buildversion.txt` file. -- Update the `-buildversion.txt` file when API changes are made. +- Bump `-buildversion.txt` whenever the module's API or behavior changes: + - **Patch** (e.g 0.1.0 → 0.1.1): bug fixes, internal refactors with no API change, or documentation-only updates to PUNKARGS. + - **Minor** (e.g 0.1.0 → 0.2.0): new flags, procs, or backward-compatible API additions. + - **Major** (e.g 1.0.0 → 2.0.0): breaking API changes (removed flags, changed return shapes, renamed procs without aliases). +- When bumping, append changelog comment lines below the version documenting each change, prefixed with the new version number. e.g: + ``` + 0.2.0 + #First line must be a semantic version number + #all other lines are ignored. + #0.2.0 - merged -exclude-dirsegments + -antiglob_paths into unified -exclude-paths (backward-compat aliases retained) + #0.1.2 - fixed path_relative delegation edge case on Windows + ``` + This keeps the changelog discoverable alongside the version number without requiring a separate CHANGES file. +- **Bootstrap-tracked files only** — `punkcheck-buildversion.txt`, `punk/repo-buildversion.txt`, `punk/mix-buildversion.txt` (the top-level `punk::mix` file only; `punk::mix::util`, `punk::mix::cli`, and `punk/mix/commandset/*` version independently and are not covered by this check), and `punk/tdl-buildversion.txt`: bump at least **minor** whenever a call site inside that file is updated to use a new API, even if the file's own interface is unchanged. `src/make.tcl` reads only these four files to classify bootsupport staleness (major=abort, minor=prompt, patch=silent-proceed); under-bumping one of them to patch when the call-site change is more significant causes `make.tcl` to mis-classify and either wrongly proceed without prompting or wrongly abort. See `src/bootsupport/AGENTS.md` "Bootsupport Staleness Handling" for the full contract. +- **All other modules** (including `punk::mix` submodules): call-site updates follow ordinary judgement from the Patch/Minor/Major rules above — a behavior-preserving call-site change is a patch (or no bump if genuinely a no-op); reserve minor for changes that add capability to the module's *own* API. `src/make.tcl` does not read these versions, so there is no automated consequence, but keep the changelog accurate since it is the only record of the module's real semantic version. - There may be occasional exceptions such as `punk::libunknown-0.1.tm`, which is deliberately manually versioned; new modules should use the magic version mechanism. - Modules with the magic version number must not appear in output paths such as `/modules`. - When referencing ranges, use bounded specs such as `1.2.3-2.0.0`. - Convert loose versions to bounded form in module metadata; helper utilities exist in boot modules for this purpose. -- Update `punk::libunknown` registries whenever adding or removing modules to keep discovery accurate. ### Documentation And Comments diff --git a/src/modules/punk/AGENTS.md b/src/modules/punk/AGENTS.md index cf7c8898..836c14e2 100644 --- a/src/modules/punk/AGENTS.md +++ b/src/modules/punk/AGENTS.md @@ -32,6 +32,7 @@ Source of truth for all modules under the `punk::*` namespace. This is the prima - Private helpers go in `namespace eval private { ... }` blocks. - Keep `namespace export` lists alphabetized. - The `#modpod-*` folders contain files that get packed into `.tm` module archives during build — do not flatten them. +- Follow the parent `src/modules/AGENTS.md` "Versioning And Releases" rules: bump `-buildversion.txt` on any API or behavior change and append a changelog comment line documenting the change. ## Verification diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm index 911c76f1..3eaabdd8 100644 --- a/src/modules/punk/ansi-999999.0a1.0.tm +++ b/src/modules/punk/ansi-999999.0a1.0.tm @@ -1325,6 +1325,13 @@ tcl::namespace::eval punk::ansi { grepstr -r m -C 2 {cancelid} [s ::after] ;#with 2 lines of context and no break indicators. }]} + To match a literal string that contains regex special characters, it is in some cases easier to use the Tcl regex + quoting switch (?q) to quote the string rather than escaping each special character with a backslash. + ${[punk::args::helpers::example -syntax none { + #The following example matches a literal string that is the Tcl expansion operator {*} + grepstr "(?q){*}" $sometext + }]} + } @leaders -min 0 -max 0 diff --git a/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/layouts/project/src/make.tcl b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/layouts/project/src/make.tcl index 1982bc97..5dd4e004 100644 --- a/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/layouts/project/src/make.tcl +++ b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/layouts/project/src/make.tcl @@ -169,7 +169,7 @@ if {[llength $commands_found] != 1 } { set do_help 1 } if {$do_help} { - puts stderr [punkmake_gethelp] + puts stderr [punkmake_gethelp] exit 0 } @@ -443,7 +443,7 @@ if {$::punkmake::command eq "bootsupport"} { puts stdout "BOOTSUPPORT non_tm_files $src - copying to $tgt (if source file changed)" set overwrite "installedsourcechanged-targets" - set resultdict [punkcheck::install_non_tm_files $src $tgt -installer make.tcl -overwrite $overwrite -punkcheck_folder $projectroot/src/bootsupport] + set resultdict [punkcheck::install_non_tm_files $src $tgt -installer make.tcl -overwrite $overwrite -punkcheck-folder $projectroot/src/bootsupport] puts stdout [punkcheck::summarize_install_resultdict $resultdict] } } @@ -471,7 +471,7 @@ if {$::punkmake::command eq "bootsupport"} { file mkdir $targetroot puts stdout "BOOTSUPPORT layouts/$layoutname: copying from $sourcemodules to $targetroot (if source file changed)" - set resultdict [punkcheck::install $sourcemodules $targetroot -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] + set resultdict [punkcheck::install $sourcemodules $targetroot -overwrite installedsourcechanged-targets -exclude-paths $antipaths] puts stdout [punkcheck::summarize_install_resultdict $resultdict] flush stdout } @@ -507,7 +507,7 @@ file mkdir $target_modules_base #external libs and modules first - and any supporting files - no 'building' required if {[file exists $sourcefolder/vendorlib]} { #exclude README.md from source folder - but only the root one - #-antiglob_paths takes relative patterns e.g + #-exclude-paths takes relative patterns e.g # */test.txt will only match test.txt exactly one level deep. # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. # **/test.txt will match at any level below the root (but not in the root) @@ -516,7 +516,7 @@ if {[file exists $sourcefolder/vendorlib]} { }] puts stdout "VENDORLIB: copying from $sourcefolder/vendorlib to $projectroot/lib (if source file changed)" - set resultdict [punkcheck::install $sourcefolder/vendorlib $projectroot/lib -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] + set resultdict [punkcheck::install $sourcefolder/vendorlib $projectroot/lib -overwrite installedsourcechanged-targets -exclude-paths $antipaths] puts stdout [punkcheck::summarize_install_resultdict $resultdict] } else { @@ -526,7 +526,7 @@ if {[file exists $sourcefolder/vendorlib]} { if {[file exists $sourcefolder/vendormodules]} { #install .tm *and other files* puts stdout "VENDORMODULES: copying from $sourcefolder/vendormodules to $target_modules_base (if source file changed)" - set resultdict [punkcheck::install $sourcefolder/vendormodules $target_modules_base -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md include_modules.config}] + set resultdict [punkcheck::install $sourcefolder/vendormodules $target_modules_base -installer make.tcl -overwrite installedsourcechanged-targets -exclude-paths {README.md include_modules.config}] puts stdout [punkcheck::summarize_install_resultdict $resultdict] } else { puts stderr "VENDORMODULES: No src/vendormodules folder found." @@ -621,7 +621,7 @@ foreach src_module_dir $source_module_folderlist { set overwrite "installedsourcechanged-targets" #set overwrite "ALL-TARGETS" puts stdout "MODULEFOLDER non_tm_files $src_module_dir - copying to $target_modules_base (if source file changed)" - set resultdict [punkcheck::install_non_tm_files $src_module_dir $target_modules_base -installer make.tcl -overwrite $overwrite -antiglob_paths {README.md}] + set resultdict [punkcheck::install_non_tm_files $src_module_dir $target_modules_base -installer make.tcl -overwrite $overwrite -exclude-paths {README.md}] puts stdout [punkcheck::summarize_install_resultdict $resultdict] } diff --git a/src/modules/punk/mix/cli-999999.0a1.0.tm b/src/modules/punk/mix/cli-999999.0a1.0.tm index 1bee984b..ed138286 100644 --- a/src/modules/punk/mix/cli-999999.0a1.0.tm +++ b/src/modules/punk/mix/cli-999999.0a1.0.tm @@ -474,7 +474,7 @@ namespace eval punk::mix::cli { set defaults [list {*}{ -installer punk::mix::cli::build_modules_from_source_to_base -call-depth-internal 0 - -max_depth 1000 + -max-depth 1000 -subdirlist {} -punkcheck_eventobj "\uFFFF" -glob *.tm @@ -487,7 +487,7 @@ namespace eval punk::mix::cli { set installername [dict get $opts -installer] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set CALLDEPTH [dict get $opts -call-depth-internal] - set max_depth [dict get $opts -max_depth] + set max_depth [dict get $opts -max-depth] set subdirlist [dict get $opts -subdirlist] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set fileglob [dict get $opts -glob] @@ -533,7 +533,7 @@ namespace eval punk::mix::cli { set config [dict create {*}{ -glob $fileglob - -max_depth 0 + -max-depth 0 }] #lassign [punkcheck::start_installer_event $punkcheck_file $installername $srcdir $basedir $config] _eventid punkcheck_eventid _recordset record_list # -- --- @@ -628,11 +628,11 @@ namespace eval punk::mix::cli { # -- --- set config [dict create {*}{ -glob * - -max_depth 100 + -max-depth 100 }] set had_error 0 - # -max_depth -1 for no limit + # -max-depth -1 for no limit set build_installername pods_in_$current_source_dir set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck] #set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck stderr] ;#with debugchannel @@ -829,11 +829,11 @@ namespace eval punk::mix::cli { # -- --- set config [dict create {*}{ -glob * - -max_depth 100 + -max-depth 100 }] set had_error 0 - # -max_depth -1 for no limit + # -max-depth -1 for no limit set build_installername tarjars_in_$current_source_dir set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck] $build_installer set_source_target $current_source_dir/$modpath $buildfolder diff --git a/src/modules/punk/mix/cli-buildversion.txt b/src/modules/punk/mix/cli-buildversion.txt index 8a16d4cb..4d786893 100644 --- a/src/modules/punk/mix/cli-buildversion.txt +++ b/src/modules/punk/mix/cli-buildversion.txt @@ -1,3 +1,4 @@ -0.3.1 +0.4.0 #First line must be a semantic version number #all other lines are ignored. +#0.4.0 - updated -max_depth to -max-depth at punkcheck::install call sites — call-site flag change warrants minor bump diff --git a/src/modules/punk/mix/commandset/doc-999999.0a1.0.tm b/src/modules/punk/mix/commandset/doc-999999.0a1.0.tm index 42bb6021..c8b4f3cb 100644 --- a/src/modules/punk/mix/commandset/doc-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/doc-999999.0a1.0.tm @@ -245,7 +245,7 @@ namespace eval punk::mix::commandset::doc { } file mkdir $output_base - set matched_paths [punk::path::treefilenames -dir $codesource_path -antiglob_paths {**/mix/templates/** **/project_layouts/** **/decktemplates/** **/_aside **/_aside/**} *.tm] + set matched_paths [punk::path::treefilenames -dir $codesource_path -exclude-paths {**/mix/templates/** **/project_layouts/** **/decktemplates/** **/_aside **/_aside/**} *.tm] set count 0 set newdocs [list] set docgen_header_comments "" diff --git a/src/modules/punk/mix/commandset/doc-buildversion.txt b/src/modules/punk/mix/commandset/doc-buildversion.txt index f47d01c8..cc25e464 100644 --- a/src/modules/punk/mix/commandset/doc-buildversion.txt +++ b/src/modules/punk/mix/commandset/doc-buildversion.txt @@ -1,3 +1,4 @@ -0.1.0 +0.1.1 #First line must be a semantic version number #all other lines are ignored. +#0.1.1 - fixed treefilenames call using -antiglob_paths instead of -exclude-paths diff --git a/src/modules/punk/mix/commandset/project-999999.0a1.0.tm b/src/modules/punk/mix/commandset/project-999999.0a1.0.tm index e155764f..d95780b8 100644 --- a/src/modules/punk/mix/commandset/project-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/project-999999.0a1.0.tm @@ -386,37 +386,38 @@ namespace eval punk::mix::commandset::project { src/PROJECT_LAYOUTS_* }] - #set exclude_dirsegments [list {*}{ + #set exclude_paths [list {*}{ # _ignore_* + # **/_ignore_* #}] - set exclude_dirsegments [list {*}{ + set exclude_paths [list {*}{ }] - #default -exclude-dirsegments_core will stop .fossil* from being updated - which is generally desirable as these are likely to be customized + #default -exclude-paths-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_path $projectdir -installer project.new -createempty 1 -overwrite ALL-TARGETS -antiglob_paths $antipaths -exclude-dirsegments $exclude_dirsegments] + set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite ALL-TARGETS -exclude-paths [concat $antipaths $exclude_paths]] } else { puts stdout "copying layout files - (if source file changed)" - set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite installedsourcechanged-targets -antiglob_paths $antipaths -exclude-dirsegments $exclude_dirsegments] + set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite installedsourcechanged-targets -exclude-paths [concat $antipaths $exclude_paths]] } puts stdout [punkcheck::summarize_install_resultdict $resultdict] if {[file exists $layout_path/src/doc]} { puts stdout "copying layout src/doc files (if target missing)" - set resultdict [punkcheck::install $layout_path/src/doc $projectdir/src/doc -createdir 1 -punkcheck_folder $projectdir -installer project.new -overwrite SYNCED-TARGETS] + set resultdict [punkcheck::install $layout_path/src/doc $projectdir/src/doc -createdir 1 -punkcheck-folder $projectdir -installer project.new -overwrite SYNCED-TARGETS] puts stdout [punkcheck::summarize_install_resultdict $resultdict] } else { puts stdout "no src/doc in source template - update not required" } #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_exclude_dirsegments_core [list "#*" "_aside" ".git" ".fossil*"] - set override_exclude_dirsegments_core [list #* _aside .git] + #In this case we need to override the default exclude-paths_core - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized. + ## default_excludepaths_core [list "#*" "**/#*" "_aside" "**/_aside" "_build" "**/_build" ".git" "**/.git" ".fossil*" "**/.fossil*"] + set override_excludepaths_core [list #* **/#* _aside **/_aside .git **/.git] if {[file exists $layout_path/.fossil-custom]} { puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)" - set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -exclude-dirsegments_core $override_exclude_dirsegments_core -overwrite SYNCED-TARGETS] + set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -createempty 1 -punkcheck-folder $projectdir -installer project.new -exclude-paths-core $override_excludepaths_core -overwrite SYNCED-TARGETS] puts stdout [punkcheck::summarize_install_resultdict $resultdict] } else { puts stdout "no .fossil-custom in source template - update not required" @@ -424,7 +425,7 @@ namespace eval punk::mix::commandset::project { if {[file exists $layout_path/.fossil-settings]} { puts stdout "copying layout src/.fossil-settings files (if target missing or uncustomised)" - set resultdict [punkcheck::install $layout_path/.fossil-settings $projectdir/.fossil-settings -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -exclude-dirsegments_core $override_exclude_dirsegments_core -overwrite SYNCED-TARGETS] + set resultdict [punkcheck::install $layout_path/.fossil-settings $projectdir/.fossil-settings -createdir 1 -createempty 1 -punkcheck-folder $projectdir -installer project.new -exclude-paths-core $override_excludepaths_core -overwrite SYNCED-TARGETS] puts stdout [punkcheck::summarize_install_resultdict $resultdict] } else { puts stdout "no .fossil-settings in source template - update not required" diff --git a/src/modules/punk/mix/commandset/project-buildversion.txt b/src/modules/punk/mix/commandset/project-buildversion.txt index f47d01c8..60d278d3 100644 --- a/src/modules/punk/mix/commandset/project-buildversion.txt +++ b/src/modules/punk/mix/commandset/project-buildversion.txt @@ -1,3 +1,5 @@ -0.1.0 +0.2.0 #First line must be a semantic version number #all other lines are ignored. +#0.2.0 - updated punkcheck::install call sites to use -exclude-paths / -exclude-paths-core (replaced -antiglob-paths + -exclude-dirsegments) — call-site API change warrants minor bump +#0.2.0 - updated call sites to use hyphenated flag names (-punkcheck-folder, -exclude-paths-core) diff --git a/src/modules/punk/path-999999.0a1.0.tm b/src/modules/punk/path-999999.0a1.0.tm index 9b52980e..c57349b7 100644 --- a/src/modules/punk/path-999999.0a1.0.tm +++ b/src/modules/punk/path-999999.0a1.0.tm @@ -1231,6 +1231,14 @@ namespace eval punk::path { puts stderr "treefilenames error while listing files in dir $opt_dir\n $matches" set dirfiles [list] } else { + #also match hidden files (e.g dotfiles on windows where glob -type f misses them) + if {![catch {glob -nocomplain -dir $opt_dir -types {hidden f} -- {*}$tailglobs} hidden_matches]} { + foreach h $hidden_matches { + if {$h ni $matches} { + lappend matches $h + } + } + } set dirfiles [_retain_files $matches $opt_exclude_files $opt_sort] } lappend files {*}[_tailbase_relative_list $opt_tailbase $dirfiles] @@ -1244,6 +1252,19 @@ namespace eval punk::path { puts stderr "treefilenames error while listing subdirs in dir $opt_dir\n $dirdirs" set dirdirs [list] } + #also match hidden directories + if {![catch {glob -nocomplain -dir $opt_dir -types {hidden d} *} hidden_dirdirs]} { + foreach h $hidden_dirdirs { + switch -- $h { + "." - ".." {continue} + default { + if {$h ni $dirdirs} { + lappend dirdirs $h + } + } + } + } + } set okdirs [list] foreach dir $dirdirs { if {![_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $dir]]} { @@ -1444,52 +1465,34 @@ namespace eval punk::path { return [treefile_priv::walk_treefilenames_zipfs $state] } + punk::args::define { + @id -id ::punk::path::relative + @cmd -name punk::path::relative\ + -summary\ + "Compute the relative path from a reference path to a location path."\ + -help\ + "Taking two directory paths, a reference and a location, computes the path + of the location relative to the reference. + + Will return a single dot '.' if the paths are the same. + + Both paths must be the same type - ie both absolute or both relative. + + Matching is case sensitive. On windows, the drive-letter component (only) is + not case sensitive, so punk::path::relative c:/etc C:/etc returns '.'. + The part following the driveletter is case sensitive, so + punk::path::relative c:/etc C:/Etc returns ../Etc. + + On windows, if the paths are absolute and specify different volumes, + only the location will be returned." + @leaders -min 2 -max 2 + reference -type string -help\ + "The path from which the relative path to location is determined." + location -type string -help\ + "The location path which may be above or below the reference path." + } #maint warning - also in punkcheck proc relative {reference location} { - #*** !doctools - #[call [fun relative] [arg reference] [arg location]] - #[para] Taking two directory paths, a reference and a location, computes the path - # of the location relative to the reference. - #[list_begin itemized] - #[item] - #[para] Arguments: - # [list_begin arguments] - # [arg_def string reference] The path from which the relative path to location is determined. - # [arg_def string location] The location path which may be above or below the reference path - # [list_end] - #[item] - #[para] Results: - #[para] The relative path of the location to the reference path. - #[para] Will return a single dot "." if the paths are the same - #[item] - #[para] Notes: - #[para] Both paths must be the same type - ie both absolute or both relative - #[para] Case sensitive. ie punk::path::relative /etc /etC - # will return ../etC - #[para] On windows, the drive-letter component (only) is not case sensitive - #[example_begin] - # P% punk::path::relative c:/etc C:/etc - # - . - #[example_end] - #[para] The part following the driveletter is case sensitive so in the following cases it recognises the driveletter matches but not the tail - #[example_begin] - # P% punk::path::relative c:/etc C:/Etc - # - ../Etc - #[example_end] - #[para] On windows, if the paths are absolute and specifiy different volumes, only the location will be returned. - #[example_begin] - # P% punk::path::relative c:/etc d:/etc/blah - # - d:/etc/blah - #[example_end] - #[para] Unix-like examples: - #[example_begin] - # P% punk::path::relative /usr/local/etc/ /usr/local/etc/somewhere/below - # - somewhere/below - # P% punk::path::relative /usr/local/etc/somewhere /usr/local/lib/here - # - ../../lib/here - #[example_end] - #[list_end] - #see also kettle # Modified copy of ::fileutil::relative (tcllib) # Adapted to 8.5 ({*}). diff --git a/src/modules/punk/path-buildversion.txt b/src/modules/punk/path-buildversion.txt index f47d01c8..a0269086 100644 --- a/src/modules/punk/path-buildversion.txt +++ b/src/modules/punk/path-buildversion.txt @@ -1,3 +1,5 @@ -0.1.0 +0.2.0 #First line must be a semantic version number #all other lines are ignored. +#0.2.0 - treefilenames now matches hidden files and recurses into hidden directories on all platforms +#0.2.0 - added PUNKARGS documentation for punk::path::relative diff --git a/src/modules/punkcheck-999999.0a1.0.tm b/src/modules/punkcheck-999999.0a1.0.tm index a2852db4..86dec318 100644 --- a/src/modules/punkcheck-999999.0a1.0.tm +++ b/src/modules/punkcheck-999999.0a1.0.tm @@ -41,9 +41,14 @@ namespace eval punkcheck { summarize_install_resultdict } - #exclude-dir & exclude-file entries match the pattern at any level - should not contain path separators - variable default_excludedirseg_core [list "#*" "_aside" "_build" ".git" ".fossil*"] + #exclude-paths entries match against the full relative path using globmatchpath. + #They may include ** to match across path segments and / to match within a segment. + #Each dir-seg pattern is expanded to both top-level and nested (**/) forms to preserve + #the "matches at any directory level" semantics of the former dir-seg mechanism. + variable default_excludepaths_core [list "#*" "**/#*" "_aside" "**/_aside" "_build" "**/_build" ".git" "**/.git" ".fossil*" "**/.fossil*"] variable default_excludefiletail_core "" + #backward-compat: retained for callers that still read default_excludedirseg_core + variable default_excludedirseg_core [list "#*" "_aside" "_build" ".git" ".fossil*"] set has_twapi 0 if {"windows" eq $::tcl_platform(platform)} { @@ -56,6 +61,11 @@ namespace eval punkcheck { interp alias "" ::punkcheck::uuid "" ::uuid::uuid generate } + proc default_excludepaths_core {} { + variable default_excludepaths_core + return $default_excludepaths_core + } + #backward-compat alias for the former segment-based default proc default_excludedirseg_core {} { variable default_excludedirseg_core return $default_excludedirseg_core @@ -1181,84 +1191,9 @@ namespace eval punkcheck { - #maint warning - also in punk::mix::util + # Delegate to punk::path::relative (verified equivalent implementation) 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 - at least for relative paths which we are likely to loop on (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 { - #case differences in volumes is common on windows - 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 ..] - ledit dst -1 -1 .. - incr baselen -1 - } - set dst [file join {*}$dst] - } - - return $dst + return [punk::path::relative $base $dst] } } #skip writing punkcheck during checksum/timestamp checks @@ -1276,16 +1211,15 @@ namespace eval punkcheck { } proc install_non_tm_files {srcdir basedir args} { #set keys [dict keys $args] - #adjust the default excludedirseg_core entries so that .fossil-custom, .fossil-settings are copied - set excludedirseg_core [punkcheck::default_excludedirseg_core] - set posn [lsearch $excludedirseg_core ".fossil*"] - if {$posn >=0} { - ledit excludedirseg_core $posn $posn - } + #adjust the default exclude-paths_core entries so that .fossil-custom, .fossil-settings are copied + set excludepaths_core [punkcheck::default_excludepaths_core] + #remove .fossil* entries (both top-level and **/ forms) so fossil folders are not excluded + set excludepaths_core [lsearch -inline -all -not $excludepaths_core ".fossil*"] + set excludepaths_core [lsearch -inline -all -not $excludepaths_core "**/.fossil*"] set defaults [list {*}{ } -glob * {*}{ } -exclude-filetails [list "*.tm" "*-buildversion.txt" "*.exe"] {*}{ - } -exclude-dirsegments_core $excludedirseg_core {*}{ + } -exclude-paths-core $excludepaths_core {*}{ } -installer punkcheck::install_non_tm_files {*}{ } ] @@ -1324,7 +1258,7 @@ namespace eval punkcheck { tgtdir -type directory -call-depth-internal -type integer -default 0 -help "(internal recursion tracker)" -subdirlist -type list -default "" -help "(primarily internal - length generally matching -call-depth-internal)" - -max_depth -type integer -default 1000 -help\ + -max-depth -type integer -default 1000 -help\ "Deepest subdirectory - use -1 for no limit." -createdir -type boolean -default 0 -help\ "Whether to create the folder at tgtdir. @@ -1333,11 +1267,45 @@ namespace eval punkcheck { "Whether to create folders at target that had no matches for our glob" -glob -type string -default "*" -help\ "Pattern matching for source file(s) to copy. Can be glob based or exact match." - -exclude-filetails_core -default {${[::punkcheck::default_excludefiltail_core]}} - -exclude-filetails -default "" - -exclude-dirsegments_core -default {${[::punkcheck::default_excludedirseg_core]}} - -exclude-dirsegments -default "" - -antiglob_paths -default {} + -exclude-filetails-core -default {${[::punkcheck::default_excludefiletail_core]}} -help\ + "Non-overridable default file-tail exclusion patterns. + These are applied in addition to -exclude-filetails and cannot be + disabled by the caller - they can only be replaced by passing + -exclude-filetails-core with a different list. + Patterns use string match against the file tail (basename) at any + level in the tree. They must not contain path separators." + -exclude-filetails -default "" -help\ + "List of glob patterns to match against file tails (basenames). + Patterns use string match and must not contain path separators. + e.g {*.swp *.tmp} excludes swap and temp files at any level." + -exclude-paths-core -default {${[::punkcheck::default_excludepaths_core]}} -help\ + "Non-overridable default path-glob exclusion patterns. + These are applied in addition to -exclude-paths and cannot be + disabled by the caller - they can only be replaced by passing + -exclude-paths-core with a different list. + Patterns are matched against the full relative source path using + punk::path::globmatchpath." + -exclude-paths -default {} -help\ + "List of path-glob patterns to exclude from installation. + Patterns are matched against the full relative source path using + punk::path::globmatchpath, so they may include ** to match across + path segments and / to match within a segment. + e.g to exclude all AGENTS.md files at any depth: {AGENTS.md **/AGENTS.md}" + #backward-compat aliases (accepted but deprecated - converted internally to -exclude-paths) + -exclude-dirsegments-core -default {${[::punkcheck::default_excludedirseg_core]}} -help\ + "DEPRECATED: use -exclude-paths-core instead. + Legacy segment-glob patterns matched against directory tail names. + Converted internally to path-glob form by expanding each segment + S to {S **/S}." + -exclude-dirsegments -default "" -help\ + "DEPRECATED: use -exclude-paths instead. + Legacy segment-glob patterns matched against directory tail names + at any level. Each pattern must not contain path separators." + -antiglob-paths -default {} -help\ + "DEPRECATED: use -exclude-paths instead. + Legacy path-glob patterns matched against the full relative source + path using punk::path::globmatchpath. Merged into -exclude-paths + internally." -overwrite -default no-targets\ -choices {no-targets newer-targets older-targets all-targets installedsourcechanged-targets synced-targets}\ -choicecolumns 1\ @@ -1353,15 +1321,22 @@ namespace eval punkcheck { synced-targets "copy if the target doesn't exist or the source changed and the target cksum is the same as the last INSTALL-RECORD -targets_cksums entry" } - -source_checksum -default comparestore -choicecolumns 3 -choices {compare store comparestore false true}\ - -choicelabels { - true "same as comparestore" - } - -punkcheck_folder -default target -choices {target source project} -choicerestricted 0 -help\ + -source-checksum -default comparestore -choicecolumns 3 -choices {compare store comparestore false true} -help\ + "Checksum behavior for source files. + compare: checksum and compare against last record, but do not store. + store: checksum and store, but do not compare against last record. + comparestore: checksum, compare against last record, and store. + false: do not checksum (not recommended - changes cannot be detected). + true: same as comparestore." + -punkcheck-folder -default target -choices {target source project} -choicerestricted 0 -help\ "The location of the .punkcheck file to track installations and checksums. The default value 'target' is generally recommended. Can also be an absolute path to a folder." - -punkcheck_records -default "" -help\ + -punkcheck-eventid -default "" -help\ + "Event ID for the install operation. When empty (default), a new UUID + is generated automatically. Pass a specific ID to group multiple + install calls under the same event in the .punkcheck file." + -punkcheck-records -default "" -help\ "Empty string or a parsed TDL records structure. e.g {tag FILEINFO - ... body { @@ -1404,28 +1379,54 @@ namespace eval punkcheck { # todo - determine what happens if mismatch between file type of a src vs target e.g target has dir matching filename at source # A pre-scan to determine no such conflict - before attempting to copy anything might provide the most integrity at slight cost in speed. # REVIEW we should only expect dirs to be created as necessary to hold files? i.e target folder won't be created if no source file matches for that folder - # -source_checksum compare|store|comparestore|false|true where true == comparestore - # -punkcheck_folder target|source|project| target is default and is generally recommended - # -punkcheck_records empty string | parsed TDL records ie {tag xxx k v} structure + # -source-checksum compare|store|comparestore|false|true where true == comparestore + # -punkcheck-folder target|source|project| target is default and is generally recommended + # -punkcheck-records empty string | parsed TDL records ie {tag xxx k v} structure # install creates FILEINFO records with a single entry in the -targets field (it is legitimate to have a list of targets for an installation operation - the oo interface supports this) proc install {srcdir tgtdir args} { + # Backward-compat: normalize old underscore flag names to hyphenated forms + set flag_aliases [dict create {*}{ + -max_depth -max-depth + -exclude-filetails_core -exclude-filetails-core + -exclude-paths_core -exclude-paths-core + -exclude-dirsegments_core -exclude-dirsegments-core + -antiglob_paths -antiglob-paths + -source_checksum -source-checksum + -punkcheck_folder -punkcheck-folder + -punkcheck_eventid -punkcheck-eventid + -punkcheck_records -punkcheck-records + }] + if {[llength $args]} { + set normalized [list] + foreach {k v} $args { + if {[dict exists $flag_aliases $k]} { + lappend normalized [dict get $flag_aliases $k] $v + } else { + lappend normalized $k $v + } + } + set args $normalized + } + set defaults [list {*}{ -call-depth-internal 0 - -max_depth 1000 + -max-depth 1000 -subdirlist {} -createdir 0 -createempty 0 -glob * - -exclude-filetails_core "\uFFFF" + -exclude-filetails-core "\uFFFF" -exclude-filetails "" - -exclude-dirsegments_core "\uFFFF" + -exclude-paths-core "\uFFFF" + -exclude-paths {} + -exclude-dirsegments-core "\uFFFF" -exclude-dirsegments {} - -antiglob_paths {} + -antiglob-paths {} -overwrite no-targets - -source_checksum comparestore - -punkcheck_folder target - -punkcheck_eventid "\uFFFF" - -punkcheck_records "" + -source-checksum comparestore + -punkcheck-folder target + -punkcheck-eventid "\uFFFF" + -punkcheck-records "" -installer punkcheck::install -progresschannel none }] @@ -1447,7 +1448,7 @@ namespace eval punkcheck { #and may be less error prone than doing slightly more opaque path manipulations at each recursion level to determine where we started #For consistency - we'll use the same mechanism in various recursive directory walking procedures such as this one. set CALLDEPTH [dict get $opts -call-depth-internal] ;#added for extra debug/sanity checking - clearer test for initial function call ie CALLDEPTH = 0 - set max_depth [dict get $opts -max_depth] ;# -1 for no limit + set max_depth [dict get $opts -max-depth] ;# -1 for no limit set subdirlist [dict get $opts -subdirlist] ;# generally should be same length as CALLDEPTH - but user could prefill set fileglob [dict get $opts -glob] set createdir [dict get $opts -createdir] ;#defaults to zero to help avoid mistakes with initial target dir - required target subdirs are created regardless of this setting @@ -1474,10 +1475,10 @@ namespace eval punkcheck { #now the values we build from these will be properly cased } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - set opt_excludefiletail_core [dict get $opts -exclude-filetails_core] + set opt_excludefiletail_core [dict get $opts -exclude-filetails-core] if {$opt_excludefiletail_core eq "\uFFFF"} { set opt_excludefiletail_core [default_excludefiletail_core] - dict set opts -exclude-filetails_core $opt_excludefiletail_core + dict set opts -exclude-filetails-core $opt_excludefiletail_core } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_excludefiletail [dict get $opts -exclude-filetails] @@ -1488,12 +1489,35 @@ namespace eval punkcheck { } } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - set opt_excludedirseg_core [dict get $opts -exclude-dirsegments_core] + # Unified -exclude-paths initialization (replaces -exclude-dirsegments + -antiglob-paths) + # Precedence: -exclude-paths-core > -exclude-dirsegments-core (legacy) > default + set opt_excludepaths_core [dict get $opts -exclude-paths-core] + set legacy_excludedirseg_core [dict get $opts -exclude-dirsegments-core] + if {$opt_excludepaths_core ne "\uFFFF"} { + # User explicitly passed -exclude-paths-core → use as-is (path-glob form) + } elseif {$legacy_excludedirseg_core ne "\uFFFF"} { + # User explicitly passed legacy -exclude-dirsegments-core → convert to path-glob form + set opt_excludepaths_core [list] + foreach seg $legacy_excludedirseg_core { + lappend opt_excludepaths_core $seg + lappend opt_excludepaths_core **/$seg + } + dict set opts -exclude-paths-core $opt_excludepaths_core + } else { + # Neither passed → use new default + set opt_excludepaths_core [default_excludepaths_core] + dict set opts -exclude-paths-core $opt_excludepaths_core + } + set opt_excludepaths [dict get $opts -exclude-paths] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # Backward-compat: convert legacy -exclude-dirsegments to path-glob form and merge + # Each segment-glob S is expanded to {S **/S} to match at any directory level, + # preserving the former string-match-against-tail semantics. + set opt_excludedirseg_core $legacy_excludedirseg_core if {$opt_excludedirseg_core eq "\uFFFF"} { set opt_excludedirseg_core [default_excludedirseg_core] - dict set opts -exclude-dirsegments_core $opt_excludedirseg_core + dict set opts -exclude-dirsegments-core $opt_excludedirseg_core } - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_excludedirseg [dict get $opts -exclude-dirsegments] #validate no path seps foreach ad $opt_excludedirseg { @@ -1501,9 +1525,18 @@ namespace eval punkcheck { error "punkcheck::install received invalid -exclude-dirsegments entry '$ad'. -exclude-dirsegments entries are meant to match to a directory name at any level so cannot contain path separators" } } + #convert legacy dir-seg user globs (NOT core) to path-glob form and append to opt_excludepaths + foreach seg $opt_excludedirseg { + lappend opt_excludepaths $seg + lappend opt_excludepaths **/$seg + } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - set opt_antiglob_paths [dict get $opts -antiglob_paths] ;#todo - combine with config file in source tree .punkcheckpublish (?) + # Backward-compat: merge legacy -antiglob-paths into opt_excludepaths + set opt_antiglob_paths [dict get $opts -antiglob-paths] ;#todo - combine with config file in source tree .punkcheckpublish (?) #antiglob_paths will usually contain file separators - and may contain glob patterns within each segment + foreach ap $opt_antiglob_paths { + lappend opt_excludepaths $ap + } set antiglob_paths_matched [list] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set known_whats [list no-targets newer-targets older-targets all-targets installedsourcechanged-targets synced-targets] @@ -1517,17 +1550,17 @@ namespace eval punkcheck { # external pkg? use twapi and ctime only on other platforms? } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - set opt_source_checksum [dict get $opts -source_checksum] + set opt_source_checksum [dict get $opts -source-checksum] if {[string is boolean $opt_source_checksum]} { if {$opt_source_checksum} { set opt_source_checksum "comparestore" } else { set opt_source_checksum 0 } - dict set opts -source_checksum $opt_source_checksum + dict set opts -source-checksum $opt_source_checksum } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - set opt_punkcheck_folder [dict get $opts -punkcheck_folder] + set opt_punkcheck_folder [dict get $opts -punkcheck-folder] if {$opt_punkcheck_folder eq "target"} { set punkcheck_folder $tgtdir } elseif {$opt_punkcheck_folder eq "source"} { @@ -1540,28 +1573,28 @@ namespace eval punkcheck { if {$srcproj eq $tgtproj} { set punkcheck_folder $tgtproj } else { - error "copy_files_from_source_to_target error: Unable to find common project dir for source and target folder - use absolutepath for -punkcheck_folder if source and target are not within same project" + error "copy_files_from_source_to_target error: Unable to find common project dir for source and target folder - use absolutepath for -punkcheck-folder if source and target are not within same project" } } else { set punkcheck_folder $opt_punkcheck_folder } if {$punkcheck_folder ne ""} { if {[file pathtype $punkcheck_folder] ne "absolute"} { - error "copy_files_from_source_to_target error: -punkcheck_folder '$punkcheck_folder' must be an absolute path, or one of: target|source|project" + error "copy_files_from_source_to_target error: -punkcheck-folder '$punkcheck_folder' must be an absolute path, or one of: target|source|project" } if {![file isdirectory $punkcheck_folder]} { - error "copy_files_from_source_to_target error: -punkcheck_folder '$punkcheck_folder' not found" + error "copy_files_from_source_to_target error: -punkcheck-folder '$punkcheck_folder' not found" } } else { #review - leave empty? use pwd? } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - set punkcheck_records [dict get $opts -punkcheck_records] + set punkcheck_records [dict get $opts -punkcheck-records] set punkcheck_records_init $punkcheck_records ;#change-detection # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_installer [dict get $opts -installer] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - set opt_punkcheck_eventid [dict get $opts -punkcheck_eventid] + set opt_punkcheck_eventid [dict get $opts -punkcheck-eventid] @@ -1572,7 +1605,7 @@ namespace eval punkcheck { if {$punkcheck_folder ne ""} { set config $opts dict unset config -call-depth-internal - dict unset config -max_depth + dict unset config -max-depth dict unset config -subdirlist dict unset config -progresschannel tcl::dict::for {k v} $config { @@ -1699,9 +1732,9 @@ namespace eval punkcheck { set relative_source_path [file join $relative_source_dir $m] set punkcheck_target_relpath [file join $target_relative_to_punkcheck_dir $m] set is_antipath 0 - foreach antipath $opt_antiglob_paths { - #puts "testing file - globmatchpath $antipath vs $relative_source_path" - if {[punk::path::globmatchpath $antipath $relative_source_path]} { + foreach pathglob [concat $opt_excludepaths_core $opt_excludepaths] { + #puts "testing file - globmatchpath $pathglob vs $relative_source_path" + if {[punk::path::globmatchpath $pathglob $relative_source_path]} { lappend antiglob_paths_matched $current_source_dir set is_antipath 1 break @@ -1968,10 +2001,13 @@ namespace eval punkcheck { } #puts stderr "subdirs: $subdirs" foreach d $subdirs { + set relative_source_path [file join $relative_source_dir $d] set skipd 0 - foreach dg [concat $opt_excludedirseg_core $opt_excludedirseg] { - if {[string match $dg $d]} { - #puts stdout "SKIPPING FOLDER $d due to excludedirseg-match: $dg " + foreach pathglob [concat $opt_excludepaths_core $opt_excludepaths] { + #puts "testing folder - globmatchpath $pathglob vs $relative_source_path" + if {[punk::path::globmatchpath $pathglob $relative_source_path]} { + lappend antiglob_paths_matched [file join $current_source_dir $d] + #puts stdout "SKIPPING FOLDER $relative_source_path due to exclude-path-match: $pathglob " set skipd 1 break } @@ -1980,21 +2016,6 @@ namespace eval punkcheck { continue } - set relative_source_path [file join $relative_source_dir $d] - set is_antipath 0 - foreach antipath $opt_antiglob_paths { - #puts "testing folder - globmatchpath $antipath vs $relative_source_path" - if {[punk::path::globmatchpath $antipath $relative_source_path]} { - lappend antiglob_paths_matched [file join $current_source_dir $d] - #puts stdout "SKIPPING FOLDER $relative_source_path due to antiglob_path-match: $antipath " - set is_antipath 1 - break - } - } - if {$is_antipath} { - continue - } - #if {![file exists $current_target_dir/$d]} { # file mkdir $current_target_dir/$d #} @@ -2004,24 +2025,24 @@ namespace eval punkcheck { } -call-depth-internal [expr {$CALLDEPTH + 1}] {*}{ } -subdirlist [list {*}$subdirlist $d] {*}{ } -glob $fileglob {*}{ - } -exclude-filetails_core $opt_excludefiletail_core {*}{ + } -exclude-filetails-core $opt_excludefiletail_core {*}{ } -exclude-filetails $opt_excludefiletail {*}{ - } -exclude-dirsegments_core $opt_excludedirseg_core {*}{ - } -exclude-dirsegments $opt_excludedirseg {*}{ + } -exclude-paths-core $opt_excludepaths_core {*}{ + } -exclude-paths $opt_excludepaths {*}{ } -overwrite $overwrite_what {*}{ - } -source_checksum $opt_source_checksum {*}{ - } -punkcheck_folder $punkcheck_folder {*}{ - } -punkcheck_eventid $punkcheck_eventid {*}{ - } -punkcheck_records $punkcheck_records {*}{ + } -source-checksum $opt_source_checksum {*}{ + } -punkcheck-folder $punkcheck_folder {*}{ + } -punkcheck-eventid $punkcheck_eventid {*}{ + } -punkcheck-records $punkcheck_records {*}{ } -installer $opt_installer {*}{ } ] set sub_opts [list {*}{ } -call-depth-internal [expr {$CALLDEPTH + 1}] {*}{ } -subdirlist [list {*}$subdirlist $d] {*}{ - } -punkcheck_folder $punkcheck_folder {*}{ - } -punkcheck_eventid $punkcheck_eventid {*}{ - } -punkcheck_records $punkcheck_records {*}{ + } -punkcheck-folder $punkcheck_folder {*}{ + } -punkcheck-eventid $punkcheck_eventid {*}{ + } -punkcheck-records $punkcheck_records {*}{ } -progresschannel $opt_progresschannel {*}{ } ] diff --git a/src/modules/punkcheck-buildversion.txt b/src/modules/punkcheck-buildversion.txt index c3ca4d16..2e2b7230 100644 --- a/src/modules/punkcheck-buildversion.txt +++ b/src/modules/punkcheck-buildversion.txt @@ -1,3 +1,5 @@ -0.1.1 +0.2.0 #First line must be a semantic version number -#all other lines are ignored. \ No newline at end of file +#all other lines are ignored. +#0.2.0 - merged -exclude-dirsegments + -antiglob_paths into unified -exclude-paths (backward-compat aliases retained) +#0.2.0 - renamed all underscore flags to hyphenated forms (-max-depth, -source-checksum, -punkcheck-folder, etc.) with backward-compat alias pre-processing \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.basic/src/make.tcl b/src/project_layouts/custom/_project/punk.basic/src/make.tcl index 1d74becb..334600ad 100644 --- a/src/project_layouts/custom/_project/punk.basic/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.basic/src/make.tcl @@ -282,6 +282,52 @@ namespace eval ::punkboot::lib { } +#------------------------------------------------------------------------------ +# Bootsupport staleness helpers — self-contained Tcl, no punk package deps. +# These run in the early boot phase before punk packages are guaranteed loaded +# (modeled on punk::lib::askuser but without punk::console / raw-mode deps). +#------------------------------------------------------------------------------ + +# Classify the version delta between an old (bootsupport) and new (source) +# semver as "major", "minor", or "patch". +# Caller must verify new_ver > old_ver via `package vcompare` first. +proc ::punkboot::lib::bootsupport_bump_level {old_ver new_ver} { + set op [split $old_ver .] + set np [split $new_ver .] + while {[llength $op] < 3} {lappend op 0} + while {[llength $np] < 3} {lappend np 0} + set op [lmap s $op { + set n [scan $s %d] + expr {[string is integer -strict $n] ? $n : 0} + }] + set np [lmap s $np { + set n [scan $s %d] + expr {[string is integer -strict $n] ? $n : 0} + }] + lassign $op o_major o_minor o_patch + lassign $np n_major n_minor n_patch + if {$n_major > $o_major} {return "major"} + if {$n_minor > $o_minor} {return "minor"} + return "patch" +} + +# Self-contained y/N prompt. Returns 1 for y/yes (case-insensitive), 0 otherwise. +# Used by the staleness abort path to ask the user whether to proceed past a +# minor-version bump. Default is No (Enter = abort) so accidental Enter is safe. +proc ::punkboot::lib::bootsupport_prompt_yesno {prompt} { + puts stdout $prompt + puts -nonewline stdout "Proceed anyway? (y/N) " + flush stdout + set stdin_state [chan configure stdin] + try { + chan configure stdin -blocking 1 + set answer [string tolower [string trim [gets stdin]]] + } finally { + chan configure stdin -blocking [dict get $stdin_state -blocking] + } + return [expr {$answer eq "y" || $answer eq "yes"}] +} + if {"::try" ni [info commands ::try]} { puts stderr "Tcl interpreter possibly too old - need at least tcl 8.6 - 'try' command not found - aborting" exit 1 @@ -469,6 +515,52 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} { #package forget punk::repo #package forget punkcheck + #------------------------------------------------------------------ + # Bootsupport staleness check + # When make.tcl is run from project root (not from src/), bootsupport + # modules are loaded in preference to source modules. If the source + # modules have been updated (e.g API changes) but bootsupport hasn't + # been rebuilt, make.tcl will fail with obscure errors from the stale + # bootsupport versions. This check compares buildversion.txt in source + # against the highest .tm version in bootsupport and warns the caller. + #------------------------------------------------------------------ + if {[file tail $startdir] ne "src"} { + set _runtime_deps [list {*}{ + } punkcheck punkcheck-buildversion.txt punkcheck-*.tm {*}{ + } punk::repo punk/repo-buildversion.txt punk/repo-*.tm {*}{ + } punk::mix punk/mix-buildversion.txt punk/mix-*.tm {*}{ + } punk::tdl punk/tdl-buildversion.txt punk/tdl-*.tm {*}{ + }] + set _stale_modules [list] + foreach {pkg buildversion_rel bootsupport_glob} $_runtime_deps { + set _src_bv_file [file join $::punkboot::scriptfolder modules $buildversion_rel] + set _bs_glob_dir [file dirname [file join $::punkboot::scriptfolder bootsupport modules $bootsupport_glob]] + set _bs_glob_pat [file tail $bootsupport_glob] + if {![file exists $_src_bv_file]} {continue} + #read source version (first line of buildversion.txt) + set _fd [open $_src_bv_file r] + set _src_version [string trim [lindex [split [read $_fd] \n] 0]] + close $_fd + #find highest version .tm in bootsupport + set _bs_version "" + set _prefix [string range $_bs_glob_pat 0 [string first "*" $_bs_glob_pat]-1] + foreach _tm [glob -nocomplain -dir $_bs_glob_dir -- $_bs_glob_pat] { + set _v [file rootname [string range [file tail $_tm] [string length $_prefix] end]] + if {$_bs_version eq "" || [package vcompare $_v $_bs_version] == 1} { + set _bs_version $_v + } + } + if {$_bs_version ne "" && $_src_version ne "" && [package vcompare $_src_version $_bs_version] == 1} { + set _bump [::punkboot::lib::bootsupport_bump_level $_bs_version $_src_version] + lappend _stale_modules [list $pkg $_src_version $_bs_version $_bump] + } + } + if {[llength $_stale_modules]} { + set ::punkboot::stale_bootsupport $_stale_modules + } + unset _runtime_deps _stale_modules + } + package require punk::repo ;#todo - push our requirements to a smaller punk::repo::xxx package with minimal dependencies package require punk::mix package require punkcheck @@ -1433,6 +1525,51 @@ if {[lsearch $::argv -k] >= 0} { #puts stdout "::argv $::argv" # ---------------------------------------- +# Abort / prompt if bootsupport modules are stale relative to source. +# Behaviour is version-aware based on the bump level between each stale +# module's bootsupport version and source version: +# - major bump -> abort unconditionally (breaking change, old bootsupport will not work) +# - minor bump -> prompt user; backward-compat aliases *should* keep old bootsupport functional +# - patch bump -> warn and proceed (non-breaking) +# 'check' is exempt in all cases — the warning is shown at the end of its output instead. +if {[info exists ::punkboot::stale_bootsupport] && $::punkboot::command ne "check"} { + set _stale $::punkboot::stale_bootsupport + set _have_major 0 + set _have_minor 0 + set _have_patch 0 + foreach _entry $_stale { + lassign $_entry _pkg _src_ver _bs_ver _bump + switch -- $_bump { + major {incr _have_major} + minor {incr _have_minor} + patch {incr _have_patch} + default {incr _have_patch} + } + } + puts stderr "==============================================================================" + puts stderr "WARNING: bootsupport modules are stale relative to source modules:" + foreach _entry $_stale { + lassign $_entry _pkg _src_ver _bs_ver _bump + puts stderr [format " %-15s bootsupport=%-10s source=%-10s bump=%s" $_pkg $_bs_ver $_src_ver $_bump] + } + puts stderr "" + puts stderr " Recommended fix — update bootsupport before proceeding:" + puts stderr " cd \[projectroot\]/src && tclsh make.tcl modules && tclsh make.tcl bootsupport" + puts stderr "==============================================================================" + if {$_have_major} { + puts stderr "-aborted- (major version bump in stale bootsupport — breaking change, cannot proceed)" + exit 1 + } + if {$_have_minor} { + if {![::punkboot::lib::bootsupport_prompt_yesno "Minor-version staleness — backward-compat aliases should keep old bootsupport functional."]} { + puts stderr "-aborted- by user" + exit 1 + } + puts stderr "-proceeding with stale bootsupport at user's request-" + } + # patch-only staleness: warn and proceed (warning already printed above) +} + set scriptfolder $::punkboot::scriptfolder @@ -1582,6 +1719,19 @@ if {$::punkboot::command eq "check"} { puts stdout $sep catch {package require struct::set} puts stdout ---[package ifneeded struct::set 2.2.3] + # Show bootsupport staleness warning at the end of check output + if {[info exists ::punkboot::stale_bootsupport]} { + puts stderr "==============================================================================" + puts stderr "WARNING: bootsupport modules are stale relative to source modules:" + foreach _entry $::punkboot::stale_bootsupport { + lassign $_entry _pkg _src_ver _bs_ver _bump + puts stderr [format " %-15s bootsupport=%-10s source=%-10s bump=%s" $_pkg $_bs_ver $_src_ver $_bump] + } + puts stderr "" + puts stderr " Run the following to update bootsupport before proceeding:" + puts stderr " cd \[projectroot\]/src && tclsh make.tcl modules && tclsh make.tcl bootsupport" + puts stderr "==============================================================================" + } exit 0 } @@ -2025,7 +2175,7 @@ if {$::punkboot::command eq "bootsupport"} { set resultdict [punkcheck::install $sourcemodules $targetroot\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -installer "punkboot-bootsupport"\ -progresschannel stdout\ ] @@ -2042,7 +2192,7 @@ if {$::punkboot::command eq "bootsupport"} { puts stdout "BOOTSUPPORT layouts/$layoutname: copying from $source_bootscript to $targetroot_bootscript (if source file changed)" set resultdict [punkcheck::install [file dirname $source_bootscript] $targetroot_bootscript\ -glob make.tcl\ - -max_depth 1\ + -max-depth 1\ -createempty 0\ -overwrite installedsourcechanged-targets\ -installer "punkboot-bootsupport"\ @@ -2098,11 +2248,11 @@ if {$::punkboot::command in {project packages modules}} { -overwrite installedsourcechanged-targets -progresschannel stdout -exclude-filetails {AGENTS.md include_modules.config} - -antiglob_paths {README.md} +-exclude-paths {README.md} }] - # -antiglob_paths {README.md AGENTS.md **/AGENTS.md include_modules.config} + # -exclude-paths {README.md AGENTS.md **/AGENTS.md include_modules.config} #-exclude-filetails {AGENTS.md include_modules.config} - #-antiglob_paths {README.md} + #-exclude-paths {README.md} puts stdout [punkcheck::summarize_install_resultdict $resultdict] } if {![llength $vendormodulefolders]} { @@ -2112,7 +2262,7 @@ if {$::punkboot::command in {project packages modules}} { if {$::punkboot::command in {project packages libs}} { #exclude README.md from source folder - but only the root one - #-antiglob_paths takes relative patterns e.g + #-exclude-paths takes relative patterns e.g # */test.txt will only match test.txt exactly one level deep. # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. # **/test.txt will match at any level below the root (but not in the root) @@ -2130,7 +2280,7 @@ if {$::punkboot::command in {project packages libs}} { puts stdout "VENDORLIB: copying tcl-version neutral and platform neutral libraries from $source_lib_folder to $target_lib_folder (if source file changed)" set resultdict [punkcheck::install $source_lib_folder $target_lib_folder\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -2150,7 +2300,7 @@ if {$::punkboot::command in {project packages libs}} { puts stdout "VENDORLIB_$which: copying from $source_lib_folder to $target_lib_folder (if source file changed)" set resultdict [punkcheck::install $source_lib_folder $target_lib_folder\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -2165,7 +2315,7 @@ if {$::punkboot::command in {project packages libs}} { puts stdout "VENDORLIB_$which: copying from $source_lib_folder to $target_lib_folder (if source file changed)" set resultdict [punkcheck::install $source_lib_folder $target_lib_folder\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -2183,7 +2333,7 @@ if {$::punkboot::command in {project packages libs}} { ######################################################## lappend projectlibfolders lib #exclude README.md from source folder - but only the root one - #-antiglob_paths takes relative patterns e.g + #-exclude-paths takes relative patterns e.g # */test.txt will only match test.txt exactly one level deep. # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. # **/test.txt will match at any level below the root (but not in the root) @@ -2200,7 +2350,7 @@ if {$::punkboot::command in {project packages libs}} { puts stdout "PROJECTLIB: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -2219,7 +2369,7 @@ if {$::punkboot::command in {project packages libs}} { puts stdout "PROJECTLIB_$which: copying from $source_lib_folder to $target_lib_folder (if source file changed)" set resultdict [punkcheck::install $source_lib_folder $target_lib_folder\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -2235,7 +2385,7 @@ if {$::punkboot::command in {project packages libs}} { puts stdout "PROJECTLIB_$which: copying from $source_lib_folder to $target_lib_folder (if source file changed)" set resultdict [punkcheck::install $source_lib_folder $target_lib_folder\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -2358,7 +2508,7 @@ if {$::punkboot::command in {project packages modules}} { set resultdict [punkcheck::install_non_tm_files $src_module_dir $target_modules_base\ -installer make.tcl\ -overwrite $overwrite\ - -antiglob_paths {README.md **/AGENTS.md AGENTS.md}\ + -exclude-paths {README.md **/AGENTS.md AGENTS.md}\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm index 778709bb..0d105eaf 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -1325,6 +1325,13 @@ tcl::namespace::eval punk::ansi { grepstr -r m -C 2 {cancelid} [s ::after] ;#with 2 lines of context and no break indicators. }]} + To match a literal string that contains regex special characters, it is in some cases easier to use the Tcl regex + quoting switch (?q) to quote the string rather than escaping each special character with a backslash. + ${[punk::args::helpers::example -syntax none { + #The following example matches a literal string that is the Tcl expansion operator {*} + grepstr "(?q){*}" $sometext + }]} + } @leaders -min 0 -max 0 diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm index e29dd871..f952ed09 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm @@ -474,7 +474,7 @@ namespace eval punk::mix::cli { set defaults [list {*}{ -installer punk::mix::cli::build_modules_from_source_to_base -call-depth-internal 0 - -max_depth 1000 + -max-depth 1000 -subdirlist {} -punkcheck_eventobj "\uFFFF" -glob *.tm @@ -487,7 +487,7 @@ namespace eval punk::mix::cli { set installername [dict get $opts -installer] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set CALLDEPTH [dict get $opts -call-depth-internal] - set max_depth [dict get $opts -max_depth] + set max_depth [dict get $opts -max-depth] set subdirlist [dict get $opts -subdirlist] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set fileglob [dict get $opts -glob] @@ -533,7 +533,7 @@ namespace eval punk::mix::cli { set config [dict create {*}{ -glob $fileglob - -max_depth 0 + -max-depth 0 }] #lassign [punkcheck::start_installer_event $punkcheck_file $installername $srcdir $basedir $config] _eventid punkcheck_eventid _recordset record_list # -- --- @@ -628,11 +628,11 @@ namespace eval punk::mix::cli { # -- --- set config [dict create {*}{ -glob * - -max_depth 100 + -max-depth 100 }] set had_error 0 - # -max_depth -1 for no limit + # -max-depth -1 for no limit set build_installername pods_in_$current_source_dir set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck] #set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck stderr] ;#with debugchannel @@ -829,11 +829,11 @@ namespace eval punk::mix::cli { # -- --- set config [dict create {*}{ -glob * - -max_depth 100 + -max-depth 100 }] set had_error 0 - # -max_depth -1 for no limit + # -max-depth -1 for no limit set build_installername tarjars_in_$current_source_dir set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck] $build_installer set_source_target $current_source_dir/$modpath $buildfolder diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.4.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.4.0.tm new file mode 100644 index 00000000..c3ba6efb --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.4.0.tm @@ -0,0 +1,1427 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'deck 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.4.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz +package require punk::repo +package require punk::ansi +package require punkcheck ;#checksum and/or timestamp records + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#review +#deck - rename to dev +namespace eval punk::mix::cli { + namespace eval temp_import { + } + namespace ensemble create + variable initialised 0 + + #lazy _init - called by punk::mix::base::_cli when ensemble used + proc _init {args} { + variable initialised + if {$initialised} { + return + } + puts stderr "punk::mix::cli::init $args" + package require punk::overlay + namespace eval ::punk::mix::cli { + 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 + } + } + set initialised 1 + } + + 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 + } + } + + #for externally launched tclsh or punkshell running src/make.tcl the cwd + #needs to be such that make.tcl can find required bootsupport libraries without relying on auto_path or tcl::tm::list mechanisms. + #we can change directory during the run, and change back again afterwards. + + #also - if no make.tcl - can we use the running shell's make.tcl ? (after prompting user?) + + if {([file tail $sourcefolder] ne "src") || (![file exists $sourcefolder/make.tcl])} { + puts stderr "dev make must be run from src folder containing make.tcl or from within a project containing src/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 { + #review - intended usecase? + 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 + } + } + } + + #if {![catch {run --timeout=150000 -debug [info nameofexecutable] $sourcefolder/make.tcl {*}$args} exitinfo]} { + # #todo - notify if exit because of timeout! + # puts stderr "exitinfo: $exitinfo" + # set exitcode [dict get $exitinfo exitcode] + #} else { + # puts stderr "Error unable to determine exitcode. err: $exitinfo" + # #cd $startdir + # return false + #} + + #use run so that stdout visible as it goes + #review - is setting a timeout here useful? It will just be annoying if the project really does need the time. + #review - on timeout what happens? (implemented in shellfilter) + # - if just stderr/stdout redirection channels closed - what happens with stdin? + # e.g 'for dev make shell' - we just get no further responses but stdin still consuming keystrokes? + try { + #cd $sourcefolder ;#dev paths can overide bootsupport modules + cd $project_base ;#bootsupport modules only + set exitinfo [run --timeout=150000 -debug [info nameofexecutable] $sourcefolder/make.tcl {*}$args] + } trap {} {emsg eopts} { + puts stderr "Error, unable to determine exitcode. err: $emsg" + return false + } finally { + cd $startdir + } + puts stderr "exitinfo: $exitinfo" + set exitcode [dict get $exitinfo exitcode] + + 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] + return [list plain tarjar zip] + } + + proc validate_modulename {modulename args} { + set opts [list {*}{ + -errorprefix validate_modulename + -strict 0 + }] + if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"} + foreach {k v} $args { + switch -- $k { + -errorprefix - -strict { + dict set opts $k $v + } + default { + error "validate_modulename error: unknown option '$k'. known options: [dict keys $opts]" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_errorprefix [dict get $opts -errorprefix] + set opt_strict [dict get $opts -strict] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + if {$opt_strict} { + if {[regexp {[A-Z]} $modulename]} { + error "$opt_errorprefix '$modulename' contains uppercase which is not recommended as per tip 590, and option -strict is set to 1" + } + } + + validate_name_not_empty_or_spaced $modulename -errorprefix $opt_errorprefix + set testname [string map {:: {}} $modulename] + if {[string first : $testname] >=0} { + error "$opt_errorprefix '$modulename' can only contain paired colons" + } + set badchars [list - "$" "?" "*"] + foreach bc $badchars { + if {[string first $bc $modulename] >= 0} { + error "$opt_errorprefix '$modulename' can not contain character '$bc'" + } + } + return $modulename + } + proc confirm_modulename {modulename} { + set finalised 0 + set aborted 0 + while {!$finalised && !$aborted} { + #first validate with -strict 0 to confirm acceptable while ignoring case issues. + #uppercase is generally valid but not recommended - so has separate prompting. + if {[catch {validate_modulename $modulename -strict 0} errM]} { + set msg "Chosen name didn't pass validation\n" + append msg "reason: $errM\n" + append msg "Please retype the modulename. You will be given a further prompt to confirm or abort." + set modulename [util::askuser $msg] + } elseif {[regexp {[A-Z]} $modulename]} { + set msg "module names containing uppercase are not recommended (see tip 590).\n" + append msg "Please retype the module name '$modulename' to proceed.\n" + append msg "If you type it exactly as it was you will be allowed to proceed with uppercase anyway\n" + append msg "Retype it all in lowercase to use recommended naming" + set answer [util::askuser $msg] + if {[regexp {[A-Z]} $answer]} { + if {$answer eq $modulename} { + #ok - user insists + set finalised 1 + } else { + #user supplied a different uppercase name - don't set finalised so we bug them again to type it two times the same way to proceed + puts stdout "A different uppercase name was supplied - reconfirmation required." + } + set modulename $answer + } else { + #user has resupplied modulename all as lowercase + if {$answer eq [string tolower $modulename]} { + set finalised 1 + } else { + #.. but it doesn't match original - require rerun + } + set modulename $answer + } + } else { + set answer [util::askuser "Proceed with the module name '$modulename'? Y to continue N to abort"] + if {[string tolower $answer] eq "y"} { + set finalised 1 + } else { + set aborted 1 + } + } + } + if {$aborted} { + return [dict create status error reason errmsg] + } else { + return [dict create status ok modulename $modulename] + } + } + + proc validate_projectname {projectname args} { + set defaults [list {*}{ + -errorprefix projectname + }] + if {[llength $args] %2 != 0} {error "validate_projectname 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_projectname error: unknown option $k. known options: $known_opts" + } + } + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_errorprefix [dict get $opts -errorprefix] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + validate_name_not_empty_or_spaced $projectname -errorprefix $opt_errorprefix + set reserved_words [list etc lib bin modules src doc vendorlib vendormodules embedded runtime _aside _build] + if {$projectname in $reserved_words } { + error "$opt_errorprefix '$projectname' cannot be one of reserved_words: $reserved_words" + } + if {[string first "::" $projectname] >= 0} { + error "$opt_errorprefix '$projectname' cannot contain namespace separator '::'" + } + return $projectname + } + proc validate_name_not_empty_or_spaced {name args} { + set opts [list {*}{ + -errorprefix projectname + }] + if {[llength $args] %2 != 0} {error "validate_name_not_empty_or_spaced args must be name-value pairs: received '$args'"} + foreach {k v} $args { + switch -- $k { + -errorprefix { + dict set opts $k $v + } + default { + error "validate_name_not_empty_or_spaced error: unknown option $k. known options: [dict keys $opts]" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_errorprefix [dict get $opts -errorprefix] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + if {![string length $name]} { + error "$opt_errorprefix cannot be empty" + } + if {[string length [string map [list " " "" \n "" \r "" \t ""] $name]] != [string length $name]} { + error "$opt_errorprefix cannot contain whitespace" + } + return $name + } + + + 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 [punk::ansi::a+ bold yellow][dict get $repopaths warnings][punk::ansi::a] + } else { + append result [punk::ansi::a+ bold yellow][dict get $repopaths warnings][punk::ansi::a] + 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 -- [>punk . logo] " " $result] + append result \n + } + } + + set timeline [exec fossil timeline -n 5 -t ci] + set timeline [string map {\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 "\nGIT 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 "#*" "_build" "_aside" ".git" ".fossil*"] ;#exact or glob patterns for folders (at any level) we don't want to search in or copy. + 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 + -podglob #modpod-* + -tarjarglob #tarjar-* + }] + 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] + set podglob [dict get $opts -podglob] + set tarjarglob [dict get $opts -tarjarglob] + 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::tm_version_magic] ;#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] + #set installer [punkcheck::installtrack new $installername $punkcheck_file stderr] ;#with debugchannel + $installer set_source_target $srcdir $basedir + set event [$installer start_event $config] + # -- --- + + } else { + set event $opt_punkcheck_eventobj + } + #---------------------------------------- + + + set process_modules [dict create] + #put pods first in processing order + set src_pods [glob -nocomplain -dir $current_source_dir -type d -tail -- $podglob] + foreach podpath $src_pods { + dict set process_modules $podpath [dict create -type pod] + } + set src_tarjars [glob -nocomplain -dir $current_source_dir -type d -tail -- $tarjarglob] + foreach tarjarpath $src_tarjars { + dict set process_modules $tarjarpath [dict create -type tarjar] + } + set src_modules [glob -nocomplain -dir $current_source_dir -type f -tail -- $fileglob] + foreach modulepath $src_modules { + dict set process_modules $modulepath [dict create -type file] + } + + set did_skip 0 ;#flag for stdout/stderr formatting only + dict for {modpath modinfo} $process_modules { + set modtype [dict get $modinfo -type] + + set is_interesting 0 + if {[string match "foobar" $current_source_dir]} { + set is_interesting 1 + } + + #debug for issues on non-windows platforms. + #if {$::tcl_platform(platform) ne "windows"} { + # set is_interesting 1 + #} + + if {$is_interesting} { + puts "build_modules_from_source_to_base >>> module $current_source_dir/$modpath" + } + set fileparts [split [file rootname $modpath] -] + #set tmfile_versionsegment [lindex $fileparts end] + lassign [split_modulename_version $modpath] basename tmfile_versionsegment + if {$tmfile_versionsegment eq ""} { + #split_modulename_version version part will be empty if not valid tcl version + #last segment doesn't look even slightly versiony - fail. + puts stderr "ERROR: Unable to confirm file $current_source_dir/$modpath is a reasonably versioned .tm module - ABORTING." + flush stderr + after 1000 + exit 1 + } + switch -- $modtype { + pod { + puts -nonewline stderr "p-" + #basename still contains leading #modpod- + if {[string match #modpod-* $basename]} { + set basename [string range $basename 8 end] + } else { + error "build_modules_from_source_to_base, pod, unexpected basename $basename" ;#shouldn't be possible with default podglob - review - why is podglob configurable? + } + set versionfile $current_source_dir/$basename-buildversion.txt ;#needs to be added in targetset_addsource to trigger rebuild if changed (only when magicversion in use) + if {$tmfile_versionsegment eq $magicversion} { + 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 + } + } else { + set module_build_version $tmfile_versionsegment + } + + set buildfolder $current_source_dir/_build + file mkdir $buildfolder + # -- --- + set config [dict create {*}{ + -glob * + -max-depth 100 + }] + set had_error 0 + + # -max-depth -1 for no limit + set build_installername pods_in_$current_source_dir + set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck] + #set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck stderr] ;#with debugchannel + $build_installer set_source_target $current_source_dir/$modpath $buildfolder + set build_event [$build_installer start_event $config] + # -- --- + set podtree_copy $buildfolder/#modpod-$basename-$module_build_version + set modulefile $buildfolder/$basename-$module_build_version.tm + + #todo - use modpod version as a source for change detection + #package require modpod + + $build_event targetset_init INSTALL $podtree_copy + $build_event targetset_addsource $current_source_dir/$modpath + if {$tmfile_versionsegment eq $magicversion} { + $build_event targetset_addsource $versionfile + } + if {\ + [llength [dict get [$build_event targetset_source_changes] changed]]\ + || [llength [$build_event get_targets_exist]] < [llength [$build_event get_targets]]\ + } { + $build_event targetset_started + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + + set delete_failed 0 + if {[file exists $buildfolder/]} { + puts stderr "deleting existing _build copy at $podtree_copy" + if {[catch { + file delete -force $podtree_copy + } errMsg]} { + puts stderr "[punk::ansi::a+ red]deletion of _build copy at $podtree_copy failed: $errMsg[punk::ansi::a]" + set delete_failed 1 + } + } + if {!$delete_failed} { + puts stdout "copying.." + puts stdout "$current_source_dir/$modpath" + puts stdout "to:" + puts stdout "$podtree_copy" + flush stdout + file copy $current_source_dir/$modpath $podtree_copy + if {$tmfile_versionsegment eq $magicversion} { + set tmfile $buildfolder/#modpod-$basename-$module_build_version/$basename-$magicversion.tm + if {[file exists $tmfile]} { + set newname $buildfolder/#modpod-$basename-$module_build_version/$basename-$module_build_version.tm + file rename $tmfile $newname + set tmfile $newname + } + set fd [open $tmfile r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd + set data [string map [list $magicversion $module_build_version] $data] + set fdout [open $tmfile w] + fconfigure $fdout -translation binary + puts -nonewline $fdout $data + close $fdout + } + #delete and regenerate zip and modpod stubbed zip + set notes [list] + if {[catch { + file delete $buildfolder/$basename-$module_build_version.zip + } err] } { + set had_error 1 + lappend notes "zip_delete_failed" + } + if {[catch { + file delete $buildfolder/$basename-$module_build_version.tm + } err]} { + set had_error 1 + lappend notes "tm_delete_failed" + } + #create ordinary zip file without using external executable + package require punk::zip + set zipfile $buildfolder/$basename-$module_build_version.zip ;#ordinary zip file (deflate) + + #zipfs mkzip does exactly what we need anyway in this case + #unfortunately it's not available in all Tclsh versions we might be running.. + if {[llength [info commands zipfs]]} { + #zipfs mkzip (2025) doesn't add entries for folders. + #(Therefore no timestamps) + #zip reading utils generally intuit their existence and display them - but often an editor can't add comments to them + set wd [pwd] + cd $buildfolder + puts "zipfs mkzip $zipfile #modpod-$basename-$module_build_version" + zipfs mkzip $zipfile #modpod-$basename-$module_build_version + cd $wd + + } else { + #use -base $buildfolder so that -directory is included in the archive - the modpod stub relies on this - and extraction would be potentially messy otherwise + #put in an archive-level comment to aid in debugging + #punk + punk::zip::mkzip -base $buildfolder -directory $buildfolder/#modpod-$basename-$module_build_version -- $zipfile * + #punk::zip::mkzip stores permissions - (unix style) - which zipfs mkzip doesn't + #Directory ident in zipfs relies on folders ending with trailing slash - if missing, it misidentifies dirs as files. + #(ie it can't use permissions/attributes alone to determine directory vs file) + #TODO - review punk::zip::mkzip and/or external zip to provide a fallback? + #JMN25 + + #set had_error 1 + #lappend notes "zipfs_unavailable" + #puts stderr "WARNING: zipfs unavailable can't build $modulefile" + } + if {!$had_error && [file exists $zipfile]} { + package require modpod + modpod::lib::make_zip_modpod $zipfile $modulefile + } + + + if {$had_error} { + $build_event targetset_end FAILED -note [join $notes ,] + } else { + # -- ---------- + $build_event targetset_end OK + # -- ---------- + } + } else { + $build_event targetset_end FAILED -note "could not delete $podtree_copy" + } + + } else { + puts -nonewline stderr "Z" + set did_skip 1 + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $build_event targetset_end SKIPPED + } + $build_event destroy + $build_installer destroy + + #JMN - review + if {!$had_error} { + $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm + $event targetset_addsource $modulefile + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ + } { + + $event targetset_started + # -- --- --- --- --- --- + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + lappend module_list $modulefile + if {[catch { + file copy -force $modulefile $target_module_dir + } errMsg]} { + puts stderr "[punk::ansi::a+ red]FAILED to copy zip modpod module $modulefile to $target_module_dir[punk::ansi::a]" + $event targetset_end FAILED -note "could not copy $modulefile" + } else { + puts stderr "[punk::ansi::a+ green]Copied zip modpod module $modulefile to $target_module_dir[punk::ansi::a]" + # -- --- --- --- --- --- + $event targetset_end OK -note "zip modpod" + } + } else { + puts -nonewline stderr "z" + set did_skip 1 + if {$is_interesting} { + puts stderr "$modulefile [$event targetset_source_changes]" + } + $event targetset_end SKIPPED + } + } + } + tarjar { + puts -nonewline stderr "t-" + #maint - overall code structure same as pod - refactor? + #basename may still contain #tarjar- + #to be obsoleted - update modpod to (optionally) use vfs::tar ? + if {[string match #tarjar-* $basename]} { + set basename [string range $basename 8 end] + } else { + error "build_modules_from_source_to_base, tarjar, unexpected basename $basename" ;#shouldn't be possible with default tarjarglob - review - why is tarjarglob configurable? + } + set versionfile $current_source_dir/$basename-buildversion.txt ;#needs to be added in targetset_addsource to trigger rebuild if changed (only when magicversion in use) + if {$tmfile_versionsegment eq $magicversion} { + set versionfiledata "" + if {![file exists $versionfile]} { + puts stderr "\n[punk::ansi::a+ brightyellow]WARNING: Missing buildversion text file: $versionfile[punk::ansi::a]" + 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:[punk::ansi::a+ red] build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file[punk::ansi::a]" + exit 3 + } + set module_build_version $ln0 + } + } else { + set module_build_version $tmfile_versionsegment + } + + set buildfolder $current_source_dir/_build + file mkdir $buildfolder + # -- --- + set config [dict create {*}{ + -glob * + -max-depth 100 + }] + set had_error 0 + + # -max-depth -1 for no limit + set build_installername tarjars_in_$current_source_dir + set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck] + $build_installer set_source_target $current_source_dir/$modpath $buildfolder + set build_event [$build_installer start_event $config] + # -- --- + set podtree_copy $buildfolder/#tarjar-$basename-$module_build_version + set modulefile $buildfolder/$basename-$module_build_version.tm + + + $build_event targetset_init INSTALL $podtree_copy + $build_event targetset_addsource $current_source_dir/$modpath + if {$tmfile_versionsegment eq $magicversion} { + $build_event targetset_addsource $versionfile + } + if {\ + [llength [dict get [$build_event targetset_source_changes] changed]]\ + || [llength [$build_event get_targets_exist]] < [llength [$build_event get_targets]]\ + } { + $build_event targetset_started + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + + set delete_failed 0 + if {[file exists $buildfolder/]} { + puts stderr "deleting existing _build copy at $podtree_copy" + if {[catch { + file delete -force $podtree_copy + } errMsg]} { + puts stderr "[punk::ansi::a+ red]deletion of _build copy at $podtree_copy failed: $errMsg[punk::ansi::a]" + set delete_failed 1 + } + } + if {!$delete_failed} { + puts stdout "copying.." + puts stdout "$current_source_dir/$modpath" + puts stdout "to:" + puts stdout "$podtree_copy" + file copy $current_source_dir/$modpath $podtree_copy + if {$tmfile_versionsegment eq $magicversion} { + set tmfile $buildfolder/#tarjar-$basename-$module_build_version/#tarjar-loadscript-$basename.tcl + #we don't need to modify version or name of the loadscript + if {![file exists $tmfile]} { + set had_error 1 + lappend notes "tarjar_loadscript_missing" + } else { + #the loadscript must end in a line starting with # and ending with backslash - with no linefeed + set fd [open $tmfile r] + chan configure $fd -translation binary + #last line must be less than 1k long + chan seek $fd -1024 end + set script_tail [read $fd] + set lastlf [string last \n $script_tail] + set lastline [string range $script_tail $lastlf+1 end] + set lastline [string trimleft $lastline] ;#lhs whitespace is ok + if {[string index $lastline 0] ne "#" || [string index $lastline end] ne "\\" } { + set had_error 1 + lappend notes "tarjar_loadscript_badtail" + } + } + } + #delete and regenerate .tm + set notes [list] + if {[catch { + file delete $buildfolder/$basename-$module_build_version.tm + } err]} { + set had_error 1 + lappend notes "tm_delete_failed" + } + #create ordinary tar file without using external executable + package require tar ;#tcllib + set tarfile $buildfolder/$basename-$module_build_version.tm ;#ordinary tar file (no compression - store) + set wd [pwd] + cd $buildfolder + puts "tar::create $tarfile #tarjar-$basename-$module_build_version" + if {[catch { + tar::create $tarfile #tarjar-$basename-$module_build_version + } errMsg]} { + set had_error 1 + puts stderr "tar::create $tarfile failed with msg\n $errMsg" + lappend notes "tar_create_failed" + } + cd $wd + + if {![file exists $tarfile]} { + set had_error 1 + lappend notes "tar_result_missing" + } + + + if {$had_error} { + $build_event targetset_end FAILED -note [join $notes ,] + } else { + # -- ---------- + $build_event targetset_end OK + # -- ---------- + } + } else { + $build_event targetset_end FAILED -note "could not delete $podtree_copy" + } + + } else { + puts -nonewline stderr "T" + set did_skip 1 + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $build_event targetset_end SKIPPED + } + $build_event destroy + $build_installer destroy + + #JMN - review + if {!$had_error} { + $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm + $event targetset_addsource $modulefile + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ + } { + + $event targetset_started + # -- --- --- --- --- --- + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + lappend module_list $modulefile + if {[catch { + file copy -force $modulefile $target_module_dir + } errMsg]} { + puts stderr "[punk::ansi::a+ red]FAILED to copy tarjar module $modulefile to $target_module_dir[punk::ansi::a]" + $event targetset_end FAILED -note "could not copy $modulefile" + } else { + puts stderr "[punk::ansi::a+ green]Copied tarjar module $modulefile to $target_module_dir[punk::ansi::a]" + # -- --- --- --- --- --- + $event targetset_end OK -note "tarjar" + } + } else { + puts -nonewline stderr "t" + set did_skip 1 + if {$is_interesting} { + puts stderr "$modulefile [$event targetset_source_changes]" + } + $event targetset_end SKIPPED + } + } + + } + file { + puts -nonewline stderr "f-" + set m $modpath + if {$tmfile_versionsegment eq $magicversion} { + #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]} { + #rebuilding the .tm from the #tarjar already handled above + puts -nonewline stderr "-" + + #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? + + ##TODO + #set buildfolder $current_sourcedir/_build + #file mkdir $buildfolder + + #set tmfile $buildfolder/$basename-$module_build_version.tm + #file delete -force $buildfolder/#tarjar-$basename-$module_build_version + #file delete -force $tmfile + + + #file copy -force $current_source_dir/#tarjar-$basename-$magicversion $buildfolder/#tarjar-$basename-$module_build_version + ## + ##bsdtar doesn't seem to work.. or I haven't worked out the right options? + ##exec tar -cvf $buildfolder/$basename-$module_build_version.tm $buildfolder/#tarjar-$basename-$module_build_version + #package require tar + #tar::create $tmfile $buildfolder/#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 { + if {$is_interesting} { + puts stdout "skipping module $current_source_dir/$m - no change in sources detected" + } + puts -nonewline stderr "m" + set did_skip 1 + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $event targetset_end SKIPPED + } + + #------------------------------ + + } + + continue + } + ##------------------------------ + ## + #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} + lappend module_list $current_source_dir/$m + file copy -force $current_source_dir/$m $target_module_dir + puts stderr "Copied already versioned module $current_source_dir/$m to $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 "f" + set did_skip 1 + if {$is_interesting} { + puts stderr "$current_source_dir/$m [$event targetset_source_changes]" + } + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $event targetset_end SKIPPED + } + } + } + } ;#end dict for {modpath modinfo} $process_modules + + + if {$CALLDEPTH >= $max_depth} { + set subdirs [list] + } else { + set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] + set targets_existing [glob -nocomplain -dir $target_module_dir -type d -tail {*}$subdirs] + } + #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 + #} + if {$d ni $targets_existing} { + 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\ + -podglob $podglob\ + ] + } + 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 + dict for {p b} $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] + dict for {r -} $::kettle::recipe::recipe { + if {$r ni $standard_recipes} { + dict unset ::kettle::recipe::recipe $r + } + } + } + proc kettle_call {calltype args} { + variable kettle_reset_bodies + switch -- $calltype { + lib {} + shell { + #on windows - could be kettle.bat or kettle.cmd - use auto_execok to find, whatever the platform. + #for now, restrict to version sitting next to exe - REVIEW + set exedir [file dirname [info nameofexecutable]] + set kettlescript [auto_execok $exedir/kettle] + if {$kettlescript eq ""} { + error "kettle_call unable to find installed kettle application file in '$exedir'" + } + + #set kettleappfile [file dirname [info nameofexecutable]]/kettle + #set kettlebatfile [file dirname [info nameofexecutable]]/kettle.bat + + #if {(![file exists $kettleappfile]) && (![file exists $kettlebatfile])} { + # error "deck 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 + # } + #} + } + default { + error "deck kettle_call 1st argument must be one of: 'lib' for direct use of kettle module or 'shell' to call as separate process" + } + } + set startdir [pwd] + if {![file exists $startdir/build.tcl]} { + error "deck 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 "deck 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 (deck)] + } + 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 + #load standard recipes as listed in build.tcl + ::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 + } + + } + proc kettle_punk_recipes {} { + set txtdst ... + } + + } +} + + +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 + if {[catch { + punk::overlay::custom_from_base [namespace current] ::punk::mix::base + } errM]} { + puts stderr "punk::mix::cli load error: Failed to overlay punk::mix::base $errM" + error "punk::mix::cli error: $errM" + } +} + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::cli [namespace eval punk::mix::cli { + variable version + set version 0.4.0 +}] +return diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.1.tm new file mode 100644 index 00000000..379adbae --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.1.tm @@ -0,0 +1,324 @@ +# -*- 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.1 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + +package require punk::path ;# for treefilenames, relative +package require punk::repo +package require punk::docgen ;#inline doctools - generate doctools .man files at src/docgen prior to using kettle to producing .html .md etc +package require punk::mix::cli ;#punk::mix::cli::lib used for kettle_call +#package require punkcheck ;#for path_relative + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +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" + puts "commands: doc.status" + } + + 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 + } + #user may delete the comment containing "--- punk::docgen::overwrites" and then manually edit, and we won't overwrite + #we still generate output in src/docgen so user can diff and manually update if thats what they prefer + set oldfiles [punk::path::treefilenames -dir $projectdir/src/doc _module_*.man] + foreach maybedoomed $oldfiles { + set fd [open $maybedoomed r] + chan conf $fd -translation binary + set data [read $fd] + close $fd + if {[string match "*--- punk::docgen overwrites *" $data]} { + file delete -force $maybedoomed + } + } + set generated [lib::do_docgen modules] + if {[dict get $generated count] > 0} { + #review + set doclist [dict get $generated docs] + set source_base [dict get $generated base] + set target_base $projectdir/src/doc + foreach dinfo $doclist { + lassign $dinfo module fpath + set relpath [punk::path::relative $source_base $fpath] + set relfolder [file dirname $relpath] + if {$relfolder eq "."} { + set relfolder "" + } + file mkdir [file join $target_base $relfolder] + set target [file join $target_base $relfolder _module_[file tail $fpath]] + puts stderr "target --> $target" + if {![file exists $target]} { + file copy $fpath $target + } + } + } + + 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 { + if {"::meta" eq [info commands ::meta]} { + puts stderr "There appears to be a leftover ::meta command which is presumed to be from doctools. Destroying object" + ::meta destroy + } + 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 {args} { + set argd [punk::args::parse $args withdef { + @id -id ::punk::mix::commandset::doc::validate + -- -type none -optional 1 -help "end of options marker --" + -individual -type boolean -default 1 + @values -min 0 -max -1 + patterns -default {*.man} -type any -multiple 1 + }] + set opt_individual [tcl::dict::get $argd opts -individual] + set patterns [tcl::dict::get $argd values patterns] + + + #todo - run and validate punk::docgen output + 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] + set docroot $projectdir/src/doc + cd $docroot + + if {!$opt_individual && "*.man" in $patterns} { + if {[catch { + dtplite validate $docroot + } errM]} { + puts stderr "commandset::doc::validate failed for projectdir '$projectdir'" + puts stderr "docroot '$docroot'" + puts stderr "dtplite error was: $errM" + } + } else { + foreach p $patterns { + set treefiles [punk::path::treefilenames $p] + foreach path $treefiles { + puts stdout "dtplite validate $path" + dtplite validate $path + } + } + } + + #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 + proc do_docgen {{project_subpath modules}} { + #Extract doctools comments from source code + set projectdir [punk::repo::find_project] + set output_base [file join $projectdir src docgen] + set codesource_path [file join $projectdir $project_subpath] + if {![file isdirectory $codesource_path]} { + puts stderr "WARNING punk::mix::commandset::doc unable to find codesource_path $codesource_path during do_docgen - skipping inline doctools generation" + return + } + if {[file isdirectory $output_base]} { + if {[catch { + file delete -force $output_base + }]} { + error "do_docgen failed to delete existing output base folder: $output_base" + } + } + file mkdir $output_base + + set matched_paths [punk::path::treefilenames -dir $codesource_path -exclude-paths {**/mix/templates/** **/project_layouts/** **/decktemplates/** **/_aside **/_aside/**} *.tm] + set count 0 + set newdocs [list] + set docgen_header_comments "" + append docgen_header_comments {[comment {--- punk::docgen generated from inline doctools comments ---}]} \n + append docgen_header_comments {[comment {--- punk::docgen DO NOT EDIT DOCS HERE UNLESS YOU REMOVE THESE COMMENT LINES ---}]} \n + append docgen_header_comments {[comment {--- punk::docgen overwrites this file ---}]} \n + foreach fullpath $matched_paths { + puts stdout "do_docgen processing: $fullpath" + set doctools [punk::docgen::get_doctools_comments $fullpath] + if {$doctools ne ""} { + set fname [file tail $fullpath] + set mod_tail [file rootname $fname] + set relpath [punk::path::relative $codesource_path [file dirname $fullpath]] + if {$relpath eq "."} { + set relpath "" + } + set tailsegs [file split $relpath] + set module_fullname [join $tailsegs ::]::$mod_tail + set target_docname $fname.man + set this_outdir [file join $output_base $relpath] + + if {[string length $fname] > 99} { + #output needs to be tarballed to do checksum change tests in a reasonably straightforward and not-too-terribly slow way. + #hack - review. Determine exact limit - test if tcllib tar fixed or if it's a limit of the particular tar format + #work around tcllib tar filename length limit ( somewhere around 100?) This seems to be a limit on the length of a particular segment in the path.. not whole path length? + #this case only came up because docgen used to path munge to long filenames - but left because we know there is a limit and renaming fixes it - even if it's ugly - but still allows doc generation. + #review - if we're checking fname - should also test length of whole path and determine limits for tar + package require md5 + if {[package vsatisfies [package present md5] 2- ] } { + set md5opt "-hex" + } else { + set md5opt "" + } + set target_docname [md5::md5 {*}$md5opt [encoding convertto utf-8 $fullpath]]_overlongfilename.man + puts stderr "WARNING - overlong file name - renaming $fullpath" + puts stderr " to [file dirname $fullpath]/$target_docname" + } + + file mkdir $this_outdir + puts stdout "saving [string length $doctools] bytes of doctools output from file $relpath/$fname" + set outfile [file join $this_outdir $target_docname] + set fd [open $outfile w] + fconfigure $fd -translation binary + puts -nonewline $fd $docgen_header_comments$doctools + close $fd + incr count + lappend newdocs [list $module_fullname $outfile] + } + } + return [list count $count docs $newdocs base $output_base] + } + + } +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## 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.1 +}] +return \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.1.tm new file mode 100644 index 00000000..cb395eaa --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.1.tm @@ -0,0 +1,1178 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'deck 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.1 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::mix::commandset::project 0 0.1.1] +#[copyright "2023"] +#[titledesc {dec commandset - project}] [comment {-- Name section and table of contents description --}] +#[moddesc {deck CLI commandset - project}] [comment {-- Description at end of page heading --}] +#[require punk::mix::commandset::project] +#[description] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::mix::commandset::project +#[para]Import into an ensemble namespace similarly to the way it is done with punk::mix::cli e.g +#[example { +# namespace eval myproject::cli { +# namespace export * +# namespace ensemble create +# package require punk::overlay +# +# 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 +# } +#}] +#[para] Where the . in the above example is the prefix/command separator +#[para]The prefix ('project' in the above example) can be any string desired to disambiguate commands imported from other commandsets. +#[para]The above results in the availability of the ensemble command: ::myproject::cli project.new, which is implemented in ::punk::mix::commandset::project::new +#[para]Similarly, procs under ::punk::mix::commandset::project::collection will be available as subcommands of the ensemble as projects. +#[para] +#[subsection Concepts] +#[para] see punk::overlay + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::mix::commandset::project +#[list_begin itemized] + +package require Tcl 8.6- +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package punk::ns] +#[item] [package sqlite3] (binary) +#[item] [package overtype] +#[item] [package textutil] (tcllib) + + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::mix::commandset::project { + namespace export * + #*** !doctools + #[subsection {Namespace punk::mix::commandset::project}] + #[para] core commandset functions for punk::mix::commandset::project + #[list_begin definitions] + + proc _default {} { + package require punk::ns + set dispatched_to [lindex [info level 2] 0] ;#e.g ::punk::mix::cli::project + set dispatch_tail [punk::ns::nstail $dispatched_to] + set dispatch_ensemble [punk::ns::nsprefix $dispatched_to] ;#e.g ::punk::mix::cli + set sibling_commands [namespace eval $dispatch_ensemble {namespace export}] + #todo - get separator? + set sep "." + set result [list] + foreach sib $sibling_commands { + if {[string match ${dispatch_tail}${sep}* $sib]} { + lappend result $sib + } + } + return [lsort $result] + } + + + namespace eval argdoc { + set layout_dict [punk::cap::call_handler punk.templates get_itemdict_projectlayouts] + variable LAYOUTNAMES [dict keys $layout_dict] + } + punk::args::define { + @id -id ::punk::mix::commandset::project::new + @cmd -name "punk::mix::commandset::project::new" -help\ + "" + @leaders -min 1 -max 1 + project -type string -help\ + "Project name or path. + If just a name is given ... (todo)" + @opts + -type -default plain + -empty -default 0 -type boolean + -force -default 0 -type boolean + -update -default 0 -type boolean + -confirm -default 1 -type boolean + -layout -default "punk.project" -choices {${$::punk::mix::commandset::project::argdoc::LAYOUTNAMES}} + } + + proc new {newprojectpath_or_name args} { + #*** !doctools + # [call [fun new] [arg newprojectpath_or_name] [opt args]] + #new project structure - may be dedicated to one module, or contain many. + #create minimal folder structure only by specifying in args: -modules {} + 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 -errorprefix "punk mix project.new" + + + set defaults [list\ + -type plain\ + -empty 0\ + -force 0\ + -update 0\ + -confirm 1\ + -modules \uFFFF\ + -layout punk.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 "deck 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_layout [dict get $opts -layout] + set opt_update [dict get $opts -update] + # -- --- --- --- --- --- --- --- --- --- --- --- --- + 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 + if {$opt_force || $opt_update} { + #generally undesirable to add default project module during an update. + #user can use dev module.new manually or supply module name in -modules + set opt_modules [list] + } else { + set opt_modules [list [string tolower $projectname]] ;#default modules to lowercase as is the modern (tip 590) recommendation for Tcl + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- + + + #todo - install support binaries on a per-project basis in a way that doesn't impact machine (e.g not added to path) - cache in user config dir if possible, supply mechanism to clear cache + # + 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 deck features." + if {[string length [set scoop_prog [auto_execok scoop]]]} { + #restrict to windows? + set answer [util::askuser "scoop detected. Would you like deck 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 "-------------------------------------------" + } + + + package require punk::cap + if {[punk::cap::capability_has_handler punk.templates]} { + set layout_dict [punk::cap::call_handler punk.templates get_itemdict_projectlayouts] + } else { + put stderr "commandset::project::new WARNING - no handler available for the 'punk.templates' capability - template providers will be unable to provide layout locations" + return + } + if {[dict exists $layout_dict $opt_layout]} { + set layout_name $opt_layout + set layout_info [dict get $layout_dict $layout_name] + set layout_path [dict get $layout_info path] + set layout_sourceinfo [dict get $layout_info sourceinfo] + } else { + puts stderr "commandset::project::new - no exact match for specified layout-name $opt_layout found" + puts stderr "layout names found: [dict keys $layout_dict]" + return + + #todo - pick highest version layout that matches opt_layout if version not specified but multiple exist + + #set layout_name ... + #set layout_info .. + #set layout_path ... + } + + + + #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 $layout_path 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} { + set warnmsg "mix new WARNING: -update 1 was supplied. Will copy layout $layout_path using -update option to add missing items" + if {$opt_confirm} { + puts stderr $warnmsg + set msg "Do you want to proceed to possibly overwrite some existing files in $projectdir? Y|N" + set answer [util::askuser $msg] + 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 prompt." + return + } + } + puts stderr $warnmsg + } + + 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 + } + #review + set fossil_repo_file $repodb_folder/$projectname.fossil + } + + 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 + + puts stdout ">>> about to call punkcheck::install $layout_path $projectdir" + set resultdict [dict create] + set antipaths [list {*}{ + src/doc/* + src/doc/include/* + src/PROJECT_LAYOUTS_* + }] + + #set exclude_paths [list {*}{ + # _ignore_* + # **/_ignore_* + #}] + set exclude_paths [list {*}{ + }] + + #default -exclude-paths-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_path $projectdir -installer project.new -createempty 1 -overwrite ALL-TARGETS -exclude-paths [concat $antipaths $exclude_paths]] + } else { + puts stdout "copying layout files - (if source file changed)" + set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite installedsourcechanged-targets -exclude-paths [concat $antipaths $exclude_paths]] + } + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + + if {[file exists $layout_path/src/doc]} { + puts stdout "copying layout src/doc files (if target missing)" + set resultdict [punkcheck::install $layout_path/src/doc $projectdir/src/doc -createdir 1 -punkcheck-folder $projectdir -installer project.new -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no src/doc in source template - update not required" + } + + #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 exclude-paths_core - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized. + ## default_excludepaths_core [list "#*" "**/#*" "_aside" "**/_aside" "_build" "**/_build" ".git" "**/.git" ".fossil*" "**/.fossil*"] + set override_excludepaths_core [list #* **/#* _aside **/_aside .git **/.git] + if {[file exists $layout_path/.fossil-custom]} { + puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)" + set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -createempty 1 -punkcheck-folder $projectdir -installer project.new -exclude-paths-core $override_excludepaths_core -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no .fossil-custom in source template - update not required" + } + + if {[file exists $layout_path/.fossil-settings]} { + puts stdout "copying layout src/.fossil-settings files (if target missing or uncustomised)" + set resultdict [punkcheck::install $layout_path/.fossil-settings $projectdir/.fossil-settings -createdir 1 -createempty 1 -punkcheck-folder $projectdir -installer project.new -exclude-paths-core $override_excludepaths_core -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no .fossil-settings in source template - update not required" + } + + #scan all files in template + # + #TODO - deck command to substitute templates? + set templateinfo_list [punk::mix::commandset::layout::lib::layout_scan_for_template_files $opt_layout] + set stripprefix [file normalize $layout_path] + + set tagmap [list [lib::template_tag project] $projectname] + if {[llength $templateinfo_list]} { + puts stdout "Filling template file placeholders with the following tag map:" + foreach {placeholder value} $tagmap { + puts stdout " $placeholder -> $value" + } + } + foreach templateinfo $templateinfo_list { + lassign $templateinfo templatefullpath template_tagnames_found + set templatetail [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] + set fpath [file join $projectdir $templatetail] + foreach t $template_tagnames_found { + if {"%$t%" ni [dict keys $tagmap]} { + puts stderr "warning: No substitution available for tag: %$t% in $fpath" + } + } + + if {[file exists $fpath]} { + set fd [open $fpath r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd + set data2 [string map $tagmap $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" + } + } + + ::cd $projectdir + + if {[file exists $projectdir/src/modules]} { + foreach m $opt_modules { + #check if mod-ver.tm file or #modpod-mod-ver folder exist + set tmfile $projectdir/src/modules/$m-[punk::mix::util::tm_version_magic].tm + set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::tm_version_magic]/$m-[punk::mix::util::tm_version_magic].tm + + set has_tm [file exists $tmfile] + set has_pod [file exists $podfile] + #puts stderr "=====> has_tm: $has_tm has_pod: $has_pod" + if {!$has_tm && !$has_pod} { + #todo - option for -module_template - and check existence at top? or change opt_modules to be a list of dicts with configuration info -template -type etc + punk::mix::commandset::module::new -project $projectname -type $opt_type $m + } else { + #we should rarely if ever want to force any src/modules to be overwritten + if {$opt_force} { + if {$has_pod} { + set answer [util::askuser "OVERWRITE the src/modules file $podfile ?? (generally not desirable) Y|N"] + set overwrite_type zip + } else { + set answer [util::askuser "OVERWRITE the src/modules file $tmfile ?? (generally not desirable) Y|N"] + set overwrite_type $opt_type + } + if {[string tolower $answer] eq "y"} { + #REVIEW - all pods zip - for now + punk::mix::commandset::module::new -project $projectname -type $overwrite_type -force 1 $m + } + } + } + } + } 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" + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::mix::commandset::project ---}] + + namespace eval collection { + #*** !doctools + #[subsection {Namespace punk::mix::commandset::project::collection}] + #[para] commandset functions for operating with multiple projects. + #[para] It would usually be imported with the prefix "projects" and separator "." to result in commands such as: projects.detail + #[list_begin definitions] + namespace export * + namespace path [namespace parent] + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::_default + @cmd -name "punk::mix::commandset::project::collection::_default"\ + -summary\ + "List projects under fossil managment."\ + -help\ + "List projects under fossil management, showing fossil db location and number of checkouts" + @values -min 0 -max -1 + glob -type string -multiple 1 -default * + } + #e.g imported as 'projects' + proc _default {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::_default] + set globlist [dict get $argd values glob] + + #*** !doctools + #[call [fun _default] [arg glob...]] + #[para]List projects under fossil management, showing fossil db location and number of checkouts + #[para]The glob argument is optional unless option/value pairs are also supplied, in which case * should be explicitly supplied + #[para]glob restricts output based on the name of the fossil db file e.g s* for all projects beginning with s + #[para]The _default function is made available in the ensemble by the name of the prefix used when importing the commandset. + #[para]e.g + #[para] punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection + #[para]Will result in the command being available as projects + package require overtype + set db_projects [lib::get_projects {*}$globlist] + 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 Repo 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] {string length $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] + set file_idx 0 + foreach dbfile $col1_dbfiles { + set project_name "" + set project_code "" + set project_desc "" + set db_error "" + if {[file exists $dbfile]} { + if {[catch { + 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) + } + } + } errM]} { + set db_error $errM + } + catch {dbp close} + } else { + set db_error "fossil file $dbfile missing" + } + lappend col4_pnames $project_name + lappend col5_pcodes $project_code + dict lappend codes $project_code $dbfile + lappend col7_pdescs $project_desc + if {$db_error ne ""} { + lset col1_dbfiles $file_idx "[a+ web-red]$dbfile[a]" + } + incr file_idx + } + + 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 Repo 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] {string length $v}]] + set col3 [string repeat " " $widest3] + set title4 "Project Name" + set widest4 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col4_pnames] {string length $v}]] + set col4 [string repeat " " $widest4] + set title5 "Project Code" + set widest5 [tcl::mathfunc::max {*}[lmap v [concat [list $title5] $col5_pcodes] {string length $v}]] + set col5 [string repeat " " $widest5] + set title6 "Dup" + set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col6_dupids] {string length $v}]] + set col6 [string repeat " " $widest6] + set title7 "Description" + #set widest7 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col7_pdescs] {string length $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]] + } + + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::work + @cmd -name punk::mix::commandset::project::collection::work\ + -summary\ + "List projects with checkout directories."\ + -help\ + "Get project info by opening the central fossil config-db to determine + fossil database files for each project, and the known checkout folders. + If -detail is true, a second operation gathers file state information + for each checkout folder." + @leaders -min 0 -max 0 + -cd -type none -help\ + "If this flag is provided, after lsting, prompt the user to enter + the row number of the checkout to 'cd' into, or an option to cancel. + If there is only one project with only a single checkout, the + cd operation will occur without prompting unless -prompt was + also supplied." + -prompt -type none -help\ + "If there is only one checkout in the result, cause a prompt to be + raised instead of automatically peforming the cd operation. + Has no effect if -cd was not supplied, or if -cd is supplied and + there are multiple checkouts, in which case user is always prompted." + -detail -type boolean -default 0 -help\ + "Include file state information for each checkout in the resulting + table. This includes information such as which files are changed, + unchanged,new,missing or extra and can take a little more time to + gather as it must examine the filesystem for each checkout folder. + + Note that although the default is false - if only a single project + matches the glob pattern(s) then file state will be gathered for + each of its checkouts. Use an explicit -detail 0 if this is not + desired." + @values -min 0 -max -1 + glob -type string -multiple 1 -default * -optional 1 -help\ + "glob patterns used to search for project. The glob is applied against + the names of the fossil repository database files - not the project-name, + which is not available in the central fossil config-db. + Case insensitive." + } + proc work {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] + lassign [dict values $argd] leaders opts values received + package require sqlite3 + set globlist [dict get $values glob] + + set db_projects [lib::get_projects {*}$globlist] + #list of lists of the form: + #{fosdb fname workdirlist} + if {[llength $db_projects] == 0} { + puts stderr "::punk::mix::commandset::project::work No Repo DB name matches found for '$globlist'" + return "" + } + # -- --- --- --- --- --- --- + set opt_cd [dict exists $received -cd] + # -- --- --- --- --- --- --- + set opt_detail [dict get $opts -detail] + if {[dict exists $received -detail] && !$opt_detail} { + set opt_detail_explicit_zero 1 + } else { + set opt_detail_explicit_zero 0 + } + set opt_prompt [dict exists $received -prompt] + # -- --- --- --- --- --- --- + 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 and opt_detail is 0 and not explicit - retrieve workingdir state for each co + if {([llength [dict keys $fosdb_cache]] == 1)} { + if {!$opt_detail_explicit_zero} { + set opt_detail 1 + } + puts stderr "Result is from a single repo db [dict keys $fosdb_cache]" + } + if {$opt_detail} { + if {!$opt_detail_explicit_zero} { + set detailmsg "Use -detail 0 to omit file state" + } else { + set detailmsg "" + } + puts stderr "Gathering file state for [llength $workdirs] checkout folder(s). $detailmsg" + set c_rev [list] + set c_rev_iso [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_rev_iso [dict get $state_dict revision_iso8601] + 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 t0b "Revision iso8601" + set w0b [tcl::mathfunc::max {*}[lmap v [concat [list $t0] $c_rev_iso] {string length $v}]] + set c0b [string repeat " " $w0b] + 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::left $c0b $t0b] [overtype::right $c1 $t1] [overtype::right $c2 $t2] [overtype::right $c3 $t3] [overtype::right $c4 $t4] [overtype::right $c5 $t5]" + foreach r $c_rev iso $c_rev_iso u $c_unchanged c $c_changed n $c_new m $c_missing e $c_extra { + lappend col_states "[overtype::left $c0 $r] [overtype::left $c0b $iso] [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 "Repo 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 { + if {![file exists $wd]} { + set row [punk::ansi::a+ strike red]$row[a] + set wd [punk::ansi::a+ red]$wd[a] + } + 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 { + if {![file exists $wd]} { + set row [punk::ansi::a+ strike red]$row[a] + set wd [punk::ansi::a+ red]$wd[a] + } + 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 && !$opt_prompt} { + 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 [deck stat] + return $workingdir + } + } + } + return $msg + } + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::cd + @cmd -name punk::mix::commandset::project::collection::cd\ + -summary\ + "List projects with checkout directories and prompt for which checkout to cd to."\ + -help\ + "List projects with checkout directories and prompt for which checkout to cd to." + @leaders -min 0 -max 0 + }\ + [punk::args::resolved_def -types opts ::punk::mix::commandset::project::collection::work -detail]\ + { + -prompt -type none -help\ + "Prompt even when result contains only one checkout location as a possible cd target. + User will always be prompted if result contains more than one checkout." + @values -min 0 -max -1 + }\ + [punk::args::resolved_def -types values ::punk::mix::commandset::project::collection::work glob] + + proc cd {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] + work -cd {*}$args + } + + #*** !doctools + #[list_end] [comment {-- end collection namespace definitions --}] + } + + namespace eval lib { + proc template_tag {tagname} { + #todo - support different tagwrappers - it shouldn't be so likely to collide with common code idioms etc. + #we need to detect presence of tags intended for punk::mix system + #consider using punk::cap to enable multiple template-substitution providers with their own set of tagnames and/or tag wrappers, where substitution providers are all run + return [string cat % $tagname %] + } + punk::args::define { + @id -id ::punk::mix::commandset::project::lib::get_projects + @cmd -name punk::mix::commandset::project::lib::get_projects\ + -summary\ + "Return a 3-element list of projects referred to by central fossil config-db."\ + -help\ + "Get project info only by opening the central fossil config-db. + Each member of the returned list is a 3-element list of: + + The shortname is simply the name based on the root name of the fossil database, + it is not necessarily the project-name by which the project is referred to in the fossil + checkout databases." + @values -min 0 -max -1 + glob -type string -multiple 1 -default * -optional 1 -help\ + "case insensitive glob for the name of the fossil database." + } + proc get_projects {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::lib::get_projects] + set globlist [dict get $argd values glob] + + set fossil_prog [auto_execok fossil] + + set configdb [punk::repo::fossil_get_configdb] + + package require sqlite3 + ::sqlite3 fosconf $configdb + #set testresult [fosconf eval {select name,value from global_config;}] + #puts stderr $testresult + #list of repositories of the form repo: + #eg repo:C:/Users/someone/.fossils/tcl.fossil + + #the command: + # fossil all ignore /repo.fossil + #will remove the {repo:/repo.fossil 1} record from global_config + #but it leaves {ckout: /repo.fossil} records, even if such checkouts are closed + #when the folder itself at is removed - then commands such as 'fossil all ls -c' automatically remove the corresponding ckout: record. + + 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;}] + #list of entries like "ckout:C:/buildtcl/2024zig/tcl90/" + 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 -nocase -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 + } + + } + + + +} + + +#*** !doctools +#[manpage_end] + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::commandset::project [namespace eval punk::mix::commandset::project { + variable version + set version 0.1.1 +}] +return diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.2.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.2.0.tm new file mode 100644 index 00000000..c48c95b9 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.2.0.tm @@ -0,0 +1,1178 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'deck 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.2.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::mix::commandset::project 0 0.2.0] +#[copyright "2023"] +#[titledesc {dec commandset - project}] [comment {-- Name section and table of contents description --}] +#[moddesc {deck CLI commandset - project}] [comment {-- Description at end of page heading --}] +#[require punk::mix::commandset::project] +#[description] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::mix::commandset::project +#[para]Import into an ensemble namespace similarly to the way it is done with punk::mix::cli e.g +#[example { +# namespace eval myproject::cli { +# namespace export * +# namespace ensemble create +# package require punk::overlay +# +# 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 +# } +#}] +#[para] Where the . in the above example is the prefix/command separator +#[para]The prefix ('project' in the above example) can be any string desired to disambiguate commands imported from other commandsets. +#[para]The above results in the availability of the ensemble command: ::myproject::cli project.new, which is implemented in ::punk::mix::commandset::project::new +#[para]Similarly, procs under ::punk::mix::commandset::project::collection will be available as subcommands of the ensemble as projects. +#[para] +#[subsection Concepts] +#[para] see punk::overlay + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::mix::commandset::project +#[list_begin itemized] + +package require Tcl 8.6- +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package punk::ns] +#[item] [package sqlite3] (binary) +#[item] [package overtype] +#[item] [package textutil] (tcllib) + + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::mix::commandset::project { + namespace export * + #*** !doctools + #[subsection {Namespace punk::mix::commandset::project}] + #[para] core commandset functions for punk::mix::commandset::project + #[list_begin definitions] + + proc _default {} { + package require punk::ns + set dispatched_to [lindex [info level 2] 0] ;#e.g ::punk::mix::cli::project + set dispatch_tail [punk::ns::nstail $dispatched_to] + set dispatch_ensemble [punk::ns::nsprefix $dispatched_to] ;#e.g ::punk::mix::cli + set sibling_commands [namespace eval $dispatch_ensemble {namespace export}] + #todo - get separator? + set sep "." + set result [list] + foreach sib $sibling_commands { + if {[string match ${dispatch_tail}${sep}* $sib]} { + lappend result $sib + } + } + return [lsort $result] + } + + + namespace eval argdoc { + set layout_dict [punk::cap::call_handler punk.templates get_itemdict_projectlayouts] + variable LAYOUTNAMES [dict keys $layout_dict] + } + punk::args::define { + @id -id ::punk::mix::commandset::project::new + @cmd -name "punk::mix::commandset::project::new" -help\ + "" + @leaders -min 1 -max 1 + project -type string -help\ + "Project name or path. + If just a name is given ... (todo)" + @opts + -type -default plain + -empty -default 0 -type boolean + -force -default 0 -type boolean + -update -default 0 -type boolean + -confirm -default 1 -type boolean + -layout -default "punk.project" -choices {${$::punk::mix::commandset::project::argdoc::LAYOUTNAMES}} + } + + proc new {newprojectpath_or_name args} { + #*** !doctools + # [call [fun new] [arg newprojectpath_or_name] [opt args]] + #new project structure - may be dedicated to one module, or contain many. + #create minimal folder structure only by specifying in args: -modules {} + 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 -errorprefix "punk mix project.new" + + + set defaults [list\ + -type plain\ + -empty 0\ + -force 0\ + -update 0\ + -confirm 1\ + -modules \uFFFF\ + -layout punk.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 "deck 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_layout [dict get $opts -layout] + set opt_update [dict get $opts -update] + # -- --- --- --- --- --- --- --- --- --- --- --- --- + 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 + if {$opt_force || $opt_update} { + #generally undesirable to add default project module during an update. + #user can use dev module.new manually or supply module name in -modules + set opt_modules [list] + } else { + set opt_modules [list [string tolower $projectname]] ;#default modules to lowercase as is the modern (tip 590) recommendation for Tcl + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- + + + #todo - install support binaries on a per-project basis in a way that doesn't impact machine (e.g not added to path) - cache in user config dir if possible, supply mechanism to clear cache + # + 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 deck features." + if {[string length [set scoop_prog [auto_execok scoop]]]} { + #restrict to windows? + set answer [util::askuser "scoop detected. Would you like deck 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 "-------------------------------------------" + } + + + package require punk::cap + if {[punk::cap::capability_has_handler punk.templates]} { + set layout_dict [punk::cap::call_handler punk.templates get_itemdict_projectlayouts] + } else { + put stderr "commandset::project::new WARNING - no handler available for the 'punk.templates' capability - template providers will be unable to provide layout locations" + return + } + if {[dict exists $layout_dict $opt_layout]} { + set layout_name $opt_layout + set layout_info [dict get $layout_dict $layout_name] + set layout_path [dict get $layout_info path] + set layout_sourceinfo [dict get $layout_info sourceinfo] + } else { + puts stderr "commandset::project::new - no exact match for specified layout-name $opt_layout found" + puts stderr "layout names found: [dict keys $layout_dict]" + return + + #todo - pick highest version layout that matches opt_layout if version not specified but multiple exist + + #set layout_name ... + #set layout_info .. + #set layout_path ... + } + + + + #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 $layout_path 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} { + set warnmsg "mix new WARNING: -update 1 was supplied. Will copy layout $layout_path using -update option to add missing items" + if {$opt_confirm} { + puts stderr $warnmsg + set msg "Do you want to proceed to possibly overwrite some existing files in $projectdir? Y|N" + set answer [util::askuser $msg] + 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 prompt." + return + } + } + puts stderr $warnmsg + } + + 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 + } + #review + set fossil_repo_file $repodb_folder/$projectname.fossil + } + + 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 + + puts stdout ">>> about to call punkcheck::install $layout_path $projectdir" + set resultdict [dict create] + set antipaths [list {*}{ + src/doc/* + src/doc/include/* + src/PROJECT_LAYOUTS_* + }] + + #set exclude_paths [list {*}{ + # _ignore_* + # **/_ignore_* + #}] + set exclude_paths [list {*}{ + }] + + #default -exclude-paths-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_path $projectdir -installer project.new -createempty 1 -overwrite ALL-TARGETS -exclude-paths [concat $antipaths $exclude_paths]] + } else { + puts stdout "copying layout files - (if source file changed)" + set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite installedsourcechanged-targets -exclude-paths [concat $antipaths $exclude_paths]] + } + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + + if {[file exists $layout_path/src/doc]} { + puts stdout "copying layout src/doc files (if target missing)" + set resultdict [punkcheck::install $layout_path/src/doc $projectdir/src/doc -createdir 1 -punkcheck-folder $projectdir -installer project.new -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no src/doc in source template - update not required" + } + + #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 exclude-paths_core - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized. + ## default_excludepaths_core [list "#*" "**/#*" "_aside" "**/_aside" "_build" "**/_build" ".git" "**/.git" ".fossil*" "**/.fossil*"] + set override_excludepaths_core [list #* **/#* _aside **/_aside .git **/.git] + if {[file exists $layout_path/.fossil-custom]} { + puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)" + set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -createempty 1 -punkcheck-folder $projectdir -installer project.new -exclude-paths-core $override_excludepaths_core -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no .fossil-custom in source template - update not required" + } + + if {[file exists $layout_path/.fossil-settings]} { + puts stdout "copying layout src/.fossil-settings files (if target missing or uncustomised)" + set resultdict [punkcheck::install $layout_path/.fossil-settings $projectdir/.fossil-settings -createdir 1 -createempty 1 -punkcheck-folder $projectdir -installer project.new -exclude-paths-core $override_excludepaths_core -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no .fossil-settings in source template - update not required" + } + + #scan all files in template + # + #TODO - deck command to substitute templates? + set templateinfo_list [punk::mix::commandset::layout::lib::layout_scan_for_template_files $opt_layout] + set stripprefix [file normalize $layout_path] + + set tagmap [list [lib::template_tag project] $projectname] + if {[llength $templateinfo_list]} { + puts stdout "Filling template file placeholders with the following tag map:" + foreach {placeholder value} $tagmap { + puts stdout " $placeholder -> $value" + } + } + foreach templateinfo $templateinfo_list { + lassign $templateinfo templatefullpath template_tagnames_found + set templatetail [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] + set fpath [file join $projectdir $templatetail] + foreach t $template_tagnames_found { + if {"%$t%" ni [dict keys $tagmap]} { + puts stderr "warning: No substitution available for tag: %$t% in $fpath" + } + } + + if {[file exists $fpath]} { + set fd [open $fpath r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd + set data2 [string map $tagmap $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" + } + } + + ::cd $projectdir + + if {[file exists $projectdir/src/modules]} { + foreach m $opt_modules { + #check if mod-ver.tm file or #modpod-mod-ver folder exist + set tmfile $projectdir/src/modules/$m-[punk::mix::util::tm_version_magic].tm + set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::tm_version_magic]/$m-[punk::mix::util::tm_version_magic].tm + + set has_tm [file exists $tmfile] + set has_pod [file exists $podfile] + #puts stderr "=====> has_tm: $has_tm has_pod: $has_pod" + if {!$has_tm && !$has_pod} { + #todo - option for -module_template - and check existence at top? or change opt_modules to be a list of dicts with configuration info -template -type etc + punk::mix::commandset::module::new -project $projectname -type $opt_type $m + } else { + #we should rarely if ever want to force any src/modules to be overwritten + if {$opt_force} { + if {$has_pod} { + set answer [util::askuser "OVERWRITE the src/modules file $podfile ?? (generally not desirable) Y|N"] + set overwrite_type zip + } else { + set answer [util::askuser "OVERWRITE the src/modules file $tmfile ?? (generally not desirable) Y|N"] + set overwrite_type $opt_type + } + if {[string tolower $answer] eq "y"} { + #REVIEW - all pods zip - for now + punk::mix::commandset::module::new -project $projectname -type $overwrite_type -force 1 $m + } + } + } + } + } 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" + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::mix::commandset::project ---}] + + namespace eval collection { + #*** !doctools + #[subsection {Namespace punk::mix::commandset::project::collection}] + #[para] commandset functions for operating with multiple projects. + #[para] It would usually be imported with the prefix "projects" and separator "." to result in commands such as: projects.detail + #[list_begin definitions] + namespace export * + namespace path [namespace parent] + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::_default + @cmd -name "punk::mix::commandset::project::collection::_default"\ + -summary\ + "List projects under fossil managment."\ + -help\ + "List projects under fossil management, showing fossil db location and number of checkouts" + @values -min 0 -max -1 + glob -type string -multiple 1 -default * + } + #e.g imported as 'projects' + proc _default {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::_default] + set globlist [dict get $argd values glob] + + #*** !doctools + #[call [fun _default] [arg glob...]] + #[para]List projects under fossil management, showing fossil db location and number of checkouts + #[para]The glob argument is optional unless option/value pairs are also supplied, in which case * should be explicitly supplied + #[para]glob restricts output based on the name of the fossil db file e.g s* for all projects beginning with s + #[para]The _default function is made available in the ensemble by the name of the prefix used when importing the commandset. + #[para]e.g + #[para] punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection + #[para]Will result in the command being available as projects + package require overtype + set db_projects [lib::get_projects {*}$globlist] + 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 Repo 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] {string length $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] + set file_idx 0 + foreach dbfile $col1_dbfiles { + set project_name "" + set project_code "" + set project_desc "" + set db_error "" + if {[file exists $dbfile]} { + if {[catch { + 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) + } + } + } errM]} { + set db_error $errM + } + catch {dbp close} + } else { + set db_error "fossil file $dbfile missing" + } + lappend col4_pnames $project_name + lappend col5_pcodes $project_code + dict lappend codes $project_code $dbfile + lappend col7_pdescs $project_desc + if {$db_error ne ""} { + lset col1_dbfiles $file_idx "[a+ web-red]$dbfile[a]" + } + incr file_idx + } + + 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 Repo 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] {string length $v}]] + set col3 [string repeat " " $widest3] + set title4 "Project Name" + set widest4 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col4_pnames] {string length $v}]] + set col4 [string repeat " " $widest4] + set title5 "Project Code" + set widest5 [tcl::mathfunc::max {*}[lmap v [concat [list $title5] $col5_pcodes] {string length $v}]] + set col5 [string repeat " " $widest5] + set title6 "Dup" + set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col6_dupids] {string length $v}]] + set col6 [string repeat " " $widest6] + set title7 "Description" + #set widest7 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col7_pdescs] {string length $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]] + } + + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::work + @cmd -name punk::mix::commandset::project::collection::work\ + -summary\ + "List projects with checkout directories."\ + -help\ + "Get project info by opening the central fossil config-db to determine + fossil database files for each project, and the known checkout folders. + If -detail is true, a second operation gathers file state information + for each checkout folder." + @leaders -min 0 -max 0 + -cd -type none -help\ + "If this flag is provided, after lsting, prompt the user to enter + the row number of the checkout to 'cd' into, or an option to cancel. + If there is only one project with only a single checkout, the + cd operation will occur without prompting unless -prompt was + also supplied." + -prompt -type none -help\ + "If there is only one checkout in the result, cause a prompt to be + raised instead of automatically peforming the cd operation. + Has no effect if -cd was not supplied, or if -cd is supplied and + there are multiple checkouts, in which case user is always prompted." + -detail -type boolean -default 0 -help\ + "Include file state information for each checkout in the resulting + table. This includes information such as which files are changed, + unchanged,new,missing or extra and can take a little more time to + gather as it must examine the filesystem for each checkout folder. + + Note that although the default is false - if only a single project + matches the glob pattern(s) then file state will be gathered for + each of its checkouts. Use an explicit -detail 0 if this is not + desired." + @values -min 0 -max -1 + glob -type string -multiple 1 -default * -optional 1 -help\ + "glob patterns used to search for project. The glob is applied against + the names of the fossil repository database files - not the project-name, + which is not available in the central fossil config-db. + Case insensitive." + } + proc work {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] + lassign [dict values $argd] leaders opts values received + package require sqlite3 + set globlist [dict get $values glob] + + set db_projects [lib::get_projects {*}$globlist] + #list of lists of the form: + #{fosdb fname workdirlist} + if {[llength $db_projects] == 0} { + puts stderr "::punk::mix::commandset::project::work No Repo DB name matches found for '$globlist'" + return "" + } + # -- --- --- --- --- --- --- + set opt_cd [dict exists $received -cd] + # -- --- --- --- --- --- --- + set opt_detail [dict get $opts -detail] + if {[dict exists $received -detail] && !$opt_detail} { + set opt_detail_explicit_zero 1 + } else { + set opt_detail_explicit_zero 0 + } + set opt_prompt [dict exists $received -prompt] + # -- --- --- --- --- --- --- + 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 and opt_detail is 0 and not explicit - retrieve workingdir state for each co + if {([llength [dict keys $fosdb_cache]] == 1)} { + if {!$opt_detail_explicit_zero} { + set opt_detail 1 + } + puts stderr "Result is from a single repo db [dict keys $fosdb_cache]" + } + if {$opt_detail} { + if {!$opt_detail_explicit_zero} { + set detailmsg "Use -detail 0 to omit file state" + } else { + set detailmsg "" + } + puts stderr "Gathering file state for [llength $workdirs] checkout folder(s). $detailmsg" + set c_rev [list] + set c_rev_iso [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_rev_iso [dict get $state_dict revision_iso8601] + 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 t0b "Revision iso8601" + set w0b [tcl::mathfunc::max {*}[lmap v [concat [list $t0] $c_rev_iso] {string length $v}]] + set c0b [string repeat " " $w0b] + 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::left $c0b $t0b] [overtype::right $c1 $t1] [overtype::right $c2 $t2] [overtype::right $c3 $t3] [overtype::right $c4 $t4] [overtype::right $c5 $t5]" + foreach r $c_rev iso $c_rev_iso u $c_unchanged c $c_changed n $c_new m $c_missing e $c_extra { + lappend col_states "[overtype::left $c0 $r] [overtype::left $c0b $iso] [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 "Repo 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 { + if {![file exists $wd]} { + set row [punk::ansi::a+ strike red]$row[a] + set wd [punk::ansi::a+ red]$wd[a] + } + 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 { + if {![file exists $wd]} { + set row [punk::ansi::a+ strike red]$row[a] + set wd [punk::ansi::a+ red]$wd[a] + } + 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 && !$opt_prompt} { + 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 [deck stat] + return $workingdir + } + } + } + return $msg + } + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::cd + @cmd -name punk::mix::commandset::project::collection::cd\ + -summary\ + "List projects with checkout directories and prompt for which checkout to cd to."\ + -help\ + "List projects with checkout directories and prompt for which checkout to cd to." + @leaders -min 0 -max 0 + }\ + [punk::args::resolved_def -types opts ::punk::mix::commandset::project::collection::work -detail]\ + { + -prompt -type none -help\ + "Prompt even when result contains only one checkout location as a possible cd target. + User will always be prompted if result contains more than one checkout." + @values -min 0 -max -1 + }\ + [punk::args::resolved_def -types values ::punk::mix::commandset::project::collection::work glob] + + proc cd {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] + work -cd {*}$args + } + + #*** !doctools + #[list_end] [comment {-- end collection namespace definitions --}] + } + + namespace eval lib { + proc template_tag {tagname} { + #todo - support different tagwrappers - it shouldn't be so likely to collide with common code idioms etc. + #we need to detect presence of tags intended for punk::mix system + #consider using punk::cap to enable multiple template-substitution providers with their own set of tagnames and/or tag wrappers, where substitution providers are all run + return [string cat % $tagname %] + } + punk::args::define { + @id -id ::punk::mix::commandset::project::lib::get_projects + @cmd -name punk::mix::commandset::project::lib::get_projects\ + -summary\ + "Return a 3-element list of projects referred to by central fossil config-db."\ + -help\ + "Get project info only by opening the central fossil config-db. + Each member of the returned list is a 3-element list of: + + The shortname is simply the name based on the root name of the fossil database, + it is not necessarily the project-name by which the project is referred to in the fossil + checkout databases." + @values -min 0 -max -1 + glob -type string -multiple 1 -default * -optional 1 -help\ + "case insensitive glob for the name of the fossil database." + } + proc get_projects {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::lib::get_projects] + set globlist [dict get $argd values glob] + + set fossil_prog [auto_execok fossil] + + set configdb [punk::repo::fossil_get_configdb] + + package require sqlite3 + ::sqlite3 fosconf $configdb + #set testresult [fosconf eval {select name,value from global_config;}] + #puts stderr $testresult + #list of repositories of the form repo: + #eg repo:C:/Users/someone/.fossils/tcl.fossil + + #the command: + # fossil all ignore /repo.fossil + #will remove the {repo:/repo.fossil 1} record from global_config + #but it leaves {ckout: /repo.fossil} records, even if such checkouts are closed + #when the folder itself at is removed - then commands such as 'fossil all ls -c' automatically remove the corresponding ckout: record. + + 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;}] + #list of entries like "ckout:C:/buildtcl/2024zig/tcl90/" + 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 -nocase -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 + } + + } + + + +} + + +#*** !doctools +#[manpage_end] + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::commandset::project [namespace eval punk::mix::commandset::project { + variable version + set version 0.2.0 +}] +return diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm index 230bad31..fa63e4fb 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm @@ -1444,52 +1444,34 @@ namespace eval punk::path { return [treefile_priv::walk_treefilenames_zipfs $state] } + punk::args::define { + @id -id ::punk::path::relative + @cmd -name punk::path::relative\ + -summary\ + "Compute the relative path from a reference path to a location path."\ + -help\ + "Taking two directory paths, a reference and a location, computes the path + of the location relative to the reference. + + Will return a single dot '.' if the paths are the same. + + Both paths must be the same type - ie both absolute or both relative. + + Matching is case sensitive. On windows, the drive-letter component (only) is + not case sensitive, so punk::path::relative c:/etc C:/etc returns '.'. + The part following the driveletter is case sensitive, so + punk::path::relative c:/etc C:/Etc returns ../Etc. + + On windows, if the paths are absolute and specify different volumes, + only the location will be returned." + @leaders -min 2 -max 2 + reference -type string -help\ + "The path from which the relative path to location is determined." + location -type string -help\ + "The location path which may be above or below the reference path." + } #maint warning - also in punkcheck proc relative {reference location} { - #*** !doctools - #[call [fun relative] [arg reference] [arg location]] - #[para] Taking two directory paths, a reference and a location, computes the path - # of the location relative to the reference. - #[list_begin itemized] - #[item] - #[para] Arguments: - # [list_begin arguments] - # [arg_def string reference] The path from which the relative path to location is determined. - # [arg_def string location] The location path which may be above or below the reference path - # [list_end] - #[item] - #[para] Results: - #[para] The relative path of the location to the reference path. - #[para] Will return a single dot "." if the paths are the same - #[item] - #[para] Notes: - #[para] Both paths must be the same type - ie both absolute or both relative - #[para] Case sensitive. ie punk::path::relative /etc /etC - # will return ../etC - #[para] On windows, the drive-letter component (only) is not case sensitive - #[example_begin] - # P% punk::path::relative c:/etc C:/etc - # - . - #[example_end] - #[para] The part following the driveletter is case sensitive so in the following cases it recognises the driveletter matches but not the tail - #[example_begin] - # P% punk::path::relative c:/etc C:/Etc - # - ../Etc - #[example_end] - #[para] On windows, if the paths are absolute and specifiy different volumes, only the location will be returned. - #[example_begin] - # P% punk::path::relative c:/etc d:/etc/blah - # - d:/etc/blah - #[example_end] - #[para] Unix-like examples: - #[example_begin] - # P% punk::path::relative /usr/local/etc/ /usr/local/etc/somewhere/below - # - somewhere/below - # P% punk::path::relative /usr/local/etc/somewhere /usr/local/lib/here - # - ../../lib/here - #[example_end] - #[list_end] - #see also kettle # Modified copy of ::fileutil::relative (tcllib) # Adapted to 8.5 ({*}). diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.2.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.2.0.tm new file mode 100644 index 00000000..68f0b744 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.2.0.tm @@ -0,0 +1,1611 @@ +# -*- 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::path 0.2.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::path 0 0.2.0] +#[copyright "2023"] +#[titledesc {Filesystem path utilities}] [comment {-- Name section and table of contents description --}] +#[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}] +#[require punk::path] +#[description] +#[keywords module path filesystem] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::path +#[para] Filesystem path utility functions +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::path +#[list_begin itemized] + +package require Tcl 8.6- +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {punk::args}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#namespace eval punk::path::class { + #*** !doctools + #[subsection {Namespace punk::path::class}] + #[para] class definitions + #if {[info commands [namespace current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + #} +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::path { + namespace export {[a-z]*} + #variable xyz + + #*** !doctools + #[subsection {Namespace punk::path}] + #[para] Core API functions for punk::path + #[list_begin definitions] + + # -- --- + #punk::path::normjoin + # - simplify . and .. segments as far as possible whilst respecting specific types of root. + # -- --- + #a form of file normalize that supports //xxx to be treated as server path names + #(ie regardless of unices ignoring (generally) leading double slashes, and regardless of windows volumerelative path syntax) + #(sometimes //server.com used as a short form for urls - which doesn't seem too incompatible with this anyway) + # -- --- + #This is intended to be purely a string analysis - without reference to filesystem volumes or vfs or zipfs mountpoints etc + #(but this also means we won't be able to resolve windows shortnames or dos device paths - so we will preserve those as they are) - review + #(It also means we can't resolve per drive working directories on windows - so we will preserve c: as is rather than converting to absolute - review) + # + #TODO - option for caller to provide a -base below which we can't backtrack. + #This is preferable to setting policy here for example regarding forcing no trackback below //servername/share + #Our default is to allow trackback to: + # :// + # :/ + # //./ (dos device volume) + # //server (while normalizing //./UNC/server to same) + # / (ordinary unix root) + # ./../ - (track back indefinitely on relpath as we are not resolving to anything physical and can't fully simplify the leading backtracks) + # + #The caller should do the file/vfs operations to determine this - not us. + # -- --- + #simplify path with respect to /./ & /../ elements - independent of platform + #NOTE: "anomalies" in standard tcl processing on windows: + #e.g file normalize {//host} -> c:/host (or e.g d:/host if we happen to be on another volume) + #file normalize {//host/share} -> //host/share + #This is because //host is treated as volume-relative in cmd/powershell and Tcl quite reasonably follows suit. + #This prevents cwd and windows commandlines from pointing to the server (above the share) + #Explorer however does allow pointing to the //server level and seeing shares as if they are directory entries. + #we are more interested in supporting the explorer-like behaviour - as while volumerelative paths are also useful on windows - they are lesser known. + #REVIEW. + #To get back to some consistent cross platform behaviour - we will treat //something as a root/volume i.e we can't backtrack above it with ".." + #note too that file split on UNC paths doesn't give a clear indication of the root + # file split //./UNC/server/share/subpath -> //./UNC server share subpath + # file split //server/share/subpath -> //server/share subpath + #TODO - disallow all change of root or change from relative path to absolute result. + #e.g normjoin relpath/../d:/secret should not return d:/secret - but ./d:/secret + # ================ + #known issues: + #1) + # normjoin d://a//b//c -> d://a/b/c + # This is because we don't detect specific schemes. ie it's treated the same as https://a/b/c -> https://a/b/c + # Not considered a problem - just potentially surprising. + # To avoid it we would have to enumerate possible schemes. + # As it stands a unix system could define a 'scheme' that happens to match windows style driveletters. Consider a 'feature' ? review. + # won't fix? + #2) + # normjoin https:///real.com/../fake.com -> https:///fake.com + # The extra slash means effectively our servername is empty - this is potentially confusing but probably the right thing to do here. + # It's a concern only if upstream treats the tripple slash in this case as valid and maps it to https:// - which would probably be bad anyway. + # won't fix (review) + #3) + #similarly + # normjoin //./UNC//server/share/subpath -> ///server/share/subpath (when 2 or more slashes directly after UNC) + # normjoin ///server/share -> ///server/share + #This is effectively an empty servername in the input with 'server' being pushed one level down - and the output is consistent + # possibly won't fix - review + #4) inconsistency + # we return normalized //server/share for //./UNC/server share + # but other dos device paths are maintained + # e.g //./c:/etc + # This is because such paths could contain alternate segment names (windows shortnames) which we aren't in a position to resolve. + # caller should + # #as with 'case' below - caller will need to run a post 'file normalize' + #5) we don't normalize case like file normalize does on windows platform. + # This is intentional. It could only be done with reference to underlying filesystem which we don't want here. + # + # ================ + # + #relpaths all end up with leading . - while not always the simplest form, this is ok. (helps stop inadvertent conversions to absolutes) + # Tests - TODO + # normjoin /d:/..//vfs:/test -> /vfs:/test (good - not converted to //vfs:/test) + + #normjoin c: should theoretically return current per drive working directory on c: + # - would need to use win32 GetFullPathName to resolve this. + proc normjoin {args} { + set args [lmap a $args {string map "\\\\ /" $a}] + set path [plainjoin {*}$args] + switch -exact -- $path { + "" { + return "" + } + / - // { + #treated in unixlike manner - (but leading doubleslashes with subsequent data are server indication) + #// not considered a servername indicator - but /// (for consistency) is. (empty servername?) + return / + } + /// { + #if this is effectively //$emptyservername/ + #then for consistency we should trail //=3 + #todo - shortcircuit that here? + } + } + # /// + set doubleslash1_posn [string first // $path] + + # -- --- --- temp warning on windows only - no x-platform difference in result + #on windows //host is of type volumerelative + # whereas //host/share is of type absolute + if {"windows" eq $::tcl_platform(platform) && [file pathtype $path] eq "volumerelative"} { + #volumerelative probably only occurs on windows anyway + if {$doubleslash1_posn == 0} { + #e.g //something where no further slashes + #review - eventually get rid of this warning and require upstream to know the appropriate usecase + puts stderr "Warning - ambiguous path $path - treating as server path - not 'volumerelative'" + } else { + # /something/etc + # /mnt/c/stuff + #output will retain leading / as if on unix. + #on windows - the result would still be interpreted as volumerelative if the caller normalizes it + } + } + # -- --- --- + + set is_relpath 0 + + #set path [string map [list \\ /] $path] + set finalparts [list] + set is_nonunc_dosdevice 0 + if {[punk::winpath::is_dos_device_path $path]} { + #review + if {[string range $path 4 6] eq "UNC"} { + #convert to 'standard' //server/... path for processing + set path "/[string range $path 7 end]" ;# //server/... + } else { + #error "normjoin non-UNC dos device path '$path' not supported" + #first segment after //./ or //?/ represents the volume or drive. + #not applicable to unix - but unlikely to conflict with a genuine usecase there (review) + #we should pass through and stop navigation below //./vol + #!!! + #not anomaly in tcl (continues in tcl9) + #file exists //./c:/test -> 0 + #file exists //?/c:/test -> 1 + #file exists //./BootPartition/Windows -> 1 + #file exists //?/BootPartition/Windows -> 0 + set is_nonunc_dosdevice 1 + } + } + + if {$is_nonunc_dosdevice} { + #dosdevice prefix //./ or //?/ - preserve it (without trailing slash which will be put back in with join) + set prefix [string range $path 0 2] + set tail [string range $path 4 end] + set tailparts [split $tail /] + set parts [concat [list $prefix] $tailparts] + set rootindex 1 ;#disallow backtrack below //./ + } else { + #note use of ordinary ::split vs file split is deliberate. + if {$doubleslash1_posn == 0} { + #this is handled differently on different platforms as far as 'file split' is concerned. + #e.g for file split //sharehost/share/path/etc + #e.g on windows: -> //sharehost/share path + #e.g on freebsd: -> / sharehost share path etc + #however..also on windows: file split //sharehost -> / sharehost + #normalize by dropping leading slash before split - and then treating first 2 segments as a root + #set parts [file split [string range $path 1 end]] + set parts [split $path /] + #assert parts here has {} {} as first 2 entries + set rootindex 2 + #currently prefer can backtrack to the //zipfs:/ scheme (below the mountpoint - to browse other mounts) + #alternative handling for //zipfs:/path - don't go below mountpoint + #but we can't determine just from string if mountpoint is direct subpath or a lower one e.g //zipfs:/arbitraryname/actualmountpoint + #review - more generally //:/path ? + #todo - make an option for zipfs and others to determine the 'base' + #if {"zipfs:" eq [lindex $parts 2]} { + # set rootindex 3 + #} + } else { + #path may or may not begin with a single slash here. + #treat same on unix and windows + set rootindex 0 + #set parts [file split $path] + set parts [::split $path /] + #e.g /a/b/c -> {} a b c + #or relative path a/b/c -> a b c + #or c:/a/b/c -> c: a b c + if {[string match *: [lindex $parts 0]]} { + if {[lindex $parts 1] eq ""} { + #scheme://x splits to scheme: {} x + set parts [concat [list [lindex $parts 0]/] [lrange $parts 2 end]] + #e.g {scheme:/ x} + set rootindex 1 ;#disallow below first element of scheme + } else { + set rootindex 0 + } + } elseif {[lindex $parts 0] ne ""} { + #relpath a/b/c + #set parts [linsert $parts 0 .] + ledit parts -1 -1 . + set rootindex 0 + #allow backtracking arbitrarily for leading .. entries - simplify where possible + #also need to stop possible conversion to absolute path + set is_relpath 1 + } + } + } + set baseparts [lrange $parts 0 $rootindex] ;#base below which we can't retreat via ".." + #puts stderr "-->baseparts:$baseparts" + #ensure that if our rootindex already spans a dotted segment (after the first one) we remove it + #must maintain initial . for relpaths to stop them converting to absolute via backtrack + # + set finalparts [list [lindex $baseparts 0]] + foreach b [lrange $baseparts 1 end] { + if {$b ni {. ..}} { + lappend finalparts $b + } + } + set baselen [expr {$rootindex + 1}] + if {$is_relpath} { + set i [expr {$rootindex+1}] + foreach p [lrange $parts $i end] { + switch -exact -- $p { + . - "" {} + .. { + switch -exact -- [lindex $finalparts end] { + . - .. { + lappend finalparts .. + } + default { + #lpop finalparts + ledit finalparts end end + } + } + } + default { + lappend finalparts $p + } + } + incr i + } + } else { + foreach p [lrange $parts $rootindex+1 end] { + if {[llength $finalparts] <= $baselen} { + if {$p ni {. .. ""}} { + lappend finalparts $p + } + } else { + switch -exact -- $p { + . - "" {} + .. { + #lpop finalparts ;#uses punk::lib::compat::lpop if on < 8.7 + ledit finalparts end end ;#uses punk::lib::compat::ledit if on < 8.7 + } + default { + lappend finalparts $p + } + } + } + } + } + #puts "==>finalparts: '$finalparts'" + # using join - {"" "" server share} -> //server/share and {a b} -> a/b + if {[llength $finalparts] == 1 && [lindex $finalparts 0] eq ""} { + #backtracking on unix-style path can end up with empty string as only member of finalparts + #e.g /x/.. + return / + } + set result [::join $finalparts /] + #normalize volumes and mountschemes to have trailing slash if no subpath + #e.g c: -> c:/ + #//zipfs: -> //zipfs:/ + if {[set lastchar [string index $result end]] eq ":"} { + if {$result eq "//zipfs:"} { + set result "//zipfs:/" + } else { + if {[string first / $result] < 0} { + set result $result/ + } + } + } elseif {[string match //* $result]} { + if {![punk::winpath::is_dos_device_path $result]} { + #server + set tail [string range $result 2 end] + set tailparts [split $tail /] + if {[llength $tailparts] <=1} { + #empty // or //servername + append result / + } + } + } elseif {[llength $finalparts] == 2} { + if {[string range [lindex $finalparts 0] end-1 end] eq ":/"} { + #e.g https://server/ -> finalparts {https:/ server} + #e.g https:/// -> finalparts {https:/ ""} + #scheme based path should always return trailing slash after server component - even if server component empty. + lappend finalparts "" ;#force trailing / + return [join $finalparts /] + } + } + if {[file extension [lindex $finalparts end]] eq ".lnk"} { + if {![catch {package require punk::winlnk}]} { + if {![catch {punk::winlnk::target $result} path]} { + return $path + } + } + } + return $result + } + + proc trim_final_slash {str} { + if {[string index $str end] eq "/"} { + return [string range $str 0 end-1] + } + return $str + } + + + #x-platform - punk::path::pathtype - can be used in safe interps - different concept of pathtypes to 'file pathtype' + # - no volumerelative + # - no lookup of file volumes (volume is a windows concept - but with //zipfs:/ somewhat applicable to other platforms) + # - /* as absolute (covers also //zipfs:/ (volume), //server , //./etc , //./UNC) + # - xxx:// as absolute (scheme) + # - xxx:/ or x:/ as absolute + # - x: xxx: -> as absolute (volume-basic or volume-extended) + + #note also on windows - legacy name for COM devices + # COM1 = COM1: + # //./COM1 ?? review + + proc pathtype {str} { + set str [string map "\\\\ /" $str] + if {[string index $str 0] eq "/"} { + #todo - look for //xxx:/ prefix (generalisation of //zipfs:/) as a 'volume' specifically {volume mount} ?? - review + # look for //server prefix as {absolute server} + # look for //./UNC/server or //?/UNC/server as {absolute server UNC} ? + # look for //./ as {absolute dosdevice} + return absolute + } + + #only firstsegment with single colon at last position (after some non empty string) counts as volume or scheme - review + #e.g a:b:/.. or a::/.. or :/.. is not treated as volume/scheme whereas ab:/ is. + set firstslash [string first / $str] + if {$firstslash == -1} { + set firstsegment $str + } else { + set firstsegment [string range $str 0 $firstslash-1] + } + if {[set firstc [string first : $firstsegment]] > 0} { + set lhs_firstsegment [string range $firstsegment 0 $firstc-1] + set rhs_firstsegment [string range $firstsegment $firstc+1 end] ;#exclude a:b/ etc + if {$rhs_firstsegment eq ""} { + set rhs_entire_path [string range $str $firstc+1 end] + #assert lhs_firstsegment not empty since firstc > 0 + #count following / sequence + set i 0 + set slashes_after_firstsegment "" ;#run of slashes *directly* following first segment + while {$i < [string length $rhs_entire_path]} { + if {[string index $rhs_entire_path $i] eq "/"} { + append slashes_after_firstsegment / + } else { + break + } + incr i + } + switch -exact -- $slashes_after_firstsegment { + "" - / { + if {[string length $lhs_firstsegment] == 1} { + return {absolute volume basic} + } else { + return {absolute volume extended} + } + } + default { + #2 or more / + #this will return 'scheme' even for c:// - even though that may look like a windows volume - review + return {absolute scheme} + } + } + } + } + #assert first element of any return has been absolute or relative + return relative + } + + + proc plain {str} { + set str [string map "\\\\ /" $str] + set pathinfo [punk::path::pathtype $str] + if {[lindex $pathinfo 0] eq "relative" && ![string match ./* $str]} { + set str ./$str + } + if {[string index $str end] eq "/"} { + if {[string map {/ ""} $str] eq ""} { + #all slash segment + return $str + } else { + if {[lindex $pathinfo 1] ni {volume scheme}} { + return [string range $str 0 end-1] + } + } + } + return $str + } + #purely string based - no reference to filesystem knowledge + #unix-style forward slash only + proc plainjoin {args} { + set args [lmap a $args {string map "\\\\ /" $a}] + #if {[llength $args] == 1} { + # return [lindex $args 0] + #} + set out "" + foreach a $args { + if {![string length $out]} { + append out [plain $a] + } else { + set a [plain $a] + if {[string map {/ ""} $out] eq ""} { + set out [string range $out 0 end-1] + } + + if {[string map {/ ""} $a] eq ""} { + #all / segment + append out [string range $a 0 end-1] + } else { + if {[string length $a] > 2 && [string match "./*" $a]} { + set a [string range $a 2 end] + } + if {[string index $out end] eq "/"} { + append out $a + } else { + append out / $a + } + } + } + } + return $out + } + proc plainjoin1 {args} { + if {[llength $args] == 1} { + return [lindex $args 0] + } + set out [trim_final_slash [lindex $args 0]] + foreach a [lrange $args 1 end] { + set a [trim_final_slash $a] + append out / $a + } + return $out + } + + #intention? + #proc filepath_dotted_dirname {path} { + #} + + proc strip_prefixdepth {path prefix} { + if {$prefix eq ""} { + return [norm $path] + } + return [file join {*}{ + } {*}[lrange {*}{ + } [file split [norm $path]] {*}{ + } [llength [file split [norm $prefix]]] {*}{ + } end + ] + ] + } + + + ## for comparison + #proc nsglob_as_re {glob} { + # #any segment that is not just * must match exactly one segment in the path + # set pats [list] + # foreach seg [nsparts_cached $glob] { + # switch -exact -- $seg { + # "" { + # lappend pats "" + # } + # * { + # #review - ::g*t will not find ::got:it (won't match single inner colon) - this should be fixed + # #lappend pats {[^:]*} + # #negative lookahead + # #any number of chars not followed by ::, followed by any number of non : + # lappend pats {(?:.(?!::))*[^:]*} + # } + # ** { + # lappend pats {.*} + # } + # default { + # set seg [string map {. [.]} $seg] + # if {[regexp {[*?]} $seg]} { + # #set pat [string map [list ** {.*} * {[^:]*} ? {[^:]}] $seg] + # set pat [string map [list ** {.*} * {(?:.(?!::))*[^:]*} ? {[^:]}] $seg] + # lappend pats "$pat" + # } else { + # lappend pats "$seg" + # } + # } + # } + # } + # return "^[join $pats ::]\$" + #} + proc pathglob_as_re {pathglob} { + #*** !doctools + #[call [fun pathglob_as_re] [arg pathglob]] + #[para] Returns a regular expression for matching a path to a glob pattern which can contain glob chars *|? in any segment of the path structure + #[para] Does not support square bracket globs or character classes. + #[para] ** matches any number of subdirectories. + #[para] e.g /etc/**/*.txt will match any .txt files at any depth below /etc (except directly within /etc itself) + #[para] e.g /etc/**.txt will match any .txt files at any depth below /etc + #[para] any segment that does not contain ** must match exactly one segment in the path + #[para] e.g the glob /etc/*/*.doc - will match any .doc files that are exactly one tree level below /etc + #[para] The pathglob doesn't have to contain glob characters, in which case the returned regex will match the pathglob exactly as specified. + #[para] Regular expression syntax is deliberateley not supported within the pathglob string so that supplied regex characters will be treated as literals + + + #todo - consider whether a way to escape the glob chars ? * is practical - to allow literals ? * + # - would require counting immediately-preceding backslashes + set pats [list] + foreach seg [file split $pathglob] { + if {[string range $seg end end] eq "/"} { + set seg [string range $seg 0 end-1] ;# e.g c:/ -> c: / -> "" so that join at end doesn't double up + } + switch -- $seg { + * {lappend pats {[^/]*}} + ** {lappend pats {.*}} + default { + set seg [string map [list ^ {\^} $ {\$} \[ {\[} \] {\]} ( {\(} ) {\)} \{ \\\{ \\ {\\}] $seg] ;#treat regex characters (or tcl glob square bracket chars) in the input as literals + #set seg [string map [list . {[.]}] $seg] + set seg [string map {. [.]} $seg] + if {[regexp {[*?]} $seg]} { + set pat [string map [list ** {.*} * {[^/]*} ? {[^/]}] $seg] + lappend pats "$pat" + } else { + lappend pats "$seg" + } + } + } + } + return "^[join $pats /]\$" + } + + punk::args::define { + @id -id ::punk::path::globmatchpath + @cmd -name punk::path::globmatchpath\ + -summary\ + "Match path to *|**|? glob patterns"\ + -help\ + "Return a boolean indicating whether the path matches the specialised glob pattern. + A pattern such as /usr/*/bin will match any path that has /usr as the first segment and bin as the third segment, + with any single segment in between. + A pattern such as /usr/**/bin will match any path that has /usr as the first segment and bin as the last segment, + with 1 or more segments in between (so it will not match /usr/bin). + A pattern such as /usr/** will match any path that has /usr as the first segment, with 1 or more segments + following (so it will not match /usr itself). + A pattern such as **/*.txt will match any path that ends with .txt, with 1 or more leading segments + (so it will not match test.txt or .txt). + A pattern such as ** will match any path. + The glob characters * and ? are the only special characters in the pathglob syntax. + - they are treated as glob characters regardless of where they appear in the pathglob string. + Note that this is different from other Tcl glob contexts where square brackets can be used. + The pathglob syntax treats other characters, including square brackets as literals. + For example, the pattern /usr/te?t will match /usr/test and /usr/text but not /usr/texxt, and the pattern /usr/te*t + will match /usr/test, /usr/teat, and /usr/teeeet but not /usr/te/t. + The pathglob syntax does not support escaping of glob characters - any glob characters in the pathglob are treated + as glob characters. For example, the pattern /usr/* will match any path that has /usr as the first segment and any + single segment as the second segment, but there is no way to specify a pattern that matches any path that has /usr + as the first segment and a literal * as the second segment. + Caller must ensure that file separator is forward slash. (e.g use file normalize on windows) + + options: + -nocase 0|1 (default 0 - case sensitive) + If -nocase is not supplied - default to case sensitive *except for driveletter* + ie - the driveletter alone in paths such as c:/etc will still be case insensitive. (ie c:/ETC/* will match C:/ETC/blah but not C:/etc/blah) + Explicitly specifying -nocase 0 will require the entire case to match including the driveletter. + " + @leaders + pathglob -type string -help "glob pattern to match path against. See [fun pathglob_as_re] for syntax of glob patterns" + path -type string -help "path to match against glob pattern" + @opts + -nocase -type boolean -default 0 -help\ + "case insensitive matching (default false - case sensitive) + - except for driveletter on windows which is always case insensitive + unless -nocase 0 is explicitly specified" + @values -min 0 -max 0 + } + # -id + proc globmatchpath {pathglob path args} { + #*** !doctools + #[call [fun globmatchpath] [arg pathglob] [arg path] [opt {option value...}]] + #[para] Return true if the pathglob matches the path + #[para] see [fun pathglob_as_re] for pathglob description + #[para] Caller must ensure that file separator is forward slash. (e.g use file normalize on windows) + #[para] + #[para] Known options: + #[para] -nocase 0|1 (default 0 - case sensitive) + #[para] If -nocase is not supplied - default to case sensitive *except for driveletter* + #[para] ie - the driveletter alone in paths such as c:/etc will still be case insensitive. (ie c:/ETC/* will match C:/ETC/blah but not C:/etc/blah) + #[para] Explicitly specifying -nocase 0 will require the entire case to match including the driveletter. + + set opts [dict create {*}{ + -nocase \uFFFF + }] + foreach {k v} $args { + switch -- $k { + -nocase { + dict set opts $k $v + } + default { + error "Unrecognised option '$k'. Known-options: [dict keys $opts]" + } + } + } + # -- --- --- --- --- --- + set opt_nocase [dict get $opts -nocase] + set explicit_nocase 1 ;#default to disprove + if {$opt_nocase eq "\uFFFF"} { + set opt_nocase 0 + set explicit_nocase 0 + } + # -- --- --- --- --- --- + if {$opt_nocase} { + return [regexp -nocase [pathglob_as_re $pathglob] $path] + } else { + set re [pathglob_as_re $pathglob] + if {$explicit_nocase} { + set ismatch [regexp $re $path] ;#explicit -nocase 0 - require exact match of path literals including driveletter + } else { + #caller is using default for -nocase - which indicates case sensitivity - but we have an exception for the driveletter. + set re_segments [file split $re] ;#Note that file split c:/etc gives {c:/ etc} but file split ^c:/etc gives {^c: etc} + set first_seg [lindex $re_segments 0] + if {[regexp {^\^(.{1}):$} $first_seg _match driveletter]} { + #first part of re is like "^c:" i.e a drive letter + set chars [string tolower $driveletter][string toupper $driveletter] + set re [join [concat "^\[$chars\]:" [lrange $re_segments 1 end]] /] ;#rebuild re with case insensitive driveletter only - use join - not file join. file join will misinterpret leading re segment. + } + #puts stderr "-->re: $re" + set ismatch [regexp $re $path] + } + } + return $ismatch + } + punk::args::define { + @id -id ::punk::path::subfolders1 + @cmd -name punk::path::subfolders1\ + -summary\ + "Listing of directories below supplied path."\ + -help\ + "List of folders below path. + The resulting list is unsorted." + @opts + -recursive -type none -help\ + "" + -exclude-paths -type list -default {} -help\ + "list of path patterns to exclude from results. + May include * and ** path segments e.g /usr/** + A single /*/ will match any single segment in the path, and a single /**/ will match any number of segments in the path. + + e.g to exclude any path with _aside as a segment in the middle: -exclude-paths **/_aside/** + i.e this would exclude /usr/_aside/etc and /usr/x/_aside/etc but not /usr/x/_aside or _aside/etc + + To exclude all paths with _aside as a segment anywhere: -exclude-paths { **/_aside/** **/_aside _aside/**} + " + #todo -depth + @values -min 0 -max 1 + path -type directory -optional 1 -help\ + "Path of folder. If not supplied current directory is used. + This may be a relative or absolute path. Relative paths are treated as relative to current directory. + When using relative paths - the result will also be relative paths with the same relative prefix. + (e.g if path is ../test - the results will be ../test/subfolder1 ../test/subfolder2 etc) + Patterns in -exclude-paths are matched against the resulting paths + (so should be written to match the same relative prefix if path is relative)" + } + + proc subfolders1 {args} { + #NOTE - this algorithm based on omit_only_patterns and prune_base_patterns was suggested by a 2026 AI model - it is apparent to this programmer that it is inadequate for the purpose. + #e.g consider subfolders1 -recursion -exclude {**/vfs/** **/src/**} + #This can still return something like c:/repo/etc/src/vfs - which should be excluded by the pattern **/src/** + #todo - review and fix properly. + set argd [punk::args::parse $args withid ::punk::path::subfolders1] + lassign [dict values $argd] leaders opts values received + set do_recursion [dict exists $received -recursive] + set exclude_paths [dict get $opts -exclude-paths] + if {"**" in $exclude_paths} { + #if ** is in exclude_paths - then we can skip all glob matching and just return empty list + #This is likely user error - so we'll be loud about it for now but will still return empty list rather than erroring. + #If user code is building exclude_paths dynamically - they can check for this case themselves and avoid the call to subfolders1 to suppress this message. + puts stderr "punk::path::subfolders1 Warning - exclude_paths contains '**' - all paths will be excluded" + return [list] + } + if {[dict exists $received path]} { + set path [dict get $values path] + } else { + set path [pwd] + } + + set all_subfolders [glob -nocomplain -directory $path -types d *] + + + #example of expected exclude_paths pattern behaviour when recursion is enabled: + # **/dirname -> omit /x/y/dirname, but still visit /x/y/dirname/* + + # **/dirname/* -> include /x/y/dirname and /x/y/dirname/a/b but omit directories that are a single level below /x/y/dirname such as /x/y/dirname/a + + #c:/** - would exclude all subfolders below c: but not c: itself + + # **/test/** - would exclude any path with test as a segment and all its subfolders + #- but not paths with test as a segment that is the final segment + + set folders [list] + set recurse_subdirs [list] + + foreach f $all_subfolders { + set include_in_results 1 + set allow_recurse 1 + foreach pat $exclude_paths { + set pat_parts [file split $pat] ;#note file split c:/test gives {c:/ test} but file split **/test gives {** test} + #also note that file split on windows treats forward slashes and backslashes the same. + #by using file split, we gain some flexibility in syntax of paths and patterns, + #but lose the ability to use backslashes as escapes to allow literal glob characters in path segments. + #This is almost always a non-issue on windows since * and ? are not valid in path segments there, and is rarely an issue on unix even though + # * and ? are technically valid in path segments, but it is inadvisable there anyway for compatibility with shells etc. + if {[llength $pat_parts] >= 2 && [lindex $pat_parts end] eq "**"} { + set base_pat [file join {*}[lrange $pat_parts 0 end-1]] + if {[globmatchpath $pat $f]} { + set include_in_results 0 + set allow_recurse 0 + } elseif {[globmatchpath $base_pat $f]} { + set allow_recurse 0 + } + } elseif {[globmatchpath $pat $f]} { + set include_in_results 0 + } + if {!$include_in_results && !$allow_recurse} { + break + } + } + if {$include_in_results} { + lappend folders $f + } + if {$allow_recurse} { + lappend recurse_subdirs $f + } + } + if {$do_recursion} { + foreach subdir $recurse_subdirs { + lappend folders {*}[subfolders1 -exclude-paths $exclude_paths -recursive $subdir] + } + } + return $folders + } + + namespace eval subfolder_priv { + proc classify_exclude_pattern {pat} { + set parts [file split $pat] + if {[llength $parts] >= 2 && [lindex $parts end] eq "**"} { + set boundary_pat [file join {*}[lrange $parts 0 end-1]] + return [dict create {*}{ + } pattern $pat {*}{ + } kind subtree {*}{ + } boundary_pat $boundary_pat {*}{ + } descend_pat $pat {*}{ + } + ] + } + if {[llength $parts] >= 2 && [lindex $parts end] eq "*"} { + return [dict create {*}{ + } pattern $pat {*}{ + } kind child_only {*}{ + } match_pat $pat {*}{ + } + ] + } + return [dict create {*}{ + } pattern $pat {*}{ + } kind exact {*}{ + } match_pat $pat {*}{ + } + ] + } + + proc compile_exclude_rules {exclude_paths} { + set rules [list] + foreach pat $exclude_paths { + lappend rules [classify_exclude_pattern $pat] + } + return $rules + } + + proc match_rule_at_node {rule path} { + set kind [dict get $rule kind] + switch -- $kind { + exact - child_only { + if {[::punk::path::globmatchpath [dict get $rule match_pat] $path]} { + return [dict create include_current 0 recurse_below 1 child_rules [list $rule]] + } + return [dict create include_current 1 recurse_below 1 child_rules [list $rule]] + } + subtree { + set descend_pat [dict get $rule descend_pat] + set boundary_pat [dict get $rule boundary_pat] + if {[::punk::path::globmatchpath $descend_pat $path]} { + return [dict create include_current 0 recurse_below 0 child_rules [list]] + } + if {[::punk::path::globmatchpath $boundary_pat $path]} { + return [dict create include_current 1 recurse_below 0 child_rules [list]] + } + return [dict create include_current 1 recurse_below 1 child_rules [list $rule]] + } + default { + error "Unknown exclude rule kind '$kind'" + } + } + } + + proc walk_subfolders {path rules do_recursion} { + set all_subfolders [glob -nocomplain -directory $path -types d *] + set folders [list] + foreach f $all_subfolders { + set include_current 1 + set recurse_below $do_recursion + set child_rules [list] + foreach rule $rules { + set outcome [match_rule_at_node $rule $f] + if {![dict get $outcome include_current]} { + set include_current 0 + } + if {![dict get $outcome recurse_below]} { + set recurse_below 0 + } + if {$do_recursion} { + lappend child_rules {*}[dict get $outcome child_rules] + } + if {!$include_current && !$recurse_below} { + break + } + } + if {$include_current} { + lappend folders $f + } + if {$do_recursion && $recurse_below} { + lappend folders {*}[walk_subfolders $f $child_rules $do_recursion] + } + } + return $folders + } + } + + punk::args::define { + @id -id ::punk::path::subfolders + @cmd -name punk::path::subfolders\ + -summary\ + "Listing of directories below supplied path."\ + -help\ + "List of folders below path. + The resulting list is unsorted. + " + @opts + -recursive -type none -help\ + "" + -exclude-paths -type list -default {} -help\ + "list of path patterns to exclude from results. + May include * and ** path segments e.g /usr/** + A single /*/ will match any single segment in the path, and a single /**/ will match any number of segments in the path. + + e.g to exclude any path with _aside as a segment in the middle: -exclude-paths **/_aside/** + i.e this would exclude /usr/_aside/etc and /usr/x/_aside/etc but not /usr/x/_aside or _aside/etc + + To exclude all paths with _aside as a segment anywhere: -exclude-paths { **/_aside/** **/_aside ./_aside/**} + " + #todo -depth + @values -min 0 -max 1 + path -type directory -optional 1 -help\ + "Path of base folder. If not supplied current directory is used. + This may be a relative or absolute path. Relative paths are treated as relative to current directory. + When using relative paths - the result will also be relative paths with the same relative prefix. + (e.g if path is ../test - the results will be ../test/subfolder1 ../test/subfolder2 etc) + Patterns in -exclude-paths are matched against the resulting paths + (so should be written to match the same relative prefix if path is relative)" + } + + proc subfolders {args} { + set argd [punk::args::parse $args withid ::punk::path::subfolders] + lassign [dict values $argd] leaders opts values received + set do_recursion [dict exists $received -recursive] + set exclude_paths [dict get $opts -exclude-paths] + if {"**" in $exclude_paths} { + puts stderr "punk::path::subfolders Warning - exclude_paths contains '**' - all paths will be excluded" + return [list] + } + if {[dict exists $received path]} { + set path [dict get $values path] + } else { + set path [pwd] + } + set compiled_rules [subfolder_priv::compile_exclude_rules $exclude_paths] + return [subfolder_priv::walk_subfolders $path $compiled_rules $do_recursion] + } + + namespace eval treefile_priv { + proc _path_segment_matches {pattern_segment path_segment} { + if {[::punk::path::globmatchpath $pattern_segment $path_segment]} { + return 1 + } + if {[string range $pattern_segment end end] eq "/" && [string range $path_segment end end] eq "/"} { + set root_probe __punk_path_root_probe__ + return [::punk::path::globmatchpath [file join $pattern_segment $root_probe] [file join $path_segment $root_probe]] + } + return 0 + } + + proc _pattern_prefix_viable_parts {pattern_parts path_parts} { + if {![llength $path_parts]} { + return 1 + } + if {![llength $pattern_parts]} { + return 0 + } + + set pattern_head [lindex $pattern_parts 0] + set path_head [lindex $path_parts 0] + + if {$pattern_head eq "**"} { + if {[_pattern_prefix_viable_parts [lrange $pattern_parts 1 end] $path_parts]} { + return 1 + } + return [_pattern_prefix_viable_parts $pattern_parts [lrange $path_parts 1 end]] + } + + if {[_path_segment_matches $pattern_head $path_head]} { + return [_pattern_prefix_viable_parts [lrange $pattern_parts 1 end] [lrange $path_parts 1 end]] + } + return 0 + } + + proc pattern_prefix_viable {pattern path} { + return [_pattern_prefix_viable_parts [file split $pattern] [file split $path]] + } + + proc pattern_boundary {pattern} { + set parts [file split $pattern] + if {[llength $parts] >= 2 && [lindex $parts end] eq "**"} { + return [file join {*}[lrange $parts 0 end-1]] + } + return "" + } + + proc directory_state {glob_paths path inherited_allbelow} { + if {$inherited_allbelow} { + return [dict create include_files 1 recurse_below 1 next_allbelow 1] + } + + set include_files 0 + set recurse_below 0 + set next_allbelow 0 + + foreach gp $glob_paths { + if {[::punk::path::globmatchpath $gp $path]} { + set include_files 1 + set recurse_below 1 + set next_allbelow 1 + break + } + + set boundary [pattern_boundary $gp] + if {$boundary ne "" && [::punk::path::globmatchpath $boundary $path]} { + set recurse_below 1 + set next_allbelow 1 + continue + } + + if {[pattern_prefix_viable $gp $path]} { + set recurse_below 1 + } + } + + return [dict create {*}{ + } include_files $include_files {*}{ + } recurse_below $recurse_below {*}{ + } next_allbelow $next_allbelow {*}{ + } + ] + } + + proc child_path_state {glob_paths child_path inherited_allbelow} { + if {$inherited_allbelow} { + return 1 + } + foreach gp $glob_paths { + if {[pattern_prefix_viable $gp $child_path]} { + return 1 + } + } + return 0 + } + + proc _sort_paths {paths sortmode} { + switch -- $sortmode { + ascii { + return [lsort $paths] + } + dictionary { + return [lsort -dictionary $paths] + } + natural { + return [natsort::sort $paths] + } + default { + return $paths + } + } + } + + proc _path_matches_any {patterns path} { + foreach pattern $patterns { + if {[::punk::path::globmatchpath $pattern $path]} { + return 1 + } + } + return 0 + } + + proc _tailbase_relative {tailbase path} { + if {$tailbase eq ""} { + return $path + } + return [::punk::path::relative $tailbase $path] + } + + proc _tailbase_match_path {tailbase path} { + set match_path [_tailbase_relative $tailbase $path] + if {$match_path eq "."} { + return "" + } + return $match_path + } + + proc _tailbase_relative_list {tailbase paths} { + if {$tailbase eq ""} { + return $paths + } + set relative_paths [list] + foreach path $paths { + lappend relative_paths [_tailbase_relative $tailbase $path] + } + return $relative_paths + } + + proc _retain_files {matches exclude_files sortmode} { + set retained [list] + foreach match $matches { + set skip 0 + set file_tail [file tail $match] + foreach anti $exclude_files { + if {[string match $anti $file_tail]} { + set skip 1 + break + } + } + if {!$skip} { + lappend retained $match + } + } + return [_sort_paths $retained $sortmode] + } + + proc _state_from_argd {argd} { + set opts [dict get $argd opts] + set values [dict get $argd values] + set received [dict get $argd received] + + if {[dict exists $received -directory]} { + set directory [dict get $opts -directory] + } else { + set directory [pwd] + } + + set glob_paths [dict get $opts -include-paths] + if {"*" in $glob_paths} { + set glob_paths {*} + } + + set sortmode [dict get $opts -sort] + if {$sortmode eq "natural"} { + package require natsort + } + + return [dict create {*}{ + depth 0 + subvector {} + allbelow 0 + } sort $sortmode {*}{ + } directory $directory {*}{ + } tailbase [dict get $opts -tailbase] {*}{ + } exclude_paths [dict get $opts -exclude-paths] {*}{ + } exclude_files [dict get $opts -exclude-files] {*}{ + } glob_paths $glob_paths {*}{ + } tailglobs [dict get $values tailglobs] {*}{ + } + ] + } + + proc walk_treefilenames {state} { + set opt_dir [dict get $state directory] + set opt_tailbase [dict get $state tailbase] + set depth [dict get $state depth] + set subvector [dict get $state subvector] + set callallbelow [dict get $state allbelow] + set opt_sort [dict get $state sort] + set opt_exclude_paths [dict get $state exclude_paths] + set opt_exclude_files [dict get $state exclude_files] + set opt_glob_paths [dict get $state glob_paths] + set tailglobs [dict get $state tailglobs] + + if {![file isdirectory $opt_dir]} { + return [list] + } + if {[string match //zipfs:/* $opt_dir]} { + return [walk_treefilenames_zipfs $state] + } + set opt_dir_match [_tailbase_match_path $opt_tailbase $opt_dir] + if {[_path_matches_any $opt_exclude_paths $opt_dir_match]} { + return [list] + } + + set files [list] + set dir_state [directory_state $opt_glob_paths $opt_dir_match $callallbelow] + if {[dict get $dir_state include_files]} { + if {[catch {glob -nocomplain -dir $opt_dir -type f -- {*}$tailglobs} matches]} { + puts stderr "treefilenames error while listing files in dir $opt_dir\n $matches" + set dirfiles [list] + } else { + #also match hidden files (e.g dotfiles on windows where glob -type f misses them) + if {![catch {glob -nocomplain -dir $opt_dir -types {hidden f} -- {*}$tailglobs} hidden_matches]} { + foreach h $hidden_matches { + if {$h ni $matches} { + lappend matches $h + } + } + } + set dirfiles [_retain_files $matches $opt_exclude_files $opt_sort] + } + lappend files {*}[_tailbase_relative_list $opt_tailbase $dirfiles] + } + + if {![dict get $dir_state recurse_below]} { + return $files + } + + if {[catch {glob -nocomplain -dir $opt_dir -type d *} dirdirs]} { + puts stderr "treefilenames error while listing subdirs in dir $opt_dir\n $dirdirs" + set dirdirs [list] + } + #also match hidden directories + if {![catch {glob -nocomplain -dir $opt_dir -types {hidden d} *} hidden_dirdirs]} { + foreach h $hidden_dirdirs { + switch -- $h { + "." - ".." {continue} + default { + if {$h ni $dirdirs} { + lappend dirdirs $h + } + } + } + } + } + set okdirs [list] + foreach dir $dirdirs { + if {![_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $dir]]} { + lappend okdirs $dir + } + } + + if {$opt_glob_paths eq "*"} { + set matchdirs $okdirs + } else { + set matchdirs [list] + foreach dir $okdirs { + if {$callallbelow || [child_path_state $opt_glob_paths [_tailbase_match_path $opt_tailbase $dir] $callallbelow]} { + lappend matchdirs $dir + } + } + } + + set finaldirs [_sort_paths $matchdirs $opt_sort] + set childallbelow [expr {$callallbelow || [dict get $dir_state next_allbelow]}] + set nextsubvector [list {*}$subvector [file tail $opt_dir]] + foreach dir $finaldirs { + set child_state [dict merge $state [dict create {*}{ + } directory $dir {*}{ + } depth [expr {$depth + 1}] {*}{ + } subvector $nextsubvector {*}{ + } allbelow $childallbelow {*}{ + } + ]] + lappend files {*}[walk_treefilenames $child_state] + } + return $files + } + + proc walk_treefilenames_zipfs {state} { + set opt_dir [dict get $state directory] + set opt_tailbase [dict get $state tailbase] + set opt_exclude_paths [dict get $state exclude_paths] + set opt_exclude_files [dict get $state exclude_files] + set opt_glob_paths [dict get $state glob_paths] + set opt_sort [dict get $state sort] + set tailglobs [dict get $state tailglobs] + + if {![string match [zipfs root]* $opt_dir]} { + error "treefilenames_zipfs can only be used on paths beginning with [zipfs root] on this systems" + } + set dir [string trimright $opt_dir "/"] + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $dir]]} { + return [list] + } + set dirlen [string length $dir] + set subpaths [zipfs list $dir/*] + set dirlist [list] + set skipdirs [list] + set filelist [list] + foreach sub $subpaths { + set tail [string range $sub $dirlen+1 end] + set tailparts [file split $tail] + set accum "" + set skipdir 0 + foreach tailpart [lrange $tailparts 0 end-1] { + append accum "/$tailpart" + set superpath "${dir}${accum}" + if {$superpath in $skipdirs} { + set skipdir 1 + break + } + if {$superpath ni $dirlist} { + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $superpath]]} { + lappend skipdirs $superpath + set skipdir 1 + break + } else { + lappend dirlist $superpath + } + } + } + if {!$skipdir} { + append accum "/[lindex $tailparts end]" + set finalpart "${dir}${accum}" + if {$finalpart ni $dirlist} { + if {[file type $finalpart] eq "file"} { + set file_tail [lindex $tailparts end] + set match 0 + if {"*" ni $tailglobs} { + foreach tailglob $tailglobs { + if {[string match $tailglob $file_tail]} { + set match 1 + break + } + } + } else { + set match 1 + } + if {$match && $opt_glob_paths ne "*"} { + set file_dir_match [_tailbase_match_path $opt_tailbase [file dirname $finalpart]] + set file_dir_state [directory_state $opt_glob_paths $file_dir_match 0] + set match [dict get $file_dir_state include_files] + } + if {$match} { + set skipfile 0 + foreach anti $opt_exclude_files { + if {[string match $anti $file_tail]} { + set skipfile 1 + break + } + } + if {!$skipfile} { + lappend filelist [_tailbase_relative $opt_tailbase $finalpart] + } + } + } else { + if {$finalpart ni $dirlist} { + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $finalpart]]} { + lappend skipdirs $finalpart + } else { + lappend dirlist $finalpart + } + } + } + } + } + } + return [_sort_paths $filelist $opt_sort] + } + } + + #todo - treefolders with similar search caps as treefilenames + + punk::args::define { + @id -id ::punk::path::treefilenames + @cmd -name punk::path::treefilenames\ + -summary\ + "List of filenames below supplied path."\ + -help\ + "List of filenames below path. + The resulting list is unsorted. + + The path globbing syntax supports *, ** and ? as glob characters in any segment of the path, with the following semantics: + * matches any single segment in the path + ** matches 1 or more segments in the path (so /usr/**/bin will match /usr/x/bin and user/x/y/bin but not /usr/bin ) + ? matches any single character in a single segment of the path (so /usr/te?t will match /usr/test and /usr/text but not /usr/texxt) + " + -directory -type directory -help\ + "folder in which to begin recursive scan for files." + -tailbase -type string -default "" -help\ + "if supplied, only the relative path compared to the tailbase will be returned for each file. + So if tailbase is /usr and a file is found at /usr/x/y/file.txt, the returned path for that file would be x/y/file.txt. + If tailbase is not supplied, the full path to each file will be returned. + + If tailbase is supplied, it should be a prefix of the directory supplied (or the directory itself) + The patterns in -exclude-paths should be written to match the returned paths (i.e with the tailbase prefix removed) if -tailbase is supplied. + If the tailbase is not a prefix of the directory supplied, the resulting paths may have /../ components in them to account for the difference, + but the behaviour is not well defined in this case and it is recommended to ensure tailbase is a prefix of the directory supplied if using -tailbase. + + see: punk::path::relative to compute relative paths + " + -sort -type any -default natural -choices {none ascii dictionary natural} + -exclude-paths -default {} -help\ + "list of path patterns to exclude + may include * and ** path segments e.g + /usr/** (exclude subfolders based at /usr but not + files within /usr itself) + **/_aside (exclude files where _aside is last segment) + **/_aside/* (exclude folders one below an _aside folder) + **/_aside/** (exclude files in all folders with _aside as a segment)" + -exclude-files -default {} + -include-paths -default {**} -help\ + "list of path patterns to include + may include * and ** path segments e.g + /usr/** (include files in subfolders based at /usr but not + files within /usr itself) + **/_aside (include files where _aside is last segment in the folder) + **/_aside/* (include files in folders one below an _aside folder) + **/_aside/** (include all files in folders with _aside as a segment)" + @values -min 0 -max -1 -optional 1 -type string + tailglobs -default * -multiple 1 -help\ + "Patterns to match against filename portion (last segment) of each file path + within the directory tree being searched." + } + + #todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/ + #then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase) + proc treefilenames {args} { + set argd [punk::args::parse $args withid ::punk::path::treefilenames] + set state [treefile_priv::_state_from_argd $argd] + return [treefile_priv::walk_treefilenames $state] + } + punk::args::set_idalias ::punk::path::treefilenames_zipfs ::punk::path::treefilenames + proc treefilenames_zipfs {args} { + #seems to be 2 or 3 times faster than treefilenames for //zipfs:/ paths - REVIEW + # is sort order the same? + set argd [punk::args::parse $args withid ::punk::path::treefilenames] + set state [treefile_priv::_state_from_argd $argd] + if {![file isdirectory [dict get $state directory]]} { + return [list] + } + return [treefile_priv::walk_treefilenames_zipfs $state] + } + + punk::args::define { + @id -id ::punk::path::relative + @cmd -name punk::path::relative\ + -summary\ + "Compute the relative path from a reference path to a location path."\ + -help\ + "Taking two directory paths, a reference and a location, computes the path + of the location relative to the reference. + + Will return a single dot '.' if the paths are the same. + + Both paths must be the same type - ie both absolute or both relative. + + Matching is case sensitive. On windows, the drive-letter component (only) is + not case sensitive, so punk::path::relative c:/etc C:/etc returns '.'. + The part following the driveletter is case sensitive, so + punk::path::relative c:/etc C:/Etc returns ../Etc. + + On windows, if the paths are absolute and specify different volumes, + only the location will be returned." + @leaders -min 2 -max 2 + reference -type string -help\ + "The path from which the relative path to location is determined." + location -type string -help\ + "The location path which may be above or below the reference path." + } + #maint warning - also in punkcheck + proc relative {reference location} { + #see also kettle + # Modified copy of ::fileutil::relative (tcllib) + # Adapted to 8.5 ({*}). + + #review - check volume info on windows.. UNC paths? + if {[file pathtype $reference] ne [file pathtype $location]} { + return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $reference] vs. [file pathtype $location], ($reference vs. $location)" + } + + #avoid normalizing if possible (file normalize *very* expensive on windows) + set do_normalize 0 + if {[file pathtype $reference] eq "relative"} { + #if reference is relative so is location + if {[regexp {[.]{2}} [list $reference $location]]} { + set do_normalize 1 + } + if {[regexp {[.]/} [list $reference $location]]} { + set do_normalize 1 + } + } else { + set do_normalize 1 + } + if {$do_normalize} { + set reference [file normalize $reference] + set location [file normalize $location] + } + + set save $location + set reference [file split $reference] + set location [file split $location] + + while {[lindex $location 0] eq [lindex $reference 0]} { + set location [lrange $location 1 end] + set reference [lrange $reference 1 end] + if {![llength $location]} {break} + } + + set location_len [llength $location] + set reference_len [llength $reference] + + if {($location_len == 0) && ($reference_len == 0)} { + # Cases: + # (a) reference == location + + set location . + } else { + # Cases: + # (b) ref is: ref/sub = sub + # loc is: ref = {} + + # (c) ref is: ref = {} + # loc is: ref/sub = sub + + while {$reference_len > 0} { + #set location [linsert $location 0 ..] + ledit location -1 -1 .. + incr reference_len -1 + } + set location [file join {*}$location] + } + return $location + } + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::path ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::path::lib { + namespace export * + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace punk::path::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::path::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +namespace eval punk::path::system { + #*** !doctools + #[subsection {Namespace punk::path::system}] + #[para] Internal functions that are not part of the API + + + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::path [namespace eval punk::path { + variable pkg punk::path + variable version + set version 0.2.0 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck-0.2.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck-0.2.0.tm new file mode 100644 index 00000000..351647d0 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck-0.2.0.tm @@ -0,0 +1,2479 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'dev 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 punkcheck 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + +package require punk::tdl +package require punk::path +package require punk::repo +package require punk::mix::util + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Punkcheck uses the TDL format which is a list of lists in Tcl format +# It is intended primarily for source build/distribution tracking within a punk project or single filesystem - with relative paths. +# +#see following article regarding the many problems with using mtime for build-decisions: https://apenwarr.ca/log/20181113 +# +namespace eval punkcheck { + namespace export {*}{ + uuid + installtrack + install + install_tm_files + install_non_tm_files + summarize_install_resultdict + } + + #exclude-paths entries match against the full relative path using globmatchpath. + #They may include ** to match across path segments and / to match within a segment. + #Each dir-seg pattern is expanded to both top-level and nested (**/) forms to preserve + #the "matches at any directory level" semantics of the former dir-seg mechanism. + variable default_excludepaths_core [list "#*" "**/#*" "_aside" "**/_aside" "_build" "**/_build" ".git" "**/.git" ".fossil*" "**/.fossil*"] + variable default_excludefiletail_core "" + #backward-compat: retained for callers that still read default_excludedirseg_core + variable default_excludedirseg_core [list "#*" "_aside" "_build" ".git" ".fossil*"] + + set has_twapi 0 + if {"windows" eq $::tcl_platform(platform)} { + set has_twapi [expr {![catch {package require twapi}]}] + } + if {$has_twapi} { + interp alias "" ::punkcheck::uuid "" ::twapi::new_uuid + } else { + catch {package require uuid} + interp alias "" ::punkcheck::uuid "" ::uuid::uuid generate + } + + proc default_excludepaths_core {} { + variable default_excludepaths_core + return $default_excludepaths_core + } + #backward-compat alias for the former segment-based default + proc default_excludedirseg_core {} { + variable default_excludedirseg_core + return $default_excludedirseg_core + } + proc default_excludefiletail_core {} { + variable default_excludefiletail_core + if {$default_excludefiletail_core eq ""} { + set default_excludefiletail_core [list "*.swp" "*[punk::mix::util::tm_version_magic]*" "*-buildversion.txt" ".punkcheck"] + } + return $default_excludefiletail_core + } + + + proc load_records_from_file {punkcheck_file} { + set record_list [list] + if {[file exists $punkcheck_file]} { + set tdlscript [punk::mix::util::fcat $punkcheck_file] + if {[catch { + set record_list [punk::tdl::prettyparse $tdlscript] + } errparse]} { + error "punkcheck::load_records_from_file failed to parse '$punkcheck_file'\n error:$errparse" + } + } + return $record_list + } + proc save_records_to_file {recordlist punkcheck_file {trigger {}} {debugchannel ""}} { + set newtdl [punk::tdl::prettyprint $recordlist] + set linecount [llength [split $newtdl \n]] + + if {$debugchannel ne "" && $trigger ne ""} { + puts $debugchannel "\x1b\[36mSaving [llength $recordlist] records as $linecount lines to file '$punkcheck_file' trigger: \x1b\[32m$trigger\x1b\[m" + } + #puts stdout $newtdl + set fd [open $punkcheck_file w] + chan configure $fd -translation binary + puts -nonewline $fd $newtdl + flush $fd + close $fd + return [list recordcount [llength $recordlist] linecount $linecount] + } + + + #todo - work out way to use same punkcheck file for multiple installers running concurrently. Thread? + #an installtrack objects represents an installation path from sourceroot to targetroot + #The source and target folders should be as specific as possible but it is valid to specify for example c:/ -> c:/ (or / -> /) if source and targets within the installation operation are spread around. + # + set objname [namespace current]::installtrack + if {$objname ni [info commands $objname]} { + package require oolib + + #FILEINFO record - target fileset with body records: INSTALL-RECORD,INSTALL-INPROGRESS,INSTALL-SKIPPED,DELETE-RECORD,DELETE-INPROGRESS,MODIFY-INPROGRESS,MODIFY-RECORD + #each FILEINFO body being a list of SOURCE records + oo::class create targetset { + variable o_targets + variable o_keep_installrecords + variable o_keep_skipped + variable o_keep_inprogress + variable o_records + constructor {args} { + #set o_records [oolib::collection create [namespace current]::recordcollection] + set o_records [list] + + } + + method as_record {} { + dict create {*}{ + } tag FILEINFO {*}{ + } -targets $o_targets {*}{ + } -keep_installrecords $o_keep_installrecords {*}{ + } -keep_skipped $o_keep_skipped {*}{ + } -keep_inprogress $o_keep_inprogress {*}{ + } body $o_records {*}{ + } + } + + #retrieve last completed record for the fileset ie exclude SKIPPED,INSTALL-INPROGRESS,DELETE-INPROGRESS,MODIFY-INPROGRESS + method get_last_record {fileset_record} { + set body [dict_getwithdefault $fileset_record body [list]] + set previous_records [lrange $body 0 end-1] + #get last previous that is tagged INSTALL-RECORD,MODIFY-RECORD,DELETE-RECORD + set revlist [lreverse $previous_records] + foreach rec $revlist { + switch -- [dict get $rec tag] { + INSTALL-RECORD - MODIFY-RECORD - DELETE-RECORD - VIRTUAL-RECORD { + return $rec + } + } + } + return [list] + } + } + + #instances created by an installtrack object in method start_event + #also in installtrack constructor - to represent existing events from the .punkcheck data + oo::class create installevent { + variable o_id + variable o_rel_sourceroot + variable o_rel_targetroot + variable o_ts_begin + variable o_ts_end + variable o_types + variable o_configdict + variable o_targets + variable o_operation + variable o_operation_start_ts + variable o_path_cksum_cache + variable o_fileset_record + variable o_installer ;#parent object + variable o_debugchannel + constructor {installer rel_sourceroot rel_targetroot args} { + set o_installer $installer + set o_debugchannel [$installer get_debugchannel] + set o_operation_start_ts "" + set o_path_cksum_cache [dict create] + set o_operation "" + set defaults [dict create {*}{ + -id "" + -tsbegin "" + -config {} + -tsend "" + -types {} + }] + set opts [dict merge $defaults $args] + if {[dict get $opts -id] eq ""} { + set o_id [punkcheck::uuid] + } else { + set o_id [dict get $opts -id] + } + if {[dict get $opts -tsbegin] eq ""} { + set o_ts_begin [clock microseconds] + } else { + set o_ts_begin [dict get $opts -tsbegin] + } + set o_ts_end [dict get $opts -tsend] + set o_types [dict get $opts -types] + set o_configdict [dict get $opts -config] + + set o_rel_sourceroot $rel_sourceroot + set o_rel_targetroot $rel_targetroot + } + destructor { + #puts "[self] destructor called" + } + method as_record {} { + set begin_seconds [expr {$o_ts_begin / 1000000}] + set tsiso_begin [clock format $begin_seconds -format "%Y-%m-%dT%H:%M:%S"] + if {$o_ts_end ne ""} { + set end_seconds [expr {$o_ts_end / 1000000}] + set tsiso_end [clock format $end_seconds -format "%Y-%m-%dT%H:%M:%S"] + } else { + set tsiso_end "" + } + + dict create {*}{ + } tag EVENT {*}{ + } -tsiso_begin $tsiso_begin {*}{ + } -ts_begin $o_ts_begin {*}{ + } -tsiso_end $tsiso_end {*}{ + } -ts_end $o_ts_end {*}{ + } -id $o_id {*}{ + } -source $o_rel_sourceroot {*}{ + } -targets $o_rel_targetroot {*}{ + } -types $o_types {*}{ + } -config $o_configdict {*}{ + } + } + method get_id {} { + return $o_id + } + method get_operation {} { + return $o_operation + } + method get_targets {} { + return $o_targets + } + method get_targets_exist {} { + set punkcheck_folder [file dirname [$o_installer get_checkfile]] + #puts stdout "### punkcheck glob -dir $punkcheck_folder -tails {*}$o_targets" + #targets can be paths such as punk/mix/commandset/module-0.1.0.tm - glob can search levels below supplied -dir + set existing [glob -nocomplain -dir $punkcheck_folder -tails {*}$o_targets] + + return $existing + } + method end {} { + set o_ts_end [clock microseconds] + } + method targetset_dict {} { + punk::records_as_target_dict [$o_installer get_recordlist] + } + + #related - installfile_begin + #call init before we know if we are going to run the operation vs skip + method targetset_init {operation targetset} { + set known_ops [list QUERY INSTALL MODIFY DELETE VIRTUAL] + if {[string toupper $operation] ni $known_ops} { + error "[self] add_target unknown operation '$operation'. Known operations $known_ops" + } + set o_operation [string toupper $operation] + + if {$o_operation_start_ts ne ""} { + error "[self] targetset_init $o_operation operation already in progress. Use targetset_finished or targetset_complete to finish." + } + set o_operation_start_ts [clock microseconds] + set seconds [expr {$o_operation_start_ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] + + set relativepath_targetset [list] + if {$o_operation eq "VIRTUAL"} { + foreach p $targetset { + lappend relativepath_targetset $p + } + } else { + foreach p $targetset { + if {[file pathtype $p] eq "absolute"} { + lappend relativepath_targetset [punkcheck::lib::path_relative $punkcheck_folder $p] + } else { + lappend relativepath_targetset $p + } + } + } + + + set fields [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $o_operation_start_ts {*}{ + } -installer [$o_installer get_name] {*}{ + } -eventid $o_id {*}{ + } + ] + + set o_targets [lsort -dictionary -increasing $relativepath_targetset] ;#exact sort order not critical - but must be consistent + + + set record_list [punkcheck::load_records_from_file $punkcheck_file] + + #--------------------------------------------------------------------------- + #load as dict to test for dupes + #set _targetdict [my targetset_dict] + if {[catch { + set _targetdict [punkcheck::recordlist::records_as_target_dict $record_list] + } errMsg]} { + error "targetset_init operation:$operation error verifying existing records from file $punkcheck_file. Error: $errMsg" + } + #--------------------------------------------------------------------------- + + set extractioninfo [punkcheck::recordlist::extract_or_create_fileset_record $o_targets $record_list] + set o_fileset_record [dict get $extractioninfo record] + set record_list [dict get $extractioninfo recordset] ;#if fileset wasn't present, same as original record_list, otherwise full recordset with the fileset record removed, ready for reinsertion. + set isnew [dict get $extractioninfo isnew] + set oldposition [dict get $extractioninfo oldposition] + unset extractioninfo + + #INSTALL-INPROGRESS will become INSTALL-RECORD or INSTALL-FAILED or INSTALL-SKIPPED upon finalisation + #-installer and -eventid keys are added here + set new_inprogress_record [dict create tag [string toupper $operation]-INPROGRESS {*}$fields -tempcontext [my as_record] body {}] + #set existing_body [dict_getwithdefault $o_fileset_record body [list]] + #todo - look for existing "-INPROGRESS" records - mark as failed or incomplete? + dict lappend o_fileset_record body $new_inprogress_record + + if {$isnew} { + lappend record_list $o_fileset_record + } else { + #set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record] + ledit record_list $oldposition -1 $o_fileset_record + } + if {$o_operation ne "QUERY"} { + punkcheck::save_records_to_file $record_list $punkcheck_file "targetset_init $o_operation [llength $targetset] targets" + } + return $o_fileset_record + + } + #operation has been started + #todo - upgrade .punkcheck format to hold more than just list of SOURCE entries in each record. + # - allow arbitrary targetset_startphase targetset_endphase calls to store timestamps and calculate elapsed time + method targetset_started {} { + set punkcheck_folder [file dirname [$o_installer get_checkfile]] + if {$o_operation eq "QUERY"} { + set fileinfo_body [dict get $o_fileset_record body] ;#body of FILEINFO record + set installing_record [lindex $fileinfo_body end] + + set ts_start [dict get $installing_record -ts] + set ts_now [clock microseconds] + set metadata_us [expr {$ts_now - $ts_start}] + + #?? + #JJJ + #dict set installing_record -metadata_us $metadata_us + dict set installing_record -ts_start_transfer $ts_now + + lset fileinfo_body end $installing_record + + return [dict set o_fileset_record body $fileinfo_body] + } else { + #legacy call + #saves to .punkcheck file + return [set o_fileset_record [punkcheck::installfile_started_install $punkcheck_folder $o_fileset_record]] + } + } + method targetset_end {status args} { + set defaults [dict create {*}{ + -note \uFFFF + }] + set known_opts [dict keys $defaults] + if {[llength $args] % 2} { + error "targetset_end arguments after status must be in the form of -flag value pairs. known flags: $known_opts" + } + set opts [dict merge $defaults $args] + if {[dict get $opts -note] eq "\uFFFF"} { + dict unset opts -note + } + + set status [string toupper $status] + set statusdict [dict create OK RECORD SKIPPED SKIPPED FAILED FAILED] + if {$o_operation_start_ts eq ""} { + error "[self] targetset_end $status - no current operation - call targetset_started first" + } + if {$status ni [dict keys $statusdict]} { + error "[self] targetset_end unrecognized status:$status known values: [dict keys $statusdict]" + } + if {![punkcheck::lib::is_file_record_inprogress $o_fileset_record]} { + error "targetset_end $status error: bad fileset_record - expected FILEINFO with last body element *-INPROGRESS" + } + set targetlist [dict get $o_fileset_record -targets] + if {$targetlist ne $o_targets} { + error "targetset_end $status error. targetlist mismatch between file : $targetlist vs $o_targets" + } + set operation_end_ts [clock microseconds] + set elapsed_us [expr {$operation_end_ts - $o_operation_start_ts}] + set file_record_body [dict get $o_fileset_record body] + set installing_record [lindex $file_record_body end] + set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] + set record_list [punkcheck::load_records_from_file $punkcheck_file] + if {[dict exists $installing_record -ts_start_transfer]} { + set ts_start_transfer [dict get $installing_record -ts_start_transfer] + set transfer_us [expr {$operation_end_ts - $ts_start_transfer}] + dict set installing_record -transfer_us $transfer_us + } + if {[dict exists $opts -note]} { + dict set installing_record -note [dict get $opts -note] + } + + dict set installing_record -elapsed_us $elapsed_us + dict unset installing_record -tempcontext + dict set installing_record tag "${o_operation}-[dict get $statusdict $status]" ;# e.g INSTALL-RECORD, INSTALL-SKIPPED + if {$o_operation in [list INSTALL MODIFY] && [dict get $statusdict $status] eq "RECORD"} { + #only calculate and store post operation target cksums on successful INSTALL or MODIFY, doesn't make sense for DELETE or VIRTUAL operations + set new_targets_cksums [list] ;#ordered list of cksums matching targetset order + set cksum_all_opts "" ;#same cksum opts for each target so we store it once + set ts_begin_cksum [clock microseconds] + foreach p $o_targets { + set tgt_cksum_info [punk::mix::base::lib::cksum_path [file join $punkcheck_folder $p]] + lappend new_targets_cksums [dict get $tgt_cksum_info cksum] + if {$cksum_all_opts eq ""} { + set cksum_all_opts [dict get $tgt_cksum_info opts] + } + } + set cksum_us [expr {[clock microseconds] - $ts_begin_cksum}] + dict set installing_record -targets_cksums $new_targets_cksums + dict set installing_record -cksum_all_opts $cksum_all_opts + dict set installing_record -cksum_us $cksum_us + } + lset file_record_body end $installing_record + dict set o_fileset_record body $file_record_body + set o_fileset_record [punkcheck::recordlist::file_record_prune $o_fileset_record] + + set oldrecordinfo [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $oldrecordinfo position] + if {$old_posn == -1} { + lappend record_list $o_fileset_record + } else { + lset record_list $old_posn $o_fileset_record + } + if {$o_operation ne "QUERY"} { + punkcheck::save_records_to_file $record_list $punkcheck_file "targetset_end $o_operation $status [llength $o_targets] targets" + } + set o_operation_start_ts "" + set o_operation "" + return $o_fileset_record + } + #can supply empty cksum value + # - that will influence the opts used if there is no existing install record + method targetset_cksumcache_set {path_cksum_dict} { + set o_path_cksum_cache $path_cksum_dict + } + method targetset_cksumcache_configure {path {cksuminfodict {}}} { + if {$cksuminfodict eq {}} { + if {[dict exists $o_path_cksum_cache $path]} { + return [dict get $o_path_cksum_cache $path] + } else { + return + } + } + dict for {k v} $cksuminfodict { + switch -- $k { + cksum - opts {} + default { + error "targetset_cksumcache_configure error. Unknown dict value $k. Allowed values {cksum opts}" + } + } + } + dict set o_path_cksum_cache $path $cksuminfodict + } + method targetset_addsource {source_path} { + set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] + if {[file pathtype $source_path] eq "absolute"} { + set rel_source_path [punkcheck::lib::path_relative $punkcheck_folder $source_path] + } else { + set rel_source_path $source_path + } + + #installfile_add_source_and_fetch_metadata accepts list of {cksum opt } dictionaries - although we only have one per path from our configured cksumcache + if {[dict exists $o_path_cksum_cache $rel_source_path]} { + set path_cksum_caches [list [dict get $o_path_cksum_cache $rel_source_path]] + } else { + set path_cksum_caches [list] + } + set o_fileset_record [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $rel_source_path $o_fileset_record $path_cksum_caches] + #JJJ - update -metadata_us here? + + } + method targetset_last_complete {} { + #retrieve last completed record for the fileset ie exclude SKIPPED,INSTALL-INPROGRESS,DELETE-INPROGRESS,MODIFY-INPROGRESS + set body [punkcheck::dict_getwithdefault $o_fileset_record body [list]] + set previous_records [lrange $body 0 end] + #get last that is tagged INSTALL-RECORD,MODIFY-RECORD,DELETE-RECORD + set revlist [lreverse $previous_records] + foreach rec $revlist { + if {[dict get $rec tag] in [list "INSTALL-RECORD" "MODIFY-RECORD" "DELETE-RECORD" "VIRTUAL-RECORD"]} { + return $rec + } + } + return [list] + + } + method targetset_source_changes {} { + punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $o_fileset_record body] end] + } + + } + + + oo::class create installtrack { + variable o_name + variable o_tsiso + variable o_ts + variable o_keep_events + variable o_checkfile + variable o_sourceroot + variable o_rel_sourceroot + variable o_targetroot + variable o_rel_targetroot + variable o_record_list + variable o_active_event + variable o_events + variable o_debugchannel + constructor {installername punkcheck_file {debugchannel ""}} { + set o_debugchannel $debugchannel + set o_active_event "" + set o_name $installername + + set o_checkfile [file normalize $punkcheck_file] + set o_sourceroot "" + set o_targetroot "" + set o_rel_sourceroot "" + set o_rel_targetroot "" + set o_record_list [list] + + #todo - validate punkcheck file location further?? + set punkcheck_folder [file dirname $o_checkfile] + if {![file isdirectory $punkcheck_folder]} { + error "[self] constructor error. Folder for punkcheck_file not found - $o_checkfile" + } + + my load_all_records + if {![llength $o_record_list] && $o_debugchannel ne ""} { + puts $o_debugchannel "\x1b\[32mNo existing records found in punkcheck file '$o_checkfile' for installer '$installername'. Starting with empty record list.\x1b\[m" + } else { + #verify no duplicate installer records for this installer. + #JMN + set sanity_dict [dict create] + set insane "" + foreach rec $o_record_list { + if {[dict get $rec tag] eq "INSTALLER"} { + set name [dict get $rec -name] + if {[dict exists $sanity_dict $name]} { + #todo - warn - duplicate record for same targetlist - shouldn't happen as we should be using get_file_record to find existing records + if {$o_debugchannel ne ""} { + puts $o_debugchannel "\x1b\[31mpunkcheck installtrack - multiple INSTALLER records with same name '$name'\x1b\[m" + } + set insane "$name" + break + } + dict set sanity_dict $name {} + } + } + if {$insane ne ""} { + set msg "Sanity check: punkcheck file '$o_checkfile' contains multiple records for INSTALLER -name '$insane'." + append msg \n "This may indicate a problem such as multiple concurrent installtrack instances using the same punkcheck file," + append msg \n " or a previous installtrack instance that did not complete properly." + append msg \n " Do you want to DELETE the .punkcheck file?" + append msg \n " It is safe to delete .punkcheck files, at the cost of loss of history and checksums used to optimize installs." + append msg \n " They are a record of installation events and checksums used to avoid unnecessary reinstalls." + append msg \n " If not confirmed, an error will be raised - likely aborting the current operation." + append msg \n "confirm deletion and continue by regenerating the file, by typing the 3 letters: 'yes'." + set answer [punk::lib::askuser $msg] + if {[string tolower $answer] ne "yes"} { + error "Failing due to sanity check failure. User did not confirm with 'yes'." + } + if {[file exists $o_checkfile] && [file isfile $o_checkfile]} { + file delete $o_checkfile + } + if {[file exists $o_checkfile]} { + error "Failed to delete punkcheck file '$o_checkfile' after sanity check failure. Please investigate and resolve the issue before proceeding." + } + set o_record_list [list] + } else { + if {$o_debugchannel ne ""} { + puts $o_debugchannel "\x1b\[32mSanity check passed: no duplicate INSTALLER records found for installer '$installername' in punkcheck file '$o_checkfile'.\x1b\[m" + } + } + unset sanity_dict + } + + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + set this_installer_record [punkcheck::recordlist::new_installer_record $o_name] + #set o_record_list [linsert $o_record_list 0 $this_installer_record] + ledit o_record_list -1 -1 $this_installer_record + } else { + set this_installer_record [dict get $resultinfo record] + } + set o_tsiso [dict get $this_installer_record -tsiso] + set o_ts [dict get $this_installer_record -ts] + set o_keep_events [dict get $this_installer_record -keep_events] + + set o_events [oolib::collection create [namespace current]::eventcollection] + set eventlist [punkcheck::dict_getwithdefault $this_installer_record body [list]] + foreach e $eventlist { + set eobj [punkcheck::installevent create [namespace current]::event_[my events count] [self] [dict get $e -source] [dict get $e -targets] {*}$e] + #$o_events add $e [dict get $e -id] + $o_events add $eobj [dict get $e -id] + } + + } + destructor { + #puts "[self] destructor called" + } + method test {} { + return [self] + } + method get_name {} { + return $o_name + } + method get_checkfile {} { + return $o_checkfile + } + method get_debugchannel {} { + return $o_debugchannel + } + + #call set_source_target before calling start_event/end_event + #each event can have different source->target pairs - but may often have same, so set on installtrack as defaults. Only persisted in event records. + method set_source_target {sourceroot targetroot} { + if {[file pathtype $sourceroot] ne "absolute"} { + error "[self] set_source_target error: sourceroot must be absolute path. Received '$sourceroot'" + } + if {[file pathtype $targetroot] ne "absolute"} { + error "[self] set_source_target error: targetroot must be absolute path. Received '$targetroot'" + } + set punkcheck_folder [file dirname $o_checkfile] + set o_sourceroot $sourceroot + set o_targetroot $targetroot + set o_rel_sourceroot [punkcheck::lib::path_relative $punkcheck_folder $sourceroot] + set o_rel_targetroot [punkcheck::lib::path_relative $punkcheck_folder $targetroot] + return [list $o_rel_sourceroot $o_rel_targetroot] + } + #review/fix to allow multiple installtrack objects on same punkcheck file. + method load_all_records {} { + set o_record_list [punkcheck::load_records_from_file $o_checkfile] + } + + #does not include associated FILEINFO records - as a targetset (FILEINFO record) can be associated with events from multiple installers over time. + #e.g a logfile common to installers, or a separate installer that updates a previous output. + method as_record {} { + set eventrecords [list] + foreach eobj [my events items] { + lappend eventrecords [$eobj as_record] + } + set fields [list {*}{ + } -tsiso $o_tsiso {*}{ + } -ts $o_ts {*}{ + } -name $o_name\ {*}{ + } -keep_events $o_keep_events {*}{ + } body $eventrecords {*}{ + } + ] + set record [dict create tag INSTALLER {*}$fields] + } + #open file and save only own records + method save_all_records {} { + my save_installer_record + #todo - save FILEINFO targetset records + } + method save_installer_record {} { + set file_records [punkcheck::load_records_from_file $o_checkfile] + + set this_installer_record [my as_record] + + set persistedinfo [punkcheck::recordlist::get_installer_record $o_name $file_records] + set existing_header_posn [dict get $persistedinfo position] + if {$existing_header_posn == -1} { + #set file_records [linsert $file_records 0 $this_installer_record] + ledit file_records -1 -1 $this_installer_record + } else { + lset file_records $existing_header_posn $this_installer_record + } + punkcheck::save_records_to_file $file_records $o_checkfile "save_installer_record" + } + method events {args} { + tailcall $o_events {*}$args + } + method start_event {configdict} { + if {$o_active_event ne ""} { + error "[self] start_event error - event already started: $o_active_event" + } + if {$o_rel_sourceroot eq "" || $o_rel_targetroot eq ""} { + error "[self] No configured sourceroot or targetroot. Call [self] set_source_target first" + } + + if {[llength $configdict] %2 != 0} { + error "[self] new_event configdict must have an even number of elements" + } + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + error "[self] start_event - installer record missing. installer: $o_name" + } else { + set this_installer_record [dict get $resultinfo record] + } + + set eventobj [punkcheck::installevent create [namespace current]::event_[my events count] [self] $o_rel_sourceroot $o_rel_targetroot -config $configdict] + set eventid [$eventobj get_id] + set event_record [$eventobj as_record] + + set this_installer_record [punkcheck::recordlist::installer_record_add_event $this_installer_record $event_record] + set this_installer_record [punkcheck::recordlist::installer_record_pruneevents $this_installer_record $o_record_list] + + #replace + lset o_record_list $existing_header_posn $this_installer_record + + punkcheck::save_records_to_file $o_record_list $o_checkfile "start_event $eventid" + set o_active_event $eventobj + my events add $eventobj $eventid + return $eventobj + } + method installer_record_from_file {} { + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + } + method get_recordlist {} { + return $o_recordlist + } + method end_event {} { + if {$o_active_event eq ""} { + error "[self] end_event error - no active event" + } + $o_active_event end + } + method get_event {} { + return $o_active_event + } + } + } + proc start_installer_event {punkcheck_file installername from_fullpath to_fullpath config} { + set eventid [punkcheck::uuid] + if {[file pathtype $from_fullpath] ne "absolute"} { + error "start_installer_event error: from_fullpath must be absolute path. Received '$from_fullpath'" + } + if {[file pathtype $to_fullpath] ne "absolute"} { + error "start_installer_event error: to_fullpath must be absolute path. Received '$to_fullpath'" + } + set punkcheck_folder [file dirname $punkcheck_file] + set rel_source [punkcheck::lib::path_relative $punkcheck_folder $from_fullpath] + set rel_target [punkcheck::lib::path_relative $punkcheck_folder $to_fullpath] + + + set record_list [punkcheck::load_records_from_file $punkcheck_file] + set resultinfo [punkcheck::recordlist::get_installer_record $installername $record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + set this_installer_record [punkcheck::recordlist::new_installer_record $installername] + } else { + set this_installer_record [dict get $resultinfo record] + } + + set event_record [punkcheck::recordlist::new_installer_event_record install {*}{ + -id $eventid + -source $rel_source + -targets $rel_target + -config $config + }] + + set this_installer_record [punkcheck::recordlist::installer_record_add_event $this_installer_record $event_record] + set this_installer_record [punkcheck::recordlist::installer_record_pruneevents $this_installer_record $record_list] + + if {$existing_header_posn == -1} { + #not found - prepend + #set record_list [linsert $record_list 0 $this_installer_record] + ledit record_list -1 -1 $this_installer_record + } else { + #replace + lset record_list $existing_header_posn $this_installer_record + } + + punkcheck::save_records_to_file $record_list $punkcheck_file "start_installer_event $eventid" + return [list eventid $eventid recordset $record_list] + } + #----------------------------------------------- + proc installfile_help {} { + set msg "" + append msg "Call in order:" \n + append msg " start_installer_event (get dict with eventid and recordset keys)" + append msg " installfile_begin (to return a new INSTALLING record) - must pass in a valid eventid" \n + append msg " installfile_add_source_and_fetch_metadata (1+ times to update SOURCE record with checksum/timestamp info from source)" \n + append msg " ( - possibly with same algorithm as previous installrecord)" \n + append msg " ( - todo - search/load metadata for this source from other FILEINFO records for same installer)" \n + append msg "Finalize by calling:" \n + append msg " installfile_started_install" \n + append msg " (install the file e.g file copy)" \n + append msg " installfile_finished_install" \n + append msg " OR" \n + append msg " installfile_skipped_install" \n + } + proc installfile_begin {punkcheck_folder target_relpath installername args} { + if {[llength $args] %2 !=0} { + error "punkcheck installfile_begin args must be name-value pairs" + } + set target_relpath [lsort -dictionary -increasing $target_relpath] ;#exact sort order not critical - but must be consistent + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set defaults [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $ts {*}{ + } -installer $installername {*}{ + } -eventid unspecified {*}{ + } + ] + set opts [dict merge $defaults $args] + set opt_eventid [dict get $opts -eventid] + + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set resultinfo [punkcheck::recordlist::get_installer_record $installername $record_list] + set installer_record_position [dict get $resultinfo position] + if {$installer_record_position == -1} { + error "installfile_begin error: Failed to retrieve installer record for installer name:'$installername' - ensure start_installer_event has been called with same installer, and -eventid is passed to installfile_begin" + } + set this_installer_record [dict get $resultinfo record] + set events [dict get $this_installer_record body] + set active_event [list] + foreach evt [lreverse $events] { + if {[dict get $evt -id] eq $opt_eventid} { + set active_event $evt + break + } + } + if {![llength $active_event]} { + error "installfile_begin error: eventid $opt_eventid not found for installer '$installername' - aborting" + } + + + set extractioninfo [punkcheck::recordlist::extract_or_create_fileset_record $target_relpath $record_list] + set file_record [dict get $extractioninfo record] + set record_list [dict get $extractioninfo recordset] + set isnew [dict get $extractioninfo isnew] + set oldposition [dict get $extractioninfo oldposition] + unset extractioninfo + + #INSTALL-INPROGRESS will become INSTALL-RECORD or INSTALL-FAILED or INSTALL-SKIPPED upon finalisation + #-installer and -eventid keys are added here + set new_installing_record [dict create tag INSTALL-INPROGRESS {*}$opts -tempcontext $active_event body {}] + #set existing_body [dict_getwithdefault $file_record body [list]] + #todo - look for existing "INSTALL-INPROGRESS" records - mark as failed? + dict lappend file_record body $new_installing_record + + if {$isnew} { + lappend record_list $file_record + } else { + #set record_list [linsert $record_list[unset record_list] $oldposition $file_record] + ledit record_list $oldposition -1 $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_begin $installername $opt_eventid $target_relpath" + return $file_record + } + + #todo - ensure that removing a dependency is noticed as a change + #e.g previous installrecord had 2 source records - but we now only depend on one. + #The files we depended on for the previous record haven't changed themselves - but the list of files has (reduced by one) + #cached_cksums is list of dicts with keys cksum & opts + #Will only be used if any opts values present match those from file_record's -cksum_all_opts (in last install record) or first cached_cksum will be used if no last install record values + proc installfile_add_source_and_fetch_metadata {punkcheck_folder source_relpath file_record {cached_cksums {}}} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_add_source_and_fetch_metadata error: bad file_record - expected FILEINFO with last body element *-INPROGRESS ($file_record)" + } + #validate any passed cached_cksums + foreach cacheinfo $cached_cksums { + if {[llength $cacheinfo] % 2 != 0} { + error "installfile_add_source_and_fetch_metadata error.If cached_cksums is supplied, it must be a list of dicts containing keys cksum & opts" + } + dict for {k v} $cacheinfo { + switch -- $k { + cksum {} + opts { + #todo - validate $v keys + } + default { + error "installfile_add_source_and_fetch_metadata error. Unrecognised key $k. Known keys {cksum opts}" + } + } + + } + } + set ts_start [clock microseconds] + set last_installrecord [lib::file_record_get_last_installrecord $file_record] + set prev_ftype "" + set prev_fsize "" + set prev_cksum "" + set prev_cksum_opts "" + if {[llength $last_installrecord]} { + set src [lib::install_record_get_matching_source_record $last_installrecord $source_relpath] + if {[llength $src]} { + if {[dict_getwithdefault $src -path ""] eq $source_relpath} { + set prev_ftype [dict_getwithdefault $src -type ""] + set prev_fsize [dict_getwithdefault $src -size ""] + set prev_cksum [dict_getwithdefault $src -cksum ""] + set prev_cksum_opts [dict_getwithdefault $src -cksum_all_opts ""] + } + } + } + #check that this relpath not already added as child of *-INPROGRESS + set file_record_body [dict_getwithdefault $file_record body [list]] ;#new file_record may have no body + set installing_record [lindex $file_record_body end] + set already_present_record [lib::install_record_get_matching_source_record $installing_record $source_relpath] + if {[llength $already_present_record]} { + error "installfile_add_source_and_fetch_metadata error: source path $source_relpath already exists in the file_record - cannot add again" + } + + set use_cache 0 + if {$prev_cksum_opts ne ""} { + set cksum_opts $prev_cksum_opts + #find first cached_cksum that is compatible with cksum opts used in latest install record + foreach cacheinfo $cached_cksums { + set cachedopts [dict get $cacheinfo opts] + set cache_is_match 1 + dict for {k v} $cachedopts { + if {[dict exists $prev_cksum_opts $k] && $v ne [dict get $prev_cksum_opts $k]} { + set cache_is_match 0 + break + } + } + if {$cache_is_match} { + set use_cache_record $cacheinfo + set use_cache 1 + break + } + } + + } else { + #no cksum opts available from an install record + set cksum_opts "" + #use first entry in cached_cksums if we can + if {[llength $cached_cksums]} { + set use_cache 1 + set use_cache_record [lindex $cached_cksums 0] + } + } + + #todo - accept argument of cached source cksum info (for client calling multiple targets with same source in quick succession e.g when building .vfs kits with multiple runtimes) + #if same cksum_opts - then use cached data instead of checksumming here. + + #allow nonexistant as a source + set fpath [file join $punkcheck_folder $source_relpath] + #windows: file exist + file type = 2ms vs 500ms for 2x glob + set floc [file dirname $fpath] + set fname [file tail $fpath] + set file_set [glob -nocomplain -dir $floc -type f -tails -- $fname] + set dir_set [glob -nocomplain -dir $floc -type d -tails -- $fname] + set link_set [glob -nocomplain -dir $floc -type l -tails -- $fname] + if {[llength $file_set] == 0 && [llength $dir_set] == 0 && [llength $link_set] == 0} { + #could also theoretically exist as less common types, b,c,p,s (block,char,pipe,socket) + #- we don't expect them here - REVIEW - ever possible? + #- installing/examining such things an unlikely usecase and would require special handling anyway. + set ftype "missing" + set fsize "" + } else { + if {[llength $dir_set]} { + set ftype "directory" + set fsize "NA" + } elseif {[llength $link_set]} { + set ftype "link" + set fsize 0 + } else { + set ftype "file" + #todo - optionally use mtime instead of cksum (for files only)? + #mtime is not reliable across platforms and filesystems though.. see article linked at top. + set fsize [file size $fpath] + } + } + + #if {![file exists $fpath]} { + # set ftype "missing" + # set fsize "" + #} else { + # set ftype [file type $fpath] + # if {$ftype eq "directory"} { + # set fsize "NA" + # } else { + # #todo - optionally use mtime instead of cksum (for files only)? + # #mtime is not reliable across platforms and filesystems though.. see article linked at top. + # set fsize [file size $fpath] + # } + #} + #get_relativecksum_from_base and fill_relativecksums_from_base_and_relativepathdict will set cksum to if fpath doesn't exist + if {$use_cache} { + set source_cksum_info [punk::mix::base::lib::fill_relativecksums_from_base_and_relativepathdict $punkcheck_folder [dict create $source_relpath $use_cache_record]] + } else { + set source_cksum_info [punk::mix::base::lib::get_relativecksum_from_base $punkcheck_folder $source_relpath {*}$cksum_opts] + } + + + lassign $source_cksum_info pathkey ckinfo + if {$pathkey ne $source_relpath} { + error "installfile_add_source_and_fetch_metadata error: cksum returned wrong path info '$pathkey' expected '$source_relpath'" + } + set cksum [dict get $ckinfo cksum] + #set cksum_all_opts [dict get $ckinfo cksum_all_opts] + set cksum_all_opts [dict get $ckinfo opts] + if {$cksum ne $prev_cksum || $ftype ne $prev_ftype || $fsize ne $prev_fsize} { + set changed 1 + } else { + set changed 0 + } + set installing_record_sources [dict_getwithdefault $installing_record body [list]] + set ts_now [clock microseconds] ;#gathering metadata - especially checksums on folder can take some time - calc and store elapsed us for time taken to gather metadata + set metadata_us [expr {$ts_now - $ts_start}] + set this_source_record [dict create tag SOURCE -type $ftype -size $fsize -path $source_relpath -cksum $cksum -cksum_all_opts $cksum_all_opts -changed $changed -metadata_us $metadata_us] + lappend installing_record_sources $this_source_record + dict set installing_record body $installing_record_sources + + lset file_record_body end $installing_record + + dict set file_record body $file_record_body + return $file_record + } + + #write back to punkcheck - don't accept recordset - invalid to update anything other than the installing_record at this time + proc installfile_started_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_started_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set ts_now [clock microseconds] + set metadata_us [expr {$ts_now - $ts_start}] + + dict set installing_record -metadata_us $metadata_us + dict set installing_record -ts_start_transfer $ts_now + + lset file_record_body end $installing_record + + dict set file_record body $file_record_body + + + set getresult [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $getresult position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_started_install [llength $targetlist] targets" + return $file_record + } + proc installfile_finished_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_finished_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set ts_start_transfer [dict get $installing_record -ts_start_transfer] + set ts_now [clock microseconds] + set elapsed_us [expr {$ts_now - $ts_start}] + set transfer_us [expr {$ts_now - $ts_start_transfer}] + dict set installing_record -transfer_us $transfer_us + dict set installing_record -elapsed_us $elapsed_us + dict unset installing_record -tempcontext + dict set installing_record tag "INSTALL-RECORD" + + lset file_record_body end $installing_record + dict set file_record body $file_record_body + + set file_record [punkcheck::recordlist::file_record_prune $file_record] + + set oldrecordinfo [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $oldrecordinfo position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_finished_install [llength $targetlist] targets" + return $file_record + } + proc installfile_skipped_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + set msg "installfile_skipped_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + append msg \n "received:" + append msg \n $file_record + error $msg + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set tsnow [clock microseconds] + set elapsed_us [expr {$tsnow - $ts_start}] + dict set installing_record -elapsed_us $elapsed_us + dict set installing_record tag "INSTALL-SKIPPED" + + lset file_record_body end $installing_record + dict set file_record body $file_record_body + + set file_record [punkcheck::recordlist::file_record_prune $file_record] + + set getresult [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $getresult position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_skipped_install [llength $targetlist] targets" + return $file_record + } + #----------------------------------------------- + #then: file_record_add_installrecord + + namespace eval lib { + set pkg punkcheck + namespace path ::punkcheck + proc is_file_record_inprogress {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + return 0 + } + set installing_record [lindex [dict_getwithdefault $file_record body [list]] end] + if {[dict_getwithdefault $installing_record tag [list]] ni [list QUERY-INPROGRESS INSTALL-INPROGRESS MODIFY-INPROGRESS DELETE-INPROGRESS VIRTUAL-INPROGRESS]} { + return 0 + } + return 1 + } + proc is_file_record_installing {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + return 0 + } + set installing_record [lindex [dict_getwithdefault $file_record body [list]] end] + if {[dict_getwithdefault $installing_record tag [list]] ne "INSTALL-INPROGRESS"} { + return 0 + } + return 1 + } + proc file_record_get_last_installrecord {file_record} { + set body [dict_getwithdefault $file_record body [list]] + set previous_install_records [lrange $body 0 end-1] + #get last previous that is tagged INSTALL-RECORD,MODIFY-RECORD,VIRTUAL-RECORD + #REVIEW DELETERECORD ??? + set revlist [lreverse $previous_install_records] + foreach rec $revlist { + if {[dict get $rec tag] in [list "INSTALL-RECORD" "MODIFY-RECORD" "VIRTUAL-RECORD"]} { + return $rec + } + } + return [list] + } + + #should work on *-INPROGRESS or INSTALL(etc) record - don't restrict tag to INSTALL + proc install_record_get_matching_source_record {install_record source_relpath} { + set body [dict_getwithdefault $install_record body [list]] + foreach src $body { + if {[dict get $src tag] eq "SOURCE"} { + if {[dict_getwithdefault $src -path ""] eq $source_relpath} { + return $src + } + } + } + return [list] + } + + + + # Delegate to punk::path::relative (verified equivalent implementation) + proc path_relative {base dst} { + return [punk::path::relative $base $dst] + } + } + #skip writing punkcheck during checksum/timestamp checks + + #todo - punk::args - fetch from punkcheck::install (with overrides) + proc install_tm_files {srcdir basedir args} { + set defaults [list {*}{ + -glob *.tm + -installer punkcheck::install_tm_files + } -exclude-filetails [list "*[punk::mix::util::tm_version_magic]*"] {*}{ + } + ] + set opts [dict merge $defaults $args] + punkcheck::install $srcdir $basedir {*}$opts + } + proc install_non_tm_files {srcdir basedir args} { + #set keys [dict keys $args] + #adjust the default exclude-paths_core entries so that .fossil-custom, .fossil-settings are copied + set excludepaths_core [punkcheck::default_excludepaths_core] + #remove .fossil* entries (both top-level and **/ forms) so fossil folders are not excluded + set excludepaths_core [lsearch -inline -all -not $excludepaths_core ".fossil*"] + set excludepaths_core [lsearch -inline -all -not $excludepaths_core "**/.fossil*"] + set defaults [list {*}{ + } -glob * {*}{ + } -exclude-filetails [list "*.tm" "*-buildversion.txt" "*.exe"] {*}{ + } -exclude-paths-core $excludepaths_core {*}{ + } -installer punkcheck::install_non_tm_files {*}{ + } + ] + set opts [dict merge $defaults $args] + punkcheck::install $srcdir $basedir {*}$opts + } + + #for tcl8.6 - tcl8.7+ has dict getwithdefault (dict getdef) + proc dict_getwithdefault {dictValue args} { + if {[llength $args] < 2} { + error {wrong # args: should be "dict_getdef dictionary ?key ...? key default"} + } + set keys [lrange $args 0 end-1] + if {[dict exists $dictValue {*}$keys]} { + return [dict get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + lappend PUNKARGS [list { + @id -id ::punkcheck::install + @cmd -name ::punkcheck::install -help\ + "Unidirectional file transfer to possibly non-empty target folder. + This is the simpler form of the API, performing a transfer from one + directory tree to another, copying each file when changes in the source + file are detected. + Changes are detected by content checksum. The first install will record + source checksums in a .punkcheck file (ideally located at the root of the + target folder). Subsequent installs will compare stored checksums with + the current checksums of the source files. + For more advanced install operations, the object command installtrack + can be used to define install operations. e.g when the transfer is not + one-to-one and a target file depends on multiple source files." + @leaders -min 2 -max 2 + srcdir -type directory + tgtdir -type directory + -call-depth-internal -type integer -default 0 -help "(internal recursion tracker)" + -subdirlist -type list -default "" -help "(primarily internal - length generally matching -call-depth-internal)" + -max-depth -type integer -default 1000 -help\ + "Deepest subdirectory - use -1 for no limit." + -createdir -type boolean -default 0 -help\ + "Whether to create the folder at tgtdir. + Any required subdirectories are created regardless of this setting." + -createempty -type boolean -default 0 -help\ + "Whether to create folders at target that had no matches for our glob" + -glob -type string -default "*" -help\ + "Pattern matching for source file(s) to copy. Can be glob based or exact match." + -exclude-filetails-core -default {${[::punkcheck::default_excludefiletail_core]}} -help\ + "Non-overridable default file-tail exclusion patterns. + These are applied in addition to -exclude-filetails and cannot be + disabled by the caller - they can only be replaced by passing + -exclude-filetails-core with a different list. + Patterns use string match against the file tail (basename) at any + level in the tree. They must not contain path separators." + -exclude-filetails -default "" -help\ + "List of glob patterns to match against file tails (basenames). + Patterns use string match and must not contain path separators. + e.g {*.swp *.tmp} excludes swap and temp files at any level." + -exclude-paths-core -default {${[::punkcheck::default_excludepaths_core]}} -help\ + "Non-overridable default path-glob exclusion patterns. + These are applied in addition to -exclude-paths and cannot be + disabled by the caller - they can only be replaced by passing + -exclude-paths-core with a different list. + Patterns are matched against the full relative source path using + punk::path::globmatchpath." + -exclude-paths -default {} -help\ + "List of path-glob patterns to exclude from installation. + Patterns are matched against the full relative source path using + punk::path::globmatchpath, so they may include ** to match across + path segments and / to match within a segment. + e.g to exclude all AGENTS.md files at any depth: {AGENTS.md **/AGENTS.md}" + #backward-compat aliases (accepted but deprecated - converted internally to -exclude-paths) + -exclude-dirsegments-core -default {${[::punkcheck::default_excludedirseg_core]}} -help\ + "DEPRECATED: use -exclude-paths-core instead. + Legacy segment-glob patterns matched against directory tail names. + Converted internally to path-glob form by expanding each segment + S to {S **/S}." + -exclude-dirsegments -default "" -help\ + "DEPRECATED: use -exclude-paths instead. + Legacy segment-glob patterns matched against directory tail names + at any level. Each pattern must not contain path separators." + -antiglob-paths -default {} -help\ + "DEPRECATED: use -exclude-paths instead. + Legacy path-glob patterns matched against the full relative source + path using punk::path::globmatchpath. Merged into -exclude-paths + internally." + -overwrite -default no-targets\ + -choices {no-targets newer-targets older-targets all-targets installedsourcechanged-targets synced-targets}\ + -choicecolumns 1\ + -choicelabels { + no-targets "only copy files that are missing at the target" + newer-targets "copy files with older source timestamp over newer + target timestamp and those missing at the target + (a form of 'restore' operation)" + older-targets "copy files with newer source timestamp over older + target timestamp and those missing at the target" + all-targets "copy regardless of timestamp at target" + installedsourcechanged-targets "copy if the target doesn't exist or the source changed" + synced-targets "copy if the target doesn't exist or the source changed + and the target cksum is the same as the last INSTALL-RECORD -targets_cksums entry" + } + -source-checksum -default comparestore -choicecolumns 3 -choices {compare store comparestore false true} -help\ + "Checksum behavior for source files. + compare: checksum and compare against last record, but do not store. + store: checksum and store, but do not compare against last record. + comparestore: checksum, compare against last record, and store. + false: do not checksum (not recommended - changes cannot be detected). + true: same as comparestore." + -punkcheck-folder -default target -choices {target source project} -choicerestricted 0 -help\ + "The location of the .punkcheck file to track installations and checksums. + The default value 'target' is generally recommended. + Can also be an absolute path to a folder." + -punkcheck-eventid -default "" -help\ + "Event ID for the install operation. When empty (default), a new UUID + is generated automatically. Pass a specific ID to group multiple + install calls under the same event in the .punkcheck file." + -punkcheck-records -default "" -help\ + "Empty string or a parsed TDL records structure. + e.g + {tag FILEINFO - ... body { + {tag INSTALL-RECORD - ... body {}} + ... + }... + }" + -installer -default "punkcheck::install" -help\ + "A user nominated string that is stored in the .punkcheck file + This might be the name of a script or installation process." + -progresschannel -default none -type string -help\ + "Name of channel e.g stderr, stdout to which progress messages are written. + This includes the tree-like output consisting of dots (or green U) for each + file processed. As the number of files in a tree is not known beforehand, + it isn't useful for a percentage-based progress meter, but it could potentially + be used to drive a spinner if the textual data is not desired. + Setting to none or an invalid channel will deactivate the output." + }] + ## unidirectional file transfer to possibly non empty folder + #default of -overwrite no-targets will only copy files that are missing at the target + # -overwrite newer-targets will copy files with older source timestamp over newer target timestamp and those missing at the target (a form of 'restore' operation) + # -overwrite older-targets will copy files with newer source timestamp over older target timestamp and those missing at the target + # -overwrite all-targets will copy regardless of timestamp at target + # -overwrite installedsourcechanged-targets will copy if the target doesn't exist or the source changed + # -overwrite synced-targets will copy if the target doesn't exist or the source changed and the target cksum is the same as the last INSTALL-RECORD -targets_cksums entry + # review - timestamps unreliable + # - what about slightly mismatched system clocks and mounted filesystems? caller responsibility to verify first? + # if timestamp exactly equal - should we check content-hash? This is presumably only likely to occur deliberately(maliciously?) + # e.g some process that digitally signs or otherwise modifies a file and preserves update timestmp? + # if such a content-mismatch - what default behaviour and what options would make sense? + # probably it's reasonable that only all-targets would overwrite such files. + # consider -source_fudge_seconds +-X ?, -source_override_timestamp ts ??? etc which only adjust timestamp for calculation purposes? Define a specific need/usecase when reviewing. + # + # valid filetypes for src tgt + # src dir tgt dir + # todo - review and consider enabling symlink src and dst + # no need for src file - as we use -glob with no glob characters to match one source file file + # no ability to target file with different name - keep it simpler and caller will have to use an intermediate folder/file if they need to rename something? + # + # todo - determine what happens if mismatch between file type of a src vs target e.g target has dir matching filename at source + # A pre-scan to determine no such conflict - before attempting to copy anything might provide the most integrity at slight cost in speed. + # REVIEW we should only expect dirs to be created as necessary to hold files? i.e target folder won't be created if no source file matches for that folder + # -source-checksum compare|store|comparestore|false|true where true == comparestore + # -punkcheck-folder target|source|project| target is default and is generally recommended + # -punkcheck-records empty string | parsed TDL records ie {tag xxx k v} structure + # install creates FILEINFO records with a single entry in the -targets field (it is legitimate to have a list of targets for an installation operation - the oo interface supports this) + proc install {srcdir tgtdir args} { + # Backward-compat: normalize old underscore flag names to hyphenated forms + set flag_aliases [dict create {*}{ + -max_depth -max-depth + -exclude-filetails_core -exclude-filetails-core + -exclude-paths_core -exclude-paths-core + -exclude-dirsegments_core -exclude-dirsegments-core + -antiglob_paths -antiglob-paths + -source_checksum -source-checksum + -punkcheck_folder -punkcheck-folder + -punkcheck_eventid -punkcheck-eventid + -punkcheck_records -punkcheck-records + }] + if {[llength $args]} { + set normalized [list] + foreach {k v} $args { + if {[dict exists $flag_aliases $k]} { + lappend normalized [dict get $flag_aliases $k] $v + } else { + lappend normalized $k $v + } + } + set args $normalized + } + + set defaults [list {*}{ + -call-depth-internal 0 + -max-depth 1000 + -subdirlist {} + -createdir 0 + -createempty 0 + -glob * + -exclude-filetails-core "\uFFFF" + -exclude-filetails "" + -exclude-paths-core "\uFFFF" + -exclude-paths {} + -exclude-dirsegments-core "\uFFFF" + -exclude-dirsegments {} + -antiglob-paths {} + -overwrite no-targets + -source-checksum comparestore + -punkcheck-folder target + -punkcheck-eventid "\uFFFF" + -punkcheck-records "" + -installer punkcheck::install + -progresschannel none + }] + + if {([llength $args] %2) != 0} { + error "punkcheck::install requires option-style arguments to be in pairs. Received args: $args" + } + foreach {k -} $args { + if {$k ni [dict keys $defaults]} { + error "punkcheck::install unrecognised option '$k' known options: '[dict keys $defaults]'" + } + } + set opts [dict merge $defaults $args] + + #The choice to recurse using the original values of srcdir & tgtdir, and passing the subpath down as a list in -subdirlist seems an odd one. + #(as opposed to a more 'standard' mechanism of adjusting srcdir & tgtdir as we move down the tree) + #It comes from build_modules_from_source_to_base where we need to keep track of position relative to our targetdir starting point to handle submodules e.g pkg::something::mypkg-0.1.tm + #It could have been handled with some other parameter such as -depth, but this -subdirlist mechanism, whilst perhaps not beautiful, is straightforward enough + #and may be less error prone than doing slightly more opaque path manipulations at each recursion level to determine where we started + #For consistency - we'll use the same mechanism in various recursive directory walking procedures such as this one. + set CALLDEPTH [dict get $opts -call-depth-internal] ;#added for extra debug/sanity checking - clearer test for initial function call ie CALLDEPTH = 0 + set max_depth [dict get $opts -max-depth] ;# -1 for no limit + set subdirlist [dict get $opts -subdirlist] ;# generally should be same length as CALLDEPTH - but user could prefill + set fileglob [dict get $opts -glob] + set createdir [dict get $opts -createdir] ;#defaults to zero to help avoid mistakes with initial target dir - required target subdirs are created regardless of this setting + set opt_createempty [dict get $opts -createempty] + set opt_progresschannel [dict get $opts -progresschannel] + if {$opt_progresschannel in {"" none} || [catch {chan configure $opt_progresschannel}]} { + set opt_progresschannel "" + } + + if {$CALLDEPTH == 0} { + #expensive to normalize but we need to do it at least once + set srcdir [file normalize $srcdir] + set tgtdir [file normalize $tgtdir] + if {$createdir} { + file mkdir $tgtdir + } else { + if {![file exists $tgtdir]} { + error "punkcheck::install base target dir:'$tgtdir' doesn't exist (srcdir:$srcdir tgtdir:$tgtdir args:'$args')" + } + } + if {([file type $srcdir] ni [list directory]) || ([file type $tgtdir] ni [list directory])} { + error "punkcheck::install requires source and target dirs to be of type 'directory' type current source: [file type $srcdir] type current target: [file type $tgtdir]" + } + #now the values we build from these will be properly cased + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_excludefiletail_core [dict get $opts -exclude-filetails-core] + if {$opt_excludefiletail_core eq "\uFFFF"} { + set opt_excludefiletail_core [default_excludefiletail_core] + dict set opts -exclude-filetails-core $opt_excludefiletail_core + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_excludefiletail [dict get $opts -exclude-filetails] + #validate no path seps + foreach af $opt_excludefiletail { + if {[llength [file split $af]] > 1} { + error "punkcheck::install received invalid -exclude-filetails entry '$af'. -exclude-filetails entries are meant to match to a file name at any level so cannot contain path separators" + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # Unified -exclude-paths initialization (replaces -exclude-dirsegments + -antiglob-paths) + # Precedence: -exclude-paths-core > -exclude-dirsegments-core (legacy) > default + set opt_excludepaths_core [dict get $opts -exclude-paths-core] + set legacy_excludedirseg_core [dict get $opts -exclude-dirsegments-core] + if {$opt_excludepaths_core ne "\uFFFF"} { + # User explicitly passed -exclude-paths-core → use as-is (path-glob form) + } elseif {$legacy_excludedirseg_core ne "\uFFFF"} { + # User explicitly passed legacy -exclude-dirsegments-core → convert to path-glob form + set opt_excludepaths_core [list] + foreach seg $legacy_excludedirseg_core { + lappend opt_excludepaths_core $seg + lappend opt_excludepaths_core **/$seg + } + dict set opts -exclude-paths-core $opt_excludepaths_core + } else { + # Neither passed → use new default + set opt_excludepaths_core [default_excludepaths_core] + dict set opts -exclude-paths-core $opt_excludepaths_core + } + set opt_excludepaths [dict get $opts -exclude-paths] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # Backward-compat: convert legacy -exclude-dirsegments to path-glob form and merge + # Each segment-glob S is expanded to {S **/S} to match at any directory level, + # preserving the former string-match-against-tail semantics. + set opt_excludedirseg_core $legacy_excludedirseg_core + if {$opt_excludedirseg_core eq "\uFFFF"} { + set opt_excludedirseg_core [default_excludedirseg_core] + dict set opts -exclude-dirsegments-core $opt_excludedirseg_core + } + set opt_excludedirseg [dict get $opts -exclude-dirsegments] + #validate no path seps + foreach ad $opt_excludedirseg { + if {[llength [file split $ad]] > 1} { + error "punkcheck::install received invalid -exclude-dirsegments entry '$ad'. -exclude-dirsegments entries are meant to match to a directory name at any level so cannot contain path separators" + } + } + #convert legacy dir-seg user globs (NOT core) to path-glob form and append to opt_excludepaths + foreach seg $opt_excludedirseg { + lappend opt_excludepaths $seg + lappend opt_excludepaths **/$seg + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # Backward-compat: merge legacy -antiglob-paths into opt_excludepaths + set opt_antiglob_paths [dict get $opts -antiglob-paths] ;#todo - combine with config file in source tree .punkcheckpublish (?) + #antiglob_paths will usually contain file separators - and may contain glob patterns within each segment + foreach ap $opt_antiglob_paths { + lappend opt_excludepaths $ap + } + set antiglob_paths_matched [list] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set known_whats [list no-targets newer-targets older-targets all-targets installedsourcechanged-targets synced-targets] + set overwrite_what [string tolower [dict get $opts -overwrite]]; #accept any case for value to allow emphasis by caller e.g -overwrite NEWER-TARGETS + if {$overwrite_what ni $known_whats} { + error "punkcheck::install received unrecognised value for -overwrite. Received value '$overwrite_what' vs known values '$known_whats'" + } + if {$overwrite_what in [list newer-targets older-targets]} { + error "punkcheck::install newer-target, older-targets not implemented - sorry" + #TODO - check crossplatform availability of ctime (on windows it still seems to be creation time, but on bsd/linux it's last attribute mod time) + # external pkg? use twapi and ctime only on other platforms? + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_source_checksum [dict get $opts -source-checksum] + if {[string is boolean $opt_source_checksum]} { + if {$opt_source_checksum} { + set opt_source_checksum "comparestore" + } else { + set opt_source_checksum 0 + } + dict set opts -source-checksum $opt_source_checksum + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_punkcheck_folder [dict get $opts -punkcheck-folder] + if {$opt_punkcheck_folder eq "target"} { + set punkcheck_folder $tgtdir + } elseif {$opt_punkcheck_folder eq "source"} { + set punkcheck_folder $srcdir + } elseif {$opt_punkcheck_folder eq "project"} { + set sourceprojectinfo [punk::repo::find_repos $srcdir] + set targetprojectinfo [punk::repo::find_repos $tgtdir] + set srcproj [lindex [dict get $sourceprojectinfo project] 0] + set tgtproj [lindex [dict get $targetprojectinfo project] 0] + if {$srcproj eq $tgtproj} { + set punkcheck_folder $tgtproj + } else { + error "copy_files_from_source_to_target error: Unable to find common project dir for source and target folder - use absolutepath for -punkcheck-folder if source and target are not within same project" + } + } else { + set punkcheck_folder $opt_punkcheck_folder + } + if {$punkcheck_folder ne ""} { + if {[file pathtype $punkcheck_folder] ne "absolute"} { + error "copy_files_from_source_to_target error: -punkcheck-folder '$punkcheck_folder' must be an absolute path, or one of: target|source|project" + } + if {![file isdirectory $punkcheck_folder]} { + error "copy_files_from_source_to_target error: -punkcheck-folder '$punkcheck_folder' not found" + } + } else { + #review - leave empty? use pwd? + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set punkcheck_records [dict get $opts -punkcheck-records] + set punkcheck_records_init $punkcheck_records ;#change-detection + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_installer [dict get $opts -installer] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_punkcheck_eventid [dict get $opts -punkcheck-eventid] + + + + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + + if {$CALLDEPTH == 0} { + set punkcheck_eventid "" + if {$punkcheck_folder ne ""} { + set config $opts + dict unset config -call-depth-internal + dict unset config -max-depth + dict unset config -subdirlist + dict unset config -progresschannel + tcl::dict::for {k v} $config { + if {$v eq "\uFFFF"} { + dict unset config $k + } + } + lassign [punkcheck::start_installer_event $punkcheck_file $opt_installer $srcdir $tgtdir $config] _eventid punkcheck_eventid _recordset punkcheck_records + } + } else { + set punkcheck_eventid $opt_punkcheck_eventid + } + + + + if {$opt_source_checksum != 0} { + #we need to read the file even if only set to store (or we would overwrite entries) + set compare_cksums 1 + } else { + set compare_cksums 0 + } + + if {[string match *store* $opt_source_checksum]} { + set store_source_cksums 1 + } else { + set store_source_cksums 0 + } + + + + + + if {[llength $subdirlist] == 0} { + set current_source_dir $srcdir + set current_target_dir $tgtdir + } else { + set current_source_dir $srcdir/[file join {*}$subdirlist] + set current_target_dir $tgtdir/[file join {*}$subdirlist] + } + + + set relative_target_dir [lib::path_relative $tgtdir $current_target_dir] + if {$relative_target_dir eq "."} { + set relative_target_dir "" + } + set relative_source_dir [lib::path_relative $srcdir $current_source_dir] + if {$relative_source_dir eq "."} { + set relative_source_dir "" + } + set target_relative_to_punkcheck_dir [lib::path_relative $punkcheck_folder $current_target_dir] + if {$target_relative_to_punkcheck_dir eq "."} { + set target_relative_to_punkcheck_dir "" + } + foreach unpub $opt_antiglob_paths { + #puts "testing folder - globmatchpath $unpub $relative_source_dir" + if {[punk::path::globmatchpath $unpub $relative_source_dir]} { + lappend antiglob_paths_matched $current_source_dir + return [list files_copied {} files_skipped {} sources_unchanged {} punkcheck_records $punkcheck_records antiglob_paths_matched $antiglob_paths_matched srcdir $srcdir tgtdir $tgtdir punkcheck_folder $punkcheck_folder] + } + } + + + if {![file exists $current_source_dir]} { + error "punkcheck::install current source dir:'$current_source_dir' doesn't exist (srcdir:$srcdir tgtdir:$tgtdir args:'$args')" + } + + set files_copied [list] + set files_skipped [list] + set sources_unchanged [list] + + + set candidate_list [glob -nocomplain -dir $current_source_dir -type f -tail -- $fileglob] + set hidden_candidate_list [glob -nocomplain -dir $current_source_dir -types {hidden f} -tail -- $fileglob] + foreach h $hidden_candidate_list { + if {$h ni $candidate_list} { + lappend candidate_list $h + } + } + set match_list [list] + foreach m $candidate_list { + set suppress 0 + foreach anti [concat $opt_excludefiletail_core $opt_excludefiletail] { + if {[string match $anti $m]} { + #puts stderr "anti: $anti vs m:$m" + set suppress 1 + break + } + } + if {$suppress == 0} { + lappend match_list $m + } + } + + #sample .punkcheck file record (raw form) to make the code clearer + #punk::tdl converts to dict form e.g: tag FILEINFO -targets filename body sublist + #Valid installrecord types are INSTALL-RECORD SKIPPED INSTALL-INPROGRESS, MODIFY-RECORD MODIFY-INPROGRESS DELETE-RECORD DELETE-INPROGRESS + # + #FILEINFO -targets jjjetc-0.1.0.tm -keep_installrecords 2 -keep_skipped 1 -keep_inprogress 2 { + # INSTALL-RECORD -tsiso 2023-09-20T07:30:30 -ts 1695159030266610 -installer punk::mix::cli::build_modules_from_source_to_base -metadata_us 18426 -ts_start_transfer 1695159030285036 -transfer_us 10194 -elapsed_us 28620 { + # SOURCE -type file -path ../src/modules/jjjetc-buildversion.txt -cksum c7c71839c36b3d21c8370fed106192fcd659eca9 -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 3423 + # SOURCE -type file -path ../src/modules/jjjetc-0.2.0.tm -cksum b646fc2ee88cbd068d2e946fe929b7aea96bd39d -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 3413 + # } + # INSTALL-SKIPPED -tsiso 2023-09-20T08:14:26 -ts 1695161666087880 -installer punk::mix::cli::build_modules_from_source_to_base -elapsed_us 18914 { + # SOURCE -type file -path ../src/modules/jjjetc-buildversion.txt -cksum c7c71839c36b3d21c8370fed106192fcd659eca9 -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 0 -metadata_us 3435 + # SOURCE -type file -path ../src/modules/jjjetc-0.2.0.tm -cksum b646fc2ee88cbd068d2e946fe929b7aea96bd39d -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 0 -metadata_us 3338 + # } + #} + + if {[llength $match_list]} { + #example - target dir has a file where there is a directory at the source + if {[file exists $current_target_dir] && ([file type $current_target_dir] ni [list directory])} { + error "punkcheck::install target subfolder $current_target_dir exists but is not of type 'directory'. Type current target folder: [file type $current_target_dir]" + } + } + + #proc get_relativecksum_from_base_and_fullpath {base fullpath args} + + + #puts stdout "Current target dir: $current_target_dir" + set last_depth "" + foreach m $match_list { + set new_tgt_cksum_info [list] + set relative_target_path [file join $relative_target_dir $m] + set relative_source_path [file join $relative_source_dir $m] + set punkcheck_target_relpath [file join $target_relative_to_punkcheck_dir $m] + set is_antipath 0 + foreach pathglob [concat $opt_excludepaths_core $opt_excludepaths] { + #puts "testing file - globmatchpath $pathglob vs $relative_source_path" + if {[punk::path::globmatchpath $pathglob $relative_source_path]} { + lappend antiglob_paths_matched $current_source_dir + set is_antipath 1 + break + } + } + if {$is_antipath} { + continue + } + + set ts_start [clock microseconds] + set seconds [expr {$ts_start / 1000000}] + set ts_start_iso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + + + #puts stdout " rel_target: $punkcheck_target_relpath" + + set fetch_filerec_result [punkcheck::recordlist::get_file_record $punkcheck_target_relpath $punkcheck_records] + #change to use extract_or_create_fileset_record ? + set existing_filerec_posn [dict get $fetch_filerec_result position] + if {$existing_filerec_posn == -1} { + if {$opt_progresschannel ne ""} { + puts stdout "\nNO existing record for $punkcheck_target_relpath" + } + set has_filerec 0 + set new_filerec [dict create tag FILEINFO -targets $punkcheck_target_relpath] + set filerec $new_filerec + } else { + set has_filerec 1 + #puts stdout " TDL existing FILEINFO record for $punkcheck_target_relpath" + #puts stdout " $existing_install_record" + set filerec [dict get $fetch_filerec_result record] + } + set filerec [punkcheck::recordlist::file_record_set_defaults $filerec] + + #new INSTALLREC must be tagged as INSTALL-INPROGRESS to use recordlist::installfile_ method + set new_install_record [dict create tag INSTALL-INPROGRESS -tsiso $ts_start_iso -ts $ts_start -installer $opt_installer -eventid $punkcheck_eventid] + dict lappend filerec body $new_install_record ;#can't use recordlist::file_record_add_installrecord as '*-INPROGRESS' isn't a final tag - so pruning would be mucked up. No need to prune now anyway. + unset new_install_record + + + if {$opt_progresschannel ne ""} { + if {$last_depth ne $CALLDEPTH} { + if {$CALLDEPTH <=1} { + puts -nonewline $opt_progresschannel \n[string repeat " " $CALLDEPTH][file tail $relative_source_dir] + } + flush $opt_progresschannel + ##set last_depth $CALLDEPTH ;# done down below + } + } + + + + set relative_source_path [lib::path_relative $punkcheck_folder $current_source_dir/$m] + #puts stdout " rel_source: $relative_source_path" + #if {[file pathtype $relative_source_path] ne "relative"} { + #REVIEW + #different volume or root + #} + #Note this isn't a recordlist function - so it doesn't purely operate on the records + #this hits the filesystem for the sourcepath - gets checksums/timestamps depending on config. + #It doesn't save to .punkcheck (the only punkcheck::installfile_ method which doesn't) + set ts1 [clock milliseconds] + set filerec [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $relative_source_path $filerec] + set ts2 [clock milliseconds] + set diff [expr {$ts2 - $ts1}] + if {$diff > 100} { + #todo -errorchannel + set errprefix ">>> punkcheck:" + puts stderr "\n$errprefix performance warning: fetch_metadata for $m took $diff ms." + set lb [lindex [dict get $filerec body] end] + #puts stderr "$errprefix filerec last body record:$lb" + set records [dict get $lb body] + set lr [lindex $records end] + set alg [dict get $lr -cksum_all_opts -cksum_algorithm] + if {$alg eq "sha1"} { + puts stderr "$errprefix cksum_algorithm: sha1 (accelerators: [::sha1::Implementations])" + puts stderr "$errprefix sha1 from: [package ifneeded sha1 [package present sha1]]" + } else { + puts stderr "$errprefix cksum_algorithm: $alg" + } + } + + + + #changeinfo comes from last record in body - which is the record we are working on and so will always exist + set changeinfo [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $filerec body] end]] + set changed [dict get $changeinfo changed] + set unchanged [dict get $changeinfo unchanged] + + if {[llength $unchanged]} { + lappend sources_unchanged $current_source_dir/$m + } + + set is_skip 0 + set is_new 0 + if {$overwrite_what eq "all-targets"} { + file mkdir $current_target_dir + #-------------------------------------------- + #sometimes we get the error: 'error copying "file1" to "file2": invalid argument' + #-------------------------------------------- + puts stderr "punkcheck: about to: file copy -force $current_source_dir/$m $current_target_dir" + file copy -force $current_source_dir/$m $current_target_dir + lappend files_copied $current_source_dir/$m + } else { + if {![file exists $current_target_dir/$m]} { + #puts stderr "punkcheck: first copy to $current_target_dir/$m " + file mkdir $current_target_dir + puts stderr "punkcheck: about to: file copy $current_source_dir/$m $current_target_dir" + file copy $current_source_dir/$m $current_target_dir + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + lappend files_copied $current_source_dir/$m + incr filecount_new + set is_new 1 + } else { + switch -- $overwrite_what { + installedsourcechanged-targets { + if {[llength $changed]} { + #An unrecorded installation is considered a source change (from unknown/unrecorded source to recorded) + puts -nonewline stderr "punkcheck: about to: file copy -force $current_source_dir/$m $current_target_dir" + set ts1 [clock milliseconds] + file mkdir $current_target_dir + file copy -force $current_source_dir/$m $current_target_dir + set ts2 [clock milliseconds] + puts -nonewline stderr " (copy time [expr {$ts2 - $ts1}] ms)" + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + set ts3 [clock milliseconds] + puts stderr " (cksum time [expr {$ts2 - $ts1}] ms)" + lappend files_copied $current_source_dir/$m + } else { + set is_skip 1 + lappend files_skipped $current_source_dir/$m + } + } + synced-targets { + #disallow overwriting of target that has been modified by some other mechanism + #review + if {[llength $changed]} { + #only overwrite if the target file checksum equals the last installed checksum (ie target is in sync with previous source-set and so hasn't been customized) + set existing_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + set is_target_unmodified_since_install 0 + set target_cksum_compare "unknown" + set latest_install_record [punkcheck::recordlist::file_record_latest_installrecord $filerec] ;#may be no such record - in which case we get an empty list + if {[dict exists $latest_install_record -targets_cksums]} { + set last_install_cksum [dict get $latest_install_record -targets_cksums] ;#in this case we know there is only one as 'install' always uses targetset size of 1. (FILEINFO record per file in source folder) + if {[dict get $existing_tgt_cksum_info cksum] eq $last_install_cksum} { + set is_target_unmodified_since_install 1 + set target_cksum_compare "match" + } else { + set target_cksum_compare "nomatch" + } + } else { + set target_cksum_compare "norecord" + } + if {$is_target_unmodified_since_install} { + file mkdir $current_target_dir + puts stderr "punkcheck: synced-targets about to: file copy -force $current_source_dir/$m $current_target_dir" + file copy -force $current_source_dir/$m $current_target_dir + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + lappend files_copied $current_source_dir/$m + } else { + #either cksum is different or we were unable to verify the record. Either way we can't know if the target is in sync so we must skip it + set is_skip 1 + puts stderr "Skipping file copy $m target $current_target_dir/$m - require synced_target to overwrite - current target cksum compared to previous install: $target_cksum_compare" + lappend files_skipped $current_source_dir/$m + } + } else { + set is_skip 1 + lappend files_skipped $current_source_dir/$m + } + } + default { + set is_skip 1 + puts stderr "Skipping file copy $m target $current_target_dir/$m already exists (use -overwrite all-targets to overwrite)" + #TODO! implement newer-targets older-targets? (note ctimes/mtimes are unreliable - may not be worth implementing) + lappend files_skipped $current_source_dir/$m + } + } + } + } + #target dir was created as necessary if files matched above + #now ensure target dir exists if -createempty true + if {$opt_createempty && ![file exists $current_target_dir]} { + file mkdir $current_target_dir + } + + + + + set ts_now [clock microseconds] + set elapsed_us [expr {$ts_now - $ts_start}] + + #if {$store_source_cksums} { + #} + + set install_records [dict get $filerec body] + set current_install_record [lindex $install_records end] + #change the tag from *-INPROGRESS to INSTALL-RECORD/SKIPPED + if {$is_skip} { + set tag INSTALL-SKIPPED + } else { + set tag INSTALL-RECORD + } + dict set current_install_record tag $tag + dict set current_install_record -elapsed_us $elapsed_us + if {[llength $new_tgt_cksum_info]} { + dict set current_install_record -targets_cksums [list [dict get $new_tgt_cksum_info cksum]] + dict set current_install_record -cksum_all_opts [dict get $new_tgt_cksum_info opts] + } + lset install_records end $current_install_record + dict set filerec body $install_records + set filerec [punkcheck::recordlist::file_record_prune $filerec] ;#prune now that tag is finalized + if {!$has_filerec} { + #not found in original recordlist - append + lappend punkcheck_records $filerec + } else { + lset punkcheck_records $existing_filerec_posn $filerec + } + + + #------------------------------------------------------------ + if {$is_skip} { + set mark . + } else { + if {$is_new} { + set mark \x1b\[32\;1mN\x1b\[m + } else { + #updated + set mark \x1b\[32\;1mU\x1b\[m + } + } + if {$opt_progresschannel ne ""} { + if {$last_depth ne $CALLDEPTH} { + puts -nonewline $opt_progresschannel \n[string repeat " " $CALLDEPTH]$mark + flush $opt_progresschannel + set last_depth $CALLDEPTH + } else { + puts -nonewline $opt_progresschannel $mark + } + } + #------------------------------------------------------------ + + } + + if {$max_depth != -1 && $CALLDEPTH >= $max_depth} { + #don't process any more subdirs + #sometimes deliberately called with max_depth 1 - so don't warn here. review + #puts stderr "punkcheck::install warning - reached max_depth $max_depth" + set subdirs [list] + } else { + set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] + set hiddensubdirs [glob -nocomplain -dir $current_source_dir -type {hidden d} -tail *] + foreach h $hiddensubdirs { + switch -- $h { + "." - ".." { + continue + } + default { + if {$h ni $subdirs} { + lappend subdirs $h + } + } + } + } + } + #puts stderr "subdirs: $subdirs" + foreach d $subdirs { + set relative_source_path [file join $relative_source_dir $d] + set skipd 0 + foreach pathglob [concat $opt_excludepaths_core $opt_excludepaths] { + #puts "testing folder - globmatchpath $pathglob vs $relative_source_path" + if {[punk::path::globmatchpath $pathglob $relative_source_path]} { + lappend antiglob_paths_matched [file join $current_source_dir $d] + #puts stdout "SKIPPING FOLDER $relative_source_path due to exclude-path-match: $pathglob " + set skipd 1 + break + } + } + if {$skipd} { + continue + } + + #if {![file exists $current_target_dir/$d]} { + # file mkdir $current_target_dir/$d + #} + + + set sub_opts_1 [list {*}{ + } -call-depth-internal [expr {$CALLDEPTH + 1}] {*}{ + } -subdirlist [list {*}$subdirlist $d] {*}{ + } -glob $fileglob {*}{ + } -exclude-filetails-core $opt_excludefiletail_core {*}{ + } -exclude-filetails $opt_excludefiletail {*}{ + } -exclude-paths-core $opt_excludepaths_core {*}{ + } -exclude-paths $opt_excludepaths {*}{ + } -overwrite $overwrite_what {*}{ + } -source-checksum $opt_source_checksum {*}{ + } -punkcheck-folder $punkcheck_folder {*}{ + } -punkcheck-eventid $punkcheck_eventid {*}{ + } -punkcheck-records $punkcheck_records {*}{ + } -installer $opt_installer {*}{ + } + ] + set sub_opts [list {*}{ + } -call-depth-internal [expr {$CALLDEPTH + 1}] {*}{ + } -subdirlist [list {*}$subdirlist $d] {*}{ + } -punkcheck-folder $punkcheck_folder {*}{ + } -punkcheck-eventid $punkcheck_eventid {*}{ + } -punkcheck-records $punkcheck_records {*}{ + } -progresschannel $opt_progresschannel {*}{ + } + ] + set sub_opts [dict merge $opts $sub_opts] + set sub_result [punkcheck::install $srcdir $tgtdir {*}$sub_opts] + + lappend files_copied {*}[dict get $sub_result files_copied] + lappend files_skipped {*}[dict get $sub_result files_skipped] + lappend sources_unchanged {*}[dict get $sub_result sources_unchanged] + lappend antiglob_paths_matched {*}[dict get $sub_result antiglob_paths_matched] + set punkcheck_records [dict get $sub_result punkcheck_records] + } + + if {[string match *store* $opt_source_checksum]} { + #puts "subdirlist: $subdirlist" + if {$CALLDEPTH == 0} { + if {[llength $files_copied] || [llength $files_skipped]} { + #puts stdout ">>>>>>>>>>>>>>>>>>>" + set saveresult [punkcheck::save_records_to_file $punkcheck_records $punkcheck_file "install $srcdir to $tgtdir"] + puts stdout "\npunkcheck::install [dict get $saveresult recordcount] records saved as [dict get $saveresult linecount] lines to $punkcheck_file copied: [llength $files_copied] skipped: [llength $files_skipped]" + #puts stdout ">>>>>>>>>>>>>>>>>>>" + } else { + #todo - write db INSTALLER record if -debug true + + } + #puts stdout "sources_unchanged" + #puts stdout "$sources_unchanged" + #puts stdout "- -- --- --- --- ---" + } + } + + return [list files_copied $files_copied files_skipped $files_skipped sources_unchanged $sources_unchanged antiglob_paths_matched $antiglob_paths_matched punkcheck_records $punkcheck_records punkcheck_folder $punkcheck_folder srcdir $srcdir tgtdir $tgtdir] + } + + + lappend PUNKARGS [list { + @id -id ::punkcheck::summarize_install_resultdict + @cmd -name punkcheck::summarize_install_resultdict -help\ + "Emits a string summarizing a punkcheck resultdict, showing + how many items were copied, and the source, target locations" + @opts + -title -type string -default "" + -forcecolour -type boolean -default 0 -help\ + "When true, passes the forcecolour tag to punk::ansi functions. + This enables ANSI sgr colours even when colour + is off. (ignoring env(NO_COLOR)) + To disable colour - ensure the NO_COLOR env var is set, + or use: + namespace eval ::punk::console {variable colour_disabled 1}" + @values -min 1 -max 1 + resultdict -type dict + }] + proc summarize_install_resultdict {args} { + set argd [punk::args::parse $args withid ::punkcheck::summarize_install_resultdict] + lassign [dict values $argd] leaders opts values received + set title [dict get $opts -title] + set forcecolour [dict get $opts -forcecolour] + set resultdict [dict get $values resultdict] + + set has_ansi [expr {![catch {package require punk::ansi}]}] + if {$has_ansi} { + if {$forcecolour} { + set fc "forcecolour" + } else { + set fc "" + } + set R [punk::ansi::a] ;#reset + set LINE_COLOUR [punk::ansi::a+ {*}$forcecolour bold cyan] + set LOW_COLOUR [punk::ansi::a+ {*}$forcecolour bold green] + set HIGH_COLOUR [punk::ansi::a+ {*}$forcecolour bold yellow] + } else { + set R "" + set LINE_COLOUR "" + set LOW_COLOUR "" + set HIGH_COLOUR "" + } + + set msg "" + if {[dict size $resultdict]} { + set copied [dict get $resultdict files_copied] + if {[llength $copied] == 0} { + set HIGHLIGHT $LOW_COLOUR + } else { + set HIGHLIGHT $HIGH_COLOUR + } + set ruler $LINE_COLOUR[string repeat - 78]$R + if {$title ne ""} { + append msg $ruler \n + append msg $title \n + } + append msg $ruler \n + #append msg "[dict keys $resultdict]" \n + set tgtdir [dict get $resultdict tgtdir] + set checkfolder [dict get $resultdict punkcheck_folder] + append msg "${HIGHLIGHT}Copied [llength $copied] files from [dict get $resultdict srcdir] to [dict get $resultdict tgtdir]$R" \n + foreach f $copied { + append msg "COPIED [punkcheck::lib::path_relative $checkfolder $f]" \n + append msg " TO $tgtdir" \n + } + append msg "[llength [dict get $resultdict sources_unchanged]] unchanged source files" \n + append msg "[llength [dict get $resultdict files_skipped]] skipped files" \n + append msg $ruler \n + } + return $msg + } + + namespace eval recordlist { + set pkg punkcheck + namespace path ::punkcheck + + proc records_as_target_dict {record_list} { + set result [dict create] + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + set tgtlist [dict get $rec -targets] + if {[dict exists $result $tgtlist]} { + #todo - warn - duplicate record for same targetlist - shouldn't happen as we should be using get_file_record to find existing records + error "punkcheck::recordlist::records_as_target_dict - multiple records with same targetlist '$tgtlist'" + } + dict set result $tgtlist $rec + } + } + return $result + } + + + #will only match if same base was used.. and same targetlist + proc get_file_record {targetlist record_list} { + set posn 0 + set found_posn -1 + set record "" + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + if {[dict get $rec -targets] eq $targetlist} { + set found_posn $posn + set record $rec + break + } + } + incr posn + } + return [list position $found_posn record $record] + } + proc file_install_record_source_changes {install_record} { + #reject INSTALLFAILED items ? + switch -- [dict get $install_record tag] { + "QUERY-INPROGRESS" - + "INSTALL-RECORD" - + "INSTALL-SKIPPED" - + "INSTALL-INPROGRESS" - + "MODIFY-INPROGRESS" - + "MODIFY-RECORD" - + "MODIFY-SKIPPED" - + "VIRTUAL-INPROGRESS" - + "VIRTUAL-RECORD" - + "VIRTUAL-SKIPPED" - + "DELETE-RECORD" - + "DELETE-INPROGRESS" - + "DELETE-SKIPPED" { + } + default { + error "file_install_record_source_changes bad install record: tag '[dict get $install_record tag]' not INSTALL-RECORD|SKIPPED|INSTALL-INPROGRESS|MODIFY-RECORD|MODIFY-INPROGRESS|VIRTUAL-RECORD|VIRTUAL-INPROGRESS|DELETE-RECORD|DELETE-INPROGRESS" + } + } + set source_list [dict_getwithdefault $install_record body [list]] + set changed [list] + set unchanged [list] + foreach src $source_list { + if {[dict exists $src -changed]} { + if {[dict get $src -changed] !=0} { + lappend changed [dict get $src -path] + } else { + lappend unchanged [dict get $src -path] + } + } else { + lappend changed [dict get $src -path] + } + } + return [dict create changed $changed unchanged $unchanged] + } + + #assume only one for name - use first encountered? + proc get_installer_record {name record_list} { + set posn 0 + set found_posns [list] + set record "" + #puts ">>>> checking [llength $record_list] punkcheck records" + foreach rec $record_list { + if {[dict get $rec tag] eq "INSTALLER"} { + if {[dict get $rec -name] eq $name} { + set found_posn $posn + set record $rec + lappend found_posns $posn + } + } + incr posn + } + if {[llength $found_posns] > 1} { + error "punkcheck::recordlist::get_installer_record - multiple installer records with name '$name' found at positions $found_posns" + } elseif {[llength $found_posns] == 0} { + return [list position -1 record ""] + } else { + #single record found + return [list position [lindex $found_posn 0] record $record] + } + + } + + proc new_installer_record {name args} { + if {[llength $args] %2 !=0} { + error "punkcheck new_installer_record args must be name-value pairs" + } + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + + #put -tsiso first so it lines up with -tsiso in event records + set defaults [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $ts {*}{ + } -name $name {*}{ + } -keep_events 5 {*}{ + } + ] + set opts [dict merge $defaults $args] + + #set this_installer_record_list [punk::tdl::prettyparse [list INSTALLER name $opt_installer ts $ts tsiso $tsiso keep_events 5 {}]] + #set this_installer_record [lindex $this_installer_record_list 0] + + set record [dict create tag INSTALLER {*}$opts body {}] + + + return $record + } + proc new_installer_event_record {type args} { + if {[llength $args] %2 !=0} { + error "punkcheck new_installer_event_record args must be name-value pairs" + } + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set defaults [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $ts {*}{ + } -type $type {*}{ + } + ] + set opts [dict merge $defaults $args] + + set record [dict create tag EVENT {*}$opts] + } + #need to scan entire set if filerecords to check if event is still referenced + proc installer_record_pruneevents {installer_record record_list} { + set keep 5 + if {[dict exists $installer_record -keep_events]} { + set keep [dict get $installer_record -keep_events] + } + + if {[dict exists $installer_record body]} { + set body_items [dict get $installer_record body] + } else { + set body_items [list] + } + set kept_body_items [list] + set kcount 0 + foreach item [lreverse $body_items] { + if {[dict get $item tag] eq "EVENT"} { + incr kcount + if {$keep < 0 || $kcount <= $keep} { + lappend kept_body_items $item + } else { + set eventid "" + if {[dict exists $item -id]} { + set eventid [dict get $item -id] + } + if {$eventid ne "" && $eventid ne "unspecified"} { + #keep if referenced, discard if not, or if eventid empty/unspecified + set is_referenced 0 + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + if {[dict exists $rec body]} { + foreach install [dict get $rec body] { + if {[dict exists $install -eventid] && [dict get $install -eventid] eq $eventid} { + set is_referenced 1 + break + } + } + } + } + if {$is_referenced} { + break + } + } + if {$is_referenced} { + lappend kept_body_items $item + } + } + } + } else { + lappend kept_body_items $item + } + } + set kept_body_items [lreverse $kept_body_items] + dict set installer_record body $kept_body_items + return $installer_record + } + proc installer_record_add_event {installer_record event} { + if {[dict get $installer_record tag] ne "INSTALLER"} { + error "installer_record_add_event bad installer record: tag not INSTALLER" + } + if {[dict get $event tag] ne "EVENT"} { + error "installer_record_add_event bad event record: tag not EVENT" + } + if {[dict exists $installer_record body]} { + set body_items [dict get $installer_record body] + } else { + set body_items [list] + } + lappend body_items $event + dict set installer_record body $body_items + return $installer_record + } + proc file_record_latest_installrecord {file_record} { + tailcall file_record_latest_operationrecord INSTALL $file_record + } + proc file_record_latest_operationrecord {operation file_record} { + set operation [string toupper $operation] + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_latest_operationrecord bad file_record: tag not FILEINFO" + } + if {![dict exists $file_record body]} { + return [list] + } + set body_items [dict get $file_record body] + foreach item [lreverse $body_items] { + if {[dict get $item tag] eq "$operation-RECORD"} { + return $item + } + } + return [list] + } + + + proc file_record_set_defaults {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_set_defaults bad file_record: tag not FILEINFO" + } + set defaults [list -keep_installrecords 3 -keep_skipped 1 -keep_inprogress 2] + foreach {k v} $defaults { + if {![dict exists $file_record $k]} { + dict set file_record $k $v + } + } + return $file_record + } + + #negative keep_ value will keep all + proc file_record_prune {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_prune bad file_record: tag not FILEINFO" + } + set file_record [file_record_set_defaults $file_record] + set kmap [list -keep_installrecords *-RECORD -keep_skipped *-SKIPPED -keep_inprogress *-INPROGRESS] + foreach {key rtype} $kmap { + set keep [dict get $file_record $key] + if {[dict exists $file_record body]} { + set body_items [dict get $file_record body] + } else { + set body_items [list] + } + set kept_body_items [list] + set kcount 0 + foreach item [lreverse $body_items] { + if {[string match $rtype [dict get $item tag]]} { + incr kcount + if {$keep < 0 || $kcount <= $keep} { + lappend kept_body_items $item + } + } else { + lappend kept_body_items $item + } + } + set kept_body_items [lreverse $kept_body_items] + dict set file_record body $kept_body_items + } + return $file_record + } + + #extract new or existing filerecord for path given + #REVIEW - locking/concurrency + proc extract_or_create_fileset_record {relative_target_paths recordset} { + set fetch_record_result [punkcheck::recordlist::get_file_record $relative_target_paths $recordset] + set existing_posn [dict get $fetch_record_result position] + if {$existing_posn == -1} { + puts stdout "punkcheck NO existing record for $relative_target_paths" + set isnew 1 + set fileset_record [dict create tag FILEINFO -targets $relative_target_paths body {}] + } else { + #set recordset [lreplace $recordset[unset recordset] $existing_posn $existing_posn] + #set recordset [lreplace $recordset[set recordset {}] $existing_posn $existing_posn] + ledit recordset $existing_posn $existing_posn + set isnew 0 + set fileset_record [dict get $fetch_record_result record] + } + return [list record $fileset_record recordset $recordset isnew $isnew oldposition $existing_posn] + } + + } + +} + + + + +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punkcheck +} + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punkcheck [namespace eval punkcheck { + set pkg punkcheck + variable version + set version 0.2.0 +}] +return diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl b/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl index 1d74becb..334600ad 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl @@ -282,6 +282,52 @@ namespace eval ::punkboot::lib { } +#------------------------------------------------------------------------------ +# Bootsupport staleness helpers — self-contained Tcl, no punk package deps. +# These run in the early boot phase before punk packages are guaranteed loaded +# (modeled on punk::lib::askuser but without punk::console / raw-mode deps). +#------------------------------------------------------------------------------ + +# Classify the version delta between an old (bootsupport) and new (source) +# semver as "major", "minor", or "patch". +# Caller must verify new_ver > old_ver via `package vcompare` first. +proc ::punkboot::lib::bootsupport_bump_level {old_ver new_ver} { + set op [split $old_ver .] + set np [split $new_ver .] + while {[llength $op] < 3} {lappend op 0} + while {[llength $np] < 3} {lappend np 0} + set op [lmap s $op { + set n [scan $s %d] + expr {[string is integer -strict $n] ? $n : 0} + }] + set np [lmap s $np { + set n [scan $s %d] + expr {[string is integer -strict $n] ? $n : 0} + }] + lassign $op o_major o_minor o_patch + lassign $np n_major n_minor n_patch + if {$n_major > $o_major} {return "major"} + if {$n_minor > $o_minor} {return "minor"} + return "patch" +} + +# Self-contained y/N prompt. Returns 1 for y/yes (case-insensitive), 0 otherwise. +# Used by the staleness abort path to ask the user whether to proceed past a +# minor-version bump. Default is No (Enter = abort) so accidental Enter is safe. +proc ::punkboot::lib::bootsupport_prompt_yesno {prompt} { + puts stdout $prompt + puts -nonewline stdout "Proceed anyway? (y/N) " + flush stdout + set stdin_state [chan configure stdin] + try { + chan configure stdin -blocking 1 + set answer [string tolower [string trim [gets stdin]]] + } finally { + chan configure stdin -blocking [dict get $stdin_state -blocking] + } + return [expr {$answer eq "y" || $answer eq "yes"}] +} + if {"::try" ni [info commands ::try]} { puts stderr "Tcl interpreter possibly too old - need at least tcl 8.6 - 'try' command not found - aborting" exit 1 @@ -469,6 +515,52 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} { #package forget punk::repo #package forget punkcheck + #------------------------------------------------------------------ + # Bootsupport staleness check + # When make.tcl is run from project root (not from src/), bootsupport + # modules are loaded in preference to source modules. If the source + # modules have been updated (e.g API changes) but bootsupport hasn't + # been rebuilt, make.tcl will fail with obscure errors from the stale + # bootsupport versions. This check compares buildversion.txt in source + # against the highest .tm version in bootsupport and warns the caller. + #------------------------------------------------------------------ + if {[file tail $startdir] ne "src"} { + set _runtime_deps [list {*}{ + } punkcheck punkcheck-buildversion.txt punkcheck-*.tm {*}{ + } punk::repo punk/repo-buildversion.txt punk/repo-*.tm {*}{ + } punk::mix punk/mix-buildversion.txt punk/mix-*.tm {*}{ + } punk::tdl punk/tdl-buildversion.txt punk/tdl-*.tm {*}{ + }] + set _stale_modules [list] + foreach {pkg buildversion_rel bootsupport_glob} $_runtime_deps { + set _src_bv_file [file join $::punkboot::scriptfolder modules $buildversion_rel] + set _bs_glob_dir [file dirname [file join $::punkboot::scriptfolder bootsupport modules $bootsupport_glob]] + set _bs_glob_pat [file tail $bootsupport_glob] + if {![file exists $_src_bv_file]} {continue} + #read source version (first line of buildversion.txt) + set _fd [open $_src_bv_file r] + set _src_version [string trim [lindex [split [read $_fd] \n] 0]] + close $_fd + #find highest version .tm in bootsupport + set _bs_version "" + set _prefix [string range $_bs_glob_pat 0 [string first "*" $_bs_glob_pat]-1] + foreach _tm [glob -nocomplain -dir $_bs_glob_dir -- $_bs_glob_pat] { + set _v [file rootname [string range [file tail $_tm] [string length $_prefix] end]] + if {$_bs_version eq "" || [package vcompare $_v $_bs_version] == 1} { + set _bs_version $_v + } + } + if {$_bs_version ne "" && $_src_version ne "" && [package vcompare $_src_version $_bs_version] == 1} { + set _bump [::punkboot::lib::bootsupport_bump_level $_bs_version $_src_version] + lappend _stale_modules [list $pkg $_src_version $_bs_version $_bump] + } + } + if {[llength $_stale_modules]} { + set ::punkboot::stale_bootsupport $_stale_modules + } + unset _runtime_deps _stale_modules + } + package require punk::repo ;#todo - push our requirements to a smaller punk::repo::xxx package with minimal dependencies package require punk::mix package require punkcheck @@ -1433,6 +1525,51 @@ if {[lsearch $::argv -k] >= 0} { #puts stdout "::argv $::argv" # ---------------------------------------- +# Abort / prompt if bootsupport modules are stale relative to source. +# Behaviour is version-aware based on the bump level between each stale +# module's bootsupport version and source version: +# - major bump -> abort unconditionally (breaking change, old bootsupport will not work) +# - minor bump -> prompt user; backward-compat aliases *should* keep old bootsupport functional +# - patch bump -> warn and proceed (non-breaking) +# 'check' is exempt in all cases — the warning is shown at the end of its output instead. +if {[info exists ::punkboot::stale_bootsupport] && $::punkboot::command ne "check"} { + set _stale $::punkboot::stale_bootsupport + set _have_major 0 + set _have_minor 0 + set _have_patch 0 + foreach _entry $_stale { + lassign $_entry _pkg _src_ver _bs_ver _bump + switch -- $_bump { + major {incr _have_major} + minor {incr _have_minor} + patch {incr _have_patch} + default {incr _have_patch} + } + } + puts stderr "==============================================================================" + puts stderr "WARNING: bootsupport modules are stale relative to source modules:" + foreach _entry $_stale { + lassign $_entry _pkg _src_ver _bs_ver _bump + puts stderr [format " %-15s bootsupport=%-10s source=%-10s bump=%s" $_pkg $_bs_ver $_src_ver $_bump] + } + puts stderr "" + puts stderr " Recommended fix — update bootsupport before proceeding:" + puts stderr " cd \[projectroot\]/src && tclsh make.tcl modules && tclsh make.tcl bootsupport" + puts stderr "==============================================================================" + if {$_have_major} { + puts stderr "-aborted- (major version bump in stale bootsupport — breaking change, cannot proceed)" + exit 1 + } + if {$_have_minor} { + if {![::punkboot::lib::bootsupport_prompt_yesno "Minor-version staleness — backward-compat aliases should keep old bootsupport functional."]} { + puts stderr "-aborted- by user" + exit 1 + } + puts stderr "-proceeding with stale bootsupport at user's request-" + } + # patch-only staleness: warn and proceed (warning already printed above) +} + set scriptfolder $::punkboot::scriptfolder @@ -1582,6 +1719,19 @@ if {$::punkboot::command eq "check"} { puts stdout $sep catch {package require struct::set} puts stdout ---[package ifneeded struct::set 2.2.3] + # Show bootsupport staleness warning at the end of check output + if {[info exists ::punkboot::stale_bootsupport]} { + puts stderr "==============================================================================" + puts stderr "WARNING: bootsupport modules are stale relative to source modules:" + foreach _entry $::punkboot::stale_bootsupport { + lassign $_entry _pkg _src_ver _bs_ver _bump + puts stderr [format " %-15s bootsupport=%-10s source=%-10s bump=%s" $_pkg $_bs_ver $_src_ver $_bump] + } + puts stderr "" + puts stderr " Run the following to update bootsupport before proceeding:" + puts stderr " cd \[projectroot\]/src && tclsh make.tcl modules && tclsh make.tcl bootsupport" + puts stderr "==============================================================================" + } exit 0 } @@ -2025,7 +2175,7 @@ if {$::punkboot::command eq "bootsupport"} { set resultdict [punkcheck::install $sourcemodules $targetroot\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -installer "punkboot-bootsupport"\ -progresschannel stdout\ ] @@ -2042,7 +2192,7 @@ if {$::punkboot::command eq "bootsupport"} { puts stdout "BOOTSUPPORT layouts/$layoutname: copying from $source_bootscript to $targetroot_bootscript (if source file changed)" set resultdict [punkcheck::install [file dirname $source_bootscript] $targetroot_bootscript\ -glob make.tcl\ - -max_depth 1\ + -max-depth 1\ -createempty 0\ -overwrite installedsourcechanged-targets\ -installer "punkboot-bootsupport"\ @@ -2098,11 +2248,11 @@ if {$::punkboot::command in {project packages modules}} { -overwrite installedsourcechanged-targets -progresschannel stdout -exclude-filetails {AGENTS.md include_modules.config} - -antiglob_paths {README.md} +-exclude-paths {README.md} }] - # -antiglob_paths {README.md AGENTS.md **/AGENTS.md include_modules.config} + # -exclude-paths {README.md AGENTS.md **/AGENTS.md include_modules.config} #-exclude-filetails {AGENTS.md include_modules.config} - #-antiglob_paths {README.md} + #-exclude-paths {README.md} puts stdout [punkcheck::summarize_install_resultdict $resultdict] } if {![llength $vendormodulefolders]} { @@ -2112,7 +2262,7 @@ if {$::punkboot::command in {project packages modules}} { if {$::punkboot::command in {project packages libs}} { #exclude README.md from source folder - but only the root one - #-antiglob_paths takes relative patterns e.g + #-exclude-paths takes relative patterns e.g # */test.txt will only match test.txt exactly one level deep. # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. # **/test.txt will match at any level below the root (but not in the root) @@ -2130,7 +2280,7 @@ if {$::punkboot::command in {project packages libs}} { puts stdout "VENDORLIB: copying tcl-version neutral and platform neutral libraries from $source_lib_folder to $target_lib_folder (if source file changed)" set resultdict [punkcheck::install $source_lib_folder $target_lib_folder\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -2150,7 +2300,7 @@ if {$::punkboot::command in {project packages libs}} { puts stdout "VENDORLIB_$which: copying from $source_lib_folder to $target_lib_folder (if source file changed)" set resultdict [punkcheck::install $source_lib_folder $target_lib_folder\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -2165,7 +2315,7 @@ if {$::punkboot::command in {project packages libs}} { puts stdout "VENDORLIB_$which: copying from $source_lib_folder to $target_lib_folder (if source file changed)" set resultdict [punkcheck::install $source_lib_folder $target_lib_folder\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -2183,7 +2333,7 @@ if {$::punkboot::command in {project packages libs}} { ######################################################## lappend projectlibfolders lib #exclude README.md from source folder - but only the root one - #-antiglob_paths takes relative patterns e.g + #-exclude-paths takes relative patterns e.g # */test.txt will only match test.txt exactly one level deep. # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. # **/test.txt will match at any level below the root (but not in the root) @@ -2200,7 +2350,7 @@ if {$::punkboot::command in {project packages libs}} { puts stdout "PROJECTLIB: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -2219,7 +2369,7 @@ if {$::punkboot::command in {project packages libs}} { puts stdout "PROJECTLIB_$which: copying from $source_lib_folder to $target_lib_folder (if source file changed)" set resultdict [punkcheck::install $source_lib_folder $target_lib_folder\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -2235,7 +2385,7 @@ if {$::punkboot::command in {project packages libs}} { puts stdout "PROJECTLIB_$which: copying from $source_lib_folder to $target_lib_folder (if source file changed)" set resultdict [punkcheck::install $source_lib_folder $target_lib_folder\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -2358,7 +2508,7 @@ if {$::punkboot::command in {project packages modules}} { set resultdict [punkcheck::install_non_tm_files $src_module_dir $target_modules_base\ -installer make.tcl\ -overwrite $overwrite\ - -antiglob_paths {README.md **/AGENTS.md AGENTS.md}\ + -exclude-paths {README.md **/AGENTS.md AGENTS.md}\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm index 778709bb..0d105eaf 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -1325,6 +1325,13 @@ tcl::namespace::eval punk::ansi { grepstr -r m -C 2 {cancelid} [s ::after] ;#with 2 lines of context and no break indicators. }]} + To match a literal string that contains regex special characters, it is in some cases easier to use the Tcl regex + quoting switch (?q) to quote the string rather than escaping each special character with a backslash. + ${[punk::args::helpers::example -syntax none { + #The following example matches a literal string that is the Tcl expansion operator {*} + grepstr "(?q){*}" $sometext + }]} + } @leaders -min 0 -max 0 diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm index e29dd871..f952ed09 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm @@ -474,7 +474,7 @@ namespace eval punk::mix::cli { set defaults [list {*}{ -installer punk::mix::cli::build_modules_from_source_to_base -call-depth-internal 0 - -max_depth 1000 + -max-depth 1000 -subdirlist {} -punkcheck_eventobj "\uFFFF" -glob *.tm @@ -487,7 +487,7 @@ namespace eval punk::mix::cli { set installername [dict get $opts -installer] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set CALLDEPTH [dict get $opts -call-depth-internal] - set max_depth [dict get $opts -max_depth] + set max_depth [dict get $opts -max-depth] set subdirlist [dict get $opts -subdirlist] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set fileglob [dict get $opts -glob] @@ -533,7 +533,7 @@ namespace eval punk::mix::cli { set config [dict create {*}{ -glob $fileglob - -max_depth 0 + -max-depth 0 }] #lassign [punkcheck::start_installer_event $punkcheck_file $installername $srcdir $basedir $config] _eventid punkcheck_eventid _recordset record_list # -- --- @@ -628,11 +628,11 @@ namespace eval punk::mix::cli { # -- --- set config [dict create {*}{ -glob * - -max_depth 100 + -max-depth 100 }] set had_error 0 - # -max_depth -1 for no limit + # -max-depth -1 for no limit set build_installername pods_in_$current_source_dir set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck] #set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck stderr] ;#with debugchannel @@ -829,11 +829,11 @@ namespace eval punk::mix::cli { # -- --- set config [dict create {*}{ -glob * - -max_depth 100 + -max-depth 100 }] set had_error 0 - # -max_depth -1 for no limit + # -max-depth -1 for no limit set build_installername tarjars_in_$current_source_dir set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck] $build_installer set_source_target $current_source_dir/$modpath $buildfolder diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.4.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.4.0.tm new file mode 100644 index 00000000..c3ba6efb --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.4.0.tm @@ -0,0 +1,1427 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'deck 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.4.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz +package require punk::repo +package require punk::ansi +package require punkcheck ;#checksum and/or timestamp records + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#review +#deck - rename to dev +namespace eval punk::mix::cli { + namespace eval temp_import { + } + namespace ensemble create + variable initialised 0 + + #lazy _init - called by punk::mix::base::_cli when ensemble used + proc _init {args} { + variable initialised + if {$initialised} { + return + } + puts stderr "punk::mix::cli::init $args" + package require punk::overlay + namespace eval ::punk::mix::cli { + 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 + } + } + set initialised 1 + } + + 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 + } + } + + #for externally launched tclsh or punkshell running src/make.tcl the cwd + #needs to be such that make.tcl can find required bootsupport libraries without relying on auto_path or tcl::tm::list mechanisms. + #we can change directory during the run, and change back again afterwards. + + #also - if no make.tcl - can we use the running shell's make.tcl ? (after prompting user?) + + if {([file tail $sourcefolder] ne "src") || (![file exists $sourcefolder/make.tcl])} { + puts stderr "dev make must be run from src folder containing make.tcl or from within a project containing src/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 { + #review - intended usecase? + 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 + } + } + } + + #if {![catch {run --timeout=150000 -debug [info nameofexecutable] $sourcefolder/make.tcl {*}$args} exitinfo]} { + # #todo - notify if exit because of timeout! + # puts stderr "exitinfo: $exitinfo" + # set exitcode [dict get $exitinfo exitcode] + #} else { + # puts stderr "Error unable to determine exitcode. err: $exitinfo" + # #cd $startdir + # return false + #} + + #use run so that stdout visible as it goes + #review - is setting a timeout here useful? It will just be annoying if the project really does need the time. + #review - on timeout what happens? (implemented in shellfilter) + # - if just stderr/stdout redirection channels closed - what happens with stdin? + # e.g 'for dev make shell' - we just get no further responses but stdin still consuming keystrokes? + try { + #cd $sourcefolder ;#dev paths can overide bootsupport modules + cd $project_base ;#bootsupport modules only + set exitinfo [run --timeout=150000 -debug [info nameofexecutable] $sourcefolder/make.tcl {*}$args] + } trap {} {emsg eopts} { + puts stderr "Error, unable to determine exitcode. err: $emsg" + return false + } finally { + cd $startdir + } + puts stderr "exitinfo: $exitinfo" + set exitcode [dict get $exitinfo exitcode] + + 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] + return [list plain tarjar zip] + } + + proc validate_modulename {modulename args} { + set opts [list {*}{ + -errorprefix validate_modulename + -strict 0 + }] + if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"} + foreach {k v} $args { + switch -- $k { + -errorprefix - -strict { + dict set opts $k $v + } + default { + error "validate_modulename error: unknown option '$k'. known options: [dict keys $opts]" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_errorprefix [dict get $opts -errorprefix] + set opt_strict [dict get $opts -strict] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + if {$opt_strict} { + if {[regexp {[A-Z]} $modulename]} { + error "$opt_errorprefix '$modulename' contains uppercase which is not recommended as per tip 590, and option -strict is set to 1" + } + } + + validate_name_not_empty_or_spaced $modulename -errorprefix $opt_errorprefix + set testname [string map {:: {}} $modulename] + if {[string first : $testname] >=0} { + error "$opt_errorprefix '$modulename' can only contain paired colons" + } + set badchars [list - "$" "?" "*"] + foreach bc $badchars { + if {[string first $bc $modulename] >= 0} { + error "$opt_errorprefix '$modulename' can not contain character '$bc'" + } + } + return $modulename + } + proc confirm_modulename {modulename} { + set finalised 0 + set aborted 0 + while {!$finalised && !$aborted} { + #first validate with -strict 0 to confirm acceptable while ignoring case issues. + #uppercase is generally valid but not recommended - so has separate prompting. + if {[catch {validate_modulename $modulename -strict 0} errM]} { + set msg "Chosen name didn't pass validation\n" + append msg "reason: $errM\n" + append msg "Please retype the modulename. You will be given a further prompt to confirm or abort." + set modulename [util::askuser $msg] + } elseif {[regexp {[A-Z]} $modulename]} { + set msg "module names containing uppercase are not recommended (see tip 590).\n" + append msg "Please retype the module name '$modulename' to proceed.\n" + append msg "If you type it exactly as it was you will be allowed to proceed with uppercase anyway\n" + append msg "Retype it all in lowercase to use recommended naming" + set answer [util::askuser $msg] + if {[regexp {[A-Z]} $answer]} { + if {$answer eq $modulename} { + #ok - user insists + set finalised 1 + } else { + #user supplied a different uppercase name - don't set finalised so we bug them again to type it two times the same way to proceed + puts stdout "A different uppercase name was supplied - reconfirmation required." + } + set modulename $answer + } else { + #user has resupplied modulename all as lowercase + if {$answer eq [string tolower $modulename]} { + set finalised 1 + } else { + #.. but it doesn't match original - require rerun + } + set modulename $answer + } + } else { + set answer [util::askuser "Proceed with the module name '$modulename'? Y to continue N to abort"] + if {[string tolower $answer] eq "y"} { + set finalised 1 + } else { + set aborted 1 + } + } + } + if {$aborted} { + return [dict create status error reason errmsg] + } else { + return [dict create status ok modulename $modulename] + } + } + + proc validate_projectname {projectname args} { + set defaults [list {*}{ + -errorprefix projectname + }] + if {[llength $args] %2 != 0} {error "validate_projectname 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_projectname error: unknown option $k. known options: $known_opts" + } + } + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_errorprefix [dict get $opts -errorprefix] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + validate_name_not_empty_or_spaced $projectname -errorprefix $opt_errorprefix + set reserved_words [list etc lib bin modules src doc vendorlib vendormodules embedded runtime _aside _build] + if {$projectname in $reserved_words } { + error "$opt_errorprefix '$projectname' cannot be one of reserved_words: $reserved_words" + } + if {[string first "::" $projectname] >= 0} { + error "$opt_errorprefix '$projectname' cannot contain namespace separator '::'" + } + return $projectname + } + proc validate_name_not_empty_or_spaced {name args} { + set opts [list {*}{ + -errorprefix projectname + }] + if {[llength $args] %2 != 0} {error "validate_name_not_empty_or_spaced args must be name-value pairs: received '$args'"} + foreach {k v} $args { + switch -- $k { + -errorprefix { + dict set opts $k $v + } + default { + error "validate_name_not_empty_or_spaced error: unknown option $k. known options: [dict keys $opts]" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_errorprefix [dict get $opts -errorprefix] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + if {![string length $name]} { + error "$opt_errorprefix cannot be empty" + } + if {[string length [string map [list " " "" \n "" \r "" \t ""] $name]] != [string length $name]} { + error "$opt_errorprefix cannot contain whitespace" + } + return $name + } + + + 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 [punk::ansi::a+ bold yellow][dict get $repopaths warnings][punk::ansi::a] + } else { + append result [punk::ansi::a+ bold yellow][dict get $repopaths warnings][punk::ansi::a] + 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 -- [>punk . logo] " " $result] + append result \n + } + } + + set timeline [exec fossil timeline -n 5 -t ci] + set timeline [string map {\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 "\nGIT 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 "#*" "_build" "_aside" ".git" ".fossil*"] ;#exact or glob patterns for folders (at any level) we don't want to search in or copy. + 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 + -podglob #modpod-* + -tarjarglob #tarjar-* + }] + 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] + set podglob [dict get $opts -podglob] + set tarjarglob [dict get $opts -tarjarglob] + 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::tm_version_magic] ;#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] + #set installer [punkcheck::installtrack new $installername $punkcheck_file stderr] ;#with debugchannel + $installer set_source_target $srcdir $basedir + set event [$installer start_event $config] + # -- --- + + } else { + set event $opt_punkcheck_eventobj + } + #---------------------------------------- + + + set process_modules [dict create] + #put pods first in processing order + set src_pods [glob -nocomplain -dir $current_source_dir -type d -tail -- $podglob] + foreach podpath $src_pods { + dict set process_modules $podpath [dict create -type pod] + } + set src_tarjars [glob -nocomplain -dir $current_source_dir -type d -tail -- $tarjarglob] + foreach tarjarpath $src_tarjars { + dict set process_modules $tarjarpath [dict create -type tarjar] + } + set src_modules [glob -nocomplain -dir $current_source_dir -type f -tail -- $fileglob] + foreach modulepath $src_modules { + dict set process_modules $modulepath [dict create -type file] + } + + set did_skip 0 ;#flag for stdout/stderr formatting only + dict for {modpath modinfo} $process_modules { + set modtype [dict get $modinfo -type] + + set is_interesting 0 + if {[string match "foobar" $current_source_dir]} { + set is_interesting 1 + } + + #debug for issues on non-windows platforms. + #if {$::tcl_platform(platform) ne "windows"} { + # set is_interesting 1 + #} + + if {$is_interesting} { + puts "build_modules_from_source_to_base >>> module $current_source_dir/$modpath" + } + set fileparts [split [file rootname $modpath] -] + #set tmfile_versionsegment [lindex $fileparts end] + lassign [split_modulename_version $modpath] basename tmfile_versionsegment + if {$tmfile_versionsegment eq ""} { + #split_modulename_version version part will be empty if not valid tcl version + #last segment doesn't look even slightly versiony - fail. + puts stderr "ERROR: Unable to confirm file $current_source_dir/$modpath is a reasonably versioned .tm module - ABORTING." + flush stderr + after 1000 + exit 1 + } + switch -- $modtype { + pod { + puts -nonewline stderr "p-" + #basename still contains leading #modpod- + if {[string match #modpod-* $basename]} { + set basename [string range $basename 8 end] + } else { + error "build_modules_from_source_to_base, pod, unexpected basename $basename" ;#shouldn't be possible with default podglob - review - why is podglob configurable? + } + set versionfile $current_source_dir/$basename-buildversion.txt ;#needs to be added in targetset_addsource to trigger rebuild if changed (only when magicversion in use) + if {$tmfile_versionsegment eq $magicversion} { + 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 + } + } else { + set module_build_version $tmfile_versionsegment + } + + set buildfolder $current_source_dir/_build + file mkdir $buildfolder + # -- --- + set config [dict create {*}{ + -glob * + -max-depth 100 + }] + set had_error 0 + + # -max-depth -1 for no limit + set build_installername pods_in_$current_source_dir + set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck] + #set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck stderr] ;#with debugchannel + $build_installer set_source_target $current_source_dir/$modpath $buildfolder + set build_event [$build_installer start_event $config] + # -- --- + set podtree_copy $buildfolder/#modpod-$basename-$module_build_version + set modulefile $buildfolder/$basename-$module_build_version.tm + + #todo - use modpod version as a source for change detection + #package require modpod + + $build_event targetset_init INSTALL $podtree_copy + $build_event targetset_addsource $current_source_dir/$modpath + if {$tmfile_versionsegment eq $magicversion} { + $build_event targetset_addsource $versionfile + } + if {\ + [llength [dict get [$build_event targetset_source_changes] changed]]\ + || [llength [$build_event get_targets_exist]] < [llength [$build_event get_targets]]\ + } { + $build_event targetset_started + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + + set delete_failed 0 + if {[file exists $buildfolder/]} { + puts stderr "deleting existing _build copy at $podtree_copy" + if {[catch { + file delete -force $podtree_copy + } errMsg]} { + puts stderr "[punk::ansi::a+ red]deletion of _build copy at $podtree_copy failed: $errMsg[punk::ansi::a]" + set delete_failed 1 + } + } + if {!$delete_failed} { + puts stdout "copying.." + puts stdout "$current_source_dir/$modpath" + puts stdout "to:" + puts stdout "$podtree_copy" + flush stdout + file copy $current_source_dir/$modpath $podtree_copy + if {$tmfile_versionsegment eq $magicversion} { + set tmfile $buildfolder/#modpod-$basename-$module_build_version/$basename-$magicversion.tm + if {[file exists $tmfile]} { + set newname $buildfolder/#modpod-$basename-$module_build_version/$basename-$module_build_version.tm + file rename $tmfile $newname + set tmfile $newname + } + set fd [open $tmfile r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd + set data [string map [list $magicversion $module_build_version] $data] + set fdout [open $tmfile w] + fconfigure $fdout -translation binary + puts -nonewline $fdout $data + close $fdout + } + #delete and regenerate zip and modpod stubbed zip + set notes [list] + if {[catch { + file delete $buildfolder/$basename-$module_build_version.zip + } err] } { + set had_error 1 + lappend notes "zip_delete_failed" + } + if {[catch { + file delete $buildfolder/$basename-$module_build_version.tm + } err]} { + set had_error 1 + lappend notes "tm_delete_failed" + } + #create ordinary zip file without using external executable + package require punk::zip + set zipfile $buildfolder/$basename-$module_build_version.zip ;#ordinary zip file (deflate) + + #zipfs mkzip does exactly what we need anyway in this case + #unfortunately it's not available in all Tclsh versions we might be running.. + if {[llength [info commands zipfs]]} { + #zipfs mkzip (2025) doesn't add entries for folders. + #(Therefore no timestamps) + #zip reading utils generally intuit their existence and display them - but often an editor can't add comments to them + set wd [pwd] + cd $buildfolder + puts "zipfs mkzip $zipfile #modpod-$basename-$module_build_version" + zipfs mkzip $zipfile #modpod-$basename-$module_build_version + cd $wd + + } else { + #use -base $buildfolder so that -directory is included in the archive - the modpod stub relies on this - and extraction would be potentially messy otherwise + #put in an archive-level comment to aid in debugging + #punk + punk::zip::mkzip -base $buildfolder -directory $buildfolder/#modpod-$basename-$module_build_version -- $zipfile * + #punk::zip::mkzip stores permissions - (unix style) - which zipfs mkzip doesn't + #Directory ident in zipfs relies on folders ending with trailing slash - if missing, it misidentifies dirs as files. + #(ie it can't use permissions/attributes alone to determine directory vs file) + #TODO - review punk::zip::mkzip and/or external zip to provide a fallback? + #JMN25 + + #set had_error 1 + #lappend notes "zipfs_unavailable" + #puts stderr "WARNING: zipfs unavailable can't build $modulefile" + } + if {!$had_error && [file exists $zipfile]} { + package require modpod + modpod::lib::make_zip_modpod $zipfile $modulefile + } + + + if {$had_error} { + $build_event targetset_end FAILED -note [join $notes ,] + } else { + # -- ---------- + $build_event targetset_end OK + # -- ---------- + } + } else { + $build_event targetset_end FAILED -note "could not delete $podtree_copy" + } + + } else { + puts -nonewline stderr "Z" + set did_skip 1 + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $build_event targetset_end SKIPPED + } + $build_event destroy + $build_installer destroy + + #JMN - review + if {!$had_error} { + $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm + $event targetset_addsource $modulefile + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ + } { + + $event targetset_started + # -- --- --- --- --- --- + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + lappend module_list $modulefile + if {[catch { + file copy -force $modulefile $target_module_dir + } errMsg]} { + puts stderr "[punk::ansi::a+ red]FAILED to copy zip modpod module $modulefile to $target_module_dir[punk::ansi::a]" + $event targetset_end FAILED -note "could not copy $modulefile" + } else { + puts stderr "[punk::ansi::a+ green]Copied zip modpod module $modulefile to $target_module_dir[punk::ansi::a]" + # -- --- --- --- --- --- + $event targetset_end OK -note "zip modpod" + } + } else { + puts -nonewline stderr "z" + set did_skip 1 + if {$is_interesting} { + puts stderr "$modulefile [$event targetset_source_changes]" + } + $event targetset_end SKIPPED + } + } + } + tarjar { + puts -nonewline stderr "t-" + #maint - overall code structure same as pod - refactor? + #basename may still contain #tarjar- + #to be obsoleted - update modpod to (optionally) use vfs::tar ? + if {[string match #tarjar-* $basename]} { + set basename [string range $basename 8 end] + } else { + error "build_modules_from_source_to_base, tarjar, unexpected basename $basename" ;#shouldn't be possible with default tarjarglob - review - why is tarjarglob configurable? + } + set versionfile $current_source_dir/$basename-buildversion.txt ;#needs to be added in targetset_addsource to trigger rebuild if changed (only when magicversion in use) + if {$tmfile_versionsegment eq $magicversion} { + set versionfiledata "" + if {![file exists $versionfile]} { + puts stderr "\n[punk::ansi::a+ brightyellow]WARNING: Missing buildversion text file: $versionfile[punk::ansi::a]" + 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:[punk::ansi::a+ red] build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file[punk::ansi::a]" + exit 3 + } + set module_build_version $ln0 + } + } else { + set module_build_version $tmfile_versionsegment + } + + set buildfolder $current_source_dir/_build + file mkdir $buildfolder + # -- --- + set config [dict create {*}{ + -glob * + -max-depth 100 + }] + set had_error 0 + + # -max-depth -1 for no limit + set build_installername tarjars_in_$current_source_dir + set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck] + $build_installer set_source_target $current_source_dir/$modpath $buildfolder + set build_event [$build_installer start_event $config] + # -- --- + set podtree_copy $buildfolder/#tarjar-$basename-$module_build_version + set modulefile $buildfolder/$basename-$module_build_version.tm + + + $build_event targetset_init INSTALL $podtree_copy + $build_event targetset_addsource $current_source_dir/$modpath + if {$tmfile_versionsegment eq $magicversion} { + $build_event targetset_addsource $versionfile + } + if {\ + [llength [dict get [$build_event targetset_source_changes] changed]]\ + || [llength [$build_event get_targets_exist]] < [llength [$build_event get_targets]]\ + } { + $build_event targetset_started + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + + set delete_failed 0 + if {[file exists $buildfolder/]} { + puts stderr "deleting existing _build copy at $podtree_copy" + if {[catch { + file delete -force $podtree_copy + } errMsg]} { + puts stderr "[punk::ansi::a+ red]deletion of _build copy at $podtree_copy failed: $errMsg[punk::ansi::a]" + set delete_failed 1 + } + } + if {!$delete_failed} { + puts stdout "copying.." + puts stdout "$current_source_dir/$modpath" + puts stdout "to:" + puts stdout "$podtree_copy" + file copy $current_source_dir/$modpath $podtree_copy + if {$tmfile_versionsegment eq $magicversion} { + set tmfile $buildfolder/#tarjar-$basename-$module_build_version/#tarjar-loadscript-$basename.tcl + #we don't need to modify version or name of the loadscript + if {![file exists $tmfile]} { + set had_error 1 + lappend notes "tarjar_loadscript_missing" + } else { + #the loadscript must end in a line starting with # and ending with backslash - with no linefeed + set fd [open $tmfile r] + chan configure $fd -translation binary + #last line must be less than 1k long + chan seek $fd -1024 end + set script_tail [read $fd] + set lastlf [string last \n $script_tail] + set lastline [string range $script_tail $lastlf+1 end] + set lastline [string trimleft $lastline] ;#lhs whitespace is ok + if {[string index $lastline 0] ne "#" || [string index $lastline end] ne "\\" } { + set had_error 1 + lappend notes "tarjar_loadscript_badtail" + } + } + } + #delete and regenerate .tm + set notes [list] + if {[catch { + file delete $buildfolder/$basename-$module_build_version.tm + } err]} { + set had_error 1 + lappend notes "tm_delete_failed" + } + #create ordinary tar file without using external executable + package require tar ;#tcllib + set tarfile $buildfolder/$basename-$module_build_version.tm ;#ordinary tar file (no compression - store) + set wd [pwd] + cd $buildfolder + puts "tar::create $tarfile #tarjar-$basename-$module_build_version" + if {[catch { + tar::create $tarfile #tarjar-$basename-$module_build_version + } errMsg]} { + set had_error 1 + puts stderr "tar::create $tarfile failed with msg\n $errMsg" + lappend notes "tar_create_failed" + } + cd $wd + + if {![file exists $tarfile]} { + set had_error 1 + lappend notes "tar_result_missing" + } + + + if {$had_error} { + $build_event targetset_end FAILED -note [join $notes ,] + } else { + # -- ---------- + $build_event targetset_end OK + # -- ---------- + } + } else { + $build_event targetset_end FAILED -note "could not delete $podtree_copy" + } + + } else { + puts -nonewline stderr "T" + set did_skip 1 + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $build_event targetset_end SKIPPED + } + $build_event destroy + $build_installer destroy + + #JMN - review + if {!$had_error} { + $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm + $event targetset_addsource $modulefile + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ + } { + + $event targetset_started + # -- --- --- --- --- --- + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + lappend module_list $modulefile + if {[catch { + file copy -force $modulefile $target_module_dir + } errMsg]} { + puts stderr "[punk::ansi::a+ red]FAILED to copy tarjar module $modulefile to $target_module_dir[punk::ansi::a]" + $event targetset_end FAILED -note "could not copy $modulefile" + } else { + puts stderr "[punk::ansi::a+ green]Copied tarjar module $modulefile to $target_module_dir[punk::ansi::a]" + # -- --- --- --- --- --- + $event targetset_end OK -note "tarjar" + } + } else { + puts -nonewline stderr "t" + set did_skip 1 + if {$is_interesting} { + puts stderr "$modulefile [$event targetset_source_changes]" + } + $event targetset_end SKIPPED + } + } + + } + file { + puts -nonewline stderr "f-" + set m $modpath + if {$tmfile_versionsegment eq $magicversion} { + #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]} { + #rebuilding the .tm from the #tarjar already handled above + puts -nonewline stderr "-" + + #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? + + ##TODO + #set buildfolder $current_sourcedir/_build + #file mkdir $buildfolder + + #set tmfile $buildfolder/$basename-$module_build_version.tm + #file delete -force $buildfolder/#tarjar-$basename-$module_build_version + #file delete -force $tmfile + + + #file copy -force $current_source_dir/#tarjar-$basename-$magicversion $buildfolder/#tarjar-$basename-$module_build_version + ## + ##bsdtar doesn't seem to work.. or I haven't worked out the right options? + ##exec tar -cvf $buildfolder/$basename-$module_build_version.tm $buildfolder/#tarjar-$basename-$module_build_version + #package require tar + #tar::create $tmfile $buildfolder/#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 { + if {$is_interesting} { + puts stdout "skipping module $current_source_dir/$m - no change in sources detected" + } + puts -nonewline stderr "m" + set did_skip 1 + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $event targetset_end SKIPPED + } + + #------------------------------ + + } + + continue + } + ##------------------------------ + ## + #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} + lappend module_list $current_source_dir/$m + file copy -force $current_source_dir/$m $target_module_dir + puts stderr "Copied already versioned module $current_source_dir/$m to $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 "f" + set did_skip 1 + if {$is_interesting} { + puts stderr "$current_source_dir/$m [$event targetset_source_changes]" + } + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $event targetset_end SKIPPED + } + } + } + } ;#end dict for {modpath modinfo} $process_modules + + + if {$CALLDEPTH >= $max_depth} { + set subdirs [list] + } else { + set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] + set targets_existing [glob -nocomplain -dir $target_module_dir -type d -tail {*}$subdirs] + } + #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 + #} + if {$d ni $targets_existing} { + 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\ + -podglob $podglob\ + ] + } + 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 + dict for {p b} $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] + dict for {r -} $::kettle::recipe::recipe { + if {$r ni $standard_recipes} { + dict unset ::kettle::recipe::recipe $r + } + } + } + proc kettle_call {calltype args} { + variable kettle_reset_bodies + switch -- $calltype { + lib {} + shell { + #on windows - could be kettle.bat or kettle.cmd - use auto_execok to find, whatever the platform. + #for now, restrict to version sitting next to exe - REVIEW + set exedir [file dirname [info nameofexecutable]] + set kettlescript [auto_execok $exedir/kettle] + if {$kettlescript eq ""} { + error "kettle_call unable to find installed kettle application file in '$exedir'" + } + + #set kettleappfile [file dirname [info nameofexecutable]]/kettle + #set kettlebatfile [file dirname [info nameofexecutable]]/kettle.bat + + #if {(![file exists $kettleappfile]) && (![file exists $kettlebatfile])} { + # error "deck 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 + # } + #} + } + default { + error "deck kettle_call 1st argument must be one of: 'lib' for direct use of kettle module or 'shell' to call as separate process" + } + } + set startdir [pwd] + if {![file exists $startdir/build.tcl]} { + error "deck 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 "deck 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 (deck)] + } + 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 + #load standard recipes as listed in build.tcl + ::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 + } + + } + proc kettle_punk_recipes {} { + set txtdst ... + } + + } +} + + +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 + if {[catch { + punk::overlay::custom_from_base [namespace current] ::punk::mix::base + } errM]} { + puts stderr "punk::mix::cli load error: Failed to overlay punk::mix::base $errM" + error "punk::mix::cli error: $errM" + } +} + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::cli [namespace eval punk::mix::cli { + variable version + set version 0.4.0 +}] +return diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.1.tm new file mode 100644 index 00000000..379adbae --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.1.tm @@ -0,0 +1,324 @@ +# -*- 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.1 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + +package require punk::path ;# for treefilenames, relative +package require punk::repo +package require punk::docgen ;#inline doctools - generate doctools .man files at src/docgen prior to using kettle to producing .html .md etc +package require punk::mix::cli ;#punk::mix::cli::lib used for kettle_call +#package require punkcheck ;#for path_relative + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +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" + puts "commands: doc.status" + } + + 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 + } + #user may delete the comment containing "--- punk::docgen::overwrites" and then manually edit, and we won't overwrite + #we still generate output in src/docgen so user can diff and manually update if thats what they prefer + set oldfiles [punk::path::treefilenames -dir $projectdir/src/doc _module_*.man] + foreach maybedoomed $oldfiles { + set fd [open $maybedoomed r] + chan conf $fd -translation binary + set data [read $fd] + close $fd + if {[string match "*--- punk::docgen overwrites *" $data]} { + file delete -force $maybedoomed + } + } + set generated [lib::do_docgen modules] + if {[dict get $generated count] > 0} { + #review + set doclist [dict get $generated docs] + set source_base [dict get $generated base] + set target_base $projectdir/src/doc + foreach dinfo $doclist { + lassign $dinfo module fpath + set relpath [punk::path::relative $source_base $fpath] + set relfolder [file dirname $relpath] + if {$relfolder eq "."} { + set relfolder "" + } + file mkdir [file join $target_base $relfolder] + set target [file join $target_base $relfolder _module_[file tail $fpath]] + puts stderr "target --> $target" + if {![file exists $target]} { + file copy $fpath $target + } + } + } + + 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 { + if {"::meta" eq [info commands ::meta]} { + puts stderr "There appears to be a leftover ::meta command which is presumed to be from doctools. Destroying object" + ::meta destroy + } + 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 {args} { + set argd [punk::args::parse $args withdef { + @id -id ::punk::mix::commandset::doc::validate + -- -type none -optional 1 -help "end of options marker --" + -individual -type boolean -default 1 + @values -min 0 -max -1 + patterns -default {*.man} -type any -multiple 1 + }] + set opt_individual [tcl::dict::get $argd opts -individual] + set patterns [tcl::dict::get $argd values patterns] + + + #todo - run and validate punk::docgen output + 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] + set docroot $projectdir/src/doc + cd $docroot + + if {!$opt_individual && "*.man" in $patterns} { + if {[catch { + dtplite validate $docroot + } errM]} { + puts stderr "commandset::doc::validate failed for projectdir '$projectdir'" + puts stderr "docroot '$docroot'" + puts stderr "dtplite error was: $errM" + } + } else { + foreach p $patterns { + set treefiles [punk::path::treefilenames $p] + foreach path $treefiles { + puts stdout "dtplite validate $path" + dtplite validate $path + } + } + } + + #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 + proc do_docgen {{project_subpath modules}} { + #Extract doctools comments from source code + set projectdir [punk::repo::find_project] + set output_base [file join $projectdir src docgen] + set codesource_path [file join $projectdir $project_subpath] + if {![file isdirectory $codesource_path]} { + puts stderr "WARNING punk::mix::commandset::doc unable to find codesource_path $codesource_path during do_docgen - skipping inline doctools generation" + return + } + if {[file isdirectory $output_base]} { + if {[catch { + file delete -force $output_base + }]} { + error "do_docgen failed to delete existing output base folder: $output_base" + } + } + file mkdir $output_base + + set matched_paths [punk::path::treefilenames -dir $codesource_path -exclude-paths {**/mix/templates/** **/project_layouts/** **/decktemplates/** **/_aside **/_aside/**} *.tm] + set count 0 + set newdocs [list] + set docgen_header_comments "" + append docgen_header_comments {[comment {--- punk::docgen generated from inline doctools comments ---}]} \n + append docgen_header_comments {[comment {--- punk::docgen DO NOT EDIT DOCS HERE UNLESS YOU REMOVE THESE COMMENT LINES ---}]} \n + append docgen_header_comments {[comment {--- punk::docgen overwrites this file ---}]} \n + foreach fullpath $matched_paths { + puts stdout "do_docgen processing: $fullpath" + set doctools [punk::docgen::get_doctools_comments $fullpath] + if {$doctools ne ""} { + set fname [file tail $fullpath] + set mod_tail [file rootname $fname] + set relpath [punk::path::relative $codesource_path [file dirname $fullpath]] + if {$relpath eq "."} { + set relpath "" + } + set tailsegs [file split $relpath] + set module_fullname [join $tailsegs ::]::$mod_tail + set target_docname $fname.man + set this_outdir [file join $output_base $relpath] + + if {[string length $fname] > 99} { + #output needs to be tarballed to do checksum change tests in a reasonably straightforward and not-too-terribly slow way. + #hack - review. Determine exact limit - test if tcllib tar fixed or if it's a limit of the particular tar format + #work around tcllib tar filename length limit ( somewhere around 100?) This seems to be a limit on the length of a particular segment in the path.. not whole path length? + #this case only came up because docgen used to path munge to long filenames - but left because we know there is a limit and renaming fixes it - even if it's ugly - but still allows doc generation. + #review - if we're checking fname - should also test length of whole path and determine limits for tar + package require md5 + if {[package vsatisfies [package present md5] 2- ] } { + set md5opt "-hex" + } else { + set md5opt "" + } + set target_docname [md5::md5 {*}$md5opt [encoding convertto utf-8 $fullpath]]_overlongfilename.man + puts stderr "WARNING - overlong file name - renaming $fullpath" + puts stderr " to [file dirname $fullpath]/$target_docname" + } + + file mkdir $this_outdir + puts stdout "saving [string length $doctools] bytes of doctools output from file $relpath/$fname" + set outfile [file join $this_outdir $target_docname] + set fd [open $outfile w] + fconfigure $fd -translation binary + puts -nonewline $fd $docgen_header_comments$doctools + close $fd + incr count + lappend newdocs [list $module_fullname $outfile] + } + } + return [list count $count docs $newdocs base $output_base] + } + + } +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## 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.1 +}] +return \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.1.tm new file mode 100644 index 00000000..cb395eaa --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.1.tm @@ -0,0 +1,1178 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'deck 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.1 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::mix::commandset::project 0 0.1.1] +#[copyright "2023"] +#[titledesc {dec commandset - project}] [comment {-- Name section and table of contents description --}] +#[moddesc {deck CLI commandset - project}] [comment {-- Description at end of page heading --}] +#[require punk::mix::commandset::project] +#[description] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::mix::commandset::project +#[para]Import into an ensemble namespace similarly to the way it is done with punk::mix::cli e.g +#[example { +# namespace eval myproject::cli { +# namespace export * +# namespace ensemble create +# package require punk::overlay +# +# 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 +# } +#}] +#[para] Where the . in the above example is the prefix/command separator +#[para]The prefix ('project' in the above example) can be any string desired to disambiguate commands imported from other commandsets. +#[para]The above results in the availability of the ensemble command: ::myproject::cli project.new, which is implemented in ::punk::mix::commandset::project::new +#[para]Similarly, procs under ::punk::mix::commandset::project::collection will be available as subcommands of the ensemble as projects. +#[para] +#[subsection Concepts] +#[para] see punk::overlay + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::mix::commandset::project +#[list_begin itemized] + +package require Tcl 8.6- +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package punk::ns] +#[item] [package sqlite3] (binary) +#[item] [package overtype] +#[item] [package textutil] (tcllib) + + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::mix::commandset::project { + namespace export * + #*** !doctools + #[subsection {Namespace punk::mix::commandset::project}] + #[para] core commandset functions for punk::mix::commandset::project + #[list_begin definitions] + + proc _default {} { + package require punk::ns + set dispatched_to [lindex [info level 2] 0] ;#e.g ::punk::mix::cli::project + set dispatch_tail [punk::ns::nstail $dispatched_to] + set dispatch_ensemble [punk::ns::nsprefix $dispatched_to] ;#e.g ::punk::mix::cli + set sibling_commands [namespace eval $dispatch_ensemble {namespace export}] + #todo - get separator? + set sep "." + set result [list] + foreach sib $sibling_commands { + if {[string match ${dispatch_tail}${sep}* $sib]} { + lappend result $sib + } + } + return [lsort $result] + } + + + namespace eval argdoc { + set layout_dict [punk::cap::call_handler punk.templates get_itemdict_projectlayouts] + variable LAYOUTNAMES [dict keys $layout_dict] + } + punk::args::define { + @id -id ::punk::mix::commandset::project::new + @cmd -name "punk::mix::commandset::project::new" -help\ + "" + @leaders -min 1 -max 1 + project -type string -help\ + "Project name or path. + If just a name is given ... (todo)" + @opts + -type -default plain + -empty -default 0 -type boolean + -force -default 0 -type boolean + -update -default 0 -type boolean + -confirm -default 1 -type boolean + -layout -default "punk.project" -choices {${$::punk::mix::commandset::project::argdoc::LAYOUTNAMES}} + } + + proc new {newprojectpath_or_name args} { + #*** !doctools + # [call [fun new] [arg newprojectpath_or_name] [opt args]] + #new project structure - may be dedicated to one module, or contain many. + #create minimal folder structure only by specifying in args: -modules {} + 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 -errorprefix "punk mix project.new" + + + set defaults [list\ + -type plain\ + -empty 0\ + -force 0\ + -update 0\ + -confirm 1\ + -modules \uFFFF\ + -layout punk.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 "deck 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_layout [dict get $opts -layout] + set opt_update [dict get $opts -update] + # -- --- --- --- --- --- --- --- --- --- --- --- --- + 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 + if {$opt_force || $opt_update} { + #generally undesirable to add default project module during an update. + #user can use dev module.new manually or supply module name in -modules + set opt_modules [list] + } else { + set opt_modules [list [string tolower $projectname]] ;#default modules to lowercase as is the modern (tip 590) recommendation for Tcl + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- + + + #todo - install support binaries on a per-project basis in a way that doesn't impact machine (e.g not added to path) - cache in user config dir if possible, supply mechanism to clear cache + # + 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 deck features." + if {[string length [set scoop_prog [auto_execok scoop]]]} { + #restrict to windows? + set answer [util::askuser "scoop detected. Would you like deck 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 "-------------------------------------------" + } + + + package require punk::cap + if {[punk::cap::capability_has_handler punk.templates]} { + set layout_dict [punk::cap::call_handler punk.templates get_itemdict_projectlayouts] + } else { + put stderr "commandset::project::new WARNING - no handler available for the 'punk.templates' capability - template providers will be unable to provide layout locations" + return + } + if {[dict exists $layout_dict $opt_layout]} { + set layout_name $opt_layout + set layout_info [dict get $layout_dict $layout_name] + set layout_path [dict get $layout_info path] + set layout_sourceinfo [dict get $layout_info sourceinfo] + } else { + puts stderr "commandset::project::new - no exact match for specified layout-name $opt_layout found" + puts stderr "layout names found: [dict keys $layout_dict]" + return + + #todo - pick highest version layout that matches opt_layout if version not specified but multiple exist + + #set layout_name ... + #set layout_info .. + #set layout_path ... + } + + + + #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 $layout_path 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} { + set warnmsg "mix new WARNING: -update 1 was supplied. Will copy layout $layout_path using -update option to add missing items" + if {$opt_confirm} { + puts stderr $warnmsg + set msg "Do you want to proceed to possibly overwrite some existing files in $projectdir? Y|N" + set answer [util::askuser $msg] + 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 prompt." + return + } + } + puts stderr $warnmsg + } + + 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 + } + #review + set fossil_repo_file $repodb_folder/$projectname.fossil + } + + 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 + + puts stdout ">>> about to call punkcheck::install $layout_path $projectdir" + set resultdict [dict create] + set antipaths [list {*}{ + src/doc/* + src/doc/include/* + src/PROJECT_LAYOUTS_* + }] + + #set exclude_paths [list {*}{ + # _ignore_* + # **/_ignore_* + #}] + set exclude_paths [list {*}{ + }] + + #default -exclude-paths-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_path $projectdir -installer project.new -createempty 1 -overwrite ALL-TARGETS -exclude-paths [concat $antipaths $exclude_paths]] + } else { + puts stdout "copying layout files - (if source file changed)" + set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite installedsourcechanged-targets -exclude-paths [concat $antipaths $exclude_paths]] + } + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + + if {[file exists $layout_path/src/doc]} { + puts stdout "copying layout src/doc files (if target missing)" + set resultdict [punkcheck::install $layout_path/src/doc $projectdir/src/doc -createdir 1 -punkcheck-folder $projectdir -installer project.new -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no src/doc in source template - update not required" + } + + #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 exclude-paths_core - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized. + ## default_excludepaths_core [list "#*" "**/#*" "_aside" "**/_aside" "_build" "**/_build" ".git" "**/.git" ".fossil*" "**/.fossil*"] + set override_excludepaths_core [list #* **/#* _aside **/_aside .git **/.git] + if {[file exists $layout_path/.fossil-custom]} { + puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)" + set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -createempty 1 -punkcheck-folder $projectdir -installer project.new -exclude-paths-core $override_excludepaths_core -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no .fossil-custom in source template - update not required" + } + + if {[file exists $layout_path/.fossil-settings]} { + puts stdout "copying layout src/.fossil-settings files (if target missing or uncustomised)" + set resultdict [punkcheck::install $layout_path/.fossil-settings $projectdir/.fossil-settings -createdir 1 -createempty 1 -punkcheck-folder $projectdir -installer project.new -exclude-paths-core $override_excludepaths_core -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no .fossil-settings in source template - update not required" + } + + #scan all files in template + # + #TODO - deck command to substitute templates? + set templateinfo_list [punk::mix::commandset::layout::lib::layout_scan_for_template_files $opt_layout] + set stripprefix [file normalize $layout_path] + + set tagmap [list [lib::template_tag project] $projectname] + if {[llength $templateinfo_list]} { + puts stdout "Filling template file placeholders with the following tag map:" + foreach {placeholder value} $tagmap { + puts stdout " $placeholder -> $value" + } + } + foreach templateinfo $templateinfo_list { + lassign $templateinfo templatefullpath template_tagnames_found + set templatetail [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] + set fpath [file join $projectdir $templatetail] + foreach t $template_tagnames_found { + if {"%$t%" ni [dict keys $tagmap]} { + puts stderr "warning: No substitution available for tag: %$t% in $fpath" + } + } + + if {[file exists $fpath]} { + set fd [open $fpath r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd + set data2 [string map $tagmap $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" + } + } + + ::cd $projectdir + + if {[file exists $projectdir/src/modules]} { + foreach m $opt_modules { + #check if mod-ver.tm file or #modpod-mod-ver folder exist + set tmfile $projectdir/src/modules/$m-[punk::mix::util::tm_version_magic].tm + set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::tm_version_magic]/$m-[punk::mix::util::tm_version_magic].tm + + set has_tm [file exists $tmfile] + set has_pod [file exists $podfile] + #puts stderr "=====> has_tm: $has_tm has_pod: $has_pod" + if {!$has_tm && !$has_pod} { + #todo - option for -module_template - and check existence at top? or change opt_modules to be a list of dicts with configuration info -template -type etc + punk::mix::commandset::module::new -project $projectname -type $opt_type $m + } else { + #we should rarely if ever want to force any src/modules to be overwritten + if {$opt_force} { + if {$has_pod} { + set answer [util::askuser "OVERWRITE the src/modules file $podfile ?? (generally not desirable) Y|N"] + set overwrite_type zip + } else { + set answer [util::askuser "OVERWRITE the src/modules file $tmfile ?? (generally not desirable) Y|N"] + set overwrite_type $opt_type + } + if {[string tolower $answer] eq "y"} { + #REVIEW - all pods zip - for now + punk::mix::commandset::module::new -project $projectname -type $overwrite_type -force 1 $m + } + } + } + } + } 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" + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::mix::commandset::project ---}] + + namespace eval collection { + #*** !doctools + #[subsection {Namespace punk::mix::commandset::project::collection}] + #[para] commandset functions for operating with multiple projects. + #[para] It would usually be imported with the prefix "projects" and separator "." to result in commands such as: projects.detail + #[list_begin definitions] + namespace export * + namespace path [namespace parent] + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::_default + @cmd -name "punk::mix::commandset::project::collection::_default"\ + -summary\ + "List projects under fossil managment."\ + -help\ + "List projects under fossil management, showing fossil db location and number of checkouts" + @values -min 0 -max -1 + glob -type string -multiple 1 -default * + } + #e.g imported as 'projects' + proc _default {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::_default] + set globlist [dict get $argd values glob] + + #*** !doctools + #[call [fun _default] [arg glob...]] + #[para]List projects under fossil management, showing fossil db location and number of checkouts + #[para]The glob argument is optional unless option/value pairs are also supplied, in which case * should be explicitly supplied + #[para]glob restricts output based on the name of the fossil db file e.g s* for all projects beginning with s + #[para]The _default function is made available in the ensemble by the name of the prefix used when importing the commandset. + #[para]e.g + #[para] punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection + #[para]Will result in the command being available as projects + package require overtype + set db_projects [lib::get_projects {*}$globlist] + 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 Repo 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] {string length $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] + set file_idx 0 + foreach dbfile $col1_dbfiles { + set project_name "" + set project_code "" + set project_desc "" + set db_error "" + if {[file exists $dbfile]} { + if {[catch { + 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) + } + } + } errM]} { + set db_error $errM + } + catch {dbp close} + } else { + set db_error "fossil file $dbfile missing" + } + lappend col4_pnames $project_name + lappend col5_pcodes $project_code + dict lappend codes $project_code $dbfile + lappend col7_pdescs $project_desc + if {$db_error ne ""} { + lset col1_dbfiles $file_idx "[a+ web-red]$dbfile[a]" + } + incr file_idx + } + + 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 Repo 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] {string length $v}]] + set col3 [string repeat " " $widest3] + set title4 "Project Name" + set widest4 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col4_pnames] {string length $v}]] + set col4 [string repeat " " $widest4] + set title5 "Project Code" + set widest5 [tcl::mathfunc::max {*}[lmap v [concat [list $title5] $col5_pcodes] {string length $v}]] + set col5 [string repeat " " $widest5] + set title6 "Dup" + set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col6_dupids] {string length $v}]] + set col6 [string repeat " " $widest6] + set title7 "Description" + #set widest7 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col7_pdescs] {string length $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]] + } + + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::work + @cmd -name punk::mix::commandset::project::collection::work\ + -summary\ + "List projects with checkout directories."\ + -help\ + "Get project info by opening the central fossil config-db to determine + fossil database files for each project, and the known checkout folders. + If -detail is true, a second operation gathers file state information + for each checkout folder." + @leaders -min 0 -max 0 + -cd -type none -help\ + "If this flag is provided, after lsting, prompt the user to enter + the row number of the checkout to 'cd' into, or an option to cancel. + If there is only one project with only a single checkout, the + cd operation will occur without prompting unless -prompt was + also supplied." + -prompt -type none -help\ + "If there is only one checkout in the result, cause a prompt to be + raised instead of automatically peforming the cd operation. + Has no effect if -cd was not supplied, or if -cd is supplied and + there are multiple checkouts, in which case user is always prompted." + -detail -type boolean -default 0 -help\ + "Include file state information for each checkout in the resulting + table. This includes information such as which files are changed, + unchanged,new,missing or extra and can take a little more time to + gather as it must examine the filesystem for each checkout folder. + + Note that although the default is false - if only a single project + matches the glob pattern(s) then file state will be gathered for + each of its checkouts. Use an explicit -detail 0 if this is not + desired." + @values -min 0 -max -1 + glob -type string -multiple 1 -default * -optional 1 -help\ + "glob patterns used to search for project. The glob is applied against + the names of the fossil repository database files - not the project-name, + which is not available in the central fossil config-db. + Case insensitive." + } + proc work {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] + lassign [dict values $argd] leaders opts values received + package require sqlite3 + set globlist [dict get $values glob] + + set db_projects [lib::get_projects {*}$globlist] + #list of lists of the form: + #{fosdb fname workdirlist} + if {[llength $db_projects] == 0} { + puts stderr "::punk::mix::commandset::project::work No Repo DB name matches found for '$globlist'" + return "" + } + # -- --- --- --- --- --- --- + set opt_cd [dict exists $received -cd] + # -- --- --- --- --- --- --- + set opt_detail [dict get $opts -detail] + if {[dict exists $received -detail] && !$opt_detail} { + set opt_detail_explicit_zero 1 + } else { + set opt_detail_explicit_zero 0 + } + set opt_prompt [dict exists $received -prompt] + # -- --- --- --- --- --- --- + 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 and opt_detail is 0 and not explicit - retrieve workingdir state for each co + if {([llength [dict keys $fosdb_cache]] == 1)} { + if {!$opt_detail_explicit_zero} { + set opt_detail 1 + } + puts stderr "Result is from a single repo db [dict keys $fosdb_cache]" + } + if {$opt_detail} { + if {!$opt_detail_explicit_zero} { + set detailmsg "Use -detail 0 to omit file state" + } else { + set detailmsg "" + } + puts stderr "Gathering file state for [llength $workdirs] checkout folder(s). $detailmsg" + set c_rev [list] + set c_rev_iso [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_rev_iso [dict get $state_dict revision_iso8601] + 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 t0b "Revision iso8601" + set w0b [tcl::mathfunc::max {*}[lmap v [concat [list $t0] $c_rev_iso] {string length $v}]] + set c0b [string repeat " " $w0b] + 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::left $c0b $t0b] [overtype::right $c1 $t1] [overtype::right $c2 $t2] [overtype::right $c3 $t3] [overtype::right $c4 $t4] [overtype::right $c5 $t5]" + foreach r $c_rev iso $c_rev_iso u $c_unchanged c $c_changed n $c_new m $c_missing e $c_extra { + lappend col_states "[overtype::left $c0 $r] [overtype::left $c0b $iso] [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 "Repo 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 { + if {![file exists $wd]} { + set row [punk::ansi::a+ strike red]$row[a] + set wd [punk::ansi::a+ red]$wd[a] + } + 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 { + if {![file exists $wd]} { + set row [punk::ansi::a+ strike red]$row[a] + set wd [punk::ansi::a+ red]$wd[a] + } + 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 && !$opt_prompt} { + 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 [deck stat] + return $workingdir + } + } + } + return $msg + } + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::cd + @cmd -name punk::mix::commandset::project::collection::cd\ + -summary\ + "List projects with checkout directories and prompt for which checkout to cd to."\ + -help\ + "List projects with checkout directories and prompt for which checkout to cd to." + @leaders -min 0 -max 0 + }\ + [punk::args::resolved_def -types opts ::punk::mix::commandset::project::collection::work -detail]\ + { + -prompt -type none -help\ + "Prompt even when result contains only one checkout location as a possible cd target. + User will always be prompted if result contains more than one checkout." + @values -min 0 -max -1 + }\ + [punk::args::resolved_def -types values ::punk::mix::commandset::project::collection::work glob] + + proc cd {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] + work -cd {*}$args + } + + #*** !doctools + #[list_end] [comment {-- end collection namespace definitions --}] + } + + namespace eval lib { + proc template_tag {tagname} { + #todo - support different tagwrappers - it shouldn't be so likely to collide with common code idioms etc. + #we need to detect presence of tags intended for punk::mix system + #consider using punk::cap to enable multiple template-substitution providers with their own set of tagnames and/or tag wrappers, where substitution providers are all run + return [string cat % $tagname %] + } + punk::args::define { + @id -id ::punk::mix::commandset::project::lib::get_projects + @cmd -name punk::mix::commandset::project::lib::get_projects\ + -summary\ + "Return a 3-element list of projects referred to by central fossil config-db."\ + -help\ + "Get project info only by opening the central fossil config-db. + Each member of the returned list is a 3-element list of: + + The shortname is simply the name based on the root name of the fossil database, + it is not necessarily the project-name by which the project is referred to in the fossil + checkout databases." + @values -min 0 -max -1 + glob -type string -multiple 1 -default * -optional 1 -help\ + "case insensitive glob for the name of the fossil database." + } + proc get_projects {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::lib::get_projects] + set globlist [dict get $argd values glob] + + set fossil_prog [auto_execok fossil] + + set configdb [punk::repo::fossil_get_configdb] + + package require sqlite3 + ::sqlite3 fosconf $configdb + #set testresult [fosconf eval {select name,value from global_config;}] + #puts stderr $testresult + #list of repositories of the form repo: + #eg repo:C:/Users/someone/.fossils/tcl.fossil + + #the command: + # fossil all ignore /repo.fossil + #will remove the {repo:/repo.fossil 1} record from global_config + #but it leaves {ckout: /repo.fossil} records, even if such checkouts are closed + #when the folder itself at is removed - then commands such as 'fossil all ls -c' automatically remove the corresponding ckout: record. + + 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;}] + #list of entries like "ckout:C:/buildtcl/2024zig/tcl90/" + 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 -nocase -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 + } + + } + + + +} + + +#*** !doctools +#[manpage_end] + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::commandset::project [namespace eval punk::mix::commandset::project { + variable version + set version 0.1.1 +}] +return diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.2.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.2.0.tm new file mode 100644 index 00000000..c48c95b9 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.2.0.tm @@ -0,0 +1,1178 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'deck 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.2.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::mix::commandset::project 0 0.2.0] +#[copyright "2023"] +#[titledesc {dec commandset - project}] [comment {-- Name section and table of contents description --}] +#[moddesc {deck CLI commandset - project}] [comment {-- Description at end of page heading --}] +#[require punk::mix::commandset::project] +#[description] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::mix::commandset::project +#[para]Import into an ensemble namespace similarly to the way it is done with punk::mix::cli e.g +#[example { +# namespace eval myproject::cli { +# namespace export * +# namespace ensemble create +# package require punk::overlay +# +# 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 +# } +#}] +#[para] Where the . in the above example is the prefix/command separator +#[para]The prefix ('project' in the above example) can be any string desired to disambiguate commands imported from other commandsets. +#[para]The above results in the availability of the ensemble command: ::myproject::cli project.new, which is implemented in ::punk::mix::commandset::project::new +#[para]Similarly, procs under ::punk::mix::commandset::project::collection will be available as subcommands of the ensemble as projects. +#[para] +#[subsection Concepts] +#[para] see punk::overlay + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::mix::commandset::project +#[list_begin itemized] + +package require Tcl 8.6- +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package punk::ns] +#[item] [package sqlite3] (binary) +#[item] [package overtype] +#[item] [package textutil] (tcllib) + + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::mix::commandset::project { + namespace export * + #*** !doctools + #[subsection {Namespace punk::mix::commandset::project}] + #[para] core commandset functions for punk::mix::commandset::project + #[list_begin definitions] + + proc _default {} { + package require punk::ns + set dispatched_to [lindex [info level 2] 0] ;#e.g ::punk::mix::cli::project + set dispatch_tail [punk::ns::nstail $dispatched_to] + set dispatch_ensemble [punk::ns::nsprefix $dispatched_to] ;#e.g ::punk::mix::cli + set sibling_commands [namespace eval $dispatch_ensemble {namespace export}] + #todo - get separator? + set sep "." + set result [list] + foreach sib $sibling_commands { + if {[string match ${dispatch_tail}${sep}* $sib]} { + lappend result $sib + } + } + return [lsort $result] + } + + + namespace eval argdoc { + set layout_dict [punk::cap::call_handler punk.templates get_itemdict_projectlayouts] + variable LAYOUTNAMES [dict keys $layout_dict] + } + punk::args::define { + @id -id ::punk::mix::commandset::project::new + @cmd -name "punk::mix::commandset::project::new" -help\ + "" + @leaders -min 1 -max 1 + project -type string -help\ + "Project name or path. + If just a name is given ... (todo)" + @opts + -type -default plain + -empty -default 0 -type boolean + -force -default 0 -type boolean + -update -default 0 -type boolean + -confirm -default 1 -type boolean + -layout -default "punk.project" -choices {${$::punk::mix::commandset::project::argdoc::LAYOUTNAMES}} + } + + proc new {newprojectpath_or_name args} { + #*** !doctools + # [call [fun new] [arg newprojectpath_or_name] [opt args]] + #new project structure - may be dedicated to one module, or contain many. + #create minimal folder structure only by specifying in args: -modules {} + 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 -errorprefix "punk mix project.new" + + + set defaults [list\ + -type plain\ + -empty 0\ + -force 0\ + -update 0\ + -confirm 1\ + -modules \uFFFF\ + -layout punk.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 "deck 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_layout [dict get $opts -layout] + set opt_update [dict get $opts -update] + # -- --- --- --- --- --- --- --- --- --- --- --- --- + 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 + if {$opt_force || $opt_update} { + #generally undesirable to add default project module during an update. + #user can use dev module.new manually or supply module name in -modules + set opt_modules [list] + } else { + set opt_modules [list [string tolower $projectname]] ;#default modules to lowercase as is the modern (tip 590) recommendation for Tcl + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- + + + #todo - install support binaries on a per-project basis in a way that doesn't impact machine (e.g not added to path) - cache in user config dir if possible, supply mechanism to clear cache + # + 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 deck features." + if {[string length [set scoop_prog [auto_execok scoop]]]} { + #restrict to windows? + set answer [util::askuser "scoop detected. Would you like deck 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 "-------------------------------------------" + } + + + package require punk::cap + if {[punk::cap::capability_has_handler punk.templates]} { + set layout_dict [punk::cap::call_handler punk.templates get_itemdict_projectlayouts] + } else { + put stderr "commandset::project::new WARNING - no handler available for the 'punk.templates' capability - template providers will be unable to provide layout locations" + return + } + if {[dict exists $layout_dict $opt_layout]} { + set layout_name $opt_layout + set layout_info [dict get $layout_dict $layout_name] + set layout_path [dict get $layout_info path] + set layout_sourceinfo [dict get $layout_info sourceinfo] + } else { + puts stderr "commandset::project::new - no exact match for specified layout-name $opt_layout found" + puts stderr "layout names found: [dict keys $layout_dict]" + return + + #todo - pick highest version layout that matches opt_layout if version not specified but multiple exist + + #set layout_name ... + #set layout_info .. + #set layout_path ... + } + + + + #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 $layout_path 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} { + set warnmsg "mix new WARNING: -update 1 was supplied. Will copy layout $layout_path using -update option to add missing items" + if {$opt_confirm} { + puts stderr $warnmsg + set msg "Do you want to proceed to possibly overwrite some existing files in $projectdir? Y|N" + set answer [util::askuser $msg] + 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 prompt." + return + } + } + puts stderr $warnmsg + } + + 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 + } + #review + set fossil_repo_file $repodb_folder/$projectname.fossil + } + + 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 + + puts stdout ">>> about to call punkcheck::install $layout_path $projectdir" + set resultdict [dict create] + set antipaths [list {*}{ + src/doc/* + src/doc/include/* + src/PROJECT_LAYOUTS_* + }] + + #set exclude_paths [list {*}{ + # _ignore_* + # **/_ignore_* + #}] + set exclude_paths [list {*}{ + }] + + #default -exclude-paths-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_path $projectdir -installer project.new -createempty 1 -overwrite ALL-TARGETS -exclude-paths [concat $antipaths $exclude_paths]] + } else { + puts stdout "copying layout files - (if source file changed)" + set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite installedsourcechanged-targets -exclude-paths [concat $antipaths $exclude_paths]] + } + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + + if {[file exists $layout_path/src/doc]} { + puts stdout "copying layout src/doc files (if target missing)" + set resultdict [punkcheck::install $layout_path/src/doc $projectdir/src/doc -createdir 1 -punkcheck-folder $projectdir -installer project.new -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no src/doc in source template - update not required" + } + + #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 exclude-paths_core - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized. + ## default_excludepaths_core [list "#*" "**/#*" "_aside" "**/_aside" "_build" "**/_build" ".git" "**/.git" ".fossil*" "**/.fossil*"] + set override_excludepaths_core [list #* **/#* _aside **/_aside .git **/.git] + if {[file exists $layout_path/.fossil-custom]} { + puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)" + set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -createempty 1 -punkcheck-folder $projectdir -installer project.new -exclude-paths-core $override_excludepaths_core -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no .fossil-custom in source template - update not required" + } + + if {[file exists $layout_path/.fossil-settings]} { + puts stdout "copying layout src/.fossil-settings files (if target missing or uncustomised)" + set resultdict [punkcheck::install $layout_path/.fossil-settings $projectdir/.fossil-settings -createdir 1 -createempty 1 -punkcheck-folder $projectdir -installer project.new -exclude-paths-core $override_excludepaths_core -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no .fossil-settings in source template - update not required" + } + + #scan all files in template + # + #TODO - deck command to substitute templates? + set templateinfo_list [punk::mix::commandset::layout::lib::layout_scan_for_template_files $opt_layout] + set stripprefix [file normalize $layout_path] + + set tagmap [list [lib::template_tag project] $projectname] + if {[llength $templateinfo_list]} { + puts stdout "Filling template file placeholders with the following tag map:" + foreach {placeholder value} $tagmap { + puts stdout " $placeholder -> $value" + } + } + foreach templateinfo $templateinfo_list { + lassign $templateinfo templatefullpath template_tagnames_found + set templatetail [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] + set fpath [file join $projectdir $templatetail] + foreach t $template_tagnames_found { + if {"%$t%" ni [dict keys $tagmap]} { + puts stderr "warning: No substitution available for tag: %$t% in $fpath" + } + } + + if {[file exists $fpath]} { + set fd [open $fpath r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd + set data2 [string map $tagmap $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" + } + } + + ::cd $projectdir + + if {[file exists $projectdir/src/modules]} { + foreach m $opt_modules { + #check if mod-ver.tm file or #modpod-mod-ver folder exist + set tmfile $projectdir/src/modules/$m-[punk::mix::util::tm_version_magic].tm + set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::tm_version_magic]/$m-[punk::mix::util::tm_version_magic].tm + + set has_tm [file exists $tmfile] + set has_pod [file exists $podfile] + #puts stderr "=====> has_tm: $has_tm has_pod: $has_pod" + if {!$has_tm && !$has_pod} { + #todo - option for -module_template - and check existence at top? or change opt_modules to be a list of dicts with configuration info -template -type etc + punk::mix::commandset::module::new -project $projectname -type $opt_type $m + } else { + #we should rarely if ever want to force any src/modules to be overwritten + if {$opt_force} { + if {$has_pod} { + set answer [util::askuser "OVERWRITE the src/modules file $podfile ?? (generally not desirable) Y|N"] + set overwrite_type zip + } else { + set answer [util::askuser "OVERWRITE the src/modules file $tmfile ?? (generally not desirable) Y|N"] + set overwrite_type $opt_type + } + if {[string tolower $answer] eq "y"} { + #REVIEW - all pods zip - for now + punk::mix::commandset::module::new -project $projectname -type $overwrite_type -force 1 $m + } + } + } + } + } 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" + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::mix::commandset::project ---}] + + namespace eval collection { + #*** !doctools + #[subsection {Namespace punk::mix::commandset::project::collection}] + #[para] commandset functions for operating with multiple projects. + #[para] It would usually be imported with the prefix "projects" and separator "." to result in commands such as: projects.detail + #[list_begin definitions] + namespace export * + namespace path [namespace parent] + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::_default + @cmd -name "punk::mix::commandset::project::collection::_default"\ + -summary\ + "List projects under fossil managment."\ + -help\ + "List projects under fossil management, showing fossil db location and number of checkouts" + @values -min 0 -max -1 + glob -type string -multiple 1 -default * + } + #e.g imported as 'projects' + proc _default {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::_default] + set globlist [dict get $argd values glob] + + #*** !doctools + #[call [fun _default] [arg glob...]] + #[para]List projects under fossil management, showing fossil db location and number of checkouts + #[para]The glob argument is optional unless option/value pairs are also supplied, in which case * should be explicitly supplied + #[para]glob restricts output based on the name of the fossil db file e.g s* for all projects beginning with s + #[para]The _default function is made available in the ensemble by the name of the prefix used when importing the commandset. + #[para]e.g + #[para] punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection + #[para]Will result in the command being available as projects + package require overtype + set db_projects [lib::get_projects {*}$globlist] + 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 Repo 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] {string length $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] + set file_idx 0 + foreach dbfile $col1_dbfiles { + set project_name "" + set project_code "" + set project_desc "" + set db_error "" + if {[file exists $dbfile]} { + if {[catch { + 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) + } + } + } errM]} { + set db_error $errM + } + catch {dbp close} + } else { + set db_error "fossil file $dbfile missing" + } + lappend col4_pnames $project_name + lappend col5_pcodes $project_code + dict lappend codes $project_code $dbfile + lappend col7_pdescs $project_desc + if {$db_error ne ""} { + lset col1_dbfiles $file_idx "[a+ web-red]$dbfile[a]" + } + incr file_idx + } + + 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 Repo 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] {string length $v}]] + set col3 [string repeat " " $widest3] + set title4 "Project Name" + set widest4 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col4_pnames] {string length $v}]] + set col4 [string repeat " " $widest4] + set title5 "Project Code" + set widest5 [tcl::mathfunc::max {*}[lmap v [concat [list $title5] $col5_pcodes] {string length $v}]] + set col5 [string repeat " " $widest5] + set title6 "Dup" + set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col6_dupids] {string length $v}]] + set col6 [string repeat " " $widest6] + set title7 "Description" + #set widest7 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col7_pdescs] {string length $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]] + } + + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::work + @cmd -name punk::mix::commandset::project::collection::work\ + -summary\ + "List projects with checkout directories."\ + -help\ + "Get project info by opening the central fossil config-db to determine + fossil database files for each project, and the known checkout folders. + If -detail is true, a second operation gathers file state information + for each checkout folder." + @leaders -min 0 -max 0 + -cd -type none -help\ + "If this flag is provided, after lsting, prompt the user to enter + the row number of the checkout to 'cd' into, or an option to cancel. + If there is only one project with only a single checkout, the + cd operation will occur without prompting unless -prompt was + also supplied." + -prompt -type none -help\ + "If there is only one checkout in the result, cause a prompt to be + raised instead of automatically peforming the cd operation. + Has no effect if -cd was not supplied, or if -cd is supplied and + there are multiple checkouts, in which case user is always prompted." + -detail -type boolean -default 0 -help\ + "Include file state information for each checkout in the resulting + table. This includes information such as which files are changed, + unchanged,new,missing or extra and can take a little more time to + gather as it must examine the filesystem for each checkout folder. + + Note that although the default is false - if only a single project + matches the glob pattern(s) then file state will be gathered for + each of its checkouts. Use an explicit -detail 0 if this is not + desired." + @values -min 0 -max -1 + glob -type string -multiple 1 -default * -optional 1 -help\ + "glob patterns used to search for project. The glob is applied against + the names of the fossil repository database files - not the project-name, + which is not available in the central fossil config-db. + Case insensitive." + } + proc work {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] + lassign [dict values $argd] leaders opts values received + package require sqlite3 + set globlist [dict get $values glob] + + set db_projects [lib::get_projects {*}$globlist] + #list of lists of the form: + #{fosdb fname workdirlist} + if {[llength $db_projects] == 0} { + puts stderr "::punk::mix::commandset::project::work No Repo DB name matches found for '$globlist'" + return "" + } + # -- --- --- --- --- --- --- + set opt_cd [dict exists $received -cd] + # -- --- --- --- --- --- --- + set opt_detail [dict get $opts -detail] + if {[dict exists $received -detail] && !$opt_detail} { + set opt_detail_explicit_zero 1 + } else { + set opt_detail_explicit_zero 0 + } + set opt_prompt [dict exists $received -prompt] + # -- --- --- --- --- --- --- + 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 and opt_detail is 0 and not explicit - retrieve workingdir state for each co + if {([llength [dict keys $fosdb_cache]] == 1)} { + if {!$opt_detail_explicit_zero} { + set opt_detail 1 + } + puts stderr "Result is from a single repo db [dict keys $fosdb_cache]" + } + if {$opt_detail} { + if {!$opt_detail_explicit_zero} { + set detailmsg "Use -detail 0 to omit file state" + } else { + set detailmsg "" + } + puts stderr "Gathering file state for [llength $workdirs] checkout folder(s). $detailmsg" + set c_rev [list] + set c_rev_iso [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_rev_iso [dict get $state_dict revision_iso8601] + 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 t0b "Revision iso8601" + set w0b [tcl::mathfunc::max {*}[lmap v [concat [list $t0] $c_rev_iso] {string length $v}]] + set c0b [string repeat " " $w0b] + 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::left $c0b $t0b] [overtype::right $c1 $t1] [overtype::right $c2 $t2] [overtype::right $c3 $t3] [overtype::right $c4 $t4] [overtype::right $c5 $t5]" + foreach r $c_rev iso $c_rev_iso u $c_unchanged c $c_changed n $c_new m $c_missing e $c_extra { + lappend col_states "[overtype::left $c0 $r] [overtype::left $c0b $iso] [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 "Repo 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 { + if {![file exists $wd]} { + set row [punk::ansi::a+ strike red]$row[a] + set wd [punk::ansi::a+ red]$wd[a] + } + 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 { + if {![file exists $wd]} { + set row [punk::ansi::a+ strike red]$row[a] + set wd [punk::ansi::a+ red]$wd[a] + } + 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 && !$opt_prompt} { + 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 [deck stat] + return $workingdir + } + } + } + return $msg + } + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::cd + @cmd -name punk::mix::commandset::project::collection::cd\ + -summary\ + "List projects with checkout directories and prompt for which checkout to cd to."\ + -help\ + "List projects with checkout directories and prompt for which checkout to cd to." + @leaders -min 0 -max 0 + }\ + [punk::args::resolved_def -types opts ::punk::mix::commandset::project::collection::work -detail]\ + { + -prompt -type none -help\ + "Prompt even when result contains only one checkout location as a possible cd target. + User will always be prompted if result contains more than one checkout." + @values -min 0 -max -1 + }\ + [punk::args::resolved_def -types values ::punk::mix::commandset::project::collection::work glob] + + proc cd {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] + work -cd {*}$args + } + + #*** !doctools + #[list_end] [comment {-- end collection namespace definitions --}] + } + + namespace eval lib { + proc template_tag {tagname} { + #todo - support different tagwrappers - it shouldn't be so likely to collide with common code idioms etc. + #we need to detect presence of tags intended for punk::mix system + #consider using punk::cap to enable multiple template-substitution providers with their own set of tagnames and/or tag wrappers, where substitution providers are all run + return [string cat % $tagname %] + } + punk::args::define { + @id -id ::punk::mix::commandset::project::lib::get_projects + @cmd -name punk::mix::commandset::project::lib::get_projects\ + -summary\ + "Return a 3-element list of projects referred to by central fossil config-db."\ + -help\ + "Get project info only by opening the central fossil config-db. + Each member of the returned list is a 3-element list of: + + The shortname is simply the name based on the root name of the fossil database, + it is not necessarily the project-name by which the project is referred to in the fossil + checkout databases." + @values -min 0 -max -1 + glob -type string -multiple 1 -default * -optional 1 -help\ + "case insensitive glob for the name of the fossil database." + } + proc get_projects {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::lib::get_projects] + set globlist [dict get $argd values glob] + + set fossil_prog [auto_execok fossil] + + set configdb [punk::repo::fossil_get_configdb] + + package require sqlite3 + ::sqlite3 fosconf $configdb + #set testresult [fosconf eval {select name,value from global_config;}] + #puts stderr $testresult + #list of repositories of the form repo: + #eg repo:C:/Users/someone/.fossils/tcl.fossil + + #the command: + # fossil all ignore /repo.fossil + #will remove the {repo:/repo.fossil 1} record from global_config + #but it leaves {ckout: /repo.fossil} records, even if such checkouts are closed + #when the folder itself at is removed - then commands such as 'fossil all ls -c' automatically remove the corresponding ckout: record. + + 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;}] + #list of entries like "ckout:C:/buildtcl/2024zig/tcl90/" + 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 -nocase -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 + } + + } + + + +} + + +#*** !doctools +#[manpage_end] + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::commandset::project [namespace eval punk::mix::commandset::project { + variable version + set version 0.2.0 +}] +return diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm index 230bad31..fa63e4fb 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm @@ -1444,52 +1444,34 @@ namespace eval punk::path { return [treefile_priv::walk_treefilenames_zipfs $state] } + punk::args::define { + @id -id ::punk::path::relative + @cmd -name punk::path::relative\ + -summary\ + "Compute the relative path from a reference path to a location path."\ + -help\ + "Taking two directory paths, a reference and a location, computes the path + of the location relative to the reference. + + Will return a single dot '.' if the paths are the same. + + Both paths must be the same type - ie both absolute or both relative. + + Matching is case sensitive. On windows, the drive-letter component (only) is + not case sensitive, so punk::path::relative c:/etc C:/etc returns '.'. + The part following the driveletter is case sensitive, so + punk::path::relative c:/etc C:/Etc returns ../Etc. + + On windows, if the paths are absolute and specify different volumes, + only the location will be returned." + @leaders -min 2 -max 2 + reference -type string -help\ + "The path from which the relative path to location is determined." + location -type string -help\ + "The location path which may be above or below the reference path." + } #maint warning - also in punkcheck proc relative {reference location} { - #*** !doctools - #[call [fun relative] [arg reference] [arg location]] - #[para] Taking two directory paths, a reference and a location, computes the path - # of the location relative to the reference. - #[list_begin itemized] - #[item] - #[para] Arguments: - # [list_begin arguments] - # [arg_def string reference] The path from which the relative path to location is determined. - # [arg_def string location] The location path which may be above or below the reference path - # [list_end] - #[item] - #[para] Results: - #[para] The relative path of the location to the reference path. - #[para] Will return a single dot "." if the paths are the same - #[item] - #[para] Notes: - #[para] Both paths must be the same type - ie both absolute or both relative - #[para] Case sensitive. ie punk::path::relative /etc /etC - # will return ../etC - #[para] On windows, the drive-letter component (only) is not case sensitive - #[example_begin] - # P% punk::path::relative c:/etc C:/etc - # - . - #[example_end] - #[para] The part following the driveletter is case sensitive so in the following cases it recognises the driveletter matches but not the tail - #[example_begin] - # P% punk::path::relative c:/etc C:/Etc - # - ../Etc - #[example_end] - #[para] On windows, if the paths are absolute and specifiy different volumes, only the location will be returned. - #[example_begin] - # P% punk::path::relative c:/etc d:/etc/blah - # - d:/etc/blah - #[example_end] - #[para] Unix-like examples: - #[example_begin] - # P% punk::path::relative /usr/local/etc/ /usr/local/etc/somewhere/below - # - somewhere/below - # P% punk::path::relative /usr/local/etc/somewhere /usr/local/lib/here - # - ../../lib/here - #[example_end] - #[list_end] - #see also kettle # Modified copy of ::fileutil::relative (tcllib) # Adapted to 8.5 ({*}). diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.2.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.2.0.tm new file mode 100644 index 00000000..68f0b744 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.2.0.tm @@ -0,0 +1,1611 @@ +# -*- 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::path 0.2.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::path 0 0.2.0] +#[copyright "2023"] +#[titledesc {Filesystem path utilities}] [comment {-- Name section and table of contents description --}] +#[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}] +#[require punk::path] +#[description] +#[keywords module path filesystem] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::path +#[para] Filesystem path utility functions +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::path +#[list_begin itemized] + +package require Tcl 8.6- +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {punk::args}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#namespace eval punk::path::class { + #*** !doctools + #[subsection {Namespace punk::path::class}] + #[para] class definitions + #if {[info commands [namespace current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + #} +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::path { + namespace export {[a-z]*} + #variable xyz + + #*** !doctools + #[subsection {Namespace punk::path}] + #[para] Core API functions for punk::path + #[list_begin definitions] + + # -- --- + #punk::path::normjoin + # - simplify . and .. segments as far as possible whilst respecting specific types of root. + # -- --- + #a form of file normalize that supports //xxx to be treated as server path names + #(ie regardless of unices ignoring (generally) leading double slashes, and regardless of windows volumerelative path syntax) + #(sometimes //server.com used as a short form for urls - which doesn't seem too incompatible with this anyway) + # -- --- + #This is intended to be purely a string analysis - without reference to filesystem volumes or vfs or zipfs mountpoints etc + #(but this also means we won't be able to resolve windows shortnames or dos device paths - so we will preserve those as they are) - review + #(It also means we can't resolve per drive working directories on windows - so we will preserve c: as is rather than converting to absolute - review) + # + #TODO - option for caller to provide a -base below which we can't backtrack. + #This is preferable to setting policy here for example regarding forcing no trackback below //servername/share + #Our default is to allow trackback to: + # :// + # :/ + # //./ (dos device volume) + # //server (while normalizing //./UNC/server to same) + # / (ordinary unix root) + # ./../ - (track back indefinitely on relpath as we are not resolving to anything physical and can't fully simplify the leading backtracks) + # + #The caller should do the file/vfs operations to determine this - not us. + # -- --- + #simplify path with respect to /./ & /../ elements - independent of platform + #NOTE: "anomalies" in standard tcl processing on windows: + #e.g file normalize {//host} -> c:/host (or e.g d:/host if we happen to be on another volume) + #file normalize {//host/share} -> //host/share + #This is because //host is treated as volume-relative in cmd/powershell and Tcl quite reasonably follows suit. + #This prevents cwd and windows commandlines from pointing to the server (above the share) + #Explorer however does allow pointing to the //server level and seeing shares as if they are directory entries. + #we are more interested in supporting the explorer-like behaviour - as while volumerelative paths are also useful on windows - they are lesser known. + #REVIEW. + #To get back to some consistent cross platform behaviour - we will treat //something as a root/volume i.e we can't backtrack above it with ".." + #note too that file split on UNC paths doesn't give a clear indication of the root + # file split //./UNC/server/share/subpath -> //./UNC server share subpath + # file split //server/share/subpath -> //server/share subpath + #TODO - disallow all change of root or change from relative path to absolute result. + #e.g normjoin relpath/../d:/secret should not return d:/secret - but ./d:/secret + # ================ + #known issues: + #1) + # normjoin d://a//b//c -> d://a/b/c + # This is because we don't detect specific schemes. ie it's treated the same as https://a/b/c -> https://a/b/c + # Not considered a problem - just potentially surprising. + # To avoid it we would have to enumerate possible schemes. + # As it stands a unix system could define a 'scheme' that happens to match windows style driveletters. Consider a 'feature' ? review. + # won't fix? + #2) + # normjoin https:///real.com/../fake.com -> https:///fake.com + # The extra slash means effectively our servername is empty - this is potentially confusing but probably the right thing to do here. + # It's a concern only if upstream treats the tripple slash in this case as valid and maps it to https:// - which would probably be bad anyway. + # won't fix (review) + #3) + #similarly + # normjoin //./UNC//server/share/subpath -> ///server/share/subpath (when 2 or more slashes directly after UNC) + # normjoin ///server/share -> ///server/share + #This is effectively an empty servername in the input with 'server' being pushed one level down - and the output is consistent + # possibly won't fix - review + #4) inconsistency + # we return normalized //server/share for //./UNC/server share + # but other dos device paths are maintained + # e.g //./c:/etc + # This is because such paths could contain alternate segment names (windows shortnames) which we aren't in a position to resolve. + # caller should + # #as with 'case' below - caller will need to run a post 'file normalize' + #5) we don't normalize case like file normalize does on windows platform. + # This is intentional. It could only be done with reference to underlying filesystem which we don't want here. + # + # ================ + # + #relpaths all end up with leading . - while not always the simplest form, this is ok. (helps stop inadvertent conversions to absolutes) + # Tests - TODO + # normjoin /d:/..//vfs:/test -> /vfs:/test (good - not converted to //vfs:/test) + + #normjoin c: should theoretically return current per drive working directory on c: + # - would need to use win32 GetFullPathName to resolve this. + proc normjoin {args} { + set args [lmap a $args {string map "\\\\ /" $a}] + set path [plainjoin {*}$args] + switch -exact -- $path { + "" { + return "" + } + / - // { + #treated in unixlike manner - (but leading doubleslashes with subsequent data are server indication) + #// not considered a servername indicator - but /// (for consistency) is. (empty servername?) + return / + } + /// { + #if this is effectively //$emptyservername/ + #then for consistency we should trail //=3 + #todo - shortcircuit that here? + } + } + # /// + set doubleslash1_posn [string first // $path] + + # -- --- --- temp warning on windows only - no x-platform difference in result + #on windows //host is of type volumerelative + # whereas //host/share is of type absolute + if {"windows" eq $::tcl_platform(platform) && [file pathtype $path] eq "volumerelative"} { + #volumerelative probably only occurs on windows anyway + if {$doubleslash1_posn == 0} { + #e.g //something where no further slashes + #review - eventually get rid of this warning and require upstream to know the appropriate usecase + puts stderr "Warning - ambiguous path $path - treating as server path - not 'volumerelative'" + } else { + # /something/etc + # /mnt/c/stuff + #output will retain leading / as if on unix. + #on windows - the result would still be interpreted as volumerelative if the caller normalizes it + } + } + # -- --- --- + + set is_relpath 0 + + #set path [string map [list \\ /] $path] + set finalparts [list] + set is_nonunc_dosdevice 0 + if {[punk::winpath::is_dos_device_path $path]} { + #review + if {[string range $path 4 6] eq "UNC"} { + #convert to 'standard' //server/... path for processing + set path "/[string range $path 7 end]" ;# //server/... + } else { + #error "normjoin non-UNC dos device path '$path' not supported" + #first segment after //./ or //?/ represents the volume or drive. + #not applicable to unix - but unlikely to conflict with a genuine usecase there (review) + #we should pass through and stop navigation below //./vol + #!!! + #not anomaly in tcl (continues in tcl9) + #file exists //./c:/test -> 0 + #file exists //?/c:/test -> 1 + #file exists //./BootPartition/Windows -> 1 + #file exists //?/BootPartition/Windows -> 0 + set is_nonunc_dosdevice 1 + } + } + + if {$is_nonunc_dosdevice} { + #dosdevice prefix //./ or //?/ - preserve it (without trailing slash which will be put back in with join) + set prefix [string range $path 0 2] + set tail [string range $path 4 end] + set tailparts [split $tail /] + set parts [concat [list $prefix] $tailparts] + set rootindex 1 ;#disallow backtrack below //./ + } else { + #note use of ordinary ::split vs file split is deliberate. + if {$doubleslash1_posn == 0} { + #this is handled differently on different platforms as far as 'file split' is concerned. + #e.g for file split //sharehost/share/path/etc + #e.g on windows: -> //sharehost/share path + #e.g on freebsd: -> / sharehost share path etc + #however..also on windows: file split //sharehost -> / sharehost + #normalize by dropping leading slash before split - and then treating first 2 segments as a root + #set parts [file split [string range $path 1 end]] + set parts [split $path /] + #assert parts here has {} {} as first 2 entries + set rootindex 2 + #currently prefer can backtrack to the //zipfs:/ scheme (below the mountpoint - to browse other mounts) + #alternative handling for //zipfs:/path - don't go below mountpoint + #but we can't determine just from string if mountpoint is direct subpath or a lower one e.g //zipfs:/arbitraryname/actualmountpoint + #review - more generally //:/path ? + #todo - make an option for zipfs and others to determine the 'base' + #if {"zipfs:" eq [lindex $parts 2]} { + # set rootindex 3 + #} + } else { + #path may or may not begin with a single slash here. + #treat same on unix and windows + set rootindex 0 + #set parts [file split $path] + set parts [::split $path /] + #e.g /a/b/c -> {} a b c + #or relative path a/b/c -> a b c + #or c:/a/b/c -> c: a b c + if {[string match *: [lindex $parts 0]]} { + if {[lindex $parts 1] eq ""} { + #scheme://x splits to scheme: {} x + set parts [concat [list [lindex $parts 0]/] [lrange $parts 2 end]] + #e.g {scheme:/ x} + set rootindex 1 ;#disallow below first element of scheme + } else { + set rootindex 0 + } + } elseif {[lindex $parts 0] ne ""} { + #relpath a/b/c + #set parts [linsert $parts 0 .] + ledit parts -1 -1 . + set rootindex 0 + #allow backtracking arbitrarily for leading .. entries - simplify where possible + #also need to stop possible conversion to absolute path + set is_relpath 1 + } + } + } + set baseparts [lrange $parts 0 $rootindex] ;#base below which we can't retreat via ".." + #puts stderr "-->baseparts:$baseparts" + #ensure that if our rootindex already spans a dotted segment (after the first one) we remove it + #must maintain initial . for relpaths to stop them converting to absolute via backtrack + # + set finalparts [list [lindex $baseparts 0]] + foreach b [lrange $baseparts 1 end] { + if {$b ni {. ..}} { + lappend finalparts $b + } + } + set baselen [expr {$rootindex + 1}] + if {$is_relpath} { + set i [expr {$rootindex+1}] + foreach p [lrange $parts $i end] { + switch -exact -- $p { + . - "" {} + .. { + switch -exact -- [lindex $finalparts end] { + . - .. { + lappend finalparts .. + } + default { + #lpop finalparts + ledit finalparts end end + } + } + } + default { + lappend finalparts $p + } + } + incr i + } + } else { + foreach p [lrange $parts $rootindex+1 end] { + if {[llength $finalparts] <= $baselen} { + if {$p ni {. .. ""}} { + lappend finalparts $p + } + } else { + switch -exact -- $p { + . - "" {} + .. { + #lpop finalparts ;#uses punk::lib::compat::lpop if on < 8.7 + ledit finalparts end end ;#uses punk::lib::compat::ledit if on < 8.7 + } + default { + lappend finalparts $p + } + } + } + } + } + #puts "==>finalparts: '$finalparts'" + # using join - {"" "" server share} -> //server/share and {a b} -> a/b + if {[llength $finalparts] == 1 && [lindex $finalparts 0] eq ""} { + #backtracking on unix-style path can end up with empty string as only member of finalparts + #e.g /x/.. + return / + } + set result [::join $finalparts /] + #normalize volumes and mountschemes to have trailing slash if no subpath + #e.g c: -> c:/ + #//zipfs: -> //zipfs:/ + if {[set lastchar [string index $result end]] eq ":"} { + if {$result eq "//zipfs:"} { + set result "//zipfs:/" + } else { + if {[string first / $result] < 0} { + set result $result/ + } + } + } elseif {[string match //* $result]} { + if {![punk::winpath::is_dos_device_path $result]} { + #server + set tail [string range $result 2 end] + set tailparts [split $tail /] + if {[llength $tailparts] <=1} { + #empty // or //servername + append result / + } + } + } elseif {[llength $finalparts] == 2} { + if {[string range [lindex $finalparts 0] end-1 end] eq ":/"} { + #e.g https://server/ -> finalparts {https:/ server} + #e.g https:/// -> finalparts {https:/ ""} + #scheme based path should always return trailing slash after server component - even if server component empty. + lappend finalparts "" ;#force trailing / + return [join $finalparts /] + } + } + if {[file extension [lindex $finalparts end]] eq ".lnk"} { + if {![catch {package require punk::winlnk}]} { + if {![catch {punk::winlnk::target $result} path]} { + return $path + } + } + } + return $result + } + + proc trim_final_slash {str} { + if {[string index $str end] eq "/"} { + return [string range $str 0 end-1] + } + return $str + } + + + #x-platform - punk::path::pathtype - can be used in safe interps - different concept of pathtypes to 'file pathtype' + # - no volumerelative + # - no lookup of file volumes (volume is a windows concept - but with //zipfs:/ somewhat applicable to other platforms) + # - /* as absolute (covers also //zipfs:/ (volume), //server , //./etc , //./UNC) + # - xxx:// as absolute (scheme) + # - xxx:/ or x:/ as absolute + # - x: xxx: -> as absolute (volume-basic or volume-extended) + + #note also on windows - legacy name for COM devices + # COM1 = COM1: + # //./COM1 ?? review + + proc pathtype {str} { + set str [string map "\\\\ /" $str] + if {[string index $str 0] eq "/"} { + #todo - look for //xxx:/ prefix (generalisation of //zipfs:/) as a 'volume' specifically {volume mount} ?? - review + # look for //server prefix as {absolute server} + # look for //./UNC/server or //?/UNC/server as {absolute server UNC} ? + # look for //./ as {absolute dosdevice} + return absolute + } + + #only firstsegment with single colon at last position (after some non empty string) counts as volume or scheme - review + #e.g a:b:/.. or a::/.. or :/.. is not treated as volume/scheme whereas ab:/ is. + set firstslash [string first / $str] + if {$firstslash == -1} { + set firstsegment $str + } else { + set firstsegment [string range $str 0 $firstslash-1] + } + if {[set firstc [string first : $firstsegment]] > 0} { + set lhs_firstsegment [string range $firstsegment 0 $firstc-1] + set rhs_firstsegment [string range $firstsegment $firstc+1 end] ;#exclude a:b/ etc + if {$rhs_firstsegment eq ""} { + set rhs_entire_path [string range $str $firstc+1 end] + #assert lhs_firstsegment not empty since firstc > 0 + #count following / sequence + set i 0 + set slashes_after_firstsegment "" ;#run of slashes *directly* following first segment + while {$i < [string length $rhs_entire_path]} { + if {[string index $rhs_entire_path $i] eq "/"} { + append slashes_after_firstsegment / + } else { + break + } + incr i + } + switch -exact -- $slashes_after_firstsegment { + "" - / { + if {[string length $lhs_firstsegment] == 1} { + return {absolute volume basic} + } else { + return {absolute volume extended} + } + } + default { + #2 or more / + #this will return 'scheme' even for c:// - even though that may look like a windows volume - review + return {absolute scheme} + } + } + } + } + #assert first element of any return has been absolute or relative + return relative + } + + + proc plain {str} { + set str [string map "\\\\ /" $str] + set pathinfo [punk::path::pathtype $str] + if {[lindex $pathinfo 0] eq "relative" && ![string match ./* $str]} { + set str ./$str + } + if {[string index $str end] eq "/"} { + if {[string map {/ ""} $str] eq ""} { + #all slash segment + return $str + } else { + if {[lindex $pathinfo 1] ni {volume scheme}} { + return [string range $str 0 end-1] + } + } + } + return $str + } + #purely string based - no reference to filesystem knowledge + #unix-style forward slash only + proc plainjoin {args} { + set args [lmap a $args {string map "\\\\ /" $a}] + #if {[llength $args] == 1} { + # return [lindex $args 0] + #} + set out "" + foreach a $args { + if {![string length $out]} { + append out [plain $a] + } else { + set a [plain $a] + if {[string map {/ ""} $out] eq ""} { + set out [string range $out 0 end-1] + } + + if {[string map {/ ""} $a] eq ""} { + #all / segment + append out [string range $a 0 end-1] + } else { + if {[string length $a] > 2 && [string match "./*" $a]} { + set a [string range $a 2 end] + } + if {[string index $out end] eq "/"} { + append out $a + } else { + append out / $a + } + } + } + } + return $out + } + proc plainjoin1 {args} { + if {[llength $args] == 1} { + return [lindex $args 0] + } + set out [trim_final_slash [lindex $args 0]] + foreach a [lrange $args 1 end] { + set a [trim_final_slash $a] + append out / $a + } + return $out + } + + #intention? + #proc filepath_dotted_dirname {path} { + #} + + proc strip_prefixdepth {path prefix} { + if {$prefix eq ""} { + return [norm $path] + } + return [file join {*}{ + } {*}[lrange {*}{ + } [file split [norm $path]] {*}{ + } [llength [file split [norm $prefix]]] {*}{ + } end + ] + ] + } + + + ## for comparison + #proc nsglob_as_re {glob} { + # #any segment that is not just * must match exactly one segment in the path + # set pats [list] + # foreach seg [nsparts_cached $glob] { + # switch -exact -- $seg { + # "" { + # lappend pats "" + # } + # * { + # #review - ::g*t will not find ::got:it (won't match single inner colon) - this should be fixed + # #lappend pats {[^:]*} + # #negative lookahead + # #any number of chars not followed by ::, followed by any number of non : + # lappend pats {(?:.(?!::))*[^:]*} + # } + # ** { + # lappend pats {.*} + # } + # default { + # set seg [string map {. [.]} $seg] + # if {[regexp {[*?]} $seg]} { + # #set pat [string map [list ** {.*} * {[^:]*} ? {[^:]}] $seg] + # set pat [string map [list ** {.*} * {(?:.(?!::))*[^:]*} ? {[^:]}] $seg] + # lappend pats "$pat" + # } else { + # lappend pats "$seg" + # } + # } + # } + # } + # return "^[join $pats ::]\$" + #} + proc pathglob_as_re {pathglob} { + #*** !doctools + #[call [fun pathglob_as_re] [arg pathglob]] + #[para] Returns a regular expression for matching a path to a glob pattern which can contain glob chars *|? in any segment of the path structure + #[para] Does not support square bracket globs or character classes. + #[para] ** matches any number of subdirectories. + #[para] e.g /etc/**/*.txt will match any .txt files at any depth below /etc (except directly within /etc itself) + #[para] e.g /etc/**.txt will match any .txt files at any depth below /etc + #[para] any segment that does not contain ** must match exactly one segment in the path + #[para] e.g the glob /etc/*/*.doc - will match any .doc files that are exactly one tree level below /etc + #[para] The pathglob doesn't have to contain glob characters, in which case the returned regex will match the pathglob exactly as specified. + #[para] Regular expression syntax is deliberateley not supported within the pathglob string so that supplied regex characters will be treated as literals + + + #todo - consider whether a way to escape the glob chars ? * is practical - to allow literals ? * + # - would require counting immediately-preceding backslashes + set pats [list] + foreach seg [file split $pathglob] { + if {[string range $seg end end] eq "/"} { + set seg [string range $seg 0 end-1] ;# e.g c:/ -> c: / -> "" so that join at end doesn't double up + } + switch -- $seg { + * {lappend pats {[^/]*}} + ** {lappend pats {.*}} + default { + set seg [string map [list ^ {\^} $ {\$} \[ {\[} \] {\]} ( {\(} ) {\)} \{ \\\{ \\ {\\}] $seg] ;#treat regex characters (or tcl glob square bracket chars) in the input as literals + #set seg [string map [list . {[.]}] $seg] + set seg [string map {. [.]} $seg] + if {[regexp {[*?]} $seg]} { + set pat [string map [list ** {.*} * {[^/]*} ? {[^/]}] $seg] + lappend pats "$pat" + } else { + lappend pats "$seg" + } + } + } + } + return "^[join $pats /]\$" + } + + punk::args::define { + @id -id ::punk::path::globmatchpath + @cmd -name punk::path::globmatchpath\ + -summary\ + "Match path to *|**|? glob patterns"\ + -help\ + "Return a boolean indicating whether the path matches the specialised glob pattern. + A pattern such as /usr/*/bin will match any path that has /usr as the first segment and bin as the third segment, + with any single segment in between. + A pattern such as /usr/**/bin will match any path that has /usr as the first segment and bin as the last segment, + with 1 or more segments in between (so it will not match /usr/bin). + A pattern such as /usr/** will match any path that has /usr as the first segment, with 1 or more segments + following (so it will not match /usr itself). + A pattern such as **/*.txt will match any path that ends with .txt, with 1 or more leading segments + (so it will not match test.txt or .txt). + A pattern such as ** will match any path. + The glob characters * and ? are the only special characters in the pathglob syntax. + - they are treated as glob characters regardless of where they appear in the pathglob string. + Note that this is different from other Tcl glob contexts where square brackets can be used. + The pathglob syntax treats other characters, including square brackets as literals. + For example, the pattern /usr/te?t will match /usr/test and /usr/text but not /usr/texxt, and the pattern /usr/te*t + will match /usr/test, /usr/teat, and /usr/teeeet but not /usr/te/t. + The pathglob syntax does not support escaping of glob characters - any glob characters in the pathglob are treated + as glob characters. For example, the pattern /usr/* will match any path that has /usr as the first segment and any + single segment as the second segment, but there is no way to specify a pattern that matches any path that has /usr + as the first segment and a literal * as the second segment. + Caller must ensure that file separator is forward slash. (e.g use file normalize on windows) + + options: + -nocase 0|1 (default 0 - case sensitive) + If -nocase is not supplied - default to case sensitive *except for driveletter* + ie - the driveletter alone in paths such as c:/etc will still be case insensitive. (ie c:/ETC/* will match C:/ETC/blah but not C:/etc/blah) + Explicitly specifying -nocase 0 will require the entire case to match including the driveletter. + " + @leaders + pathglob -type string -help "glob pattern to match path against. See [fun pathglob_as_re] for syntax of glob patterns" + path -type string -help "path to match against glob pattern" + @opts + -nocase -type boolean -default 0 -help\ + "case insensitive matching (default false - case sensitive) + - except for driveletter on windows which is always case insensitive + unless -nocase 0 is explicitly specified" + @values -min 0 -max 0 + } + # -id + proc globmatchpath {pathglob path args} { + #*** !doctools + #[call [fun globmatchpath] [arg pathglob] [arg path] [opt {option value...}]] + #[para] Return true if the pathglob matches the path + #[para] see [fun pathglob_as_re] for pathglob description + #[para] Caller must ensure that file separator is forward slash. (e.g use file normalize on windows) + #[para] + #[para] Known options: + #[para] -nocase 0|1 (default 0 - case sensitive) + #[para] If -nocase is not supplied - default to case sensitive *except for driveletter* + #[para] ie - the driveletter alone in paths such as c:/etc will still be case insensitive. (ie c:/ETC/* will match C:/ETC/blah but not C:/etc/blah) + #[para] Explicitly specifying -nocase 0 will require the entire case to match including the driveletter. + + set opts [dict create {*}{ + -nocase \uFFFF + }] + foreach {k v} $args { + switch -- $k { + -nocase { + dict set opts $k $v + } + default { + error "Unrecognised option '$k'. Known-options: [dict keys $opts]" + } + } + } + # -- --- --- --- --- --- + set opt_nocase [dict get $opts -nocase] + set explicit_nocase 1 ;#default to disprove + if {$opt_nocase eq "\uFFFF"} { + set opt_nocase 0 + set explicit_nocase 0 + } + # -- --- --- --- --- --- + if {$opt_nocase} { + return [regexp -nocase [pathglob_as_re $pathglob] $path] + } else { + set re [pathglob_as_re $pathglob] + if {$explicit_nocase} { + set ismatch [regexp $re $path] ;#explicit -nocase 0 - require exact match of path literals including driveletter + } else { + #caller is using default for -nocase - which indicates case sensitivity - but we have an exception for the driveletter. + set re_segments [file split $re] ;#Note that file split c:/etc gives {c:/ etc} but file split ^c:/etc gives {^c: etc} + set first_seg [lindex $re_segments 0] + if {[regexp {^\^(.{1}):$} $first_seg _match driveletter]} { + #first part of re is like "^c:" i.e a drive letter + set chars [string tolower $driveletter][string toupper $driveletter] + set re [join [concat "^\[$chars\]:" [lrange $re_segments 1 end]] /] ;#rebuild re with case insensitive driveletter only - use join - not file join. file join will misinterpret leading re segment. + } + #puts stderr "-->re: $re" + set ismatch [regexp $re $path] + } + } + return $ismatch + } + punk::args::define { + @id -id ::punk::path::subfolders1 + @cmd -name punk::path::subfolders1\ + -summary\ + "Listing of directories below supplied path."\ + -help\ + "List of folders below path. + The resulting list is unsorted." + @opts + -recursive -type none -help\ + "" + -exclude-paths -type list -default {} -help\ + "list of path patterns to exclude from results. + May include * and ** path segments e.g /usr/** + A single /*/ will match any single segment in the path, and a single /**/ will match any number of segments in the path. + + e.g to exclude any path with _aside as a segment in the middle: -exclude-paths **/_aside/** + i.e this would exclude /usr/_aside/etc and /usr/x/_aside/etc but not /usr/x/_aside or _aside/etc + + To exclude all paths with _aside as a segment anywhere: -exclude-paths { **/_aside/** **/_aside _aside/**} + " + #todo -depth + @values -min 0 -max 1 + path -type directory -optional 1 -help\ + "Path of folder. If not supplied current directory is used. + This may be a relative or absolute path. Relative paths are treated as relative to current directory. + When using relative paths - the result will also be relative paths with the same relative prefix. + (e.g if path is ../test - the results will be ../test/subfolder1 ../test/subfolder2 etc) + Patterns in -exclude-paths are matched against the resulting paths + (so should be written to match the same relative prefix if path is relative)" + } + + proc subfolders1 {args} { + #NOTE - this algorithm based on omit_only_patterns and prune_base_patterns was suggested by a 2026 AI model - it is apparent to this programmer that it is inadequate for the purpose. + #e.g consider subfolders1 -recursion -exclude {**/vfs/** **/src/**} + #This can still return something like c:/repo/etc/src/vfs - which should be excluded by the pattern **/src/** + #todo - review and fix properly. + set argd [punk::args::parse $args withid ::punk::path::subfolders1] + lassign [dict values $argd] leaders opts values received + set do_recursion [dict exists $received -recursive] + set exclude_paths [dict get $opts -exclude-paths] + if {"**" in $exclude_paths} { + #if ** is in exclude_paths - then we can skip all glob matching and just return empty list + #This is likely user error - so we'll be loud about it for now but will still return empty list rather than erroring. + #If user code is building exclude_paths dynamically - they can check for this case themselves and avoid the call to subfolders1 to suppress this message. + puts stderr "punk::path::subfolders1 Warning - exclude_paths contains '**' - all paths will be excluded" + return [list] + } + if {[dict exists $received path]} { + set path [dict get $values path] + } else { + set path [pwd] + } + + set all_subfolders [glob -nocomplain -directory $path -types d *] + + + #example of expected exclude_paths pattern behaviour when recursion is enabled: + # **/dirname -> omit /x/y/dirname, but still visit /x/y/dirname/* + + # **/dirname/* -> include /x/y/dirname and /x/y/dirname/a/b but omit directories that are a single level below /x/y/dirname such as /x/y/dirname/a + + #c:/** - would exclude all subfolders below c: but not c: itself + + # **/test/** - would exclude any path with test as a segment and all its subfolders + #- but not paths with test as a segment that is the final segment + + set folders [list] + set recurse_subdirs [list] + + foreach f $all_subfolders { + set include_in_results 1 + set allow_recurse 1 + foreach pat $exclude_paths { + set pat_parts [file split $pat] ;#note file split c:/test gives {c:/ test} but file split **/test gives {** test} + #also note that file split on windows treats forward slashes and backslashes the same. + #by using file split, we gain some flexibility in syntax of paths and patterns, + #but lose the ability to use backslashes as escapes to allow literal glob characters in path segments. + #This is almost always a non-issue on windows since * and ? are not valid in path segments there, and is rarely an issue on unix even though + # * and ? are technically valid in path segments, but it is inadvisable there anyway for compatibility with shells etc. + if {[llength $pat_parts] >= 2 && [lindex $pat_parts end] eq "**"} { + set base_pat [file join {*}[lrange $pat_parts 0 end-1]] + if {[globmatchpath $pat $f]} { + set include_in_results 0 + set allow_recurse 0 + } elseif {[globmatchpath $base_pat $f]} { + set allow_recurse 0 + } + } elseif {[globmatchpath $pat $f]} { + set include_in_results 0 + } + if {!$include_in_results && !$allow_recurse} { + break + } + } + if {$include_in_results} { + lappend folders $f + } + if {$allow_recurse} { + lappend recurse_subdirs $f + } + } + if {$do_recursion} { + foreach subdir $recurse_subdirs { + lappend folders {*}[subfolders1 -exclude-paths $exclude_paths -recursive $subdir] + } + } + return $folders + } + + namespace eval subfolder_priv { + proc classify_exclude_pattern {pat} { + set parts [file split $pat] + if {[llength $parts] >= 2 && [lindex $parts end] eq "**"} { + set boundary_pat [file join {*}[lrange $parts 0 end-1]] + return [dict create {*}{ + } pattern $pat {*}{ + } kind subtree {*}{ + } boundary_pat $boundary_pat {*}{ + } descend_pat $pat {*}{ + } + ] + } + if {[llength $parts] >= 2 && [lindex $parts end] eq "*"} { + return [dict create {*}{ + } pattern $pat {*}{ + } kind child_only {*}{ + } match_pat $pat {*}{ + } + ] + } + return [dict create {*}{ + } pattern $pat {*}{ + } kind exact {*}{ + } match_pat $pat {*}{ + } + ] + } + + proc compile_exclude_rules {exclude_paths} { + set rules [list] + foreach pat $exclude_paths { + lappend rules [classify_exclude_pattern $pat] + } + return $rules + } + + proc match_rule_at_node {rule path} { + set kind [dict get $rule kind] + switch -- $kind { + exact - child_only { + if {[::punk::path::globmatchpath [dict get $rule match_pat] $path]} { + return [dict create include_current 0 recurse_below 1 child_rules [list $rule]] + } + return [dict create include_current 1 recurse_below 1 child_rules [list $rule]] + } + subtree { + set descend_pat [dict get $rule descend_pat] + set boundary_pat [dict get $rule boundary_pat] + if {[::punk::path::globmatchpath $descend_pat $path]} { + return [dict create include_current 0 recurse_below 0 child_rules [list]] + } + if {[::punk::path::globmatchpath $boundary_pat $path]} { + return [dict create include_current 1 recurse_below 0 child_rules [list]] + } + return [dict create include_current 1 recurse_below 1 child_rules [list $rule]] + } + default { + error "Unknown exclude rule kind '$kind'" + } + } + } + + proc walk_subfolders {path rules do_recursion} { + set all_subfolders [glob -nocomplain -directory $path -types d *] + set folders [list] + foreach f $all_subfolders { + set include_current 1 + set recurse_below $do_recursion + set child_rules [list] + foreach rule $rules { + set outcome [match_rule_at_node $rule $f] + if {![dict get $outcome include_current]} { + set include_current 0 + } + if {![dict get $outcome recurse_below]} { + set recurse_below 0 + } + if {$do_recursion} { + lappend child_rules {*}[dict get $outcome child_rules] + } + if {!$include_current && !$recurse_below} { + break + } + } + if {$include_current} { + lappend folders $f + } + if {$do_recursion && $recurse_below} { + lappend folders {*}[walk_subfolders $f $child_rules $do_recursion] + } + } + return $folders + } + } + + punk::args::define { + @id -id ::punk::path::subfolders + @cmd -name punk::path::subfolders\ + -summary\ + "Listing of directories below supplied path."\ + -help\ + "List of folders below path. + The resulting list is unsorted. + " + @opts + -recursive -type none -help\ + "" + -exclude-paths -type list -default {} -help\ + "list of path patterns to exclude from results. + May include * and ** path segments e.g /usr/** + A single /*/ will match any single segment in the path, and a single /**/ will match any number of segments in the path. + + e.g to exclude any path with _aside as a segment in the middle: -exclude-paths **/_aside/** + i.e this would exclude /usr/_aside/etc and /usr/x/_aside/etc but not /usr/x/_aside or _aside/etc + + To exclude all paths with _aside as a segment anywhere: -exclude-paths { **/_aside/** **/_aside ./_aside/**} + " + #todo -depth + @values -min 0 -max 1 + path -type directory -optional 1 -help\ + "Path of base folder. If not supplied current directory is used. + This may be a relative or absolute path. Relative paths are treated as relative to current directory. + When using relative paths - the result will also be relative paths with the same relative prefix. + (e.g if path is ../test - the results will be ../test/subfolder1 ../test/subfolder2 etc) + Patterns in -exclude-paths are matched against the resulting paths + (so should be written to match the same relative prefix if path is relative)" + } + + proc subfolders {args} { + set argd [punk::args::parse $args withid ::punk::path::subfolders] + lassign [dict values $argd] leaders opts values received + set do_recursion [dict exists $received -recursive] + set exclude_paths [dict get $opts -exclude-paths] + if {"**" in $exclude_paths} { + puts stderr "punk::path::subfolders Warning - exclude_paths contains '**' - all paths will be excluded" + return [list] + } + if {[dict exists $received path]} { + set path [dict get $values path] + } else { + set path [pwd] + } + set compiled_rules [subfolder_priv::compile_exclude_rules $exclude_paths] + return [subfolder_priv::walk_subfolders $path $compiled_rules $do_recursion] + } + + namespace eval treefile_priv { + proc _path_segment_matches {pattern_segment path_segment} { + if {[::punk::path::globmatchpath $pattern_segment $path_segment]} { + return 1 + } + if {[string range $pattern_segment end end] eq "/" && [string range $path_segment end end] eq "/"} { + set root_probe __punk_path_root_probe__ + return [::punk::path::globmatchpath [file join $pattern_segment $root_probe] [file join $path_segment $root_probe]] + } + return 0 + } + + proc _pattern_prefix_viable_parts {pattern_parts path_parts} { + if {![llength $path_parts]} { + return 1 + } + if {![llength $pattern_parts]} { + return 0 + } + + set pattern_head [lindex $pattern_parts 0] + set path_head [lindex $path_parts 0] + + if {$pattern_head eq "**"} { + if {[_pattern_prefix_viable_parts [lrange $pattern_parts 1 end] $path_parts]} { + return 1 + } + return [_pattern_prefix_viable_parts $pattern_parts [lrange $path_parts 1 end]] + } + + if {[_path_segment_matches $pattern_head $path_head]} { + return [_pattern_prefix_viable_parts [lrange $pattern_parts 1 end] [lrange $path_parts 1 end]] + } + return 0 + } + + proc pattern_prefix_viable {pattern path} { + return [_pattern_prefix_viable_parts [file split $pattern] [file split $path]] + } + + proc pattern_boundary {pattern} { + set parts [file split $pattern] + if {[llength $parts] >= 2 && [lindex $parts end] eq "**"} { + return [file join {*}[lrange $parts 0 end-1]] + } + return "" + } + + proc directory_state {glob_paths path inherited_allbelow} { + if {$inherited_allbelow} { + return [dict create include_files 1 recurse_below 1 next_allbelow 1] + } + + set include_files 0 + set recurse_below 0 + set next_allbelow 0 + + foreach gp $glob_paths { + if {[::punk::path::globmatchpath $gp $path]} { + set include_files 1 + set recurse_below 1 + set next_allbelow 1 + break + } + + set boundary [pattern_boundary $gp] + if {$boundary ne "" && [::punk::path::globmatchpath $boundary $path]} { + set recurse_below 1 + set next_allbelow 1 + continue + } + + if {[pattern_prefix_viable $gp $path]} { + set recurse_below 1 + } + } + + return [dict create {*}{ + } include_files $include_files {*}{ + } recurse_below $recurse_below {*}{ + } next_allbelow $next_allbelow {*}{ + } + ] + } + + proc child_path_state {glob_paths child_path inherited_allbelow} { + if {$inherited_allbelow} { + return 1 + } + foreach gp $glob_paths { + if {[pattern_prefix_viable $gp $child_path]} { + return 1 + } + } + return 0 + } + + proc _sort_paths {paths sortmode} { + switch -- $sortmode { + ascii { + return [lsort $paths] + } + dictionary { + return [lsort -dictionary $paths] + } + natural { + return [natsort::sort $paths] + } + default { + return $paths + } + } + } + + proc _path_matches_any {patterns path} { + foreach pattern $patterns { + if {[::punk::path::globmatchpath $pattern $path]} { + return 1 + } + } + return 0 + } + + proc _tailbase_relative {tailbase path} { + if {$tailbase eq ""} { + return $path + } + return [::punk::path::relative $tailbase $path] + } + + proc _tailbase_match_path {tailbase path} { + set match_path [_tailbase_relative $tailbase $path] + if {$match_path eq "."} { + return "" + } + return $match_path + } + + proc _tailbase_relative_list {tailbase paths} { + if {$tailbase eq ""} { + return $paths + } + set relative_paths [list] + foreach path $paths { + lappend relative_paths [_tailbase_relative $tailbase $path] + } + return $relative_paths + } + + proc _retain_files {matches exclude_files sortmode} { + set retained [list] + foreach match $matches { + set skip 0 + set file_tail [file tail $match] + foreach anti $exclude_files { + if {[string match $anti $file_tail]} { + set skip 1 + break + } + } + if {!$skip} { + lappend retained $match + } + } + return [_sort_paths $retained $sortmode] + } + + proc _state_from_argd {argd} { + set opts [dict get $argd opts] + set values [dict get $argd values] + set received [dict get $argd received] + + if {[dict exists $received -directory]} { + set directory [dict get $opts -directory] + } else { + set directory [pwd] + } + + set glob_paths [dict get $opts -include-paths] + if {"*" in $glob_paths} { + set glob_paths {*} + } + + set sortmode [dict get $opts -sort] + if {$sortmode eq "natural"} { + package require natsort + } + + return [dict create {*}{ + depth 0 + subvector {} + allbelow 0 + } sort $sortmode {*}{ + } directory $directory {*}{ + } tailbase [dict get $opts -tailbase] {*}{ + } exclude_paths [dict get $opts -exclude-paths] {*}{ + } exclude_files [dict get $opts -exclude-files] {*}{ + } glob_paths $glob_paths {*}{ + } tailglobs [dict get $values tailglobs] {*}{ + } + ] + } + + proc walk_treefilenames {state} { + set opt_dir [dict get $state directory] + set opt_tailbase [dict get $state tailbase] + set depth [dict get $state depth] + set subvector [dict get $state subvector] + set callallbelow [dict get $state allbelow] + set opt_sort [dict get $state sort] + set opt_exclude_paths [dict get $state exclude_paths] + set opt_exclude_files [dict get $state exclude_files] + set opt_glob_paths [dict get $state glob_paths] + set tailglobs [dict get $state tailglobs] + + if {![file isdirectory $opt_dir]} { + return [list] + } + if {[string match //zipfs:/* $opt_dir]} { + return [walk_treefilenames_zipfs $state] + } + set opt_dir_match [_tailbase_match_path $opt_tailbase $opt_dir] + if {[_path_matches_any $opt_exclude_paths $opt_dir_match]} { + return [list] + } + + set files [list] + set dir_state [directory_state $opt_glob_paths $opt_dir_match $callallbelow] + if {[dict get $dir_state include_files]} { + if {[catch {glob -nocomplain -dir $opt_dir -type f -- {*}$tailglobs} matches]} { + puts stderr "treefilenames error while listing files in dir $opt_dir\n $matches" + set dirfiles [list] + } else { + #also match hidden files (e.g dotfiles on windows where glob -type f misses them) + if {![catch {glob -nocomplain -dir $opt_dir -types {hidden f} -- {*}$tailglobs} hidden_matches]} { + foreach h $hidden_matches { + if {$h ni $matches} { + lappend matches $h + } + } + } + set dirfiles [_retain_files $matches $opt_exclude_files $opt_sort] + } + lappend files {*}[_tailbase_relative_list $opt_tailbase $dirfiles] + } + + if {![dict get $dir_state recurse_below]} { + return $files + } + + if {[catch {glob -nocomplain -dir $opt_dir -type d *} dirdirs]} { + puts stderr "treefilenames error while listing subdirs in dir $opt_dir\n $dirdirs" + set dirdirs [list] + } + #also match hidden directories + if {![catch {glob -nocomplain -dir $opt_dir -types {hidden d} *} hidden_dirdirs]} { + foreach h $hidden_dirdirs { + switch -- $h { + "." - ".." {continue} + default { + if {$h ni $dirdirs} { + lappend dirdirs $h + } + } + } + } + } + set okdirs [list] + foreach dir $dirdirs { + if {![_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $dir]]} { + lappend okdirs $dir + } + } + + if {$opt_glob_paths eq "*"} { + set matchdirs $okdirs + } else { + set matchdirs [list] + foreach dir $okdirs { + if {$callallbelow || [child_path_state $opt_glob_paths [_tailbase_match_path $opt_tailbase $dir] $callallbelow]} { + lappend matchdirs $dir + } + } + } + + set finaldirs [_sort_paths $matchdirs $opt_sort] + set childallbelow [expr {$callallbelow || [dict get $dir_state next_allbelow]}] + set nextsubvector [list {*}$subvector [file tail $opt_dir]] + foreach dir $finaldirs { + set child_state [dict merge $state [dict create {*}{ + } directory $dir {*}{ + } depth [expr {$depth + 1}] {*}{ + } subvector $nextsubvector {*}{ + } allbelow $childallbelow {*}{ + } + ]] + lappend files {*}[walk_treefilenames $child_state] + } + return $files + } + + proc walk_treefilenames_zipfs {state} { + set opt_dir [dict get $state directory] + set opt_tailbase [dict get $state tailbase] + set opt_exclude_paths [dict get $state exclude_paths] + set opt_exclude_files [dict get $state exclude_files] + set opt_glob_paths [dict get $state glob_paths] + set opt_sort [dict get $state sort] + set tailglobs [dict get $state tailglobs] + + if {![string match [zipfs root]* $opt_dir]} { + error "treefilenames_zipfs can only be used on paths beginning with [zipfs root] on this systems" + } + set dir [string trimright $opt_dir "/"] + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $dir]]} { + return [list] + } + set dirlen [string length $dir] + set subpaths [zipfs list $dir/*] + set dirlist [list] + set skipdirs [list] + set filelist [list] + foreach sub $subpaths { + set tail [string range $sub $dirlen+1 end] + set tailparts [file split $tail] + set accum "" + set skipdir 0 + foreach tailpart [lrange $tailparts 0 end-1] { + append accum "/$tailpart" + set superpath "${dir}${accum}" + if {$superpath in $skipdirs} { + set skipdir 1 + break + } + if {$superpath ni $dirlist} { + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $superpath]]} { + lappend skipdirs $superpath + set skipdir 1 + break + } else { + lappend dirlist $superpath + } + } + } + if {!$skipdir} { + append accum "/[lindex $tailparts end]" + set finalpart "${dir}${accum}" + if {$finalpart ni $dirlist} { + if {[file type $finalpart] eq "file"} { + set file_tail [lindex $tailparts end] + set match 0 + if {"*" ni $tailglobs} { + foreach tailglob $tailglobs { + if {[string match $tailglob $file_tail]} { + set match 1 + break + } + } + } else { + set match 1 + } + if {$match && $opt_glob_paths ne "*"} { + set file_dir_match [_tailbase_match_path $opt_tailbase [file dirname $finalpart]] + set file_dir_state [directory_state $opt_glob_paths $file_dir_match 0] + set match [dict get $file_dir_state include_files] + } + if {$match} { + set skipfile 0 + foreach anti $opt_exclude_files { + if {[string match $anti $file_tail]} { + set skipfile 1 + break + } + } + if {!$skipfile} { + lappend filelist [_tailbase_relative $opt_tailbase $finalpart] + } + } + } else { + if {$finalpart ni $dirlist} { + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $finalpart]]} { + lappend skipdirs $finalpart + } else { + lappend dirlist $finalpart + } + } + } + } + } + } + return [_sort_paths $filelist $opt_sort] + } + } + + #todo - treefolders with similar search caps as treefilenames + + punk::args::define { + @id -id ::punk::path::treefilenames + @cmd -name punk::path::treefilenames\ + -summary\ + "List of filenames below supplied path."\ + -help\ + "List of filenames below path. + The resulting list is unsorted. + + The path globbing syntax supports *, ** and ? as glob characters in any segment of the path, with the following semantics: + * matches any single segment in the path + ** matches 1 or more segments in the path (so /usr/**/bin will match /usr/x/bin and user/x/y/bin but not /usr/bin ) + ? matches any single character in a single segment of the path (so /usr/te?t will match /usr/test and /usr/text but not /usr/texxt) + " + -directory -type directory -help\ + "folder in which to begin recursive scan for files." + -tailbase -type string -default "" -help\ + "if supplied, only the relative path compared to the tailbase will be returned for each file. + So if tailbase is /usr and a file is found at /usr/x/y/file.txt, the returned path for that file would be x/y/file.txt. + If tailbase is not supplied, the full path to each file will be returned. + + If tailbase is supplied, it should be a prefix of the directory supplied (or the directory itself) + The patterns in -exclude-paths should be written to match the returned paths (i.e with the tailbase prefix removed) if -tailbase is supplied. + If the tailbase is not a prefix of the directory supplied, the resulting paths may have /../ components in them to account for the difference, + but the behaviour is not well defined in this case and it is recommended to ensure tailbase is a prefix of the directory supplied if using -tailbase. + + see: punk::path::relative to compute relative paths + " + -sort -type any -default natural -choices {none ascii dictionary natural} + -exclude-paths -default {} -help\ + "list of path patterns to exclude + may include * and ** path segments e.g + /usr/** (exclude subfolders based at /usr but not + files within /usr itself) + **/_aside (exclude files where _aside is last segment) + **/_aside/* (exclude folders one below an _aside folder) + **/_aside/** (exclude files in all folders with _aside as a segment)" + -exclude-files -default {} + -include-paths -default {**} -help\ + "list of path patterns to include + may include * and ** path segments e.g + /usr/** (include files in subfolders based at /usr but not + files within /usr itself) + **/_aside (include files where _aside is last segment in the folder) + **/_aside/* (include files in folders one below an _aside folder) + **/_aside/** (include all files in folders with _aside as a segment)" + @values -min 0 -max -1 -optional 1 -type string + tailglobs -default * -multiple 1 -help\ + "Patterns to match against filename portion (last segment) of each file path + within the directory tree being searched." + } + + #todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/ + #then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase) + proc treefilenames {args} { + set argd [punk::args::parse $args withid ::punk::path::treefilenames] + set state [treefile_priv::_state_from_argd $argd] + return [treefile_priv::walk_treefilenames $state] + } + punk::args::set_idalias ::punk::path::treefilenames_zipfs ::punk::path::treefilenames + proc treefilenames_zipfs {args} { + #seems to be 2 or 3 times faster than treefilenames for //zipfs:/ paths - REVIEW + # is sort order the same? + set argd [punk::args::parse $args withid ::punk::path::treefilenames] + set state [treefile_priv::_state_from_argd $argd] + if {![file isdirectory [dict get $state directory]]} { + return [list] + } + return [treefile_priv::walk_treefilenames_zipfs $state] + } + + punk::args::define { + @id -id ::punk::path::relative + @cmd -name punk::path::relative\ + -summary\ + "Compute the relative path from a reference path to a location path."\ + -help\ + "Taking two directory paths, a reference and a location, computes the path + of the location relative to the reference. + + Will return a single dot '.' if the paths are the same. + + Both paths must be the same type - ie both absolute or both relative. + + Matching is case sensitive. On windows, the drive-letter component (only) is + not case sensitive, so punk::path::relative c:/etc C:/etc returns '.'. + The part following the driveletter is case sensitive, so + punk::path::relative c:/etc C:/Etc returns ../Etc. + + On windows, if the paths are absolute and specify different volumes, + only the location will be returned." + @leaders -min 2 -max 2 + reference -type string -help\ + "The path from which the relative path to location is determined." + location -type string -help\ + "The location path which may be above or below the reference path." + } + #maint warning - also in punkcheck + proc relative {reference location} { + #see also kettle + # Modified copy of ::fileutil::relative (tcllib) + # Adapted to 8.5 ({*}). + + #review - check volume info on windows.. UNC paths? + if {[file pathtype $reference] ne [file pathtype $location]} { + return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $reference] vs. [file pathtype $location], ($reference vs. $location)" + } + + #avoid normalizing if possible (file normalize *very* expensive on windows) + set do_normalize 0 + if {[file pathtype $reference] eq "relative"} { + #if reference is relative so is location + if {[regexp {[.]{2}} [list $reference $location]]} { + set do_normalize 1 + } + if {[regexp {[.]/} [list $reference $location]]} { + set do_normalize 1 + } + } else { + set do_normalize 1 + } + if {$do_normalize} { + set reference [file normalize $reference] + set location [file normalize $location] + } + + set save $location + set reference [file split $reference] + set location [file split $location] + + while {[lindex $location 0] eq [lindex $reference 0]} { + set location [lrange $location 1 end] + set reference [lrange $reference 1 end] + if {![llength $location]} {break} + } + + set location_len [llength $location] + set reference_len [llength $reference] + + if {($location_len == 0) && ($reference_len == 0)} { + # Cases: + # (a) reference == location + + set location . + } else { + # Cases: + # (b) ref is: ref/sub = sub + # loc is: ref = {} + + # (c) ref is: ref = {} + # loc is: ref/sub = sub + + while {$reference_len > 0} { + #set location [linsert $location 0 ..] + ledit location -1 -1 .. + incr reference_len -1 + } + set location [file join {*}$location] + } + return $location + } + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::path ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::path::lib { + namespace export * + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace punk::path::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::path::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +namespace eval punk::path::system { + #*** !doctools + #[subsection {Namespace punk::path::system}] + #[para] Internal functions that are not part of the API + + + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::path [namespace eval punk::path { + variable pkg punk::path + variable version + set version 0.2.0 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck-0.2.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck-0.2.0.tm new file mode 100644 index 00000000..351647d0 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck-0.2.0.tm @@ -0,0 +1,2479 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'dev 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 punkcheck 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + +package require punk::tdl +package require punk::path +package require punk::repo +package require punk::mix::util + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Punkcheck uses the TDL format which is a list of lists in Tcl format +# It is intended primarily for source build/distribution tracking within a punk project or single filesystem - with relative paths. +# +#see following article regarding the many problems with using mtime for build-decisions: https://apenwarr.ca/log/20181113 +# +namespace eval punkcheck { + namespace export {*}{ + uuid + installtrack + install + install_tm_files + install_non_tm_files + summarize_install_resultdict + } + + #exclude-paths entries match against the full relative path using globmatchpath. + #They may include ** to match across path segments and / to match within a segment. + #Each dir-seg pattern is expanded to both top-level and nested (**/) forms to preserve + #the "matches at any directory level" semantics of the former dir-seg mechanism. + variable default_excludepaths_core [list "#*" "**/#*" "_aside" "**/_aside" "_build" "**/_build" ".git" "**/.git" ".fossil*" "**/.fossil*"] + variable default_excludefiletail_core "" + #backward-compat: retained for callers that still read default_excludedirseg_core + variable default_excludedirseg_core [list "#*" "_aside" "_build" ".git" ".fossil*"] + + set has_twapi 0 + if {"windows" eq $::tcl_platform(platform)} { + set has_twapi [expr {![catch {package require twapi}]}] + } + if {$has_twapi} { + interp alias "" ::punkcheck::uuid "" ::twapi::new_uuid + } else { + catch {package require uuid} + interp alias "" ::punkcheck::uuid "" ::uuid::uuid generate + } + + proc default_excludepaths_core {} { + variable default_excludepaths_core + return $default_excludepaths_core + } + #backward-compat alias for the former segment-based default + proc default_excludedirseg_core {} { + variable default_excludedirseg_core + return $default_excludedirseg_core + } + proc default_excludefiletail_core {} { + variable default_excludefiletail_core + if {$default_excludefiletail_core eq ""} { + set default_excludefiletail_core [list "*.swp" "*[punk::mix::util::tm_version_magic]*" "*-buildversion.txt" ".punkcheck"] + } + return $default_excludefiletail_core + } + + + proc load_records_from_file {punkcheck_file} { + set record_list [list] + if {[file exists $punkcheck_file]} { + set tdlscript [punk::mix::util::fcat $punkcheck_file] + if {[catch { + set record_list [punk::tdl::prettyparse $tdlscript] + } errparse]} { + error "punkcheck::load_records_from_file failed to parse '$punkcheck_file'\n error:$errparse" + } + } + return $record_list + } + proc save_records_to_file {recordlist punkcheck_file {trigger {}} {debugchannel ""}} { + set newtdl [punk::tdl::prettyprint $recordlist] + set linecount [llength [split $newtdl \n]] + + if {$debugchannel ne "" && $trigger ne ""} { + puts $debugchannel "\x1b\[36mSaving [llength $recordlist] records as $linecount lines to file '$punkcheck_file' trigger: \x1b\[32m$trigger\x1b\[m" + } + #puts stdout $newtdl + set fd [open $punkcheck_file w] + chan configure $fd -translation binary + puts -nonewline $fd $newtdl + flush $fd + close $fd + return [list recordcount [llength $recordlist] linecount $linecount] + } + + + #todo - work out way to use same punkcheck file for multiple installers running concurrently. Thread? + #an installtrack objects represents an installation path from sourceroot to targetroot + #The source and target folders should be as specific as possible but it is valid to specify for example c:/ -> c:/ (or / -> /) if source and targets within the installation operation are spread around. + # + set objname [namespace current]::installtrack + if {$objname ni [info commands $objname]} { + package require oolib + + #FILEINFO record - target fileset with body records: INSTALL-RECORD,INSTALL-INPROGRESS,INSTALL-SKIPPED,DELETE-RECORD,DELETE-INPROGRESS,MODIFY-INPROGRESS,MODIFY-RECORD + #each FILEINFO body being a list of SOURCE records + oo::class create targetset { + variable o_targets + variable o_keep_installrecords + variable o_keep_skipped + variable o_keep_inprogress + variable o_records + constructor {args} { + #set o_records [oolib::collection create [namespace current]::recordcollection] + set o_records [list] + + } + + method as_record {} { + dict create {*}{ + } tag FILEINFO {*}{ + } -targets $o_targets {*}{ + } -keep_installrecords $o_keep_installrecords {*}{ + } -keep_skipped $o_keep_skipped {*}{ + } -keep_inprogress $o_keep_inprogress {*}{ + } body $o_records {*}{ + } + } + + #retrieve last completed record for the fileset ie exclude SKIPPED,INSTALL-INPROGRESS,DELETE-INPROGRESS,MODIFY-INPROGRESS + method get_last_record {fileset_record} { + set body [dict_getwithdefault $fileset_record body [list]] + set previous_records [lrange $body 0 end-1] + #get last previous that is tagged INSTALL-RECORD,MODIFY-RECORD,DELETE-RECORD + set revlist [lreverse $previous_records] + foreach rec $revlist { + switch -- [dict get $rec tag] { + INSTALL-RECORD - MODIFY-RECORD - DELETE-RECORD - VIRTUAL-RECORD { + return $rec + } + } + } + return [list] + } + } + + #instances created by an installtrack object in method start_event + #also in installtrack constructor - to represent existing events from the .punkcheck data + oo::class create installevent { + variable o_id + variable o_rel_sourceroot + variable o_rel_targetroot + variable o_ts_begin + variable o_ts_end + variable o_types + variable o_configdict + variable o_targets + variable o_operation + variable o_operation_start_ts + variable o_path_cksum_cache + variable o_fileset_record + variable o_installer ;#parent object + variable o_debugchannel + constructor {installer rel_sourceroot rel_targetroot args} { + set o_installer $installer + set o_debugchannel [$installer get_debugchannel] + set o_operation_start_ts "" + set o_path_cksum_cache [dict create] + set o_operation "" + set defaults [dict create {*}{ + -id "" + -tsbegin "" + -config {} + -tsend "" + -types {} + }] + set opts [dict merge $defaults $args] + if {[dict get $opts -id] eq ""} { + set o_id [punkcheck::uuid] + } else { + set o_id [dict get $opts -id] + } + if {[dict get $opts -tsbegin] eq ""} { + set o_ts_begin [clock microseconds] + } else { + set o_ts_begin [dict get $opts -tsbegin] + } + set o_ts_end [dict get $opts -tsend] + set o_types [dict get $opts -types] + set o_configdict [dict get $opts -config] + + set o_rel_sourceroot $rel_sourceroot + set o_rel_targetroot $rel_targetroot + } + destructor { + #puts "[self] destructor called" + } + method as_record {} { + set begin_seconds [expr {$o_ts_begin / 1000000}] + set tsiso_begin [clock format $begin_seconds -format "%Y-%m-%dT%H:%M:%S"] + if {$o_ts_end ne ""} { + set end_seconds [expr {$o_ts_end / 1000000}] + set tsiso_end [clock format $end_seconds -format "%Y-%m-%dT%H:%M:%S"] + } else { + set tsiso_end "" + } + + dict create {*}{ + } tag EVENT {*}{ + } -tsiso_begin $tsiso_begin {*}{ + } -ts_begin $o_ts_begin {*}{ + } -tsiso_end $tsiso_end {*}{ + } -ts_end $o_ts_end {*}{ + } -id $o_id {*}{ + } -source $o_rel_sourceroot {*}{ + } -targets $o_rel_targetroot {*}{ + } -types $o_types {*}{ + } -config $o_configdict {*}{ + } + } + method get_id {} { + return $o_id + } + method get_operation {} { + return $o_operation + } + method get_targets {} { + return $o_targets + } + method get_targets_exist {} { + set punkcheck_folder [file dirname [$o_installer get_checkfile]] + #puts stdout "### punkcheck glob -dir $punkcheck_folder -tails {*}$o_targets" + #targets can be paths such as punk/mix/commandset/module-0.1.0.tm - glob can search levels below supplied -dir + set existing [glob -nocomplain -dir $punkcheck_folder -tails {*}$o_targets] + + return $existing + } + method end {} { + set o_ts_end [clock microseconds] + } + method targetset_dict {} { + punk::records_as_target_dict [$o_installer get_recordlist] + } + + #related - installfile_begin + #call init before we know if we are going to run the operation vs skip + method targetset_init {operation targetset} { + set known_ops [list QUERY INSTALL MODIFY DELETE VIRTUAL] + if {[string toupper $operation] ni $known_ops} { + error "[self] add_target unknown operation '$operation'. Known operations $known_ops" + } + set o_operation [string toupper $operation] + + if {$o_operation_start_ts ne ""} { + error "[self] targetset_init $o_operation operation already in progress. Use targetset_finished or targetset_complete to finish." + } + set o_operation_start_ts [clock microseconds] + set seconds [expr {$o_operation_start_ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] + + set relativepath_targetset [list] + if {$o_operation eq "VIRTUAL"} { + foreach p $targetset { + lappend relativepath_targetset $p + } + } else { + foreach p $targetset { + if {[file pathtype $p] eq "absolute"} { + lappend relativepath_targetset [punkcheck::lib::path_relative $punkcheck_folder $p] + } else { + lappend relativepath_targetset $p + } + } + } + + + set fields [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $o_operation_start_ts {*}{ + } -installer [$o_installer get_name] {*}{ + } -eventid $o_id {*}{ + } + ] + + set o_targets [lsort -dictionary -increasing $relativepath_targetset] ;#exact sort order not critical - but must be consistent + + + set record_list [punkcheck::load_records_from_file $punkcheck_file] + + #--------------------------------------------------------------------------- + #load as dict to test for dupes + #set _targetdict [my targetset_dict] + if {[catch { + set _targetdict [punkcheck::recordlist::records_as_target_dict $record_list] + } errMsg]} { + error "targetset_init operation:$operation error verifying existing records from file $punkcheck_file. Error: $errMsg" + } + #--------------------------------------------------------------------------- + + set extractioninfo [punkcheck::recordlist::extract_or_create_fileset_record $o_targets $record_list] + set o_fileset_record [dict get $extractioninfo record] + set record_list [dict get $extractioninfo recordset] ;#if fileset wasn't present, same as original record_list, otherwise full recordset with the fileset record removed, ready for reinsertion. + set isnew [dict get $extractioninfo isnew] + set oldposition [dict get $extractioninfo oldposition] + unset extractioninfo + + #INSTALL-INPROGRESS will become INSTALL-RECORD or INSTALL-FAILED or INSTALL-SKIPPED upon finalisation + #-installer and -eventid keys are added here + set new_inprogress_record [dict create tag [string toupper $operation]-INPROGRESS {*}$fields -tempcontext [my as_record] body {}] + #set existing_body [dict_getwithdefault $o_fileset_record body [list]] + #todo - look for existing "-INPROGRESS" records - mark as failed or incomplete? + dict lappend o_fileset_record body $new_inprogress_record + + if {$isnew} { + lappend record_list $o_fileset_record + } else { + #set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record] + ledit record_list $oldposition -1 $o_fileset_record + } + if {$o_operation ne "QUERY"} { + punkcheck::save_records_to_file $record_list $punkcheck_file "targetset_init $o_operation [llength $targetset] targets" + } + return $o_fileset_record + + } + #operation has been started + #todo - upgrade .punkcheck format to hold more than just list of SOURCE entries in each record. + # - allow arbitrary targetset_startphase targetset_endphase calls to store timestamps and calculate elapsed time + method targetset_started {} { + set punkcheck_folder [file dirname [$o_installer get_checkfile]] + if {$o_operation eq "QUERY"} { + set fileinfo_body [dict get $o_fileset_record body] ;#body of FILEINFO record + set installing_record [lindex $fileinfo_body end] + + set ts_start [dict get $installing_record -ts] + set ts_now [clock microseconds] + set metadata_us [expr {$ts_now - $ts_start}] + + #?? + #JJJ + #dict set installing_record -metadata_us $metadata_us + dict set installing_record -ts_start_transfer $ts_now + + lset fileinfo_body end $installing_record + + return [dict set o_fileset_record body $fileinfo_body] + } else { + #legacy call + #saves to .punkcheck file + return [set o_fileset_record [punkcheck::installfile_started_install $punkcheck_folder $o_fileset_record]] + } + } + method targetset_end {status args} { + set defaults [dict create {*}{ + -note \uFFFF + }] + set known_opts [dict keys $defaults] + if {[llength $args] % 2} { + error "targetset_end arguments after status must be in the form of -flag value pairs. known flags: $known_opts" + } + set opts [dict merge $defaults $args] + if {[dict get $opts -note] eq "\uFFFF"} { + dict unset opts -note + } + + set status [string toupper $status] + set statusdict [dict create OK RECORD SKIPPED SKIPPED FAILED FAILED] + if {$o_operation_start_ts eq ""} { + error "[self] targetset_end $status - no current operation - call targetset_started first" + } + if {$status ni [dict keys $statusdict]} { + error "[self] targetset_end unrecognized status:$status known values: [dict keys $statusdict]" + } + if {![punkcheck::lib::is_file_record_inprogress $o_fileset_record]} { + error "targetset_end $status error: bad fileset_record - expected FILEINFO with last body element *-INPROGRESS" + } + set targetlist [dict get $o_fileset_record -targets] + if {$targetlist ne $o_targets} { + error "targetset_end $status error. targetlist mismatch between file : $targetlist vs $o_targets" + } + set operation_end_ts [clock microseconds] + set elapsed_us [expr {$operation_end_ts - $o_operation_start_ts}] + set file_record_body [dict get $o_fileset_record body] + set installing_record [lindex $file_record_body end] + set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] + set record_list [punkcheck::load_records_from_file $punkcheck_file] + if {[dict exists $installing_record -ts_start_transfer]} { + set ts_start_transfer [dict get $installing_record -ts_start_transfer] + set transfer_us [expr {$operation_end_ts - $ts_start_transfer}] + dict set installing_record -transfer_us $transfer_us + } + if {[dict exists $opts -note]} { + dict set installing_record -note [dict get $opts -note] + } + + dict set installing_record -elapsed_us $elapsed_us + dict unset installing_record -tempcontext + dict set installing_record tag "${o_operation}-[dict get $statusdict $status]" ;# e.g INSTALL-RECORD, INSTALL-SKIPPED + if {$o_operation in [list INSTALL MODIFY] && [dict get $statusdict $status] eq "RECORD"} { + #only calculate and store post operation target cksums on successful INSTALL or MODIFY, doesn't make sense for DELETE or VIRTUAL operations + set new_targets_cksums [list] ;#ordered list of cksums matching targetset order + set cksum_all_opts "" ;#same cksum opts for each target so we store it once + set ts_begin_cksum [clock microseconds] + foreach p $o_targets { + set tgt_cksum_info [punk::mix::base::lib::cksum_path [file join $punkcheck_folder $p]] + lappend new_targets_cksums [dict get $tgt_cksum_info cksum] + if {$cksum_all_opts eq ""} { + set cksum_all_opts [dict get $tgt_cksum_info opts] + } + } + set cksum_us [expr {[clock microseconds] - $ts_begin_cksum}] + dict set installing_record -targets_cksums $new_targets_cksums + dict set installing_record -cksum_all_opts $cksum_all_opts + dict set installing_record -cksum_us $cksum_us + } + lset file_record_body end $installing_record + dict set o_fileset_record body $file_record_body + set o_fileset_record [punkcheck::recordlist::file_record_prune $o_fileset_record] + + set oldrecordinfo [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $oldrecordinfo position] + if {$old_posn == -1} { + lappend record_list $o_fileset_record + } else { + lset record_list $old_posn $o_fileset_record + } + if {$o_operation ne "QUERY"} { + punkcheck::save_records_to_file $record_list $punkcheck_file "targetset_end $o_operation $status [llength $o_targets] targets" + } + set o_operation_start_ts "" + set o_operation "" + return $o_fileset_record + } + #can supply empty cksum value + # - that will influence the opts used if there is no existing install record + method targetset_cksumcache_set {path_cksum_dict} { + set o_path_cksum_cache $path_cksum_dict + } + method targetset_cksumcache_configure {path {cksuminfodict {}}} { + if {$cksuminfodict eq {}} { + if {[dict exists $o_path_cksum_cache $path]} { + return [dict get $o_path_cksum_cache $path] + } else { + return + } + } + dict for {k v} $cksuminfodict { + switch -- $k { + cksum - opts {} + default { + error "targetset_cksumcache_configure error. Unknown dict value $k. Allowed values {cksum opts}" + } + } + } + dict set o_path_cksum_cache $path $cksuminfodict + } + method targetset_addsource {source_path} { + set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] + if {[file pathtype $source_path] eq "absolute"} { + set rel_source_path [punkcheck::lib::path_relative $punkcheck_folder $source_path] + } else { + set rel_source_path $source_path + } + + #installfile_add_source_and_fetch_metadata accepts list of {cksum opt } dictionaries - although we only have one per path from our configured cksumcache + if {[dict exists $o_path_cksum_cache $rel_source_path]} { + set path_cksum_caches [list [dict get $o_path_cksum_cache $rel_source_path]] + } else { + set path_cksum_caches [list] + } + set o_fileset_record [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $rel_source_path $o_fileset_record $path_cksum_caches] + #JJJ - update -metadata_us here? + + } + method targetset_last_complete {} { + #retrieve last completed record for the fileset ie exclude SKIPPED,INSTALL-INPROGRESS,DELETE-INPROGRESS,MODIFY-INPROGRESS + set body [punkcheck::dict_getwithdefault $o_fileset_record body [list]] + set previous_records [lrange $body 0 end] + #get last that is tagged INSTALL-RECORD,MODIFY-RECORD,DELETE-RECORD + set revlist [lreverse $previous_records] + foreach rec $revlist { + if {[dict get $rec tag] in [list "INSTALL-RECORD" "MODIFY-RECORD" "DELETE-RECORD" "VIRTUAL-RECORD"]} { + return $rec + } + } + return [list] + + } + method targetset_source_changes {} { + punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $o_fileset_record body] end] + } + + } + + + oo::class create installtrack { + variable o_name + variable o_tsiso + variable o_ts + variable o_keep_events + variable o_checkfile + variable o_sourceroot + variable o_rel_sourceroot + variable o_targetroot + variable o_rel_targetroot + variable o_record_list + variable o_active_event + variable o_events + variable o_debugchannel + constructor {installername punkcheck_file {debugchannel ""}} { + set o_debugchannel $debugchannel + set o_active_event "" + set o_name $installername + + set o_checkfile [file normalize $punkcheck_file] + set o_sourceroot "" + set o_targetroot "" + set o_rel_sourceroot "" + set o_rel_targetroot "" + set o_record_list [list] + + #todo - validate punkcheck file location further?? + set punkcheck_folder [file dirname $o_checkfile] + if {![file isdirectory $punkcheck_folder]} { + error "[self] constructor error. Folder for punkcheck_file not found - $o_checkfile" + } + + my load_all_records + if {![llength $o_record_list] && $o_debugchannel ne ""} { + puts $o_debugchannel "\x1b\[32mNo existing records found in punkcheck file '$o_checkfile' for installer '$installername'. Starting with empty record list.\x1b\[m" + } else { + #verify no duplicate installer records for this installer. + #JMN + set sanity_dict [dict create] + set insane "" + foreach rec $o_record_list { + if {[dict get $rec tag] eq "INSTALLER"} { + set name [dict get $rec -name] + if {[dict exists $sanity_dict $name]} { + #todo - warn - duplicate record for same targetlist - shouldn't happen as we should be using get_file_record to find existing records + if {$o_debugchannel ne ""} { + puts $o_debugchannel "\x1b\[31mpunkcheck installtrack - multiple INSTALLER records with same name '$name'\x1b\[m" + } + set insane "$name" + break + } + dict set sanity_dict $name {} + } + } + if {$insane ne ""} { + set msg "Sanity check: punkcheck file '$o_checkfile' contains multiple records for INSTALLER -name '$insane'." + append msg \n "This may indicate a problem such as multiple concurrent installtrack instances using the same punkcheck file," + append msg \n " or a previous installtrack instance that did not complete properly." + append msg \n " Do you want to DELETE the .punkcheck file?" + append msg \n " It is safe to delete .punkcheck files, at the cost of loss of history and checksums used to optimize installs." + append msg \n " They are a record of installation events and checksums used to avoid unnecessary reinstalls." + append msg \n " If not confirmed, an error will be raised - likely aborting the current operation." + append msg \n "confirm deletion and continue by regenerating the file, by typing the 3 letters: 'yes'." + set answer [punk::lib::askuser $msg] + if {[string tolower $answer] ne "yes"} { + error "Failing due to sanity check failure. User did not confirm with 'yes'." + } + if {[file exists $o_checkfile] && [file isfile $o_checkfile]} { + file delete $o_checkfile + } + if {[file exists $o_checkfile]} { + error "Failed to delete punkcheck file '$o_checkfile' after sanity check failure. Please investigate and resolve the issue before proceeding." + } + set o_record_list [list] + } else { + if {$o_debugchannel ne ""} { + puts $o_debugchannel "\x1b\[32mSanity check passed: no duplicate INSTALLER records found for installer '$installername' in punkcheck file '$o_checkfile'.\x1b\[m" + } + } + unset sanity_dict + } + + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + set this_installer_record [punkcheck::recordlist::new_installer_record $o_name] + #set o_record_list [linsert $o_record_list 0 $this_installer_record] + ledit o_record_list -1 -1 $this_installer_record + } else { + set this_installer_record [dict get $resultinfo record] + } + set o_tsiso [dict get $this_installer_record -tsiso] + set o_ts [dict get $this_installer_record -ts] + set o_keep_events [dict get $this_installer_record -keep_events] + + set o_events [oolib::collection create [namespace current]::eventcollection] + set eventlist [punkcheck::dict_getwithdefault $this_installer_record body [list]] + foreach e $eventlist { + set eobj [punkcheck::installevent create [namespace current]::event_[my events count] [self] [dict get $e -source] [dict get $e -targets] {*}$e] + #$o_events add $e [dict get $e -id] + $o_events add $eobj [dict get $e -id] + } + + } + destructor { + #puts "[self] destructor called" + } + method test {} { + return [self] + } + method get_name {} { + return $o_name + } + method get_checkfile {} { + return $o_checkfile + } + method get_debugchannel {} { + return $o_debugchannel + } + + #call set_source_target before calling start_event/end_event + #each event can have different source->target pairs - but may often have same, so set on installtrack as defaults. Only persisted in event records. + method set_source_target {sourceroot targetroot} { + if {[file pathtype $sourceroot] ne "absolute"} { + error "[self] set_source_target error: sourceroot must be absolute path. Received '$sourceroot'" + } + if {[file pathtype $targetroot] ne "absolute"} { + error "[self] set_source_target error: targetroot must be absolute path. Received '$targetroot'" + } + set punkcheck_folder [file dirname $o_checkfile] + set o_sourceroot $sourceroot + set o_targetroot $targetroot + set o_rel_sourceroot [punkcheck::lib::path_relative $punkcheck_folder $sourceroot] + set o_rel_targetroot [punkcheck::lib::path_relative $punkcheck_folder $targetroot] + return [list $o_rel_sourceroot $o_rel_targetroot] + } + #review/fix to allow multiple installtrack objects on same punkcheck file. + method load_all_records {} { + set o_record_list [punkcheck::load_records_from_file $o_checkfile] + } + + #does not include associated FILEINFO records - as a targetset (FILEINFO record) can be associated with events from multiple installers over time. + #e.g a logfile common to installers, or a separate installer that updates a previous output. + method as_record {} { + set eventrecords [list] + foreach eobj [my events items] { + lappend eventrecords [$eobj as_record] + } + set fields [list {*}{ + } -tsiso $o_tsiso {*}{ + } -ts $o_ts {*}{ + } -name $o_name\ {*}{ + } -keep_events $o_keep_events {*}{ + } body $eventrecords {*}{ + } + ] + set record [dict create tag INSTALLER {*}$fields] + } + #open file and save only own records + method save_all_records {} { + my save_installer_record + #todo - save FILEINFO targetset records + } + method save_installer_record {} { + set file_records [punkcheck::load_records_from_file $o_checkfile] + + set this_installer_record [my as_record] + + set persistedinfo [punkcheck::recordlist::get_installer_record $o_name $file_records] + set existing_header_posn [dict get $persistedinfo position] + if {$existing_header_posn == -1} { + #set file_records [linsert $file_records 0 $this_installer_record] + ledit file_records -1 -1 $this_installer_record + } else { + lset file_records $existing_header_posn $this_installer_record + } + punkcheck::save_records_to_file $file_records $o_checkfile "save_installer_record" + } + method events {args} { + tailcall $o_events {*}$args + } + method start_event {configdict} { + if {$o_active_event ne ""} { + error "[self] start_event error - event already started: $o_active_event" + } + if {$o_rel_sourceroot eq "" || $o_rel_targetroot eq ""} { + error "[self] No configured sourceroot or targetroot. Call [self] set_source_target first" + } + + if {[llength $configdict] %2 != 0} { + error "[self] new_event configdict must have an even number of elements" + } + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + error "[self] start_event - installer record missing. installer: $o_name" + } else { + set this_installer_record [dict get $resultinfo record] + } + + set eventobj [punkcheck::installevent create [namespace current]::event_[my events count] [self] $o_rel_sourceroot $o_rel_targetroot -config $configdict] + set eventid [$eventobj get_id] + set event_record [$eventobj as_record] + + set this_installer_record [punkcheck::recordlist::installer_record_add_event $this_installer_record $event_record] + set this_installer_record [punkcheck::recordlist::installer_record_pruneevents $this_installer_record $o_record_list] + + #replace + lset o_record_list $existing_header_posn $this_installer_record + + punkcheck::save_records_to_file $o_record_list $o_checkfile "start_event $eventid" + set o_active_event $eventobj + my events add $eventobj $eventid + return $eventobj + } + method installer_record_from_file {} { + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + } + method get_recordlist {} { + return $o_recordlist + } + method end_event {} { + if {$o_active_event eq ""} { + error "[self] end_event error - no active event" + } + $o_active_event end + } + method get_event {} { + return $o_active_event + } + } + } + proc start_installer_event {punkcheck_file installername from_fullpath to_fullpath config} { + set eventid [punkcheck::uuid] + if {[file pathtype $from_fullpath] ne "absolute"} { + error "start_installer_event error: from_fullpath must be absolute path. Received '$from_fullpath'" + } + if {[file pathtype $to_fullpath] ne "absolute"} { + error "start_installer_event error: to_fullpath must be absolute path. Received '$to_fullpath'" + } + set punkcheck_folder [file dirname $punkcheck_file] + set rel_source [punkcheck::lib::path_relative $punkcheck_folder $from_fullpath] + set rel_target [punkcheck::lib::path_relative $punkcheck_folder $to_fullpath] + + + set record_list [punkcheck::load_records_from_file $punkcheck_file] + set resultinfo [punkcheck::recordlist::get_installer_record $installername $record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + set this_installer_record [punkcheck::recordlist::new_installer_record $installername] + } else { + set this_installer_record [dict get $resultinfo record] + } + + set event_record [punkcheck::recordlist::new_installer_event_record install {*}{ + -id $eventid + -source $rel_source + -targets $rel_target + -config $config + }] + + set this_installer_record [punkcheck::recordlist::installer_record_add_event $this_installer_record $event_record] + set this_installer_record [punkcheck::recordlist::installer_record_pruneevents $this_installer_record $record_list] + + if {$existing_header_posn == -1} { + #not found - prepend + #set record_list [linsert $record_list 0 $this_installer_record] + ledit record_list -1 -1 $this_installer_record + } else { + #replace + lset record_list $existing_header_posn $this_installer_record + } + + punkcheck::save_records_to_file $record_list $punkcheck_file "start_installer_event $eventid" + return [list eventid $eventid recordset $record_list] + } + #----------------------------------------------- + proc installfile_help {} { + set msg "" + append msg "Call in order:" \n + append msg " start_installer_event (get dict with eventid and recordset keys)" + append msg " installfile_begin (to return a new INSTALLING record) - must pass in a valid eventid" \n + append msg " installfile_add_source_and_fetch_metadata (1+ times to update SOURCE record with checksum/timestamp info from source)" \n + append msg " ( - possibly with same algorithm as previous installrecord)" \n + append msg " ( - todo - search/load metadata for this source from other FILEINFO records for same installer)" \n + append msg "Finalize by calling:" \n + append msg " installfile_started_install" \n + append msg " (install the file e.g file copy)" \n + append msg " installfile_finished_install" \n + append msg " OR" \n + append msg " installfile_skipped_install" \n + } + proc installfile_begin {punkcheck_folder target_relpath installername args} { + if {[llength $args] %2 !=0} { + error "punkcheck installfile_begin args must be name-value pairs" + } + set target_relpath [lsort -dictionary -increasing $target_relpath] ;#exact sort order not critical - but must be consistent + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set defaults [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $ts {*}{ + } -installer $installername {*}{ + } -eventid unspecified {*}{ + } + ] + set opts [dict merge $defaults $args] + set opt_eventid [dict get $opts -eventid] + + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set resultinfo [punkcheck::recordlist::get_installer_record $installername $record_list] + set installer_record_position [dict get $resultinfo position] + if {$installer_record_position == -1} { + error "installfile_begin error: Failed to retrieve installer record for installer name:'$installername' - ensure start_installer_event has been called with same installer, and -eventid is passed to installfile_begin" + } + set this_installer_record [dict get $resultinfo record] + set events [dict get $this_installer_record body] + set active_event [list] + foreach evt [lreverse $events] { + if {[dict get $evt -id] eq $opt_eventid} { + set active_event $evt + break + } + } + if {![llength $active_event]} { + error "installfile_begin error: eventid $opt_eventid not found for installer '$installername' - aborting" + } + + + set extractioninfo [punkcheck::recordlist::extract_or_create_fileset_record $target_relpath $record_list] + set file_record [dict get $extractioninfo record] + set record_list [dict get $extractioninfo recordset] + set isnew [dict get $extractioninfo isnew] + set oldposition [dict get $extractioninfo oldposition] + unset extractioninfo + + #INSTALL-INPROGRESS will become INSTALL-RECORD or INSTALL-FAILED or INSTALL-SKIPPED upon finalisation + #-installer and -eventid keys are added here + set new_installing_record [dict create tag INSTALL-INPROGRESS {*}$opts -tempcontext $active_event body {}] + #set existing_body [dict_getwithdefault $file_record body [list]] + #todo - look for existing "INSTALL-INPROGRESS" records - mark as failed? + dict lappend file_record body $new_installing_record + + if {$isnew} { + lappend record_list $file_record + } else { + #set record_list [linsert $record_list[unset record_list] $oldposition $file_record] + ledit record_list $oldposition -1 $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_begin $installername $opt_eventid $target_relpath" + return $file_record + } + + #todo - ensure that removing a dependency is noticed as a change + #e.g previous installrecord had 2 source records - but we now only depend on one. + #The files we depended on for the previous record haven't changed themselves - but the list of files has (reduced by one) + #cached_cksums is list of dicts with keys cksum & opts + #Will only be used if any opts values present match those from file_record's -cksum_all_opts (in last install record) or first cached_cksum will be used if no last install record values + proc installfile_add_source_and_fetch_metadata {punkcheck_folder source_relpath file_record {cached_cksums {}}} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_add_source_and_fetch_metadata error: bad file_record - expected FILEINFO with last body element *-INPROGRESS ($file_record)" + } + #validate any passed cached_cksums + foreach cacheinfo $cached_cksums { + if {[llength $cacheinfo] % 2 != 0} { + error "installfile_add_source_and_fetch_metadata error.If cached_cksums is supplied, it must be a list of dicts containing keys cksum & opts" + } + dict for {k v} $cacheinfo { + switch -- $k { + cksum {} + opts { + #todo - validate $v keys + } + default { + error "installfile_add_source_and_fetch_metadata error. Unrecognised key $k. Known keys {cksum opts}" + } + } + + } + } + set ts_start [clock microseconds] + set last_installrecord [lib::file_record_get_last_installrecord $file_record] + set prev_ftype "" + set prev_fsize "" + set prev_cksum "" + set prev_cksum_opts "" + if {[llength $last_installrecord]} { + set src [lib::install_record_get_matching_source_record $last_installrecord $source_relpath] + if {[llength $src]} { + if {[dict_getwithdefault $src -path ""] eq $source_relpath} { + set prev_ftype [dict_getwithdefault $src -type ""] + set prev_fsize [dict_getwithdefault $src -size ""] + set prev_cksum [dict_getwithdefault $src -cksum ""] + set prev_cksum_opts [dict_getwithdefault $src -cksum_all_opts ""] + } + } + } + #check that this relpath not already added as child of *-INPROGRESS + set file_record_body [dict_getwithdefault $file_record body [list]] ;#new file_record may have no body + set installing_record [lindex $file_record_body end] + set already_present_record [lib::install_record_get_matching_source_record $installing_record $source_relpath] + if {[llength $already_present_record]} { + error "installfile_add_source_and_fetch_metadata error: source path $source_relpath already exists in the file_record - cannot add again" + } + + set use_cache 0 + if {$prev_cksum_opts ne ""} { + set cksum_opts $prev_cksum_opts + #find first cached_cksum that is compatible with cksum opts used in latest install record + foreach cacheinfo $cached_cksums { + set cachedopts [dict get $cacheinfo opts] + set cache_is_match 1 + dict for {k v} $cachedopts { + if {[dict exists $prev_cksum_opts $k] && $v ne [dict get $prev_cksum_opts $k]} { + set cache_is_match 0 + break + } + } + if {$cache_is_match} { + set use_cache_record $cacheinfo + set use_cache 1 + break + } + } + + } else { + #no cksum opts available from an install record + set cksum_opts "" + #use first entry in cached_cksums if we can + if {[llength $cached_cksums]} { + set use_cache 1 + set use_cache_record [lindex $cached_cksums 0] + } + } + + #todo - accept argument of cached source cksum info (for client calling multiple targets with same source in quick succession e.g when building .vfs kits with multiple runtimes) + #if same cksum_opts - then use cached data instead of checksumming here. + + #allow nonexistant as a source + set fpath [file join $punkcheck_folder $source_relpath] + #windows: file exist + file type = 2ms vs 500ms for 2x glob + set floc [file dirname $fpath] + set fname [file tail $fpath] + set file_set [glob -nocomplain -dir $floc -type f -tails -- $fname] + set dir_set [glob -nocomplain -dir $floc -type d -tails -- $fname] + set link_set [glob -nocomplain -dir $floc -type l -tails -- $fname] + if {[llength $file_set] == 0 && [llength $dir_set] == 0 && [llength $link_set] == 0} { + #could also theoretically exist as less common types, b,c,p,s (block,char,pipe,socket) + #- we don't expect them here - REVIEW - ever possible? + #- installing/examining such things an unlikely usecase and would require special handling anyway. + set ftype "missing" + set fsize "" + } else { + if {[llength $dir_set]} { + set ftype "directory" + set fsize "NA" + } elseif {[llength $link_set]} { + set ftype "link" + set fsize 0 + } else { + set ftype "file" + #todo - optionally use mtime instead of cksum (for files only)? + #mtime is not reliable across platforms and filesystems though.. see article linked at top. + set fsize [file size $fpath] + } + } + + #if {![file exists $fpath]} { + # set ftype "missing" + # set fsize "" + #} else { + # set ftype [file type $fpath] + # if {$ftype eq "directory"} { + # set fsize "NA" + # } else { + # #todo - optionally use mtime instead of cksum (for files only)? + # #mtime is not reliable across platforms and filesystems though.. see article linked at top. + # set fsize [file size $fpath] + # } + #} + #get_relativecksum_from_base and fill_relativecksums_from_base_and_relativepathdict will set cksum to if fpath doesn't exist + if {$use_cache} { + set source_cksum_info [punk::mix::base::lib::fill_relativecksums_from_base_and_relativepathdict $punkcheck_folder [dict create $source_relpath $use_cache_record]] + } else { + set source_cksum_info [punk::mix::base::lib::get_relativecksum_from_base $punkcheck_folder $source_relpath {*}$cksum_opts] + } + + + lassign $source_cksum_info pathkey ckinfo + if {$pathkey ne $source_relpath} { + error "installfile_add_source_and_fetch_metadata error: cksum returned wrong path info '$pathkey' expected '$source_relpath'" + } + set cksum [dict get $ckinfo cksum] + #set cksum_all_opts [dict get $ckinfo cksum_all_opts] + set cksum_all_opts [dict get $ckinfo opts] + if {$cksum ne $prev_cksum || $ftype ne $prev_ftype || $fsize ne $prev_fsize} { + set changed 1 + } else { + set changed 0 + } + set installing_record_sources [dict_getwithdefault $installing_record body [list]] + set ts_now [clock microseconds] ;#gathering metadata - especially checksums on folder can take some time - calc and store elapsed us for time taken to gather metadata + set metadata_us [expr {$ts_now - $ts_start}] + set this_source_record [dict create tag SOURCE -type $ftype -size $fsize -path $source_relpath -cksum $cksum -cksum_all_opts $cksum_all_opts -changed $changed -metadata_us $metadata_us] + lappend installing_record_sources $this_source_record + dict set installing_record body $installing_record_sources + + lset file_record_body end $installing_record + + dict set file_record body $file_record_body + return $file_record + } + + #write back to punkcheck - don't accept recordset - invalid to update anything other than the installing_record at this time + proc installfile_started_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_started_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set ts_now [clock microseconds] + set metadata_us [expr {$ts_now - $ts_start}] + + dict set installing_record -metadata_us $metadata_us + dict set installing_record -ts_start_transfer $ts_now + + lset file_record_body end $installing_record + + dict set file_record body $file_record_body + + + set getresult [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $getresult position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_started_install [llength $targetlist] targets" + return $file_record + } + proc installfile_finished_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_finished_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set ts_start_transfer [dict get $installing_record -ts_start_transfer] + set ts_now [clock microseconds] + set elapsed_us [expr {$ts_now - $ts_start}] + set transfer_us [expr {$ts_now - $ts_start_transfer}] + dict set installing_record -transfer_us $transfer_us + dict set installing_record -elapsed_us $elapsed_us + dict unset installing_record -tempcontext + dict set installing_record tag "INSTALL-RECORD" + + lset file_record_body end $installing_record + dict set file_record body $file_record_body + + set file_record [punkcheck::recordlist::file_record_prune $file_record] + + set oldrecordinfo [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $oldrecordinfo position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_finished_install [llength $targetlist] targets" + return $file_record + } + proc installfile_skipped_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + set msg "installfile_skipped_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + append msg \n "received:" + append msg \n $file_record + error $msg + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set tsnow [clock microseconds] + set elapsed_us [expr {$tsnow - $ts_start}] + dict set installing_record -elapsed_us $elapsed_us + dict set installing_record tag "INSTALL-SKIPPED" + + lset file_record_body end $installing_record + dict set file_record body $file_record_body + + set file_record [punkcheck::recordlist::file_record_prune $file_record] + + set getresult [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $getresult position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_skipped_install [llength $targetlist] targets" + return $file_record + } + #----------------------------------------------- + #then: file_record_add_installrecord + + namespace eval lib { + set pkg punkcheck + namespace path ::punkcheck + proc is_file_record_inprogress {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + return 0 + } + set installing_record [lindex [dict_getwithdefault $file_record body [list]] end] + if {[dict_getwithdefault $installing_record tag [list]] ni [list QUERY-INPROGRESS INSTALL-INPROGRESS MODIFY-INPROGRESS DELETE-INPROGRESS VIRTUAL-INPROGRESS]} { + return 0 + } + return 1 + } + proc is_file_record_installing {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + return 0 + } + set installing_record [lindex [dict_getwithdefault $file_record body [list]] end] + if {[dict_getwithdefault $installing_record tag [list]] ne "INSTALL-INPROGRESS"} { + return 0 + } + return 1 + } + proc file_record_get_last_installrecord {file_record} { + set body [dict_getwithdefault $file_record body [list]] + set previous_install_records [lrange $body 0 end-1] + #get last previous that is tagged INSTALL-RECORD,MODIFY-RECORD,VIRTUAL-RECORD + #REVIEW DELETERECORD ??? + set revlist [lreverse $previous_install_records] + foreach rec $revlist { + if {[dict get $rec tag] in [list "INSTALL-RECORD" "MODIFY-RECORD" "VIRTUAL-RECORD"]} { + return $rec + } + } + return [list] + } + + #should work on *-INPROGRESS or INSTALL(etc) record - don't restrict tag to INSTALL + proc install_record_get_matching_source_record {install_record source_relpath} { + set body [dict_getwithdefault $install_record body [list]] + foreach src $body { + if {[dict get $src tag] eq "SOURCE"} { + if {[dict_getwithdefault $src -path ""] eq $source_relpath} { + return $src + } + } + } + return [list] + } + + + + # Delegate to punk::path::relative (verified equivalent implementation) + proc path_relative {base dst} { + return [punk::path::relative $base $dst] + } + } + #skip writing punkcheck during checksum/timestamp checks + + #todo - punk::args - fetch from punkcheck::install (with overrides) + proc install_tm_files {srcdir basedir args} { + set defaults [list {*}{ + -glob *.tm + -installer punkcheck::install_tm_files + } -exclude-filetails [list "*[punk::mix::util::tm_version_magic]*"] {*}{ + } + ] + set opts [dict merge $defaults $args] + punkcheck::install $srcdir $basedir {*}$opts + } + proc install_non_tm_files {srcdir basedir args} { + #set keys [dict keys $args] + #adjust the default exclude-paths_core entries so that .fossil-custom, .fossil-settings are copied + set excludepaths_core [punkcheck::default_excludepaths_core] + #remove .fossil* entries (both top-level and **/ forms) so fossil folders are not excluded + set excludepaths_core [lsearch -inline -all -not $excludepaths_core ".fossil*"] + set excludepaths_core [lsearch -inline -all -not $excludepaths_core "**/.fossil*"] + set defaults [list {*}{ + } -glob * {*}{ + } -exclude-filetails [list "*.tm" "*-buildversion.txt" "*.exe"] {*}{ + } -exclude-paths-core $excludepaths_core {*}{ + } -installer punkcheck::install_non_tm_files {*}{ + } + ] + set opts [dict merge $defaults $args] + punkcheck::install $srcdir $basedir {*}$opts + } + + #for tcl8.6 - tcl8.7+ has dict getwithdefault (dict getdef) + proc dict_getwithdefault {dictValue args} { + if {[llength $args] < 2} { + error {wrong # args: should be "dict_getdef dictionary ?key ...? key default"} + } + set keys [lrange $args 0 end-1] + if {[dict exists $dictValue {*}$keys]} { + return [dict get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + lappend PUNKARGS [list { + @id -id ::punkcheck::install + @cmd -name ::punkcheck::install -help\ + "Unidirectional file transfer to possibly non-empty target folder. + This is the simpler form of the API, performing a transfer from one + directory tree to another, copying each file when changes in the source + file are detected. + Changes are detected by content checksum. The first install will record + source checksums in a .punkcheck file (ideally located at the root of the + target folder). Subsequent installs will compare stored checksums with + the current checksums of the source files. + For more advanced install operations, the object command installtrack + can be used to define install operations. e.g when the transfer is not + one-to-one and a target file depends on multiple source files." + @leaders -min 2 -max 2 + srcdir -type directory + tgtdir -type directory + -call-depth-internal -type integer -default 0 -help "(internal recursion tracker)" + -subdirlist -type list -default "" -help "(primarily internal - length generally matching -call-depth-internal)" + -max-depth -type integer -default 1000 -help\ + "Deepest subdirectory - use -1 for no limit." + -createdir -type boolean -default 0 -help\ + "Whether to create the folder at tgtdir. + Any required subdirectories are created regardless of this setting." + -createempty -type boolean -default 0 -help\ + "Whether to create folders at target that had no matches for our glob" + -glob -type string -default "*" -help\ + "Pattern matching for source file(s) to copy. Can be glob based or exact match." + -exclude-filetails-core -default {${[::punkcheck::default_excludefiletail_core]}} -help\ + "Non-overridable default file-tail exclusion patterns. + These are applied in addition to -exclude-filetails and cannot be + disabled by the caller - they can only be replaced by passing + -exclude-filetails-core with a different list. + Patterns use string match against the file tail (basename) at any + level in the tree. They must not contain path separators." + -exclude-filetails -default "" -help\ + "List of glob patterns to match against file tails (basenames). + Patterns use string match and must not contain path separators. + e.g {*.swp *.tmp} excludes swap and temp files at any level." + -exclude-paths-core -default {${[::punkcheck::default_excludepaths_core]}} -help\ + "Non-overridable default path-glob exclusion patterns. + These are applied in addition to -exclude-paths and cannot be + disabled by the caller - they can only be replaced by passing + -exclude-paths-core with a different list. + Patterns are matched against the full relative source path using + punk::path::globmatchpath." + -exclude-paths -default {} -help\ + "List of path-glob patterns to exclude from installation. + Patterns are matched against the full relative source path using + punk::path::globmatchpath, so they may include ** to match across + path segments and / to match within a segment. + e.g to exclude all AGENTS.md files at any depth: {AGENTS.md **/AGENTS.md}" + #backward-compat aliases (accepted but deprecated - converted internally to -exclude-paths) + -exclude-dirsegments-core -default {${[::punkcheck::default_excludedirseg_core]}} -help\ + "DEPRECATED: use -exclude-paths-core instead. + Legacy segment-glob patterns matched against directory tail names. + Converted internally to path-glob form by expanding each segment + S to {S **/S}." + -exclude-dirsegments -default "" -help\ + "DEPRECATED: use -exclude-paths instead. + Legacy segment-glob patterns matched against directory tail names + at any level. Each pattern must not contain path separators." + -antiglob-paths -default {} -help\ + "DEPRECATED: use -exclude-paths instead. + Legacy path-glob patterns matched against the full relative source + path using punk::path::globmatchpath. Merged into -exclude-paths + internally." + -overwrite -default no-targets\ + -choices {no-targets newer-targets older-targets all-targets installedsourcechanged-targets synced-targets}\ + -choicecolumns 1\ + -choicelabels { + no-targets "only copy files that are missing at the target" + newer-targets "copy files with older source timestamp over newer + target timestamp and those missing at the target + (a form of 'restore' operation)" + older-targets "copy files with newer source timestamp over older + target timestamp and those missing at the target" + all-targets "copy regardless of timestamp at target" + installedsourcechanged-targets "copy if the target doesn't exist or the source changed" + synced-targets "copy if the target doesn't exist or the source changed + and the target cksum is the same as the last INSTALL-RECORD -targets_cksums entry" + } + -source-checksum -default comparestore -choicecolumns 3 -choices {compare store comparestore false true} -help\ + "Checksum behavior for source files. + compare: checksum and compare against last record, but do not store. + store: checksum and store, but do not compare against last record. + comparestore: checksum, compare against last record, and store. + false: do not checksum (not recommended - changes cannot be detected). + true: same as comparestore." + -punkcheck-folder -default target -choices {target source project} -choicerestricted 0 -help\ + "The location of the .punkcheck file to track installations and checksums. + The default value 'target' is generally recommended. + Can also be an absolute path to a folder." + -punkcheck-eventid -default "" -help\ + "Event ID for the install operation. When empty (default), a new UUID + is generated automatically. Pass a specific ID to group multiple + install calls under the same event in the .punkcheck file." + -punkcheck-records -default "" -help\ + "Empty string or a parsed TDL records structure. + e.g + {tag FILEINFO - ... body { + {tag INSTALL-RECORD - ... body {}} + ... + }... + }" + -installer -default "punkcheck::install" -help\ + "A user nominated string that is stored in the .punkcheck file + This might be the name of a script or installation process." + -progresschannel -default none -type string -help\ + "Name of channel e.g stderr, stdout to which progress messages are written. + This includes the tree-like output consisting of dots (or green U) for each + file processed. As the number of files in a tree is not known beforehand, + it isn't useful for a percentage-based progress meter, but it could potentially + be used to drive a spinner if the textual data is not desired. + Setting to none or an invalid channel will deactivate the output." + }] + ## unidirectional file transfer to possibly non empty folder + #default of -overwrite no-targets will only copy files that are missing at the target + # -overwrite newer-targets will copy files with older source timestamp over newer target timestamp and those missing at the target (a form of 'restore' operation) + # -overwrite older-targets will copy files with newer source timestamp over older target timestamp and those missing at the target + # -overwrite all-targets will copy regardless of timestamp at target + # -overwrite installedsourcechanged-targets will copy if the target doesn't exist or the source changed + # -overwrite synced-targets will copy if the target doesn't exist or the source changed and the target cksum is the same as the last INSTALL-RECORD -targets_cksums entry + # review - timestamps unreliable + # - what about slightly mismatched system clocks and mounted filesystems? caller responsibility to verify first? + # if timestamp exactly equal - should we check content-hash? This is presumably only likely to occur deliberately(maliciously?) + # e.g some process that digitally signs or otherwise modifies a file and preserves update timestmp? + # if such a content-mismatch - what default behaviour and what options would make sense? + # probably it's reasonable that only all-targets would overwrite such files. + # consider -source_fudge_seconds +-X ?, -source_override_timestamp ts ??? etc which only adjust timestamp for calculation purposes? Define a specific need/usecase when reviewing. + # + # valid filetypes for src tgt + # src dir tgt dir + # todo - review and consider enabling symlink src and dst + # no need for src file - as we use -glob with no glob characters to match one source file file + # no ability to target file with different name - keep it simpler and caller will have to use an intermediate folder/file if they need to rename something? + # + # todo - determine what happens if mismatch between file type of a src vs target e.g target has dir matching filename at source + # A pre-scan to determine no such conflict - before attempting to copy anything might provide the most integrity at slight cost in speed. + # REVIEW we should only expect dirs to be created as necessary to hold files? i.e target folder won't be created if no source file matches for that folder + # -source-checksum compare|store|comparestore|false|true where true == comparestore + # -punkcheck-folder target|source|project| target is default and is generally recommended + # -punkcheck-records empty string | parsed TDL records ie {tag xxx k v} structure + # install creates FILEINFO records with a single entry in the -targets field (it is legitimate to have a list of targets for an installation operation - the oo interface supports this) + proc install {srcdir tgtdir args} { + # Backward-compat: normalize old underscore flag names to hyphenated forms + set flag_aliases [dict create {*}{ + -max_depth -max-depth + -exclude-filetails_core -exclude-filetails-core + -exclude-paths_core -exclude-paths-core + -exclude-dirsegments_core -exclude-dirsegments-core + -antiglob_paths -antiglob-paths + -source_checksum -source-checksum + -punkcheck_folder -punkcheck-folder + -punkcheck_eventid -punkcheck-eventid + -punkcheck_records -punkcheck-records + }] + if {[llength $args]} { + set normalized [list] + foreach {k v} $args { + if {[dict exists $flag_aliases $k]} { + lappend normalized [dict get $flag_aliases $k] $v + } else { + lappend normalized $k $v + } + } + set args $normalized + } + + set defaults [list {*}{ + -call-depth-internal 0 + -max-depth 1000 + -subdirlist {} + -createdir 0 + -createempty 0 + -glob * + -exclude-filetails-core "\uFFFF" + -exclude-filetails "" + -exclude-paths-core "\uFFFF" + -exclude-paths {} + -exclude-dirsegments-core "\uFFFF" + -exclude-dirsegments {} + -antiglob-paths {} + -overwrite no-targets + -source-checksum comparestore + -punkcheck-folder target + -punkcheck-eventid "\uFFFF" + -punkcheck-records "" + -installer punkcheck::install + -progresschannel none + }] + + if {([llength $args] %2) != 0} { + error "punkcheck::install requires option-style arguments to be in pairs. Received args: $args" + } + foreach {k -} $args { + if {$k ni [dict keys $defaults]} { + error "punkcheck::install unrecognised option '$k' known options: '[dict keys $defaults]'" + } + } + set opts [dict merge $defaults $args] + + #The choice to recurse using the original values of srcdir & tgtdir, and passing the subpath down as a list in -subdirlist seems an odd one. + #(as opposed to a more 'standard' mechanism of adjusting srcdir & tgtdir as we move down the tree) + #It comes from build_modules_from_source_to_base where we need to keep track of position relative to our targetdir starting point to handle submodules e.g pkg::something::mypkg-0.1.tm + #It could have been handled with some other parameter such as -depth, but this -subdirlist mechanism, whilst perhaps not beautiful, is straightforward enough + #and may be less error prone than doing slightly more opaque path manipulations at each recursion level to determine where we started + #For consistency - we'll use the same mechanism in various recursive directory walking procedures such as this one. + set CALLDEPTH [dict get $opts -call-depth-internal] ;#added for extra debug/sanity checking - clearer test for initial function call ie CALLDEPTH = 0 + set max_depth [dict get $opts -max-depth] ;# -1 for no limit + set subdirlist [dict get $opts -subdirlist] ;# generally should be same length as CALLDEPTH - but user could prefill + set fileglob [dict get $opts -glob] + set createdir [dict get $opts -createdir] ;#defaults to zero to help avoid mistakes with initial target dir - required target subdirs are created regardless of this setting + set opt_createempty [dict get $opts -createempty] + set opt_progresschannel [dict get $opts -progresschannel] + if {$opt_progresschannel in {"" none} || [catch {chan configure $opt_progresschannel}]} { + set opt_progresschannel "" + } + + if {$CALLDEPTH == 0} { + #expensive to normalize but we need to do it at least once + set srcdir [file normalize $srcdir] + set tgtdir [file normalize $tgtdir] + if {$createdir} { + file mkdir $tgtdir + } else { + if {![file exists $tgtdir]} { + error "punkcheck::install base target dir:'$tgtdir' doesn't exist (srcdir:$srcdir tgtdir:$tgtdir args:'$args')" + } + } + if {([file type $srcdir] ni [list directory]) || ([file type $tgtdir] ni [list directory])} { + error "punkcheck::install requires source and target dirs to be of type 'directory' type current source: [file type $srcdir] type current target: [file type $tgtdir]" + } + #now the values we build from these will be properly cased + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_excludefiletail_core [dict get $opts -exclude-filetails-core] + if {$opt_excludefiletail_core eq "\uFFFF"} { + set opt_excludefiletail_core [default_excludefiletail_core] + dict set opts -exclude-filetails-core $opt_excludefiletail_core + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_excludefiletail [dict get $opts -exclude-filetails] + #validate no path seps + foreach af $opt_excludefiletail { + if {[llength [file split $af]] > 1} { + error "punkcheck::install received invalid -exclude-filetails entry '$af'. -exclude-filetails entries are meant to match to a file name at any level so cannot contain path separators" + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # Unified -exclude-paths initialization (replaces -exclude-dirsegments + -antiglob-paths) + # Precedence: -exclude-paths-core > -exclude-dirsegments-core (legacy) > default + set opt_excludepaths_core [dict get $opts -exclude-paths-core] + set legacy_excludedirseg_core [dict get $opts -exclude-dirsegments-core] + if {$opt_excludepaths_core ne "\uFFFF"} { + # User explicitly passed -exclude-paths-core → use as-is (path-glob form) + } elseif {$legacy_excludedirseg_core ne "\uFFFF"} { + # User explicitly passed legacy -exclude-dirsegments-core → convert to path-glob form + set opt_excludepaths_core [list] + foreach seg $legacy_excludedirseg_core { + lappend opt_excludepaths_core $seg + lappend opt_excludepaths_core **/$seg + } + dict set opts -exclude-paths-core $opt_excludepaths_core + } else { + # Neither passed → use new default + set opt_excludepaths_core [default_excludepaths_core] + dict set opts -exclude-paths-core $opt_excludepaths_core + } + set opt_excludepaths [dict get $opts -exclude-paths] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # Backward-compat: convert legacy -exclude-dirsegments to path-glob form and merge + # Each segment-glob S is expanded to {S **/S} to match at any directory level, + # preserving the former string-match-against-tail semantics. + set opt_excludedirseg_core $legacy_excludedirseg_core + if {$opt_excludedirseg_core eq "\uFFFF"} { + set opt_excludedirseg_core [default_excludedirseg_core] + dict set opts -exclude-dirsegments-core $opt_excludedirseg_core + } + set opt_excludedirseg [dict get $opts -exclude-dirsegments] + #validate no path seps + foreach ad $opt_excludedirseg { + if {[llength [file split $ad]] > 1} { + error "punkcheck::install received invalid -exclude-dirsegments entry '$ad'. -exclude-dirsegments entries are meant to match to a directory name at any level so cannot contain path separators" + } + } + #convert legacy dir-seg user globs (NOT core) to path-glob form and append to opt_excludepaths + foreach seg $opt_excludedirseg { + lappend opt_excludepaths $seg + lappend opt_excludepaths **/$seg + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # Backward-compat: merge legacy -antiglob-paths into opt_excludepaths + set opt_antiglob_paths [dict get $opts -antiglob-paths] ;#todo - combine with config file in source tree .punkcheckpublish (?) + #antiglob_paths will usually contain file separators - and may contain glob patterns within each segment + foreach ap $opt_antiglob_paths { + lappend opt_excludepaths $ap + } + set antiglob_paths_matched [list] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set known_whats [list no-targets newer-targets older-targets all-targets installedsourcechanged-targets synced-targets] + set overwrite_what [string tolower [dict get $opts -overwrite]]; #accept any case for value to allow emphasis by caller e.g -overwrite NEWER-TARGETS + if {$overwrite_what ni $known_whats} { + error "punkcheck::install received unrecognised value for -overwrite. Received value '$overwrite_what' vs known values '$known_whats'" + } + if {$overwrite_what in [list newer-targets older-targets]} { + error "punkcheck::install newer-target, older-targets not implemented - sorry" + #TODO - check crossplatform availability of ctime (on windows it still seems to be creation time, but on bsd/linux it's last attribute mod time) + # external pkg? use twapi and ctime only on other platforms? + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_source_checksum [dict get $opts -source-checksum] + if {[string is boolean $opt_source_checksum]} { + if {$opt_source_checksum} { + set opt_source_checksum "comparestore" + } else { + set opt_source_checksum 0 + } + dict set opts -source-checksum $opt_source_checksum + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_punkcheck_folder [dict get $opts -punkcheck-folder] + if {$opt_punkcheck_folder eq "target"} { + set punkcheck_folder $tgtdir + } elseif {$opt_punkcheck_folder eq "source"} { + set punkcheck_folder $srcdir + } elseif {$opt_punkcheck_folder eq "project"} { + set sourceprojectinfo [punk::repo::find_repos $srcdir] + set targetprojectinfo [punk::repo::find_repos $tgtdir] + set srcproj [lindex [dict get $sourceprojectinfo project] 0] + set tgtproj [lindex [dict get $targetprojectinfo project] 0] + if {$srcproj eq $tgtproj} { + set punkcheck_folder $tgtproj + } else { + error "copy_files_from_source_to_target error: Unable to find common project dir for source and target folder - use absolutepath for -punkcheck-folder if source and target are not within same project" + } + } else { + set punkcheck_folder $opt_punkcheck_folder + } + if {$punkcheck_folder ne ""} { + if {[file pathtype $punkcheck_folder] ne "absolute"} { + error "copy_files_from_source_to_target error: -punkcheck-folder '$punkcheck_folder' must be an absolute path, or one of: target|source|project" + } + if {![file isdirectory $punkcheck_folder]} { + error "copy_files_from_source_to_target error: -punkcheck-folder '$punkcheck_folder' not found" + } + } else { + #review - leave empty? use pwd? + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set punkcheck_records [dict get $opts -punkcheck-records] + set punkcheck_records_init $punkcheck_records ;#change-detection + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_installer [dict get $opts -installer] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_punkcheck_eventid [dict get $opts -punkcheck-eventid] + + + + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + + if {$CALLDEPTH == 0} { + set punkcheck_eventid "" + if {$punkcheck_folder ne ""} { + set config $opts + dict unset config -call-depth-internal + dict unset config -max-depth + dict unset config -subdirlist + dict unset config -progresschannel + tcl::dict::for {k v} $config { + if {$v eq "\uFFFF"} { + dict unset config $k + } + } + lassign [punkcheck::start_installer_event $punkcheck_file $opt_installer $srcdir $tgtdir $config] _eventid punkcheck_eventid _recordset punkcheck_records + } + } else { + set punkcheck_eventid $opt_punkcheck_eventid + } + + + + if {$opt_source_checksum != 0} { + #we need to read the file even if only set to store (or we would overwrite entries) + set compare_cksums 1 + } else { + set compare_cksums 0 + } + + if {[string match *store* $opt_source_checksum]} { + set store_source_cksums 1 + } else { + set store_source_cksums 0 + } + + + + + + if {[llength $subdirlist] == 0} { + set current_source_dir $srcdir + set current_target_dir $tgtdir + } else { + set current_source_dir $srcdir/[file join {*}$subdirlist] + set current_target_dir $tgtdir/[file join {*}$subdirlist] + } + + + set relative_target_dir [lib::path_relative $tgtdir $current_target_dir] + if {$relative_target_dir eq "."} { + set relative_target_dir "" + } + set relative_source_dir [lib::path_relative $srcdir $current_source_dir] + if {$relative_source_dir eq "."} { + set relative_source_dir "" + } + set target_relative_to_punkcheck_dir [lib::path_relative $punkcheck_folder $current_target_dir] + if {$target_relative_to_punkcheck_dir eq "."} { + set target_relative_to_punkcheck_dir "" + } + foreach unpub $opt_antiglob_paths { + #puts "testing folder - globmatchpath $unpub $relative_source_dir" + if {[punk::path::globmatchpath $unpub $relative_source_dir]} { + lappend antiglob_paths_matched $current_source_dir + return [list files_copied {} files_skipped {} sources_unchanged {} punkcheck_records $punkcheck_records antiglob_paths_matched $antiglob_paths_matched srcdir $srcdir tgtdir $tgtdir punkcheck_folder $punkcheck_folder] + } + } + + + if {![file exists $current_source_dir]} { + error "punkcheck::install current source dir:'$current_source_dir' doesn't exist (srcdir:$srcdir tgtdir:$tgtdir args:'$args')" + } + + set files_copied [list] + set files_skipped [list] + set sources_unchanged [list] + + + set candidate_list [glob -nocomplain -dir $current_source_dir -type f -tail -- $fileglob] + set hidden_candidate_list [glob -nocomplain -dir $current_source_dir -types {hidden f} -tail -- $fileglob] + foreach h $hidden_candidate_list { + if {$h ni $candidate_list} { + lappend candidate_list $h + } + } + set match_list [list] + foreach m $candidate_list { + set suppress 0 + foreach anti [concat $opt_excludefiletail_core $opt_excludefiletail] { + if {[string match $anti $m]} { + #puts stderr "anti: $anti vs m:$m" + set suppress 1 + break + } + } + if {$suppress == 0} { + lappend match_list $m + } + } + + #sample .punkcheck file record (raw form) to make the code clearer + #punk::tdl converts to dict form e.g: tag FILEINFO -targets filename body sublist + #Valid installrecord types are INSTALL-RECORD SKIPPED INSTALL-INPROGRESS, MODIFY-RECORD MODIFY-INPROGRESS DELETE-RECORD DELETE-INPROGRESS + # + #FILEINFO -targets jjjetc-0.1.0.tm -keep_installrecords 2 -keep_skipped 1 -keep_inprogress 2 { + # INSTALL-RECORD -tsiso 2023-09-20T07:30:30 -ts 1695159030266610 -installer punk::mix::cli::build_modules_from_source_to_base -metadata_us 18426 -ts_start_transfer 1695159030285036 -transfer_us 10194 -elapsed_us 28620 { + # SOURCE -type file -path ../src/modules/jjjetc-buildversion.txt -cksum c7c71839c36b3d21c8370fed106192fcd659eca9 -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 3423 + # SOURCE -type file -path ../src/modules/jjjetc-0.2.0.tm -cksum b646fc2ee88cbd068d2e946fe929b7aea96bd39d -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 3413 + # } + # INSTALL-SKIPPED -tsiso 2023-09-20T08:14:26 -ts 1695161666087880 -installer punk::mix::cli::build_modules_from_source_to_base -elapsed_us 18914 { + # SOURCE -type file -path ../src/modules/jjjetc-buildversion.txt -cksum c7c71839c36b3d21c8370fed106192fcd659eca9 -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 0 -metadata_us 3435 + # SOURCE -type file -path ../src/modules/jjjetc-0.2.0.tm -cksum b646fc2ee88cbd068d2e946fe929b7aea96bd39d -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 0 -metadata_us 3338 + # } + #} + + if {[llength $match_list]} { + #example - target dir has a file where there is a directory at the source + if {[file exists $current_target_dir] && ([file type $current_target_dir] ni [list directory])} { + error "punkcheck::install target subfolder $current_target_dir exists but is not of type 'directory'. Type current target folder: [file type $current_target_dir]" + } + } + + #proc get_relativecksum_from_base_and_fullpath {base fullpath args} + + + #puts stdout "Current target dir: $current_target_dir" + set last_depth "" + foreach m $match_list { + set new_tgt_cksum_info [list] + set relative_target_path [file join $relative_target_dir $m] + set relative_source_path [file join $relative_source_dir $m] + set punkcheck_target_relpath [file join $target_relative_to_punkcheck_dir $m] + set is_antipath 0 + foreach pathglob [concat $opt_excludepaths_core $opt_excludepaths] { + #puts "testing file - globmatchpath $pathglob vs $relative_source_path" + if {[punk::path::globmatchpath $pathglob $relative_source_path]} { + lappend antiglob_paths_matched $current_source_dir + set is_antipath 1 + break + } + } + if {$is_antipath} { + continue + } + + set ts_start [clock microseconds] + set seconds [expr {$ts_start / 1000000}] + set ts_start_iso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + + + #puts stdout " rel_target: $punkcheck_target_relpath" + + set fetch_filerec_result [punkcheck::recordlist::get_file_record $punkcheck_target_relpath $punkcheck_records] + #change to use extract_or_create_fileset_record ? + set existing_filerec_posn [dict get $fetch_filerec_result position] + if {$existing_filerec_posn == -1} { + if {$opt_progresschannel ne ""} { + puts stdout "\nNO existing record for $punkcheck_target_relpath" + } + set has_filerec 0 + set new_filerec [dict create tag FILEINFO -targets $punkcheck_target_relpath] + set filerec $new_filerec + } else { + set has_filerec 1 + #puts stdout " TDL existing FILEINFO record for $punkcheck_target_relpath" + #puts stdout " $existing_install_record" + set filerec [dict get $fetch_filerec_result record] + } + set filerec [punkcheck::recordlist::file_record_set_defaults $filerec] + + #new INSTALLREC must be tagged as INSTALL-INPROGRESS to use recordlist::installfile_ method + set new_install_record [dict create tag INSTALL-INPROGRESS -tsiso $ts_start_iso -ts $ts_start -installer $opt_installer -eventid $punkcheck_eventid] + dict lappend filerec body $new_install_record ;#can't use recordlist::file_record_add_installrecord as '*-INPROGRESS' isn't a final tag - so pruning would be mucked up. No need to prune now anyway. + unset new_install_record + + + if {$opt_progresschannel ne ""} { + if {$last_depth ne $CALLDEPTH} { + if {$CALLDEPTH <=1} { + puts -nonewline $opt_progresschannel \n[string repeat " " $CALLDEPTH][file tail $relative_source_dir] + } + flush $opt_progresschannel + ##set last_depth $CALLDEPTH ;# done down below + } + } + + + + set relative_source_path [lib::path_relative $punkcheck_folder $current_source_dir/$m] + #puts stdout " rel_source: $relative_source_path" + #if {[file pathtype $relative_source_path] ne "relative"} { + #REVIEW + #different volume or root + #} + #Note this isn't a recordlist function - so it doesn't purely operate on the records + #this hits the filesystem for the sourcepath - gets checksums/timestamps depending on config. + #It doesn't save to .punkcheck (the only punkcheck::installfile_ method which doesn't) + set ts1 [clock milliseconds] + set filerec [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $relative_source_path $filerec] + set ts2 [clock milliseconds] + set diff [expr {$ts2 - $ts1}] + if {$diff > 100} { + #todo -errorchannel + set errprefix ">>> punkcheck:" + puts stderr "\n$errprefix performance warning: fetch_metadata for $m took $diff ms." + set lb [lindex [dict get $filerec body] end] + #puts stderr "$errprefix filerec last body record:$lb" + set records [dict get $lb body] + set lr [lindex $records end] + set alg [dict get $lr -cksum_all_opts -cksum_algorithm] + if {$alg eq "sha1"} { + puts stderr "$errprefix cksum_algorithm: sha1 (accelerators: [::sha1::Implementations])" + puts stderr "$errprefix sha1 from: [package ifneeded sha1 [package present sha1]]" + } else { + puts stderr "$errprefix cksum_algorithm: $alg" + } + } + + + + #changeinfo comes from last record in body - which is the record we are working on and so will always exist + set changeinfo [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $filerec body] end]] + set changed [dict get $changeinfo changed] + set unchanged [dict get $changeinfo unchanged] + + if {[llength $unchanged]} { + lappend sources_unchanged $current_source_dir/$m + } + + set is_skip 0 + set is_new 0 + if {$overwrite_what eq "all-targets"} { + file mkdir $current_target_dir + #-------------------------------------------- + #sometimes we get the error: 'error copying "file1" to "file2": invalid argument' + #-------------------------------------------- + puts stderr "punkcheck: about to: file copy -force $current_source_dir/$m $current_target_dir" + file copy -force $current_source_dir/$m $current_target_dir + lappend files_copied $current_source_dir/$m + } else { + if {![file exists $current_target_dir/$m]} { + #puts stderr "punkcheck: first copy to $current_target_dir/$m " + file mkdir $current_target_dir + puts stderr "punkcheck: about to: file copy $current_source_dir/$m $current_target_dir" + file copy $current_source_dir/$m $current_target_dir + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + lappend files_copied $current_source_dir/$m + incr filecount_new + set is_new 1 + } else { + switch -- $overwrite_what { + installedsourcechanged-targets { + if {[llength $changed]} { + #An unrecorded installation is considered a source change (from unknown/unrecorded source to recorded) + puts -nonewline stderr "punkcheck: about to: file copy -force $current_source_dir/$m $current_target_dir" + set ts1 [clock milliseconds] + file mkdir $current_target_dir + file copy -force $current_source_dir/$m $current_target_dir + set ts2 [clock milliseconds] + puts -nonewline stderr " (copy time [expr {$ts2 - $ts1}] ms)" + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + set ts3 [clock milliseconds] + puts stderr " (cksum time [expr {$ts2 - $ts1}] ms)" + lappend files_copied $current_source_dir/$m + } else { + set is_skip 1 + lappend files_skipped $current_source_dir/$m + } + } + synced-targets { + #disallow overwriting of target that has been modified by some other mechanism + #review + if {[llength $changed]} { + #only overwrite if the target file checksum equals the last installed checksum (ie target is in sync with previous source-set and so hasn't been customized) + set existing_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + set is_target_unmodified_since_install 0 + set target_cksum_compare "unknown" + set latest_install_record [punkcheck::recordlist::file_record_latest_installrecord $filerec] ;#may be no such record - in which case we get an empty list + if {[dict exists $latest_install_record -targets_cksums]} { + set last_install_cksum [dict get $latest_install_record -targets_cksums] ;#in this case we know there is only one as 'install' always uses targetset size of 1. (FILEINFO record per file in source folder) + if {[dict get $existing_tgt_cksum_info cksum] eq $last_install_cksum} { + set is_target_unmodified_since_install 1 + set target_cksum_compare "match" + } else { + set target_cksum_compare "nomatch" + } + } else { + set target_cksum_compare "norecord" + } + if {$is_target_unmodified_since_install} { + file mkdir $current_target_dir + puts stderr "punkcheck: synced-targets about to: file copy -force $current_source_dir/$m $current_target_dir" + file copy -force $current_source_dir/$m $current_target_dir + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + lappend files_copied $current_source_dir/$m + } else { + #either cksum is different or we were unable to verify the record. Either way we can't know if the target is in sync so we must skip it + set is_skip 1 + puts stderr "Skipping file copy $m target $current_target_dir/$m - require synced_target to overwrite - current target cksum compared to previous install: $target_cksum_compare" + lappend files_skipped $current_source_dir/$m + } + } else { + set is_skip 1 + lappend files_skipped $current_source_dir/$m + } + } + default { + set is_skip 1 + puts stderr "Skipping file copy $m target $current_target_dir/$m already exists (use -overwrite all-targets to overwrite)" + #TODO! implement newer-targets older-targets? (note ctimes/mtimes are unreliable - may not be worth implementing) + lappend files_skipped $current_source_dir/$m + } + } + } + } + #target dir was created as necessary if files matched above + #now ensure target dir exists if -createempty true + if {$opt_createempty && ![file exists $current_target_dir]} { + file mkdir $current_target_dir + } + + + + + set ts_now [clock microseconds] + set elapsed_us [expr {$ts_now - $ts_start}] + + #if {$store_source_cksums} { + #} + + set install_records [dict get $filerec body] + set current_install_record [lindex $install_records end] + #change the tag from *-INPROGRESS to INSTALL-RECORD/SKIPPED + if {$is_skip} { + set tag INSTALL-SKIPPED + } else { + set tag INSTALL-RECORD + } + dict set current_install_record tag $tag + dict set current_install_record -elapsed_us $elapsed_us + if {[llength $new_tgt_cksum_info]} { + dict set current_install_record -targets_cksums [list [dict get $new_tgt_cksum_info cksum]] + dict set current_install_record -cksum_all_opts [dict get $new_tgt_cksum_info opts] + } + lset install_records end $current_install_record + dict set filerec body $install_records + set filerec [punkcheck::recordlist::file_record_prune $filerec] ;#prune now that tag is finalized + if {!$has_filerec} { + #not found in original recordlist - append + lappend punkcheck_records $filerec + } else { + lset punkcheck_records $existing_filerec_posn $filerec + } + + + #------------------------------------------------------------ + if {$is_skip} { + set mark . + } else { + if {$is_new} { + set mark \x1b\[32\;1mN\x1b\[m + } else { + #updated + set mark \x1b\[32\;1mU\x1b\[m + } + } + if {$opt_progresschannel ne ""} { + if {$last_depth ne $CALLDEPTH} { + puts -nonewline $opt_progresschannel \n[string repeat " " $CALLDEPTH]$mark + flush $opt_progresschannel + set last_depth $CALLDEPTH + } else { + puts -nonewline $opt_progresschannel $mark + } + } + #------------------------------------------------------------ + + } + + if {$max_depth != -1 && $CALLDEPTH >= $max_depth} { + #don't process any more subdirs + #sometimes deliberately called with max_depth 1 - so don't warn here. review + #puts stderr "punkcheck::install warning - reached max_depth $max_depth" + set subdirs [list] + } else { + set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] + set hiddensubdirs [glob -nocomplain -dir $current_source_dir -type {hidden d} -tail *] + foreach h $hiddensubdirs { + switch -- $h { + "." - ".." { + continue + } + default { + if {$h ni $subdirs} { + lappend subdirs $h + } + } + } + } + } + #puts stderr "subdirs: $subdirs" + foreach d $subdirs { + set relative_source_path [file join $relative_source_dir $d] + set skipd 0 + foreach pathglob [concat $opt_excludepaths_core $opt_excludepaths] { + #puts "testing folder - globmatchpath $pathglob vs $relative_source_path" + if {[punk::path::globmatchpath $pathglob $relative_source_path]} { + lappend antiglob_paths_matched [file join $current_source_dir $d] + #puts stdout "SKIPPING FOLDER $relative_source_path due to exclude-path-match: $pathglob " + set skipd 1 + break + } + } + if {$skipd} { + continue + } + + #if {![file exists $current_target_dir/$d]} { + # file mkdir $current_target_dir/$d + #} + + + set sub_opts_1 [list {*}{ + } -call-depth-internal [expr {$CALLDEPTH + 1}] {*}{ + } -subdirlist [list {*}$subdirlist $d] {*}{ + } -glob $fileglob {*}{ + } -exclude-filetails-core $opt_excludefiletail_core {*}{ + } -exclude-filetails $opt_excludefiletail {*}{ + } -exclude-paths-core $opt_excludepaths_core {*}{ + } -exclude-paths $opt_excludepaths {*}{ + } -overwrite $overwrite_what {*}{ + } -source-checksum $opt_source_checksum {*}{ + } -punkcheck-folder $punkcheck_folder {*}{ + } -punkcheck-eventid $punkcheck_eventid {*}{ + } -punkcheck-records $punkcheck_records {*}{ + } -installer $opt_installer {*}{ + } + ] + set sub_opts [list {*}{ + } -call-depth-internal [expr {$CALLDEPTH + 1}] {*}{ + } -subdirlist [list {*}$subdirlist $d] {*}{ + } -punkcheck-folder $punkcheck_folder {*}{ + } -punkcheck-eventid $punkcheck_eventid {*}{ + } -punkcheck-records $punkcheck_records {*}{ + } -progresschannel $opt_progresschannel {*}{ + } + ] + set sub_opts [dict merge $opts $sub_opts] + set sub_result [punkcheck::install $srcdir $tgtdir {*}$sub_opts] + + lappend files_copied {*}[dict get $sub_result files_copied] + lappend files_skipped {*}[dict get $sub_result files_skipped] + lappend sources_unchanged {*}[dict get $sub_result sources_unchanged] + lappend antiglob_paths_matched {*}[dict get $sub_result antiglob_paths_matched] + set punkcheck_records [dict get $sub_result punkcheck_records] + } + + if {[string match *store* $opt_source_checksum]} { + #puts "subdirlist: $subdirlist" + if {$CALLDEPTH == 0} { + if {[llength $files_copied] || [llength $files_skipped]} { + #puts stdout ">>>>>>>>>>>>>>>>>>>" + set saveresult [punkcheck::save_records_to_file $punkcheck_records $punkcheck_file "install $srcdir to $tgtdir"] + puts stdout "\npunkcheck::install [dict get $saveresult recordcount] records saved as [dict get $saveresult linecount] lines to $punkcheck_file copied: [llength $files_copied] skipped: [llength $files_skipped]" + #puts stdout ">>>>>>>>>>>>>>>>>>>" + } else { + #todo - write db INSTALLER record if -debug true + + } + #puts stdout "sources_unchanged" + #puts stdout "$sources_unchanged" + #puts stdout "- -- --- --- --- ---" + } + } + + return [list files_copied $files_copied files_skipped $files_skipped sources_unchanged $sources_unchanged antiglob_paths_matched $antiglob_paths_matched punkcheck_records $punkcheck_records punkcheck_folder $punkcheck_folder srcdir $srcdir tgtdir $tgtdir] + } + + + lappend PUNKARGS [list { + @id -id ::punkcheck::summarize_install_resultdict + @cmd -name punkcheck::summarize_install_resultdict -help\ + "Emits a string summarizing a punkcheck resultdict, showing + how many items were copied, and the source, target locations" + @opts + -title -type string -default "" + -forcecolour -type boolean -default 0 -help\ + "When true, passes the forcecolour tag to punk::ansi functions. + This enables ANSI sgr colours even when colour + is off. (ignoring env(NO_COLOR)) + To disable colour - ensure the NO_COLOR env var is set, + or use: + namespace eval ::punk::console {variable colour_disabled 1}" + @values -min 1 -max 1 + resultdict -type dict + }] + proc summarize_install_resultdict {args} { + set argd [punk::args::parse $args withid ::punkcheck::summarize_install_resultdict] + lassign [dict values $argd] leaders opts values received + set title [dict get $opts -title] + set forcecolour [dict get $opts -forcecolour] + set resultdict [dict get $values resultdict] + + set has_ansi [expr {![catch {package require punk::ansi}]}] + if {$has_ansi} { + if {$forcecolour} { + set fc "forcecolour" + } else { + set fc "" + } + set R [punk::ansi::a] ;#reset + set LINE_COLOUR [punk::ansi::a+ {*}$forcecolour bold cyan] + set LOW_COLOUR [punk::ansi::a+ {*}$forcecolour bold green] + set HIGH_COLOUR [punk::ansi::a+ {*}$forcecolour bold yellow] + } else { + set R "" + set LINE_COLOUR "" + set LOW_COLOUR "" + set HIGH_COLOUR "" + } + + set msg "" + if {[dict size $resultdict]} { + set copied [dict get $resultdict files_copied] + if {[llength $copied] == 0} { + set HIGHLIGHT $LOW_COLOUR + } else { + set HIGHLIGHT $HIGH_COLOUR + } + set ruler $LINE_COLOUR[string repeat - 78]$R + if {$title ne ""} { + append msg $ruler \n + append msg $title \n + } + append msg $ruler \n + #append msg "[dict keys $resultdict]" \n + set tgtdir [dict get $resultdict tgtdir] + set checkfolder [dict get $resultdict punkcheck_folder] + append msg "${HIGHLIGHT}Copied [llength $copied] files from [dict get $resultdict srcdir] to [dict get $resultdict tgtdir]$R" \n + foreach f $copied { + append msg "COPIED [punkcheck::lib::path_relative $checkfolder $f]" \n + append msg " TO $tgtdir" \n + } + append msg "[llength [dict get $resultdict sources_unchanged]] unchanged source files" \n + append msg "[llength [dict get $resultdict files_skipped]] skipped files" \n + append msg $ruler \n + } + return $msg + } + + namespace eval recordlist { + set pkg punkcheck + namespace path ::punkcheck + + proc records_as_target_dict {record_list} { + set result [dict create] + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + set tgtlist [dict get $rec -targets] + if {[dict exists $result $tgtlist]} { + #todo - warn - duplicate record for same targetlist - shouldn't happen as we should be using get_file_record to find existing records + error "punkcheck::recordlist::records_as_target_dict - multiple records with same targetlist '$tgtlist'" + } + dict set result $tgtlist $rec + } + } + return $result + } + + + #will only match if same base was used.. and same targetlist + proc get_file_record {targetlist record_list} { + set posn 0 + set found_posn -1 + set record "" + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + if {[dict get $rec -targets] eq $targetlist} { + set found_posn $posn + set record $rec + break + } + } + incr posn + } + return [list position $found_posn record $record] + } + proc file_install_record_source_changes {install_record} { + #reject INSTALLFAILED items ? + switch -- [dict get $install_record tag] { + "QUERY-INPROGRESS" - + "INSTALL-RECORD" - + "INSTALL-SKIPPED" - + "INSTALL-INPROGRESS" - + "MODIFY-INPROGRESS" - + "MODIFY-RECORD" - + "MODIFY-SKIPPED" - + "VIRTUAL-INPROGRESS" - + "VIRTUAL-RECORD" - + "VIRTUAL-SKIPPED" - + "DELETE-RECORD" - + "DELETE-INPROGRESS" - + "DELETE-SKIPPED" { + } + default { + error "file_install_record_source_changes bad install record: tag '[dict get $install_record tag]' not INSTALL-RECORD|SKIPPED|INSTALL-INPROGRESS|MODIFY-RECORD|MODIFY-INPROGRESS|VIRTUAL-RECORD|VIRTUAL-INPROGRESS|DELETE-RECORD|DELETE-INPROGRESS" + } + } + set source_list [dict_getwithdefault $install_record body [list]] + set changed [list] + set unchanged [list] + foreach src $source_list { + if {[dict exists $src -changed]} { + if {[dict get $src -changed] !=0} { + lappend changed [dict get $src -path] + } else { + lappend unchanged [dict get $src -path] + } + } else { + lappend changed [dict get $src -path] + } + } + return [dict create changed $changed unchanged $unchanged] + } + + #assume only one for name - use first encountered? + proc get_installer_record {name record_list} { + set posn 0 + set found_posns [list] + set record "" + #puts ">>>> checking [llength $record_list] punkcheck records" + foreach rec $record_list { + if {[dict get $rec tag] eq "INSTALLER"} { + if {[dict get $rec -name] eq $name} { + set found_posn $posn + set record $rec + lappend found_posns $posn + } + } + incr posn + } + if {[llength $found_posns] > 1} { + error "punkcheck::recordlist::get_installer_record - multiple installer records with name '$name' found at positions $found_posns" + } elseif {[llength $found_posns] == 0} { + return [list position -1 record ""] + } else { + #single record found + return [list position [lindex $found_posn 0] record $record] + } + + } + + proc new_installer_record {name args} { + if {[llength $args] %2 !=0} { + error "punkcheck new_installer_record args must be name-value pairs" + } + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + + #put -tsiso first so it lines up with -tsiso in event records + set defaults [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $ts {*}{ + } -name $name {*}{ + } -keep_events 5 {*}{ + } + ] + set opts [dict merge $defaults $args] + + #set this_installer_record_list [punk::tdl::prettyparse [list INSTALLER name $opt_installer ts $ts tsiso $tsiso keep_events 5 {}]] + #set this_installer_record [lindex $this_installer_record_list 0] + + set record [dict create tag INSTALLER {*}$opts body {}] + + + return $record + } + proc new_installer_event_record {type args} { + if {[llength $args] %2 !=0} { + error "punkcheck new_installer_event_record args must be name-value pairs" + } + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set defaults [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $ts {*}{ + } -type $type {*}{ + } + ] + set opts [dict merge $defaults $args] + + set record [dict create tag EVENT {*}$opts] + } + #need to scan entire set if filerecords to check if event is still referenced + proc installer_record_pruneevents {installer_record record_list} { + set keep 5 + if {[dict exists $installer_record -keep_events]} { + set keep [dict get $installer_record -keep_events] + } + + if {[dict exists $installer_record body]} { + set body_items [dict get $installer_record body] + } else { + set body_items [list] + } + set kept_body_items [list] + set kcount 0 + foreach item [lreverse $body_items] { + if {[dict get $item tag] eq "EVENT"} { + incr kcount + if {$keep < 0 || $kcount <= $keep} { + lappend kept_body_items $item + } else { + set eventid "" + if {[dict exists $item -id]} { + set eventid [dict get $item -id] + } + if {$eventid ne "" && $eventid ne "unspecified"} { + #keep if referenced, discard if not, or if eventid empty/unspecified + set is_referenced 0 + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + if {[dict exists $rec body]} { + foreach install [dict get $rec body] { + if {[dict exists $install -eventid] && [dict get $install -eventid] eq $eventid} { + set is_referenced 1 + break + } + } + } + } + if {$is_referenced} { + break + } + } + if {$is_referenced} { + lappend kept_body_items $item + } + } + } + } else { + lappend kept_body_items $item + } + } + set kept_body_items [lreverse $kept_body_items] + dict set installer_record body $kept_body_items + return $installer_record + } + proc installer_record_add_event {installer_record event} { + if {[dict get $installer_record tag] ne "INSTALLER"} { + error "installer_record_add_event bad installer record: tag not INSTALLER" + } + if {[dict get $event tag] ne "EVENT"} { + error "installer_record_add_event bad event record: tag not EVENT" + } + if {[dict exists $installer_record body]} { + set body_items [dict get $installer_record body] + } else { + set body_items [list] + } + lappend body_items $event + dict set installer_record body $body_items + return $installer_record + } + proc file_record_latest_installrecord {file_record} { + tailcall file_record_latest_operationrecord INSTALL $file_record + } + proc file_record_latest_operationrecord {operation file_record} { + set operation [string toupper $operation] + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_latest_operationrecord bad file_record: tag not FILEINFO" + } + if {![dict exists $file_record body]} { + return [list] + } + set body_items [dict get $file_record body] + foreach item [lreverse $body_items] { + if {[dict get $item tag] eq "$operation-RECORD"} { + return $item + } + } + return [list] + } + + + proc file_record_set_defaults {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_set_defaults bad file_record: tag not FILEINFO" + } + set defaults [list -keep_installrecords 3 -keep_skipped 1 -keep_inprogress 2] + foreach {k v} $defaults { + if {![dict exists $file_record $k]} { + dict set file_record $k $v + } + } + return $file_record + } + + #negative keep_ value will keep all + proc file_record_prune {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_prune bad file_record: tag not FILEINFO" + } + set file_record [file_record_set_defaults $file_record] + set kmap [list -keep_installrecords *-RECORD -keep_skipped *-SKIPPED -keep_inprogress *-INPROGRESS] + foreach {key rtype} $kmap { + set keep [dict get $file_record $key] + if {[dict exists $file_record body]} { + set body_items [dict get $file_record body] + } else { + set body_items [list] + } + set kept_body_items [list] + set kcount 0 + foreach item [lreverse $body_items] { + if {[string match $rtype [dict get $item tag]]} { + incr kcount + if {$keep < 0 || $kcount <= $keep} { + lappend kept_body_items $item + } + } else { + lappend kept_body_items $item + } + } + set kept_body_items [lreverse $kept_body_items] + dict set file_record body $kept_body_items + } + return $file_record + } + + #extract new or existing filerecord for path given + #REVIEW - locking/concurrency + proc extract_or_create_fileset_record {relative_target_paths recordset} { + set fetch_record_result [punkcheck::recordlist::get_file_record $relative_target_paths $recordset] + set existing_posn [dict get $fetch_record_result position] + if {$existing_posn == -1} { + puts stdout "punkcheck NO existing record for $relative_target_paths" + set isnew 1 + set fileset_record [dict create tag FILEINFO -targets $relative_target_paths body {}] + } else { + #set recordset [lreplace $recordset[unset recordset] $existing_posn $existing_posn] + #set recordset [lreplace $recordset[set recordset {}] $existing_posn $existing_posn] + ledit recordset $existing_posn $existing_posn + set isnew 0 + set fileset_record [dict get $fetch_record_result record] + } + return [list record $fileset_record recordset $recordset isnew $isnew oldposition $existing_posn] + } + + } + +} + + + + +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punkcheck +} + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punkcheck [namespace eval punkcheck { + set pkg punkcheck + variable version + set version 0.2.0 +}] +return diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl b/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl index 1d74becb..334600ad 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl @@ -282,6 +282,52 @@ namespace eval ::punkboot::lib { } +#------------------------------------------------------------------------------ +# Bootsupport staleness helpers — self-contained Tcl, no punk package deps. +# These run in the early boot phase before punk packages are guaranteed loaded +# (modeled on punk::lib::askuser but without punk::console / raw-mode deps). +#------------------------------------------------------------------------------ + +# Classify the version delta between an old (bootsupport) and new (source) +# semver as "major", "minor", or "patch". +# Caller must verify new_ver > old_ver via `package vcompare` first. +proc ::punkboot::lib::bootsupport_bump_level {old_ver new_ver} { + set op [split $old_ver .] + set np [split $new_ver .] + while {[llength $op] < 3} {lappend op 0} + while {[llength $np] < 3} {lappend np 0} + set op [lmap s $op { + set n [scan $s %d] + expr {[string is integer -strict $n] ? $n : 0} + }] + set np [lmap s $np { + set n [scan $s %d] + expr {[string is integer -strict $n] ? $n : 0} + }] + lassign $op o_major o_minor o_patch + lassign $np n_major n_minor n_patch + if {$n_major > $o_major} {return "major"} + if {$n_minor > $o_minor} {return "minor"} + return "patch" +} + +# Self-contained y/N prompt. Returns 1 for y/yes (case-insensitive), 0 otherwise. +# Used by the staleness abort path to ask the user whether to proceed past a +# minor-version bump. Default is No (Enter = abort) so accidental Enter is safe. +proc ::punkboot::lib::bootsupport_prompt_yesno {prompt} { + puts stdout $prompt + puts -nonewline stdout "Proceed anyway? (y/N) " + flush stdout + set stdin_state [chan configure stdin] + try { + chan configure stdin -blocking 1 + set answer [string tolower [string trim [gets stdin]]] + } finally { + chan configure stdin -blocking [dict get $stdin_state -blocking] + } + return [expr {$answer eq "y" || $answer eq "yes"}] +} + if {"::try" ni [info commands ::try]} { puts stderr "Tcl interpreter possibly too old - need at least tcl 8.6 - 'try' command not found - aborting" exit 1 @@ -469,6 +515,52 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} { #package forget punk::repo #package forget punkcheck + #------------------------------------------------------------------ + # Bootsupport staleness check + # When make.tcl is run from project root (not from src/), bootsupport + # modules are loaded in preference to source modules. If the source + # modules have been updated (e.g API changes) but bootsupport hasn't + # been rebuilt, make.tcl will fail with obscure errors from the stale + # bootsupport versions. This check compares buildversion.txt in source + # against the highest .tm version in bootsupport and warns the caller. + #------------------------------------------------------------------ + if {[file tail $startdir] ne "src"} { + set _runtime_deps [list {*}{ + } punkcheck punkcheck-buildversion.txt punkcheck-*.tm {*}{ + } punk::repo punk/repo-buildversion.txt punk/repo-*.tm {*}{ + } punk::mix punk/mix-buildversion.txt punk/mix-*.tm {*}{ + } punk::tdl punk/tdl-buildversion.txt punk/tdl-*.tm {*}{ + }] + set _stale_modules [list] + foreach {pkg buildversion_rel bootsupport_glob} $_runtime_deps { + set _src_bv_file [file join $::punkboot::scriptfolder modules $buildversion_rel] + set _bs_glob_dir [file dirname [file join $::punkboot::scriptfolder bootsupport modules $bootsupport_glob]] + set _bs_glob_pat [file tail $bootsupport_glob] + if {![file exists $_src_bv_file]} {continue} + #read source version (first line of buildversion.txt) + set _fd [open $_src_bv_file r] + set _src_version [string trim [lindex [split [read $_fd] \n] 0]] + close $_fd + #find highest version .tm in bootsupport + set _bs_version "" + set _prefix [string range $_bs_glob_pat 0 [string first "*" $_bs_glob_pat]-1] + foreach _tm [glob -nocomplain -dir $_bs_glob_dir -- $_bs_glob_pat] { + set _v [file rootname [string range [file tail $_tm] [string length $_prefix] end]] + if {$_bs_version eq "" || [package vcompare $_v $_bs_version] == 1} { + set _bs_version $_v + } + } + if {$_bs_version ne "" && $_src_version ne "" && [package vcompare $_src_version $_bs_version] == 1} { + set _bump [::punkboot::lib::bootsupport_bump_level $_bs_version $_src_version] + lappend _stale_modules [list $pkg $_src_version $_bs_version $_bump] + } + } + if {[llength $_stale_modules]} { + set ::punkboot::stale_bootsupport $_stale_modules + } + unset _runtime_deps _stale_modules + } + package require punk::repo ;#todo - push our requirements to a smaller punk::repo::xxx package with minimal dependencies package require punk::mix package require punkcheck @@ -1433,6 +1525,51 @@ if {[lsearch $::argv -k] >= 0} { #puts stdout "::argv $::argv" # ---------------------------------------- +# Abort / prompt if bootsupport modules are stale relative to source. +# Behaviour is version-aware based on the bump level between each stale +# module's bootsupport version and source version: +# - major bump -> abort unconditionally (breaking change, old bootsupport will not work) +# - minor bump -> prompt user; backward-compat aliases *should* keep old bootsupport functional +# - patch bump -> warn and proceed (non-breaking) +# 'check' is exempt in all cases — the warning is shown at the end of its output instead. +if {[info exists ::punkboot::stale_bootsupport] && $::punkboot::command ne "check"} { + set _stale $::punkboot::stale_bootsupport + set _have_major 0 + set _have_minor 0 + set _have_patch 0 + foreach _entry $_stale { + lassign $_entry _pkg _src_ver _bs_ver _bump + switch -- $_bump { + major {incr _have_major} + minor {incr _have_minor} + patch {incr _have_patch} + default {incr _have_patch} + } + } + puts stderr "==============================================================================" + puts stderr "WARNING: bootsupport modules are stale relative to source modules:" + foreach _entry $_stale { + lassign $_entry _pkg _src_ver _bs_ver _bump + puts stderr [format " %-15s bootsupport=%-10s source=%-10s bump=%s" $_pkg $_bs_ver $_src_ver $_bump] + } + puts stderr "" + puts stderr " Recommended fix — update bootsupport before proceeding:" + puts stderr " cd \[projectroot\]/src && tclsh make.tcl modules && tclsh make.tcl bootsupport" + puts stderr "==============================================================================" + if {$_have_major} { + puts stderr "-aborted- (major version bump in stale bootsupport — breaking change, cannot proceed)" + exit 1 + } + if {$_have_minor} { + if {![::punkboot::lib::bootsupport_prompt_yesno "Minor-version staleness — backward-compat aliases should keep old bootsupport functional."]} { + puts stderr "-aborted- by user" + exit 1 + } + puts stderr "-proceeding with stale bootsupport at user's request-" + } + # patch-only staleness: warn and proceed (warning already printed above) +} + set scriptfolder $::punkboot::scriptfolder @@ -1582,6 +1719,19 @@ if {$::punkboot::command eq "check"} { puts stdout $sep catch {package require struct::set} puts stdout ---[package ifneeded struct::set 2.2.3] + # Show bootsupport staleness warning at the end of check output + if {[info exists ::punkboot::stale_bootsupport]} { + puts stderr "==============================================================================" + puts stderr "WARNING: bootsupport modules are stale relative to source modules:" + foreach _entry $::punkboot::stale_bootsupport { + lassign $_entry _pkg _src_ver _bs_ver _bump + puts stderr [format " %-15s bootsupport=%-10s source=%-10s bump=%s" $_pkg $_bs_ver $_src_ver $_bump] + } + puts stderr "" + puts stderr " Run the following to update bootsupport before proceeding:" + puts stderr " cd \[projectroot\]/src && tclsh make.tcl modules && tclsh make.tcl bootsupport" + puts stderr "==============================================================================" + } exit 0 } @@ -2025,7 +2175,7 @@ if {$::punkboot::command eq "bootsupport"} { set resultdict [punkcheck::install $sourcemodules $targetroot\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -installer "punkboot-bootsupport"\ -progresschannel stdout\ ] @@ -2042,7 +2192,7 @@ if {$::punkboot::command eq "bootsupport"} { puts stdout "BOOTSUPPORT layouts/$layoutname: copying from $source_bootscript to $targetroot_bootscript (if source file changed)" set resultdict [punkcheck::install [file dirname $source_bootscript] $targetroot_bootscript\ -glob make.tcl\ - -max_depth 1\ + -max-depth 1\ -createempty 0\ -overwrite installedsourcechanged-targets\ -installer "punkboot-bootsupport"\ @@ -2098,11 +2248,11 @@ if {$::punkboot::command in {project packages modules}} { -overwrite installedsourcechanged-targets -progresschannel stdout -exclude-filetails {AGENTS.md include_modules.config} - -antiglob_paths {README.md} +-exclude-paths {README.md} }] - # -antiglob_paths {README.md AGENTS.md **/AGENTS.md include_modules.config} + # -exclude-paths {README.md AGENTS.md **/AGENTS.md include_modules.config} #-exclude-filetails {AGENTS.md include_modules.config} - #-antiglob_paths {README.md} + #-exclude-paths {README.md} puts stdout [punkcheck::summarize_install_resultdict $resultdict] } if {![llength $vendormodulefolders]} { @@ -2112,7 +2262,7 @@ if {$::punkboot::command in {project packages modules}} { if {$::punkboot::command in {project packages libs}} { #exclude README.md from source folder - but only the root one - #-antiglob_paths takes relative patterns e.g + #-exclude-paths takes relative patterns e.g # */test.txt will only match test.txt exactly one level deep. # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. # **/test.txt will match at any level below the root (but not in the root) @@ -2130,7 +2280,7 @@ if {$::punkboot::command in {project packages libs}} { puts stdout "VENDORLIB: copying tcl-version neutral and platform neutral libraries from $source_lib_folder to $target_lib_folder (if source file changed)" set resultdict [punkcheck::install $source_lib_folder $target_lib_folder\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -2150,7 +2300,7 @@ if {$::punkboot::command in {project packages libs}} { puts stdout "VENDORLIB_$which: copying from $source_lib_folder to $target_lib_folder (if source file changed)" set resultdict [punkcheck::install $source_lib_folder $target_lib_folder\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -2165,7 +2315,7 @@ if {$::punkboot::command in {project packages libs}} { puts stdout "VENDORLIB_$which: copying from $source_lib_folder to $target_lib_folder (if source file changed)" set resultdict [punkcheck::install $source_lib_folder $target_lib_folder\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -2183,7 +2333,7 @@ if {$::punkboot::command in {project packages libs}} { ######################################################## lappend projectlibfolders lib #exclude README.md from source folder - but only the root one - #-antiglob_paths takes relative patterns e.g + #-exclude-paths takes relative patterns e.g # */test.txt will only match test.txt exactly one level deep. # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. # **/test.txt will match at any level below the root (but not in the root) @@ -2200,7 +2350,7 @@ if {$::punkboot::command in {project packages libs}} { puts stdout "PROJECTLIB: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -2219,7 +2369,7 @@ if {$::punkboot::command in {project packages libs}} { puts stdout "PROJECTLIB_$which: copying from $source_lib_folder to $target_lib_folder (if source file changed)" set resultdict [punkcheck::install $source_lib_folder $target_lib_folder\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -2235,7 +2385,7 @@ if {$::punkboot::command in {project packages libs}} { puts stdout "PROJECTLIB_$which: copying from $source_lib_folder to $target_lib_folder (if source file changed)" set resultdict [punkcheck::install $source_lib_folder $target_lib_folder\ -overwrite installedsourcechanged-targets\ - -antiglob_paths $antipaths\ + -exclude-paths $antipaths\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] @@ -2358,7 +2508,7 @@ if {$::punkboot::command in {project packages modules}} { set resultdict [punkcheck::install_non_tm_files $src_module_dir $target_modules_base\ -installer make.tcl\ -overwrite $overwrite\ - -antiglob_paths {README.md **/AGENTS.md AGENTS.md}\ + -exclude-paths {README.md **/AGENTS.md AGENTS.md}\ -progresschannel stdout\ ] puts stdout [punkcheck::summarize_install_resultdict $resultdict] diff --git a/src/tests/modules/AGENTS.md b/src/tests/modules/AGENTS.md index 69a6617e..5d28f2b7 100644 --- a/src/tests/modules/AGENTS.md +++ b/src/tests/modules/AGENTS.md @@ -37,3 +37,5 @@ Unit tests for editable source modules under `src/modules/`, `src/modules_tcl8/` ## Child DOX Index +- `punkcheck/` — punkcheck module tests (install, summarize_install_resultdict) + diff --git a/src/tests/modules/punk/path/testsuites/tests/path.test b/src/tests/modules/punk/path/testsuites/tests/path.test index 2e94e499..d70e7458 100644 --- a/src/tests/modules/punk/path/testsuites/tests/path.test +++ b/src/tests/modules/punk/path/testsuites/tests/path.test @@ -517,7 +517,7 @@ namespace eval ::testspace { -cleanup $treefilenames_cleanup \ -result 1 - test treefilenames_rejects_internal_call_flags {Internal recursion state flags are not public API} \ +test treefilenames_rejects_internal_call_flags {Internal recursion state flags are not public API} \ -setup $treefilenames_tree -body { set results [list] foreach arglist { @@ -531,6 +531,96 @@ namespace eval ::testspace { } \ -cleanup $treefilenames_cleanup \ -result 1 -} + # ========================================================================= + # --- treefilenames: hidden files and hidden directories --- + # On Windows, "hidden" means the hidden file attribute is set. + # On Unix, "hidden" means the filename starts with a dot (.). + # Dotfiles/dot-directories are NOT hidden on Windows — they are found by + # regular glob -type f. The hidden attribute is Windows-specific. + # These tests use platform constraints to test the relevant behaviour. + # ========================================================================= + + # Constraint: windows hidden attribute + tcltest::testConstraint winHidden [expr {$::tcl_platform(platform) eq "windows"}] + # Constraint: unix dotfiles (files starting with . are hidden by convention) + tcltest::testConstraint unixDotfiles [expr {$::tcl_platform(platform) eq "unix"}] + + variable treefilenames_hidden_tree { + set tfh_prevdir [pwd] + set tfh_newbase [punk::lib::tempdir_newfolder -prefix punk_path_tf_hidden] + set tfh_tree_root [file join $tfh_newbase __punk_path_tf_hidden_test__] + file mkdir $tfh_tree_root + file mkdir [file join $tfh_tree_root regulardir] + file mkdir [file join $tfh_tree_root .dotdir] + #regular files + set fd [open [file join $tfh_tree_root regular.txt] w]; close $fd + set fd [open [file join $tfh_tree_root regulardir/inside.txt] w]; close $fd + #dotfile (hidden on unix, regular on windows) + set fd [open [file join $tfh_tree_root .dotfile] w]; close $fd + set fd [open [file join $tfh_tree_root .dotdir/inside_dotdir.txt] w]; close $fd + #windows hidden attribute files + set tfh_wh_file [file join $tfh_tree_root win_hidden.txt] + set fd [open $tfh_wh_file w]; close $fd + set tfh_wh_dir [file join $tfh_tree_root win_hiddendir] + file mkdir $tfh_wh_dir + set fd [open [file join $tfh_wh_dir/inside.txt] w]; close $fd + if {$::tcl_platform(platform) eq "windows"} { + file attributes $tfh_wh_file -hidden 1 + file attributes $tfh_wh_dir -hidden 1 + } + } + + variable treefilenames_hidden_cleanup { + cd $tfh_prevdir + file delete -force $tfh_newbase + } + + test treefilenames_finds_all_files_including_hidden {treefilenames finds hidden files and files inside hidden directories} \ + -setup $treefilenames_hidden_tree -body { + set result [lsort [punk::path::treefilenames -sort none -directory $tfh_tree_root -tailbase $tfh_tree_root *]] + }\ + -cleanup $treefilenames_hidden_cleanup \ + -result {.dotdir/inside_dotdir.txt .dotfile regular.txt regulardir/inside.txt win_hidden.txt win_hiddendir/inside.txt} + + test treefilenames_finds_files_in_hidden_dirs {treefilenames recurses into hidden directories to find files within}\ + -constraints winHidden \ + -setup $treefilenames_hidden_tree -body { + set result [lsort [punk::path::treefilenames -sort none -directory $tfh_tree_root -tailbase $tfh_tree_root *]] + #win_hiddendir has the hidden attribute set on windows + expr {"win_hiddendir/inside.txt" in $result} + }\ + -cleanup $treefilenames_hidden_cleanup \ + -result 1 + + test treefilenames_finds_hidden_attribute_files {treefilenames finds files with the windows hidden attribute set}\ + -constraints winHidden \ + -setup $treefilenames_hidden_tree -body { + set result [lsort [punk::path::treefilenames -sort none -directory $tfh_tree_root -tailbase $tfh_tree_root *]] + #win_hidden.txt has the hidden attribute set on windows + expr {"win_hidden.txt" in $result} + }\ + -cleanup $treefilenames_hidden_cleanup \ + -result 1 + + test treefilenames_finds_dotfiles {treefilenames finds dotfiles (files starting with .)}\ + -setup $treefilenames_hidden_tree -body { + set result [lsort [punk::path::treefilenames -sort none -directory $tfh_tree_root -tailbase $tfh_tree_root *]] + #dotfile should be found on all platforms + #on windows it's a regular file, on unix it's a hidden file + expr {".dotfile" in $result} + }\ + -cleanup $treefilenames_hidden_cleanup \ + -result 1 + + test treefilenames_finds_files_in_dotdirs {treefilenames recurses into dot-directories to find files within}\ + -setup $treefilenames_hidden_tree -body { + set result [lsort [punk::path::treefilenames -sort none -directory $tfh_tree_root -tailbase $tfh_tree_root *]] + #.dotdir should be recursed into on all platforms + #on windows it's a regular directory, on unix it's a hidden directory + expr {".dotdir/inside_dotdir.txt" in $result} + }\ + -cleanup $treefilenames_hidden_cleanup \ + -result 1 +} tcltest::cleanupTests ;#needed to produce test summary. \ No newline at end of file diff --git a/src/tests/modules/punkcheck/testsuites/punkcheck/install.test b/src/tests/modules/punkcheck/testsuites/punkcheck/install.test new file mode 100644 index 00000000..921c494a --- /dev/null +++ b/src/tests/modules/punkcheck/testsuites/punkcheck/install.test @@ -0,0 +1,684 @@ +# -*- tcl -*- +# Characterization tests for punkcheck::install and punkcheck::summarize_install_resultdict +# These tests lock down CURRENT behavior with current flag names (underscores) before any refactoring. +# Run: tclsh src/tests/runtests.tcl -report compact -show-passes 0 -include-paths modules/punkcheck/** install.test + +package require tcltest +package require punkcheck +package require punk::lib +package require punk::path + +namespace eval ::testspace { + namespace import ::tcltest::* + + # ------------------------------------------------------------------------- + # Helper: create a unique temp workspace with a source tree layout. + # Returns a dict with keys: root srcdir tgtdir + # Caller is responsible for cleanup via -cleanup {file delete -force $root} + # ------------------------------------------------------------------------- + proc make_workspace {layout} { + set root [punk::lib::tempdir_newfolder -prefix punkchecktest] + set srcdir [file join $root src] + set tgtdir [file join $root tgt] + file mkdir $srcdir $tgtdir + foreach {relpath content} $layout { + set f [file join $srcdir {*}[file split $relpath]] + file mkdir [file dirname $f] + set fd [open $f w] + chan configure $fd -translation lf + puts -nonewline $fd $content + close $fd + } + return [dict create root $root srcdir $srcdir tgtdir $tgtdir] + } + + # ========================================================================= + # --- punkcheck::install: basic copy behavior --- + # ========================================================================= + + test install_basic_copy {Basic copy of a single file to empty target}\ + -body { + set ws [make_workspace [list foo.txt "hello"]] + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir] -overwrite all-targets -createdir 1] + set copied [dict get $resultdict files_copied] + set got [string map [list [dict get $ws srcdir]/ ""] [lindex $copied 0]] + return $got + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {foo.txt} + + test install_missing_target_no_createdir {Error when target missing and -createdir 0}\ + -body { + set ws [make_workspace [list foo.txt "hello"]] + # tgtdir was created by make_workspace but we remove it to test the error path + file delete -force [dict get $ws tgtdir] + punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir] -overwrite all-targets + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -returnCodes error\ + -match glob\ + -result {punkcheck::install base target dir*doesn't exist*} + + test install_createdir_creates_target {Target dir is created when -createdir 1 and missing}\ + -body { + set ws [make_workspace [list foo.txt "hello"]] + file delete -force [dict get $ws tgtdir] + punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir] -overwrite all-targets -createdir 1 + file exists [dict get $ws tgtdir] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result 1 + + # ========================================================================= + # --- punkcheck::install: -overwrite modes --- + # ========================================================================= + + test install_no_targets_only_copies_missing {no-targets copies only files missing at target}\ + -body { + set ws [make_workspace [list a.txt "aaa" b.txt "bbb"]] + # Pre-create a.txt at target with different content + set fd [open [file join [dict get $ws tgtdir] a.txt] w] + puts -nonewline $fd "OLD_CONTENT" + close $fd + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir] -overwrite no-targets] + set copied_basenames [list] + foreach f [dict get $resultdict files_copied] { + lappend copied_basenames [file tail $f] + } + return $copied_basenames + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {b.txt} + + test install_all_targets_overwrites_existing {all-targets overwrites existing files}\ + -body { + set ws [make_workspace [list a.txt "new"]] + set fd [open [file join [dict get $ws tgtdir] a.txt] w] + puts -nonewline $fd "old" + close $fd + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir] -overwrite all-targets] + set fd [open [file join [dict get $ws tgtdir] a.txt] r] + set content [read -nonewline $fd] + close $fd + return $content + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {new} + + # ========================================================================= + # --- punkcheck::install: -exclude-filetails --- + # ========================================================================= + + test install_exclude_filetails {Excluded file tails are not copied}\ + -body { + set ws [make_workspace [list keep.txt "k" skip.bad "x"]] + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1\ + -exclude-filetails [list "*.bad"]] + set copied_basenames [list] + foreach f [dict get $resultdict files_copied] { + lappend copied_basenames [file tail $f] + } + return $copied_basenames + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {keep.txt} + + # ========================================================================= + # --- punkcheck::install: -exclude-dirsegments --- + # ========================================================================= + + test install_exclude_dirsegments {Excluded dir segments are not descended into}\ + -body { + set ws [make_workspace [list keep.txt "k" _aside/secret.txt "s"]] + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1\ + -exclude-dirsegments [list "_aside"]] + set all_copied [list] + foreach f [dict get $resultdict files_copied] { + lappend all_copied [string map [list [dict get $ws srcdir]/ ""] $f] + } + return $all_copied + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {keep.txt} + + # ========================================================================= + # --- punkcheck::install: -antiglob_paths --- + # ========================================================================= + + test install_antiglob_paths {antiglob_paths excludes matching relative paths}\ + -body { + set ws [make_workspace [list keep.txt "k" blocked/secret.txt "s"]] + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1\ + -antiglob_paths [list "blocked/**"]] + set all_copied [list] + foreach f [dict get $resultdict files_copied] { + lappend all_copied [string map [list [dict get $ws srcdir]/ ""] $f] + } + return $all_copied + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {keep.txt} + + # ------------------------------------------------------------------------- + # Additional characterization tests to lock behaviour before merge of + # -exclude-dirsegments + -antiglob_paths into unified -exclude-paths. + # These tests verify: nested dir-seg match, _core defaults applied by + # default, _core override REPLACES (not appends), antiglob top-level + # filename, antiglob deep **/FILE, and combined mechanism. + # ------------------------------------------------------------------------- + + test install_exclude_dirsegments_nested {dir-seg exclusion applies at any directory level, not just top}\ + -body { + set ws [make_workspace [list keep.txt "k" parent/_aside/secret.txt "s" parent/keep2.txt "k2"]] + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1\ + -exclude-dirsegments [list "_aside"]] + set all_copied [list] + foreach f [dict get $resultdict files_copied] { + lappend all_copied [string map [list [dict get $ws srcdir]/ ""] $f] + } + return [lsort $all_copied] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {keep.txt parent/keep2.txt} + + test install_exclude_dirsegments_core_default_applied {default _core excludes _build and .git at any level}\ + -body { + # Without explicit -exclude-dirsegments_core, default core {#* _aside _build .git .fossil*} is applied + set ws [make_workspace [list\ + keep.txt "k"\ + _build/intermediate.txt "i"\ + parent/_build/deep.txt "d"\ + .git/config "c"\ + keep2.txt "k2"]] + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1\ + -exclude-dirsegments [list]] + set all_copied [list] + foreach f [dict get $resultdict files_copied] { + lappend all_copied [string map [list [dict get $ws srcdir]/ ""] $f] + } + return [lsort $all_copied] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {keep.txt keep2.txt} + + test install_exclude_dirsegments_core_override_replaces {passing -exclude-dirsegments_core REPLACES the defaults, not appends}\ + -body { + # Override core with {#* _aside .git} - removes .fossil* AND _build exclusion + # so .fossil-custom IS copied, _build IS copied, .git IS still excluded + set ws [make_workspace [list\ + keep.txt "k"\ + _build/intermediate.txt "i"\ + .fossil-custom/menu "m"\ + .git/config "c"]] + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1\ + -exclude-dirsegments_core [list "#*" "_aside" ".git"]\ + -exclude-dirsegments [list]] + set all_copied [list] + foreach f [dict get $resultdict files_copied] { + lappend all_copied [string map [list [dict get $ws srcdir]/ ""] $f] + } + return [lsort $all_copied] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {.fossil-custom/menu _build/intermediate.txt keep.txt} + + test install_antiglob_paths_toplevel_filename {antiglob_paths with a bare filename excludes top-level file}\ + -body { + # bare filename (no path separators) - used by src/make.tcl call sites + set ws [make_workspace [list keep.txt "k" README.md "r" other.txt "o"]] + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1\ + -antiglob_paths [list "README.md"]] + set all_copied [list] + foreach f [dict get $resultdict files_copied] { + lappend all_copied [string map [list [dict get $ws srcdir]/ ""] $f] + } + return [lsort $all_copied] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {keep.txt other.txt} + + test install_antiglob_paths_deep_doublestar {antiglob_paths **/FILE matches nested files but NOT top-level (no leading slash)}\ + -body { + # **/AGENTS.md only matches nested AGENTS.md (those with a parent path segment) + # Top-level AGENTS.md requires the bare 'AGENTS.md' pattern to be excluded too. + # This is the actual globmatchpath semantics - confirmed by make.tcl using both forms. + set ws [make_workspace [list\ + keep.txt "k"\ + AGENTS.md "a1"\ + sub/AGENTS.md "a2"\ + sub/deep/AGENTS.md "a3"\ + sub/deep/keep2.txt "k2"]] + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1\ + -antiglob_paths [list "**/AGENTS.md"]] + set all_copied [list] + foreach f [dict get $resultdict files_copied] { + lappend all_copied [string map [list [dict get $ws srcdir]/ ""] $f] + } + return [lsort $all_copied] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {AGENTS.md keep.txt sub/deep/keep2.txt} + + test install_antiglob_paths_toplevel_and_deep {combining bare filename AND **/FILE excludes all occurrences}\ + -body { + # {AGENTS.md **/AGENTS.md} - covers both top-level and nested + set ws [make_workspace [list\ + keep.txt "k"\ + AGENTS.md "a1"\ + sub/AGENTS.md "a2"\ + sub/deep/AGENTS.md "a3"\ + sub/deep/keep2.txt "k2"]] + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1\ + -antiglob_paths [list "AGENTS.md" "**/AGENTS.md"]] + set all_copied [list] + foreach f [dict get $resultdict files_copied] { + lappend all_copied [string map [list [dict get $ws srcdir]/ ""] $f] + } + return [lsort $all_copied] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {keep.txt sub/deep/keep2.txt} + + test install_antiglob_paths_dir_skip {antiglob_paths with pattern matching a directory path skips that dir's recursion}\ + -body { + # **/_aside excludes _aside at any level as a directory (skip recursion) + set ws [make_workspace [list\ + keep.txt "k"\ + _aside/secret.txt "s1"\ + parent/_aside/secret2.txt "s2"\ + parent/keep3.txt "k3"]] + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1\ + -antiglob_paths [list "**/_aside" "_aside"]] + set all_copied [list] + foreach f [dict get $resultdict files_copied] { + lappend all_copied [string map [list [dict get $ws srcdir]/ ""] $f] + } + return [lsort $all_copied] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {keep.txt parent/keep3.txt} + + # ========================================================================= + # --- punkcheck::install: -exclude-paths (unified mechanism) --- + # These tests verify the new -exclude-paths flag directly. + # The legacy flags above (-exclude-dirsegments, -antiglob_paths) are + # converted internally to -exclude-paths and must produce the same results. + # ========================================================================= + + test install_exclude_paths_basic {exclude-paths with simple top-level file pattern excludes that file}\ + -body { + set ws [make_workspace [list keep.txt "k" skip.me "s" other.txt "o"]] + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1\ + -exclude-paths [list "skip.me"]] + set all_copied [list] + foreach f [dict get $resultdict files_copied] { + lappend all_copied [string map [list [dict get $ws srcdir]/ ""] $f] + } + return [lsort $all_copied] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {keep.txt other.txt} + + test install_exclude_paths_dir_skip {exclude-paths with **/dir pattern skips that dir at any level}\ + -body { + set ws [make_workspace [list\ + keep.txt "k"\ + _aside/secret.txt "s1"\ + parent/_aside/secret2.txt "s2"\ + parent/keep3.txt "k3"]] + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1\ + -exclude-paths [list "**/_aside" "_aside"]] + set all_copied [list] + foreach f [dict get $resultdict files_copied] { + lappend all_copied [string map [list [dict get $ws srcdir]/ ""] $f] + } + return [lsort $all_copied] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {keep.txt parent/keep3.txt} + + test install_exclude_paths_deep_doublestar {exclude-paths **/FILE matches nested files but not top-level}\ + -body { + set ws [make_workspace [list\ + keep.txt "k"\ + AGENTS.md "a1"\ + sub/AGENTS.md "a2"\ + sub/deep/AGENTS.md "a3"\ + sub/deep/keep2.txt "k2"]] + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1\ + -exclude-paths [list "**/AGENTS.md"]] + set all_copied [list] + foreach f [dict get $resultdict files_copied] { + lappend all_copied [string map [list [dict get $ws srcdir]/ ""] $f] + } + return [lsort $all_copied] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {AGENTS.md keep.txt sub/deep/keep2.txt} + + test install_exclude_paths_combined {exclude-paths with both bare and **/ forms excludes all occurrences}\ + -body { + set ws [make_workspace [list\ + keep.txt "k"\ + AGENTS.md "a1"\ + sub/AGENTS.md "a2"\ + sub/deep/AGENTS.md "a3"\ + sub/deep/keep2.txt "k2"]] + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1\ + -exclude-paths [list "AGENTS.md" "**/AGENTS.md"]] + set all_copied [list] + foreach f [dict get $resultdict files_copied] { + lappend all_copied [string map [list [dict get $ws srcdir]/ ""] $f] + } + return [lsort $all_copied] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {keep.txt sub/deep/keep2.txt} + + test install_exclude_paths_core_override {exclude-paths_core override REPLACES default core}\ + -body { + # Override core with only #* and _aside forms - removes .git and .fossil* exclusion + set ws [make_workspace [list\ + keep.txt "k"\ + _aside/secret.txt "s"\ + .git/config "c"\ + .fossil-custom/menu "m"]] + + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1\ + -exclude-paths_core [list "#*" "**/#*" "_aside" "**/_aside"]] + set all_copied [list] + foreach f [dict get $resultdict files_copied] { + lappend all_copied [string map [list [dict get $ws srcdir]/ ""] $f] + } + return [lsort $all_copied] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {.fossil-custom/menu .git/config keep.txt} + + # ========================================================================= + # --- punkcheck::install: hyphenated flag names (Phase 5 rename) --- + # These tests verify that the new hyphenated flag names work directly. + # The old underscore forms are still accepted via backward-compat aliases. + # ========================================================================= + + test install_max_depth_hyphenated {-max-depth (hyphenated) limits recursion depth}\ + -body { + set ws [make_workspace [list top.txt "t" sub/deep.txt "d"]] + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1\ + -max-depth 0] + set all_copied [list] + foreach f [dict get $resultdict files_copied] { + lappend all_copied [string map [list [dict get $ws srcdir]/ ""] $f] + } + return [lsort $all_copied] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {top.txt} + + test install_punkcheck_folder_hyphenated {-punkcheck-folder (hyphenated) places .punkcheck in target}\ + -body { + set ws [make_workspace [list keep.txt "k"]] + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1\ + -punkcheck-folder target] + set punkcheck_exists [file exists [file join [dict get $ws tgtdir] .punkcheck]] + return $punkcheck_exists + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result 1 + + test install_source_checksum_hyphenated {-source-checksum (hyphenated) stores checksums}\ + -body { + set ws [make_workspace [list keep.txt "k"]] + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1\ + -source-checksum comparestore] + set has_punkcheck [file exists [file join [dict get $ws tgtdir] .punkcheck]] + return $has_punkcheck + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result 1 + + # ========================================================================= + # --- punkcheck::install: -glob --- + # ========================================================================= + + test install_glob_pattern {Only files matching glob are copied}\ + -body { + set ws [make_workspace [list a.tm "a" b.txt "b"]] + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1\ + -glob "*.tm"] + set copied_basenames [list] + foreach f [dict get $resultdict files_copied] { + lappend copied_basenames [file tail $f] + } + return $copied_basenames + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {a.tm} + + # ========================================================================= + # --- punkcheck::install: -max_depth --- + # ========================================================================= + + test install_max_depth_limits_recursion {max_depth 0 limits to top-level only}\ + -body { + set ws [make_workspace [list top.txt "t" sub/deep.txt "d"]] + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1\ + -max_depth 0] + set copied_basenames [list] + foreach f [dict get $resultdict files_copied] { + lappend copied_basenames [string map [list [dict get $ws srcdir]/ ""] $f] + } + return $copied_basenames + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {top.txt} + + test install_max_depth_1_allows_one_level {max_depth 1 allows one level of recursion}\ + -body { + set ws [make_workspace [list top.txt "t" sub/deep.txt "d"]] + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1\ + -max_depth 1] + set all_copied [list] + foreach f [dict get $resultdict files_copied] { + lappend all_copied [string map [list [dict get $ws srcdir]/ ""] $f] + } + return [lsort $all_copied] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {sub/deep.txt top.txt} + + # ========================================================================= + # --- punkcheck::install: -createempty --- + # ========================================================================= + + test install_createempty_creates_empty_dirs {createempty creates target dirs with no matching files}\ + -body { + set ws [make_workspace [list sub/empty.txt "e"]] + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1 -createempty 1] + set empty_dir [file join [dict get $ws tgtdir] sub] + return [file isdirectory $empty_dir] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result 1 + + # ========================================================================= + # --- punkcheck::install: resultdict shape --- + # ========================================================================= + + test install_resultdict_keys {resultdict has expected keys}\ + -body { + set ws [make_workspace [list foo.txt "hello"]] + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1] + set keys [lsort [dict keys $resultdict]] + return $keys + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {antiglob_paths_matched files_copied files_skipped punkcheck_folder punkcheck_records sources_unchanged srcdir tgtdir} + + # ========================================================================= + # --- punkcheck::summarize_install_resultdict --- + # ========================================================================= + + test summarize_basic {summarize returns a non-empty string for a resultdict with copies}\ + -body { + set ws [make_workspace [list foo.txt "hello"]] + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1] + set summary [punkcheck::summarize_install_resultdict $resultdict] + return [expr {[string length $summary] > 0}] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result 1 + + test summarize_with_title {summarize includes the title line when -title is set}\ + -body { + set ws [make_workspace [list foo.txt "hello"]] + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1] + set summary [punkcheck::summarize_install_resultdict -title "MY TITLE" $resultdict] + return [regexp {MY TITLE} $summary] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result 1 + + test summarize_no_copies {summarize handles resultdict with zero copied files}\ + -body { + set ws [make_workspace [list foo.txt "hello"]] + set resultdict [punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite no-targets] + set summary [punkcheck::summarize_install_resultdict $resultdict] + return [expr {[string length $summary] > 0}] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result 1 + + test summarize_empty_resultdict {summarize returns non-empty string even when no files copied}\ + -body { + set rd [dict create files_copied [list] files_skipped [list] sources_unchanged [list] antiglob_paths_matched [list] punkcheck_records [list] punkcheck_folder [pwd] srcdir [pwd] tgtdir [pwd]] + set summary [punkcheck::summarize_install_resultdict $rd] + return [regexp {Copied 0 files} $summary] + }\ + -result 1 + + test summarize_unknown_option {summarize raises error on unknown option}\ + -body { + punkcheck::summarize_install_resultdict -bogus 1 [dict create files_copied [list] files_skipped [list] sources_unchanged [list] antiglob_paths_matched [list] punkcheck_records [list] punkcheck_folder [pwd] srcdir [pwd] tgtdir [pwd]] + }\ + -returnCodes error\ + -match glob\ + -result {*} + + # ========================================================================= + # --- punkcheck::install: -punkcheck_folder --- + # ========================================================================= + + test install_punkcheck_folder_target {punkcheck_folder=target places .punkcheck in tgtdir}\ + -body { + set ws [make_workspace [list foo.txt "hello"]] + punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1 -punkcheck_folder target + file exists [file join [dict get $ws tgtdir] .punkcheck] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result 1 + + test install_punkcheck_folder_source {punkcheck_folder=source places .punkcheck in srcdir}\ + -body { + set ws [make_workspace [list foo.txt "hello"]] + punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir]\ + -overwrite all-targets -createdir 1 -punkcheck_folder source + file exists [file join [dict get $ws srcdir] .punkcheck] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result 1 +} +tcltest::cleanupTests ;#needed to produce test summary line. \ No newline at end of file diff --git a/src/tests/modules/punkcheck/testsuites/punkcheck/installtrack.test b/src/tests/modules/punkcheck/testsuites/punkcheck/installtrack.test new file mode 100644 index 00000000..d38d04de --- /dev/null +++ b/src/tests/modules/punkcheck/testsuites/punkcheck/installtrack.test @@ -0,0 +1,613 @@ +# -*- tcl -*- +# Characterization tests for punkcheck::installtrack object model API +# These tests lock down the installtrack/installevent OO interface before any refactoring. +# The installtrack class is used directly by punk::mix::cli and punk::mix::commandset modules. +# Run: tclsh src/tests/runtests.tcl -report compact -show-passes 0 -include-paths modules/punkcheck/** installtrack.test + +package require tcltest +package require punkcheck +package require punk::lib + +namespace eval ::testspace { + namespace import ::tcltest::* + + # ------------------------------------------------------------------------- + # Helper: create a temp workspace with a .punkcheck folder context + # Returns a dict with keys: root punkcheck_file srcdir tgtdir + # ------------------------------------------------------------------------- + proc make_workspace {} { + set root [punk::lib::tempdir_newfolder -prefix pktracktest] + set punkcheck_file [file join $root .punkcheck] + set srcdir [file join $root src] + set tgtdir [file join $root tgt] + file mkdir $srcdir $tgtdir + return [dict create root $root punkcheck_file $punkcheck_file srcdir $srcdir tgtdir $tgtdir] + } + + # ------------------------------------------------------------------------- + # Helper: create a source file inside punkcheck_folder (root) and return abs path + # ------------------------------------------------------------------------- + proc make_source_file {root relpath content} { + set fpath [file join $root $relpath] + file mkdir [file dirname $fpath] + set fd [open $fpath w] + try { puts -nonewline $fd $content } finally { close $fd } + return $fpath + } + + # ------------------------------------------------------------------------- + # Helper: run a full VIRTUAL targetset lifecycle to seed a prior completed + # VIRTUAL-RECORD, so subsequent targetset_source_changes calls compare + # against it. Uses the same installer name "test" and same target name as + # the subsequent test code, so the FILEINFO record matches. + # ------------------------------------------------------------------------- + proc seed_virtual_record {punkcheck_file srcdir tgtdir target_name source_abspath} { + set installer [punkcheck::installtrack new "test" $punkcheck_file] + $installer set_source_target $srcdir $tgtdir + set event [$installer start_event {-install_step seed}] + $event targetset_init VIRTUAL $target_name + $event targetset_addsource $source_abspath + $event targetset_started + $event targetset_end OK + $event end + $installer destroy + } + + # ========================================================================= + # --- installtrack: constructor and basic accessors --- + # ========================================================================= + + test installtrack_construct {Constructor creates an installtrack object}\ + -body { + set ws [make_workspace] + set installer [punkcheck::installtrack new "test-installer" [dict get $ws punkcheck_file]] + set is_object [expr {[info commands $installer] ne ""}] + $installer destroy + return $is_object + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result 1 + + test installtrack_get_name {get_name returns installer name passed to constructor}\ + -body { + set ws [make_workspace] + set installer [punkcheck::installtrack new "my-installer" [dict get $ws punkcheck_file]] + set name [$installer get_name] + $installer destroy + return $name + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {my-installer} + + test installtrack_get_checkfile {get_checkfile returns punkcheck file path}\ + -body { + set ws [make_workspace] + set installer [punkcheck::installtrack new "test" [dict get $ws punkcheck_file]] + set checkfile [$installer get_checkfile] + $installer destroy + return [string map [list [dict get $ws root] ""] $checkfile] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {/.punkcheck} + + test installtrack_get_debugchannel_default {get_debugchannel returns empty string by default}\ + -body { + set ws [make_workspace] + set installer [punkcheck::installtrack new "test" [dict get $ws punkcheck_file]] + set debugchannel [$installer get_debugchannel] + $installer destroy + return $debugchannel + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {} + + # ========================================================================= + # --- installtrack: set_source_target --- + # ========================================================================= + + test installtrack_set_source_target {set_source_target stores source and target for events}\ + -body { + set ws [make_workspace] + set installer [punkcheck::installtrack new "test" [dict get $ws punkcheck_file]] + $installer set_source_target [dict get $ws srcdir] [dict get $ws tgtdir] + set event [$installer start_event {-install_step test}] + set record [$event as_record] + $installer destroy + # The event record should contain -source key + return [dict exists $record -source] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result 1 + + # ========================================================================= + # --- installtrack: start_event and installevent object --- + # ========================================================================= + + test installtrack_start_event_returns_event {start_event returns an installevent object}\ + -body { + set ws [make_workspace] + set installer [punkcheck::installtrack new "test" [dict get $ws punkcheck_file]] + $installer set_source_target [dict get $ws srcdir] [dict get $ws tgtdir] + set event [$installer start_event {-install_step test}] + set is_object [expr {[info commands $event] ne ""}] + $installer destroy + return $is_object + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result 1 + + test installevent_get_id {event get_id returns a non-empty UUID}\ + -body { + set ws [make_workspace] + set installer [punkcheck::installtrack new "test" [dict get $ws punkcheck_file]] + $installer set_source_target [dict get $ws srcdir] [dict get $ws tgtdir] + set event [$installer start_event {-install_step test}] + set event_id [$event get_id] + $installer destroy + return [expr {[string length $event_id] > 0}] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result 1 + + test installevent_as_record {event as_record returns a dict with tag EVENT}\ + -body { + set ws [make_workspace] + set installer [punkcheck::installtrack new "test" [dict get $ws punkcheck_file]] + $installer set_source_target [dict get $ws srcdir] [dict get $ws tgtdir] + set event [$installer start_event {-install_step test}] + set record [$event as_record] + $installer destroy + return [dict get $record tag] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {EVENT} + + test installevent_as_record_keys {event as_record has expected keys}\ + -body { + set ws [make_workspace] + set installer [punkcheck::installtrack new "test" [dict get $ws punkcheck_file]] + $installer set_source_target [dict get $ws srcdir] [dict get $ws tgtdir] + set event [$installer start_event {-install_step test}] + set record [$event as_record] + $installer destroy + set keys [lsort [dict keys $record]] + return $keys + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {-config -id -source -targets -ts_begin -ts_end -tsiso_begin -tsiso_end -types tag} + + # ========================================================================= + # --- installtrack: events list and get_event --- + # ========================================================================= + + test installtrack_events_list {events returns event collection after start_event}\ + -body { + set ws [make_workspace] + set installer [punkcheck::installtrack new "test" [dict get $ws punkcheck_file]] + $installer set_source_target [dict get $ws srcdir] [dict get $ws tgtdir] + set event [$installer start_event {-install_step test}] + # events method uses tailcall to delegate to oolib::collection + set count [$installer events count] + $installer destroy + return $count + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result 1 + + test installtrack_get_event {get_event retrieves the current event object}\ + -body { + set ws [make_workspace] + set installer [punkcheck::installtrack new "test" [dict get $ws punkcheck_file]] + $installer set_source_target [dict get $ws srcdir] [dict get $ws tgtdir] + set event [$installer start_event {-install_step test}] + set retrieved [$installer get_event] + set same [expr {[$event get_id] eq [$retrieved get_id]}] + $installer destroy + return $same + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result 1 + + # ========================================================================= + # --- installtrack: end_event and cleanup --- + # ========================================================================= + + test installtrack_end_event {end_event does not error after start_event}\ + -body { + set ws [make_workspace] + set installer [punkcheck::installtrack new "test" [dict get $ws punkcheck_file]] + $installer set_source_target [dict get $ws srcdir] [dict get $ws tgtdir] + set event [$installer start_event {-install_step test}] + $installer end_event + $installer destroy + return 1 + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result 1 + + test installtrack_destroy {destroy cleans up object without error}\ + -body { + set ws [make_workspace] + set installer [punkcheck::installtrack new "test" [dict get $ws punkcheck_file]] + $installer destroy + return [expr {![info exists installer] || [info commands $installer] eq ""}] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result 1 + + # ========================================================================= + # --- installtrack: save_all_records persists .punkcheck file --- + # ========================================================================= + + test installtrack_save_all_records {save_all_records creates .punkcheck file on disk}\ + -body { + set ws [make_workspace] + set installer [punkcheck::installtrack new "test" [dict get $ws punkcheck_file]] + $installer set_source_target [dict get $ws srcdir] [dict get $ws tgtdir] + set event [$installer start_event {-install_step test}] + $installer save_all_records + set exists [file exists [dict get $ws punkcheck_file]] + $installer destroy + return $exists + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result 1 + + # ========================================================================= + # --- installevent: targetset lifecycle --- + # ========================================================================= + + test installevent_targetset_init {targetset_init accepts operation and targetset name}\ + -body { + set ws [make_workspace] + set installer [punkcheck::installtrack new "test" [dict get $ws punkcheck_file]] + $installer set_source_target [dict get $ws srcdir] [dict get $ws tgtdir] + set event [$installer start_event {-install_step test}] + $event targetset_init install "myfile.txt" + $installer destroy + return 1 + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result 1 + + test installevent_targetset_started {targetset_started runs without error after init}\ + -body { + set ws [make_workspace] + set installer [punkcheck::installtrack new "test" [dict get $ws punkcheck_file]] + $installer set_source_target [dict get $ws srcdir] [dict get $ws tgtdir] + set event [$installer start_event {-install_step test}] + $event targetset_init install "myfile.txt" + $event targetset_started + $installer destroy + return 1 + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result 1 + + test installevent_targetset_end {targetset_end accepts status argument}\ + -body { + set ws [make_workspace] + set installer [punkcheck::installtrack new "test" [dict get $ws punkcheck_file]] + $installer set_source_target [dict get $ws srcdir] [dict get $ws tgtdir] + set event [$installer start_event {-install_step test}] + $event targetset_init install "myfile.txt" + $event targetset_started + $event targetset_end ok + $installer destroy + return 1 + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result 1 + + test installevent_end {event end finalizes without error}\ + -body { + set ws [make_workspace] + set installer [punkcheck::installtrack new "test" [dict get $ws punkcheck_file]] + $installer set_source_target [dict get $ws srcdir] [dict get $ws tgtdir] + set event [$installer start_event {-install_step test}] + $event targetset_init install "myfile.txt" + $event targetset_started + $event targetset_end ok + $event end + $installer destroy + return 1 + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result 1 + + # ========================================================================= + # --- installtrack: full lifecycle matching punk::mix::cli usage --- + # ========================================================================= + + test installtrack_full_lifecycle {Full lifecycle matching punk::mix::cli usage pattern}\ + -body { + set ws [make_workspace] + set installer [punkcheck::installtrack new "project.new" [dict get $ws punkcheck_file]] + $installer set_source_target [dict get $ws srcdir] [dict get $ws tgtdir] + set event [$installer start_event {-install_step teststep}] + set event_id [$event get_id] + $event targetset_init install "targetfile.txt" + $event targetset_started + $event targetset_end ok + $event end + $installer end_event + $installer save_all_records + set file_exists [file exists [dict get $ws punkcheck_file]] + $installer destroy + return [expr {$file_exists && [string length $event_id] > 0}] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result 1 + + # ========================================================================= + # --- installevent: targetset_source_changes --- + # Used by punk::mix::cli and punk::mix::commandset to decide whether a + # rebuild is needed: source changed => rebuild. + # Return shape is {dict create changed unchanged }. + # A source is "changed" if it has no prior completed record to compare + # against, or its cksum/type/size differs from the prior record. + # ========================================================================= + + test targetset_source_changes_no_prior_record {First call with no prior completed record reports source as changed}\ + -body { + set ws [make_workspace] + set root [dict get $ws root] + set src_abspath [make_source_file $root "src1.txt" "content1"] + set installer [punkcheck::installtrack new "test" [dict get $ws punkcheck_file]] + $installer set_source_target [dict get $ws srcdir] [dict get $ws tgtdir] + set event [$installer start_event {-install_step test}] + $event targetset_init VIRTUAL "vtarg1" + $event targetset_addsource $src_abspath + set result [$event targetset_source_changes] + $event end + $installer destroy + return [list [llength [dict get $result changed]] [llength [dict get $result unchanged]]] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {1 0} + + test targetset_source_changes_after_record_unchanged {Re-adding same source after VIRTUAL-RECORD reports unchanged}\ + -body { + set ws [make_workspace] + set root [dict get $ws root] + set src_abspath [make_source_file $root "src1.txt" "content1"] + seed_virtual_record [dict get $ws punkcheck_file] [dict get $ws srcdir] [dict get $ws tgtdir] "vtarg1" $src_abspath + set installer [punkcheck::installtrack new "test" [dict get $ws punkcheck_file]] + $installer set_source_target [dict get $ws srcdir] [dict get $ws tgtdir] + set event [$installer start_event {-install_step test}] + $event targetset_init VIRTUAL "vtarg1" + $event targetset_addsource $src_abspath + set result [$event targetset_source_changes] + $event end + $installer destroy + return [list [llength [dict get $result changed]] [llength [dict get $result unchanged]]] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {0 1} + + test targetset_source_changes_after_modified_source {Modifying source content reports changed}\ + -body { + set ws [make_workspace] + set root [dict get $ws root] + set src_abspath [make_source_file $root "src1.txt" "original"] + seed_virtual_record [dict get $ws punkcheck_file] [dict get $ws srcdir] [dict get $ws tgtdir] "vtarg1" $src_abspath + # modify source content (different size/cksum) + set fd [open $src_abspath w]; puts -nonewline $fd "modified-content"; close $fd + set installer [punkcheck::installtrack new "test" [dict get $ws punkcheck_file]] + $installer set_source_target [dict get $ws srcdir] [dict get $ws tgtdir] + set event [$installer start_event {-install_step test}] + $event targetset_init VIRTUAL "vtarg1" + $event targetset_addsource $src_abspath + set result [$event targetset_source_changes] + $event end + $installer destroy + return [list [llength [dict get $result changed]] [llength [dict get $result unchanged]]] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {1 0} + + test targetset_source_changes_dict_keys {Return dict contains changed and unchanged keys}\ + -body { + set ws [make_workspace] + set root [dict get $ws root] + set src_abspath [make_source_file $root "src1.txt" "x"] + set installer [punkcheck::installtrack new "test" [dict get $ws punkcheck_file]] + $installer set_source_target [dict get $ws srcdir] [dict get $ws tgtdir] + set event [$installer start_event {-install_step test}] + $event targetset_init VIRTUAL "vtarg1" + $event targetset_addsource $src_abspath + set result [$event targetset_source_changes] + $event end + $installer destroy + return [lsort [dict keys $result]] + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {changed unchanged} + + # ========================================================================= + # --- installevent: get_targets and get_targets_exist --- + # Used together with targetset_source_changes in the rebuild-decision: + # rebuild = (any changed) OR (existing targets < total targets) + # ========================================================================= + + test installevent_get_targets {get_targets returns sorted targetlist passed to targetset_init}\ + -body { + set ws [make_workspace] + set root [dict get $ws root] + set src_abspath [make_source_file $root "src1.txt" "x"] + set installer [punkcheck::installtrack new "test" [dict get $ws punkcheck_file]] + $installer set_source_target [dict get $ws srcdir] [dict get $ws tgtdir] + set event [$installer start_event {-install_step test}] + $event targetset_init VIRTUAL [list "t2.txt" "t1.txt"] + set targets [$event get_targets] + $event end + $installer destroy + return $targets + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {t1.txt t2.txt} + + test installevent_get_targets_exist_none {get_targets_exist returns empty when no targets exist on disk}\ + -body { + set ws [make_workspace] + set root [dict get $ws root] + set installer [punkcheck::installtrack new "test" [dict get $ws punkcheck_file]] + $installer set_source_target [dict get $ws srcdir] [dict get $ws tgtdir] + set event [$installer start_event {-install_step test}] + $event targetset_init VIRTUAL [list "missing1.txt"] + set existing [$event get_targets_exist] + $event end + $installer destroy + return $existing + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {} + + test installevent_get_targets_exist_partial {get_targets_exist returns only existing targets}\ + -body { + set ws [make_workspace] + set root [dict get $ws root] + # create one of the two targets at $root (which is the punkcheck_folder) + set fd [open [file join $root "exists.txt"] w]; close $fd + set installer [punkcheck::installtrack new "test" [dict get $ws punkcheck_file]] + $installer set_source_target [dict get $ws srcdir] [dict get $ws tgtdir] + set event [$installer start_event {-install_step test}] + $event targetset_init VIRTUAL [list "missing.txt" "exists.txt"] + set existing [$event get_targets_exist] + $event end + $installer destroy + return $existing + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result {exists.txt} + + # ========================================================================= + # --- installevent: combined rebuild-decision matching punk::mix::cli --- + # ========================================================================= + + test targetset_combined_rebuild_changed_source {cli-style: changed source => rebuild needed}\ + -body { + set ws [make_workspace] + set root [dict get $ws root] + set src_abspath [make_source_file $root "src1.txt" "x"] + set installer [punkcheck::installtrack new "test" [dict get $ws punkcheck_file]] + $installer set_source_target [dict get $ws srcdir] [dict get $ws tgtdir] + set event [$installer start_event {-install_step test}] + $event targetset_init VIRTUAL "vtarg1" + $event targetset_addsource $src_abspath + set needs_rebuild [expr { + [llength [dict get [$event targetset_source_changes] changed]] + || [llength [$event get_targets_exist]] < [llength [$event get_targets]] + }] + $event end + $installer destroy + return $needs_rebuild + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result 1 + + test targetset_combined_rebuild_missing_target {cli-style: unchanged source but missing target => rebuild needed}\ + -body { + set ws [make_workspace] + set root [dict get $ws root] + set src_abspath [make_source_file $root "src1.txt" "x"] + seed_virtual_record [dict get $ws punkcheck_file] [dict get $ws srcdir] [dict get $ws tgtdir] "vtarg1" $src_abspath + set installer [punkcheck::installtrack new "test" [dict get $ws punkcheck_file]] + $installer set_source_target [dict get $ws srcdir] [dict get $ws tgtdir] + set event [$installer start_event {-install_step test}] + $event targetset_init VIRTUAL "vtarg1" + $event targetset_addsource $src_abspath + set needs_rebuild [expr { + [llength [dict get [$event targetset_source_changes] changed]] + || [llength [$event get_targets_exist]] < [llength [$event get_targets]] + }] + $event end + $installer destroy + return $needs_rebuild + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result 1 + + test targetset_combined_no_rebuild {cli-style: unchanged source + existing target => no rebuild}\ + -body { + set ws [make_workspace] + set root [dict get $ws root] + set src_abspath [make_source_file $root "src1.txt" "x"] + seed_virtual_record [dict get $ws punkcheck_file] [dict get $ws srcdir] [dict get $ws tgtdir] "vtarg1" $src_abspath + # create the target file (same name as targetset) so get_targets_exist returns it + set fd [open [file join $root "vtarg1"] w]; close $fd + set installer [punkcheck::installtrack new "test" [dict get $ws punkcheck_file]] + $installer set_source_target [dict get $ws srcdir] [dict get $ws tgtdir] + set event [$installer start_event {-install_step test}] + $event targetset_init VIRTUAL "vtarg1" + $event targetset_addsource $src_abspath + set needs_rebuild [expr { + [llength [dict get [$event targetset_source_changes] changed]] + || [llength [$event get_targets_exist]] < [llength [$event get_targets]] + }] + $event end + $installer destroy + return $needs_rebuild + }\ + -cleanup { + file delete -force [dict get $ws root] + }\ + -result 0 +} +tcltest::cleanupTests ;#needed to produce test summary line. \ No newline at end of file diff --git a/src/tests/runtests.tcl b/src/tests/runtests.tcl index 91733930..43933f61 100644 --- a/src/tests/runtests.tcl +++ b/src/tests/runtests.tcl @@ -34,6 +34,7 @@ if {$libdir_arch ni $::auto_path} { #------------------------------------ package require punk package require punk::args +package require Thread package require shellrun package require punk::tcltestrun diff --git a/src/vfs/_vfscommon.vfs/modules/commandstack-0.3.tm b/src/vfs/_vfscommon.vfs/modules/commandstack-0.3.tm deleted file mode 100644 index b2561a20..00000000 --- a/src/vfs/_vfscommon.vfs/modules/commandstack-0.3.tm +++ /dev/null @@ -1,518 +0,0 @@ - - -#JMN 2021 - Public Domain -#cooperative command renaming -# -# REVIEW 2024 - code was originally for specific use in packageTrace -# - code should be reviewed for more generic utility. -# - API is obscure and undocumented. -# - unclear if intention was only for builtins -# - consider use of newer 'info cmdtype' - (but need also support for safe interps) -# - oo dispatch features may be a better implementation - especially for allowing undoing command renames in the middle of a stack. -# - document that replacement command should use 'commandstack::get_next_command ' for delegating to command as it was prior to rename -#changes: -#2024 -# - mungecommand to support namespaced commands -# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_ -#2021-09-18 -# - initial version -# - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command -# - They need to be able to load and unload in any order. -# - -#strive for no other package dependencies here. - - -namespace eval commandstack { - variable all_stacks - variable debug - set debug 0 - variable known_renamers [list ::packagetrace ::packageSuppress] - if {![info exists all_stacks]} { - #don't wipe it - set all_stacks [dict create] - } -} - -namespace eval commandstack::util { - #note - we can't use something like md5 to ID proc body text because we don't want to require additional packages. - #We could store the full text of the body to compare - but we need to identify magic strings from cooperating packages such as packageTrace - #A magic comment was chosen as the identifying method. - #The string IMPLEMENTOR_*! is searched for where the text between _ and ! is the name of the package that implemented the proc. - - #return unspecified if the command is a proc with a body but no magic comment ID - #return unknown if the command doesn't have a proc body to analyze - #otherwise return the package name identified in the magic comment - proc get_IMPLEMENTOR {command} { - #assert - command has already been resolved to a namespace ie fully qualified - if {[llength [info procs $command]]} { - #look for *IMPLEMENTOR_*! - set prefix IMPLEMENTOR_ - set suffix "!" - set body [uplevel 1 [list info body $command]] - if {[string match "*$prefix*$suffix*" $body]} { - set prefixposn [string first "$prefix" $body] - set pkgposn [expr {$prefixposn + [string length $prefix]}] - #set suffixposn [string first $suffix [string range $body $pkgposn $pkgposn+60]] - set suffixposn [string first $suffix $body $pkgposn] - return [string range $body $pkgposn $suffixposn-1] - } else { - return unspecified - } - } else { - if {[info commands tcl::info::cmdtype] ne ""} { - #tcl9 and maybe some tcl 8.7s ? - switch -- [tcl::info::cmdtype $command] { - native { - return builtin - } - default { - return undetermined - } - } - } else { - return undetermined - } - } - } -} -namespace eval commandstack::renamed_commands {} -namespace eval commandstack::temp {} ;#where we create proc initially before renaming into place - -namespace eval commandstack { - namespace export {[a-z]*} - proc help {} { - return { - - } - } - - proc debug {{on_off {}}} { - variable debug - if {$on_off eq ""} { - return $debug - } else { - if {[string is boolean -strict $debug]} { - set debug [expr {$on_off && 1}] - return $debug - } - } - } - - proc get_stack {{command ""}} { - variable all_stacks - if {$command eq ""} { - return $all_stacks - } - set command [uplevel 1 [list namespace which $command]] - if {[dict exists $all_stacks $command]} { - return [dict get $all_stacks $command] - } else { - return [list] - } - } - - #get the implementation to which the renamer (renamer is usually calling namespace) originally renamed it, or the implementation it now points to. - #review - performance impact. Possible to use oo for faster dispatch whilst allowing stack re-orgs? - #e.g if renaming builtin 'package' - this command is generally called 'a lot' - proc get_next_command {command renamer tokenid} { - variable all_stacks - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - #stack is a list of dicts, 1st entry is token { } - set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]] - if {$posn > -1} { - set record [lindex $stack $posn] - return [dict get $record implementation] - } else { - error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command' using token: $command $renamer $tokenid" - } - } else { - return $command - } - } - proc basecall {command args} { - variable all_stacks - set command [uplevel 1 [list namespace which $command]] - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - if {[llength $stack]} { - set rec1 [lindex $stack 0] - tailcall [dict get $rec1 implementation] {*}$args - } else { - tailcall $command {*}$args - } - } else { - tailcall $command {*}$args - } - } - - - #review. - # defaults to calling namespace - but can be arbitrary string - proc rename_command {args} { - #todo: consider -forcebase 1 or similar to allow this rename to point to bottom of stack (original command) bypassing existing renames - # - need to consider that upon removing, that any remaining rename that was higher on the stack should not also be diverted to the base - but rather to the next lower in the stack - # - if {[lindex $args 0] eq "-renamer"} { - set renamer [lindex $args 1] - set arglist [lrange $args 2 end] - } else { - set renamer "" - set arglist $args - } - if {[llength $arglist] != 3} { - error "commandstack::rename_command usage: rename_command ?-renamer ? command procargs procbody" - } - lassign $arglist command procargs procbody - - set command [uplevel 1 [list namespace which $command]] - set mungedcommand [string map {:: _ns_} $command] - set mungedrenamer [string map {:: _ns_} $renamer] - variable all_stacks - variable known_renamers - variable renamer_command_tokens ;#monotonically increasing int per :: representing number of renames ever done. - if {$renamer eq ""} { - set renamer [uplevel 1 [list namespace current]] - } - if {$renamer ni $known_renamers} { - lappend known_renamers $renamer - dict set renamer_command_tokens [list $renamer $command] 0 - } - - #TODO - reduce emissions to stderr - flag for debug? - - #e.g packageTrace and packageSuppress packages use this convention. - set nextinfo [uplevel 1 [list\ - apply {{command renamer procbody} { - #todo - munge dash so we can make names in renamed_commands separable - # {- _dash_} ? - set mungedcommand [string map {:: _ns_} $command] - set mungedrenamer [string map {:: _ns_} $renamer] - set tokenid [lindex [dict incr renamer_command_tokens [list $renamer $command]] 1] - set next_target ::commandstack::renamed_commands::${mungedcommand}-original-$mungedrenamer-$tokenid ;#default is to assume we are the only one playing around with it, but we'll check for known associates too. - set do_rename 0 - if {[llength [info procs $command]] || [llength [info commands $next_target]]} { - #$command is not the standard builtin - something has replaced it, could be ourself. - set next_implementor [::commandstack::util::get_IMPLEMENTOR $command] - set munged_next_implementor [string map {:: _ns_} $next_implementor] - #if undetermined/unspecified it could be the latest renamer on the stack - but we can't know for sure something else didn't rename it. - if {[dict exists $::commandstack::all_stacks $command]} { - set comstacks [dict get $::commandstack::all_stacks $command] - } else { - set comstacks [list] - } - set this_renamer_previous_entries [lsearch -all -index 3 $comstacks $renamer] ;#index 3 is value for second dict entry - (value for key 'renamer') - if {[llength $this_renamer_previous_entries]} { - if {$next_implementor eq $renamer} { - #previous renamer was us. Rather than assume our job is done.. compare the implementations - #don't rename if immediate predecessor is same code. - #set topstack [lindex $comstacks end] - #set next_impl [dict get $topstack implementation] - set current_body [info body $command] - lassign [commandstack::lib::split_body $current_body] _ current_code - set current_code [string trim $current_code] - set new_code [string trim $procbody] - if {$current_code eq $new_code} { - puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename." - puts stderr [::commandstack::show_stack $command] - } else { - puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding." - puts stdout "----------" - puts stdout "$current_code" - puts stdout "----------" - puts stdout "$new_code" - puts stdout "----------" - set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } - } else { - puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)" - puts stderr - set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } - } elseif {$next_implementor in $::commandstack::known_renamers} { - set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } elseif {$next_implementor in {builtin}} { - #native/builtin could still have been renamed - set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } elseif {$next_implementor in {unspecified undetermined}} { - #could be a standard tcl proc, or from application or package - set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } else { - puts stderr "(commandstack::rename_command) Warning - pkg:'$next_implementor' has renamed the '$command' command. Attempting to cooperate. (untested)" - set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } - } else { - #_originalcommand_ - #assume builtin/original - set next_implementor original - #rename $command $next_target - set do_rename 1 - } - #There are of course other ways in which $command may have been renamed - but we can't detect. - set token [list $command $renamer $tokenid] - return [dict create next_target $next_target next_implementor $next_implementor token $token do_rename $do_rename] - } } $command $renamer $procbody] - ] - - - variable debug - if {$debug} { - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - puts stderr "(commandstack::rename_command) Subsequent rename of command '$command'. (previous renames: [llength $stack]). Renaming to [dict get $nextinfo next_target]" - } else { - #assume this is the original - puts stderr "(commandstack::rename_command) 1st detected rename of command '$command'. Renaming to [dict get $nextinfo next_target]" - } - } - - #token is always first dict entry. (Value needs to be searched with lsearch -index 1 ) - #renamer is always second dict entry (Value needs to be searched with lsearch -index 3) - set new_record [dict create\ - token [dict get $nextinfo token]\ - renamer $renamer\ - next_implementor [dict get $nextinfo next_implementor]\ - next_getter [list ::commandstack::get_next_command {*}[dict get $nextinfo token]]\ - implementation [dict get $nextinfo next_target]\ - ] - if {![dict get $nextinfo do_rename]} { - #review - puts stderr "no rename performed" - return [dict create implementation ""] - } - catch {rename ::commandstack::temp::testproc ""} - set nextinit [string map [list %command% $command %renamer% $renamer %next_getter% [dict get $new_record next_getter] %original_implementation% [dict get $new_record implementation]] { - #IMPLEMENTOR_%renamer%! (mechanism: 'commandstack::rename_command -renamer %renamer% %command% ) - set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc. - set COMMANDSTACKNEXT [%next_getter%] - ## - }] - set final_procbody "$nextinit$procbody" - #build the proc at a temp location so that if it raises an error we don't adjust the stack or replace the original command - #(e.g due to invalid argument specifiers) - proc ::commandstack::temp::testproc $procargs $final_procbody - uplevel 1 [list rename $command [dict get $nextinfo next_target]] - uplevel 1 [list rename ::commandstack::temp::testproc $command] - dict lappend all_stacks $command $new_record - - - return $new_record - } - - #todo - concept of 'pop' for renamer. Remove topmost entry specific to the renamer - #todo - removal by token to allow renamer to have multiple entries for one command but to remove one that is not the topmost - #todo - removal of all entries pertaining to a particular renamer - #todo - allow restore to bottom-most implementation (original) - regardless of what renamers have cooperated in the stack? - - #remove by token, or by commandname if called from same context as original rename_command - #If only a commandname is supplied, and there were multiple renames from the same context (same -renamer) only the topmost is removed. - #A call to remove_rename with no token or renamer, and from a namespace context which didn't perform a rename will not remove anything. - #similarly a nonexistant token or renamer will not remove anything and will just return the current stack - proc remove_rename {token_or_command} { - if {[llength $token_or_command] == 3} { - #is token - lassign $token_or_command command renamer tokenid - } elseif {[llength $token_or_command] == 2} { - #command and renamer only supplied - lassign $token_or_command command renamer - set tokenid "" - } elseif {[llength $token_or_command] == 1} { - #is command name only - set command $token_or_command - set renamer [uplevel 1 [list namespace current]] - set tokenid "" - } - set command [uplevel 1 [list namespace which $command]] - variable all_stacks - variable known_renamers - if {$renamer ni $known_renamers} { - error "(commandstack::remove_rename) ERROR: renamer $renamer not in list of known_renamers '$known_renamers' for command '$command'. Ensure remove_rename called from same context as rename_command was, or explicitly supply exact token or { }" - } - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - if {$tokenid ne ""} { - #token_or_command is a token as returned within the rename_command result dictionary - #search first dict value - set doomed_posn [lsearch -index 1 $stack $token_or_command] - } else { - #search second dict value - set matches [lsearch -all -index 3 $stack $renamer] - set doomed_posn [lindex $matches end] ;#we don't have a full token - pop last entry for this renamer - } - if {$doomed_posn ne "" && $doomed_posn > -1} { - set doomed_record [lindex $stack $doomed_posn] - if {[llength $stack] == ($doomed_posn + 1)} { - #last on stack - put the implemenation from the doomed_record back as the actual command - uplevel #0 [list rename $command ""] - uplevel #0 [list rename [dict get $doomed_record implementation] $command] - } elseif {[llength $stack] > ($doomed_posn + 1)} { - #there is at least one more record on the stack - rewrite it to point where the doomed_record pointed - set rewrite_posn [expr {$doomed_posn + 1}] - set rewrite_record [lindex $stack $rewrite_posn] - - if {[dict get $rewrite_record next_implementor] ne $renamer} { - puts stderr "(commandstack::remove_rename) WARNING: next record on the commandstack didn't record '$renamer' as the next_implementor - not deleting implementation [dict get $rewrite_record implementation]" - } else { - uplevel #0 [list rename [dict get $rewrite_record implementation] ""] - } - dict set rewrite_record next_implementor [dict get $doomed_record next_implementor] - #don't update next_getter - it always refers to self - dict set rewrite_record implementation [dict get $doomed_record implementation] - lset stack $rewrite_posn $rewrite_record - dict set all_stacks $command $stack - } - set stack [lreplace $stack $doomed_posn $doomed_posn] - dict set all_stacks $command $stack - - } - return $stack - } - return [list] - } - - proc show_stack {{commandname_glob *}} { - variable all_stacks - if {![regexp {[?*]} $commandname_glob]} { - #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace - set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] - } - if {[package provide punk::lib] ne "" && [package provide punk] ne ""} { - #punk pipeline also needed for patterns - return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] - } else { - set result "" - set matchedkeys [dict keys $all_stacks $commandname_glob] - #don't try to calculate widest on empty list - if {[llength $matchedkeys]} { - set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]] - set indent [string repeat " " [expr {$widest + 3}]] - set indent2 "${indent} " ;#8 spaces for " i = " where i is 4 wide - set padkey [string repeat " " 20] - foreach k $matchedkeys { - append result "$k = " - set i 0 - foreach stackmember [dict get $all_stacks $k] { - if {$i > 0} { - append result "\n$indent" - } - append result [string range "$i " 0 4] " = " - set j 0 - dict for {k v} $stackmember { - if {$j > 0} { - append result "\n$indent2" - } - set displaykey [string range "$k$padkey" 0 20] - append result "$displaykey = $v" - incr j - } - incr i - } - append result \n - } - } - return $result - } - } - - #review - #document when this is to be called. Wiping stacks without undoing renames seems odd. - proc Delete_stack {command} { - variable all_stacks - if {[dict exists $all_stacks $command]} { - dict unset all_stacks $command - return 1 - } else { - return 1 - } - } - - #can be used to temporarily put a stack aside - should manually rename back when done. - #review - document how/when to use. example? intention? - proc Rename_stack {oldname newname} { - variable all_stacks - if {[dict exists $all_stacks $oldname]} { - if {[dict exists $all_stacks $newname]} { - error "(commandstack::rename_stack) cannot rename $oldname to $newname - $newname already exists in stack" - } else { - #set stackval [dict get $all_stacks $oldname] - #dict unset all_stacks $oldname - #dict set all_stacks $newname $stackval - dict set all_stacks $newname [lindex [list [dict get $all_stacks $oldname] [dict unset all_stacks $oldname]] 0] - } - } - } -} - - - - - - - - -namespace eval commandstack::lib { - proc splitx {str {regexp {[\t \r\n]+}}} { - #snarfed from tcllib textutil::splitx to avoid the dependency - # Bugfix 476988 - if {[string length $str] == 0} { - return {} - } - if {[string length $regexp] == 0} { - return [::split $str ""] - } - if {[regexp $regexp {}]} { - return -code error "splitting on regexp \"$regexp\" would cause infinite loop" - } - - set list {} - set start 0 - while {[regexp -start $start -indices -- $regexp $str match submatch]} { - foreach {subStart subEnd} $submatch break - foreach {matchStart matchEnd} $match break - incr matchStart -1 - incr matchEnd - lappend list [string range $str $start $matchStart] - if {$subStart >= $start} { - lappend list [string range $str $subStart $subEnd] - } - set start $matchEnd - } - lappend list [string range $str $start end] - return $list - } - proc split_body {procbody} { - set marker "##" - set header "" - set code "" - set found_marker 0 - foreach ln [split $procbody \n] { - if {!$found_marker} { - if {[string trim $ln] eq $marker} { - set found_marker 1 - } else { - append header $ln \n - } - } else { - append code $ln \n - } - } - if {$found_marker} { - return [list $header $code] - } else { - return [list "" $procbody] - } - } -} - -package provide commandstack [namespace eval commandstack { - set version 0.3 -}] - - diff --git a/src/vfs/_vfscommon.vfs/modules/oolib-0.1.2.tm b/src/vfs/_vfscommon.vfs/modules/oolib-0.1.2.tm deleted file mode 100644 index 858c61cd..00000000 --- a/src/vfs/_vfscommon.vfs/modules/oolib-0.1.2.tm +++ /dev/null @@ -1,201 +0,0 @@ -#JMN - api should be kept in sync with package patternlib where possible -# -package provide oolib [namespace eval oolib { - variable version - set version 0.1.2 -}] - -namespace eval oolib { - oo::class create collection { - variable o_data ;#dict - #variable o_alias - constructor {} { - set o_data [dict create] - } - method info {} { - return [dict info $o_data] - } - method count {} { - return [dict size $o_data] - } - method isEmpty {} { - expr {[dict size $o_data] == 0} - } - method names {{globOrIdx {}}} { - if {[llength $globOrIdx]} { - if {[string is integer -strict $globOrIdx]} { - set idx $globOrIdx - if {$idx < 0} { - set idx "end-[expr {abs($idx + 1)}]" - } - if {[catch {lindex [dict keys $o_data] $idx} result]} { - error "[self object] no such index : '$idx'" - } else { - return $result - } - } else { - #glob - return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] - } - } else { - return [dict keys $o_data] - } - } - #like names but without globbing - method keys {} { - dict keys $o_data - } - method key {{posn 0}} { - if {$posn < 0} { - set posn "end-[expr {abs($posn + 1)}]" - } - if {[catch {lindex [dict keys $o_data] $posn} result]} { - error "[self object] no such index : '$posn'" - } else { - return $result - } - } - method hasKey {key} { - dict exists $o_data $key - } - method get {} { - return $o_data - } - method items {} { - return [dict values $o_data] - } - method item {key} { - if {[string is integer -strict $key]} { - if {$key >= 0} { - set valposn [expr {(2*$key) +1}] - return [lindex $o_data $valposn] - } else { - set key "end-[expr {abs($key + 1)}]" - return [lindex $o_data $key] - #return [lindex [dict keys $o_data] $key] - } - } - if {[dict exists $o_data $key]} { - return [dict get $o_data $key] - } - } - #inverse lookup - method itemKeys {value} { - set value_indices [lsearch -all [dict values $o_data] $value] - set keylist [list] - foreach i $value_indices { - set idx [expr {(($i + 1) *2) -2}] - lappend keylist [lindex $o_data $idx] - } - return $keylist - } - method search {value args} { - set matches [lsearch {*}$args [dict values $o_data] $value] - if {"-inline" in $args} { - return $matches - } else { - set keylist [list] - foreach i $matches { - set idx [expr {(($i + 1) *2) -2}] - lappend keylist [lindex $o_data $idx] - } - return $keylist - } - } - #review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? - #review - what is the point of alias anyway? - why slow down other operations when a variable can hold a keyname perfectly well? - #method alias {newAlias existingKeyOrAlias} { - # if {[string is integer -strict $newAlias]} { - # error "[self object] collection key alias cannot be integer" - # } - # if {[string length $existingKeyOrAlias]} { - # set o_alias($newAlias) $existingKeyOrAlias - # } else { - # unset o_alias($newAlias) - # } - #} - #method aliases {{key ""}} { - # if {[string length $key]} { - # set result [list] - # foreach {n v} [array get o_alias] { - # if {$v eq $key} { - # lappend result $n $v - # } - # } - # return $result - # } else { - # return [array get o_alias] - # } - #} - ##if the supplied index is an alias, return the underlying key; else return the index supplied. - #method realKey {idx} { - # if {[catch {set o_alias($idx)} key]} { - # return $idx - # } else { - # return $key - # } - #} - method add {value key} { - if {[string is integer -strict $key]} { - error "[self object] collection key must not be an integer. Use another structure if integer keys required" - } - if {[dict exists $o_data $key]} { - error "[self object] col_processors object error: key '$key' already exists in collection" - } - dict set o_data $key $value - return [expr {[dict size $o_data] - 1}] ;#return index of item - } - method remove {idx {endRange ""}} { - if {[string length $endRange]} { - error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" - } - if {[string is integer -strict $idx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx+1)}]" - } - set key [lindex [dict keys $o_data] $idx] - set posn $idx - } else { - set key $idx - set posn [lsearch -exact [dict keys $o_data] $key] - if {$posn < 0} { - error "[self object] no such index: '$idx' in this collection" - } - } - dict unset o_data $key - return - } - method clear {} { - set o_data [dict create] - return - } - method reverse_the_collection {} { - #named slightly obtusely because reversing the data when there may be references held is a potential source of bugs - #the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy. - #todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations. - set dictnew [dict create] - foreach k [lreverse [dict keys $o_data]] { - dict set dictnew $k [dict get $o_data $k] - } - set o_data $dictnew - return - } - #review - cmd as list vs cmd as script? - method map {cmd} { - set seed [list] - dict for {k v} $o_data { - lappend seed [uplevel #0 [list {*}$cmd $v]] - } - return $seed - } - method objectmap {cmd} { - set seed [list] - dict for {k v} $o_data { - lappend seed [uplevel #0 [list $v {*}$cmd]] - } - return $seed - } - } - -} - diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm index 778709bb..0d105eaf 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm @@ -1325,6 +1325,13 @@ tcl::namespace::eval punk::ansi { grepstr -r m -C 2 {cancelid} [s ::after] ;#with 2 lines of context and no break indicators. }]} + To match a literal string that contains regex special characters, it is in some cases easier to use the Tcl regex + quoting switch (?q) to quote the string rather than escaping each special character with a backslash. + ${[punk::args::helpers::example -syntax none { + #The following example matches a literal string that is the Tcl expansion operator {*} + grepstr "(?q){*}" $sometext + }]} + } @leaders -min 0 -max 0 diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm index e29dd871..f952ed09 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm @@ -474,7 +474,7 @@ namespace eval punk::mix::cli { set defaults [list {*}{ -installer punk::mix::cli::build_modules_from_source_to_base -call-depth-internal 0 - -max_depth 1000 + -max-depth 1000 -subdirlist {} -punkcheck_eventobj "\uFFFF" -glob *.tm @@ -487,7 +487,7 @@ namespace eval punk::mix::cli { set installername [dict get $opts -installer] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set CALLDEPTH [dict get $opts -call-depth-internal] - set max_depth [dict get $opts -max_depth] + set max_depth [dict get $opts -max-depth] set subdirlist [dict get $opts -subdirlist] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set fileglob [dict get $opts -glob] @@ -533,7 +533,7 @@ namespace eval punk::mix::cli { set config [dict create {*}{ -glob $fileglob - -max_depth 0 + -max-depth 0 }] #lassign [punkcheck::start_installer_event $punkcheck_file $installername $srcdir $basedir $config] _eventid punkcheck_eventid _recordset record_list # -- --- @@ -628,11 +628,11 @@ namespace eval punk::mix::cli { # -- --- set config [dict create {*}{ -glob * - -max_depth 100 + -max-depth 100 }] set had_error 0 - # -max_depth -1 for no limit + # -max-depth -1 for no limit set build_installername pods_in_$current_source_dir set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck] #set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck stderr] ;#with debugchannel @@ -829,11 +829,11 @@ namespace eval punk::mix::cli { # -- --- set config [dict create {*}{ -glob * - -max_depth 100 + -max-depth 100 }] set had_error 0 - # -max_depth -1 for no limit + # -max-depth -1 for no limit set build_installername tarjars_in_$current_source_dir set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck] $build_installer set_source_target $current_source_dir/$modpath $buildfolder diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.4.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.4.0.tm new file mode 100644 index 00000000..c3ba6efb --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.4.0.tm @@ -0,0 +1,1427 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'deck 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.4.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz +package require punk::repo +package require punk::ansi +package require punkcheck ;#checksum and/or timestamp records + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#review +#deck - rename to dev +namespace eval punk::mix::cli { + namespace eval temp_import { + } + namespace ensemble create + variable initialised 0 + + #lazy _init - called by punk::mix::base::_cli when ensemble used + proc _init {args} { + variable initialised + if {$initialised} { + return + } + puts stderr "punk::mix::cli::init $args" + package require punk::overlay + namespace eval ::punk::mix::cli { + 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 + } + } + set initialised 1 + } + + 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 + } + } + + #for externally launched tclsh or punkshell running src/make.tcl the cwd + #needs to be such that make.tcl can find required bootsupport libraries without relying on auto_path or tcl::tm::list mechanisms. + #we can change directory during the run, and change back again afterwards. + + #also - if no make.tcl - can we use the running shell's make.tcl ? (after prompting user?) + + if {([file tail $sourcefolder] ne "src") || (![file exists $sourcefolder/make.tcl])} { + puts stderr "dev make must be run from src folder containing make.tcl or from within a project containing src/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 { + #review - intended usecase? + 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 + } + } + } + + #if {![catch {run --timeout=150000 -debug [info nameofexecutable] $sourcefolder/make.tcl {*}$args} exitinfo]} { + # #todo - notify if exit because of timeout! + # puts stderr "exitinfo: $exitinfo" + # set exitcode [dict get $exitinfo exitcode] + #} else { + # puts stderr "Error unable to determine exitcode. err: $exitinfo" + # #cd $startdir + # return false + #} + + #use run so that stdout visible as it goes + #review - is setting a timeout here useful? It will just be annoying if the project really does need the time. + #review - on timeout what happens? (implemented in shellfilter) + # - if just stderr/stdout redirection channels closed - what happens with stdin? + # e.g 'for dev make shell' - we just get no further responses but stdin still consuming keystrokes? + try { + #cd $sourcefolder ;#dev paths can overide bootsupport modules + cd $project_base ;#bootsupport modules only + set exitinfo [run --timeout=150000 -debug [info nameofexecutable] $sourcefolder/make.tcl {*}$args] + } trap {} {emsg eopts} { + puts stderr "Error, unable to determine exitcode. err: $emsg" + return false + } finally { + cd $startdir + } + puts stderr "exitinfo: $exitinfo" + set exitcode [dict get $exitinfo exitcode] + + 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] + return [list plain tarjar zip] + } + + proc validate_modulename {modulename args} { + set opts [list {*}{ + -errorprefix validate_modulename + -strict 0 + }] + if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"} + foreach {k v} $args { + switch -- $k { + -errorprefix - -strict { + dict set opts $k $v + } + default { + error "validate_modulename error: unknown option '$k'. known options: [dict keys $opts]" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_errorprefix [dict get $opts -errorprefix] + set opt_strict [dict get $opts -strict] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + if {$opt_strict} { + if {[regexp {[A-Z]} $modulename]} { + error "$opt_errorprefix '$modulename' contains uppercase which is not recommended as per tip 590, and option -strict is set to 1" + } + } + + validate_name_not_empty_or_spaced $modulename -errorprefix $opt_errorprefix + set testname [string map {:: {}} $modulename] + if {[string first : $testname] >=0} { + error "$opt_errorprefix '$modulename' can only contain paired colons" + } + set badchars [list - "$" "?" "*"] + foreach bc $badchars { + if {[string first $bc $modulename] >= 0} { + error "$opt_errorprefix '$modulename' can not contain character '$bc'" + } + } + return $modulename + } + proc confirm_modulename {modulename} { + set finalised 0 + set aborted 0 + while {!$finalised && !$aborted} { + #first validate with -strict 0 to confirm acceptable while ignoring case issues. + #uppercase is generally valid but not recommended - so has separate prompting. + if {[catch {validate_modulename $modulename -strict 0} errM]} { + set msg "Chosen name didn't pass validation\n" + append msg "reason: $errM\n" + append msg "Please retype the modulename. You will be given a further prompt to confirm or abort." + set modulename [util::askuser $msg] + } elseif {[regexp {[A-Z]} $modulename]} { + set msg "module names containing uppercase are not recommended (see tip 590).\n" + append msg "Please retype the module name '$modulename' to proceed.\n" + append msg "If you type it exactly as it was you will be allowed to proceed with uppercase anyway\n" + append msg "Retype it all in lowercase to use recommended naming" + set answer [util::askuser $msg] + if {[regexp {[A-Z]} $answer]} { + if {$answer eq $modulename} { + #ok - user insists + set finalised 1 + } else { + #user supplied a different uppercase name - don't set finalised so we bug them again to type it two times the same way to proceed + puts stdout "A different uppercase name was supplied - reconfirmation required." + } + set modulename $answer + } else { + #user has resupplied modulename all as lowercase + if {$answer eq [string tolower $modulename]} { + set finalised 1 + } else { + #.. but it doesn't match original - require rerun + } + set modulename $answer + } + } else { + set answer [util::askuser "Proceed with the module name '$modulename'? Y to continue N to abort"] + if {[string tolower $answer] eq "y"} { + set finalised 1 + } else { + set aborted 1 + } + } + } + if {$aborted} { + return [dict create status error reason errmsg] + } else { + return [dict create status ok modulename $modulename] + } + } + + proc validate_projectname {projectname args} { + set defaults [list {*}{ + -errorprefix projectname + }] + if {[llength $args] %2 != 0} {error "validate_projectname 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_projectname error: unknown option $k. known options: $known_opts" + } + } + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_errorprefix [dict get $opts -errorprefix] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + validate_name_not_empty_or_spaced $projectname -errorprefix $opt_errorprefix + set reserved_words [list etc lib bin modules src doc vendorlib vendormodules embedded runtime _aside _build] + if {$projectname in $reserved_words } { + error "$opt_errorprefix '$projectname' cannot be one of reserved_words: $reserved_words" + } + if {[string first "::" $projectname] >= 0} { + error "$opt_errorprefix '$projectname' cannot contain namespace separator '::'" + } + return $projectname + } + proc validate_name_not_empty_or_spaced {name args} { + set opts [list {*}{ + -errorprefix projectname + }] + if {[llength $args] %2 != 0} {error "validate_name_not_empty_or_spaced args must be name-value pairs: received '$args'"} + foreach {k v} $args { + switch -- $k { + -errorprefix { + dict set opts $k $v + } + default { + error "validate_name_not_empty_or_spaced error: unknown option $k. known options: [dict keys $opts]" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_errorprefix [dict get $opts -errorprefix] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + if {![string length $name]} { + error "$opt_errorprefix cannot be empty" + } + if {[string length [string map [list " " "" \n "" \r "" \t ""] $name]] != [string length $name]} { + error "$opt_errorprefix cannot contain whitespace" + } + return $name + } + + + 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 [punk::ansi::a+ bold yellow][dict get $repopaths warnings][punk::ansi::a] + } else { + append result [punk::ansi::a+ bold yellow][dict get $repopaths warnings][punk::ansi::a] + 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 -- [>punk . logo] " " $result] + append result \n + } + } + + set timeline [exec fossil timeline -n 5 -t ci] + set timeline [string map {\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 "\nGIT 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 "#*" "_build" "_aside" ".git" ".fossil*"] ;#exact or glob patterns for folders (at any level) we don't want to search in or copy. + 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 + -podglob #modpod-* + -tarjarglob #tarjar-* + }] + 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] + set podglob [dict get $opts -podglob] + set tarjarglob [dict get $opts -tarjarglob] + 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::tm_version_magic] ;#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] + #set installer [punkcheck::installtrack new $installername $punkcheck_file stderr] ;#with debugchannel + $installer set_source_target $srcdir $basedir + set event [$installer start_event $config] + # -- --- + + } else { + set event $opt_punkcheck_eventobj + } + #---------------------------------------- + + + set process_modules [dict create] + #put pods first in processing order + set src_pods [glob -nocomplain -dir $current_source_dir -type d -tail -- $podglob] + foreach podpath $src_pods { + dict set process_modules $podpath [dict create -type pod] + } + set src_tarjars [glob -nocomplain -dir $current_source_dir -type d -tail -- $tarjarglob] + foreach tarjarpath $src_tarjars { + dict set process_modules $tarjarpath [dict create -type tarjar] + } + set src_modules [glob -nocomplain -dir $current_source_dir -type f -tail -- $fileglob] + foreach modulepath $src_modules { + dict set process_modules $modulepath [dict create -type file] + } + + set did_skip 0 ;#flag for stdout/stderr formatting only + dict for {modpath modinfo} $process_modules { + set modtype [dict get $modinfo -type] + + set is_interesting 0 + if {[string match "foobar" $current_source_dir]} { + set is_interesting 1 + } + + #debug for issues on non-windows platforms. + #if {$::tcl_platform(platform) ne "windows"} { + # set is_interesting 1 + #} + + if {$is_interesting} { + puts "build_modules_from_source_to_base >>> module $current_source_dir/$modpath" + } + set fileparts [split [file rootname $modpath] -] + #set tmfile_versionsegment [lindex $fileparts end] + lassign [split_modulename_version $modpath] basename tmfile_versionsegment + if {$tmfile_versionsegment eq ""} { + #split_modulename_version version part will be empty if not valid tcl version + #last segment doesn't look even slightly versiony - fail. + puts stderr "ERROR: Unable to confirm file $current_source_dir/$modpath is a reasonably versioned .tm module - ABORTING." + flush stderr + after 1000 + exit 1 + } + switch -- $modtype { + pod { + puts -nonewline stderr "p-" + #basename still contains leading #modpod- + if {[string match #modpod-* $basename]} { + set basename [string range $basename 8 end] + } else { + error "build_modules_from_source_to_base, pod, unexpected basename $basename" ;#shouldn't be possible with default podglob - review - why is podglob configurable? + } + set versionfile $current_source_dir/$basename-buildversion.txt ;#needs to be added in targetset_addsource to trigger rebuild if changed (only when magicversion in use) + if {$tmfile_versionsegment eq $magicversion} { + 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 + } + } else { + set module_build_version $tmfile_versionsegment + } + + set buildfolder $current_source_dir/_build + file mkdir $buildfolder + # -- --- + set config [dict create {*}{ + -glob * + -max-depth 100 + }] + set had_error 0 + + # -max-depth -1 for no limit + set build_installername pods_in_$current_source_dir + set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck] + #set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck stderr] ;#with debugchannel + $build_installer set_source_target $current_source_dir/$modpath $buildfolder + set build_event [$build_installer start_event $config] + # -- --- + set podtree_copy $buildfolder/#modpod-$basename-$module_build_version + set modulefile $buildfolder/$basename-$module_build_version.tm + + #todo - use modpod version as a source for change detection + #package require modpod + + $build_event targetset_init INSTALL $podtree_copy + $build_event targetset_addsource $current_source_dir/$modpath + if {$tmfile_versionsegment eq $magicversion} { + $build_event targetset_addsource $versionfile + } + if {\ + [llength [dict get [$build_event targetset_source_changes] changed]]\ + || [llength [$build_event get_targets_exist]] < [llength [$build_event get_targets]]\ + } { + $build_event targetset_started + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + + set delete_failed 0 + if {[file exists $buildfolder/]} { + puts stderr "deleting existing _build copy at $podtree_copy" + if {[catch { + file delete -force $podtree_copy + } errMsg]} { + puts stderr "[punk::ansi::a+ red]deletion of _build copy at $podtree_copy failed: $errMsg[punk::ansi::a]" + set delete_failed 1 + } + } + if {!$delete_failed} { + puts stdout "copying.." + puts stdout "$current_source_dir/$modpath" + puts stdout "to:" + puts stdout "$podtree_copy" + flush stdout + file copy $current_source_dir/$modpath $podtree_copy + if {$tmfile_versionsegment eq $magicversion} { + set tmfile $buildfolder/#modpod-$basename-$module_build_version/$basename-$magicversion.tm + if {[file exists $tmfile]} { + set newname $buildfolder/#modpod-$basename-$module_build_version/$basename-$module_build_version.tm + file rename $tmfile $newname + set tmfile $newname + } + set fd [open $tmfile r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd + set data [string map [list $magicversion $module_build_version] $data] + set fdout [open $tmfile w] + fconfigure $fdout -translation binary + puts -nonewline $fdout $data + close $fdout + } + #delete and regenerate zip and modpod stubbed zip + set notes [list] + if {[catch { + file delete $buildfolder/$basename-$module_build_version.zip + } err] } { + set had_error 1 + lappend notes "zip_delete_failed" + } + if {[catch { + file delete $buildfolder/$basename-$module_build_version.tm + } err]} { + set had_error 1 + lappend notes "tm_delete_failed" + } + #create ordinary zip file without using external executable + package require punk::zip + set zipfile $buildfolder/$basename-$module_build_version.zip ;#ordinary zip file (deflate) + + #zipfs mkzip does exactly what we need anyway in this case + #unfortunately it's not available in all Tclsh versions we might be running.. + if {[llength [info commands zipfs]]} { + #zipfs mkzip (2025) doesn't add entries for folders. + #(Therefore no timestamps) + #zip reading utils generally intuit their existence and display them - but often an editor can't add comments to them + set wd [pwd] + cd $buildfolder + puts "zipfs mkzip $zipfile #modpod-$basename-$module_build_version" + zipfs mkzip $zipfile #modpod-$basename-$module_build_version + cd $wd + + } else { + #use -base $buildfolder so that -directory is included in the archive - the modpod stub relies on this - and extraction would be potentially messy otherwise + #put in an archive-level comment to aid in debugging + #punk + punk::zip::mkzip -base $buildfolder -directory $buildfolder/#modpod-$basename-$module_build_version -- $zipfile * + #punk::zip::mkzip stores permissions - (unix style) - which zipfs mkzip doesn't + #Directory ident in zipfs relies on folders ending with trailing slash - if missing, it misidentifies dirs as files. + #(ie it can't use permissions/attributes alone to determine directory vs file) + #TODO - review punk::zip::mkzip and/or external zip to provide a fallback? + #JMN25 + + #set had_error 1 + #lappend notes "zipfs_unavailable" + #puts stderr "WARNING: zipfs unavailable can't build $modulefile" + } + if {!$had_error && [file exists $zipfile]} { + package require modpod + modpod::lib::make_zip_modpod $zipfile $modulefile + } + + + if {$had_error} { + $build_event targetset_end FAILED -note [join $notes ,] + } else { + # -- ---------- + $build_event targetset_end OK + # -- ---------- + } + } else { + $build_event targetset_end FAILED -note "could not delete $podtree_copy" + } + + } else { + puts -nonewline stderr "Z" + set did_skip 1 + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $build_event targetset_end SKIPPED + } + $build_event destroy + $build_installer destroy + + #JMN - review + if {!$had_error} { + $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm + $event targetset_addsource $modulefile + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ + } { + + $event targetset_started + # -- --- --- --- --- --- + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + lappend module_list $modulefile + if {[catch { + file copy -force $modulefile $target_module_dir + } errMsg]} { + puts stderr "[punk::ansi::a+ red]FAILED to copy zip modpod module $modulefile to $target_module_dir[punk::ansi::a]" + $event targetset_end FAILED -note "could not copy $modulefile" + } else { + puts stderr "[punk::ansi::a+ green]Copied zip modpod module $modulefile to $target_module_dir[punk::ansi::a]" + # -- --- --- --- --- --- + $event targetset_end OK -note "zip modpod" + } + } else { + puts -nonewline stderr "z" + set did_skip 1 + if {$is_interesting} { + puts stderr "$modulefile [$event targetset_source_changes]" + } + $event targetset_end SKIPPED + } + } + } + tarjar { + puts -nonewline stderr "t-" + #maint - overall code structure same as pod - refactor? + #basename may still contain #tarjar- + #to be obsoleted - update modpod to (optionally) use vfs::tar ? + if {[string match #tarjar-* $basename]} { + set basename [string range $basename 8 end] + } else { + error "build_modules_from_source_to_base, tarjar, unexpected basename $basename" ;#shouldn't be possible with default tarjarglob - review - why is tarjarglob configurable? + } + set versionfile $current_source_dir/$basename-buildversion.txt ;#needs to be added in targetset_addsource to trigger rebuild if changed (only when magicversion in use) + if {$tmfile_versionsegment eq $magicversion} { + set versionfiledata "" + if {![file exists $versionfile]} { + puts stderr "\n[punk::ansi::a+ brightyellow]WARNING: Missing buildversion text file: $versionfile[punk::ansi::a]" + 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:[punk::ansi::a+ red] build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file[punk::ansi::a]" + exit 3 + } + set module_build_version $ln0 + } + } else { + set module_build_version $tmfile_versionsegment + } + + set buildfolder $current_source_dir/_build + file mkdir $buildfolder + # -- --- + set config [dict create {*}{ + -glob * + -max-depth 100 + }] + set had_error 0 + + # -max-depth -1 for no limit + set build_installername tarjars_in_$current_source_dir + set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck] + $build_installer set_source_target $current_source_dir/$modpath $buildfolder + set build_event [$build_installer start_event $config] + # -- --- + set podtree_copy $buildfolder/#tarjar-$basename-$module_build_version + set modulefile $buildfolder/$basename-$module_build_version.tm + + + $build_event targetset_init INSTALL $podtree_copy + $build_event targetset_addsource $current_source_dir/$modpath + if {$tmfile_versionsegment eq $magicversion} { + $build_event targetset_addsource $versionfile + } + if {\ + [llength [dict get [$build_event targetset_source_changes] changed]]\ + || [llength [$build_event get_targets_exist]] < [llength [$build_event get_targets]]\ + } { + $build_event targetset_started + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + + set delete_failed 0 + if {[file exists $buildfolder/]} { + puts stderr "deleting existing _build copy at $podtree_copy" + if {[catch { + file delete -force $podtree_copy + } errMsg]} { + puts stderr "[punk::ansi::a+ red]deletion of _build copy at $podtree_copy failed: $errMsg[punk::ansi::a]" + set delete_failed 1 + } + } + if {!$delete_failed} { + puts stdout "copying.." + puts stdout "$current_source_dir/$modpath" + puts stdout "to:" + puts stdout "$podtree_copy" + file copy $current_source_dir/$modpath $podtree_copy + if {$tmfile_versionsegment eq $magicversion} { + set tmfile $buildfolder/#tarjar-$basename-$module_build_version/#tarjar-loadscript-$basename.tcl + #we don't need to modify version or name of the loadscript + if {![file exists $tmfile]} { + set had_error 1 + lappend notes "tarjar_loadscript_missing" + } else { + #the loadscript must end in a line starting with # and ending with backslash - with no linefeed + set fd [open $tmfile r] + chan configure $fd -translation binary + #last line must be less than 1k long + chan seek $fd -1024 end + set script_tail [read $fd] + set lastlf [string last \n $script_tail] + set lastline [string range $script_tail $lastlf+1 end] + set lastline [string trimleft $lastline] ;#lhs whitespace is ok + if {[string index $lastline 0] ne "#" || [string index $lastline end] ne "\\" } { + set had_error 1 + lappend notes "tarjar_loadscript_badtail" + } + } + } + #delete and regenerate .tm + set notes [list] + if {[catch { + file delete $buildfolder/$basename-$module_build_version.tm + } err]} { + set had_error 1 + lappend notes "tm_delete_failed" + } + #create ordinary tar file without using external executable + package require tar ;#tcllib + set tarfile $buildfolder/$basename-$module_build_version.tm ;#ordinary tar file (no compression - store) + set wd [pwd] + cd $buildfolder + puts "tar::create $tarfile #tarjar-$basename-$module_build_version" + if {[catch { + tar::create $tarfile #tarjar-$basename-$module_build_version + } errMsg]} { + set had_error 1 + puts stderr "tar::create $tarfile failed with msg\n $errMsg" + lappend notes "tar_create_failed" + } + cd $wd + + if {![file exists $tarfile]} { + set had_error 1 + lappend notes "tar_result_missing" + } + + + if {$had_error} { + $build_event targetset_end FAILED -note [join $notes ,] + } else { + # -- ---------- + $build_event targetset_end OK + # -- ---------- + } + } else { + $build_event targetset_end FAILED -note "could not delete $podtree_copy" + } + + } else { + puts -nonewline stderr "T" + set did_skip 1 + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $build_event targetset_end SKIPPED + } + $build_event destroy + $build_installer destroy + + #JMN - review + if {!$had_error} { + $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm + $event targetset_addsource $modulefile + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ + } { + + $event targetset_started + # -- --- --- --- --- --- + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + lappend module_list $modulefile + if {[catch { + file copy -force $modulefile $target_module_dir + } errMsg]} { + puts stderr "[punk::ansi::a+ red]FAILED to copy tarjar module $modulefile to $target_module_dir[punk::ansi::a]" + $event targetset_end FAILED -note "could not copy $modulefile" + } else { + puts stderr "[punk::ansi::a+ green]Copied tarjar module $modulefile to $target_module_dir[punk::ansi::a]" + # -- --- --- --- --- --- + $event targetset_end OK -note "tarjar" + } + } else { + puts -nonewline stderr "t" + set did_skip 1 + if {$is_interesting} { + puts stderr "$modulefile [$event targetset_source_changes]" + } + $event targetset_end SKIPPED + } + } + + } + file { + puts -nonewline stderr "f-" + set m $modpath + if {$tmfile_versionsegment eq $magicversion} { + #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]} { + #rebuilding the .tm from the #tarjar already handled above + puts -nonewline stderr "-" + + #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? + + ##TODO + #set buildfolder $current_sourcedir/_build + #file mkdir $buildfolder + + #set tmfile $buildfolder/$basename-$module_build_version.tm + #file delete -force $buildfolder/#tarjar-$basename-$module_build_version + #file delete -force $tmfile + + + #file copy -force $current_source_dir/#tarjar-$basename-$magicversion $buildfolder/#tarjar-$basename-$module_build_version + ## + ##bsdtar doesn't seem to work.. or I haven't worked out the right options? + ##exec tar -cvf $buildfolder/$basename-$module_build_version.tm $buildfolder/#tarjar-$basename-$module_build_version + #package require tar + #tar::create $tmfile $buildfolder/#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 { + if {$is_interesting} { + puts stdout "skipping module $current_source_dir/$m - no change in sources detected" + } + puts -nonewline stderr "m" + set did_skip 1 + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $event targetset_end SKIPPED + } + + #------------------------------ + + } + + continue + } + ##------------------------------ + ## + #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} + lappend module_list $current_source_dir/$m + file copy -force $current_source_dir/$m $target_module_dir + puts stderr "Copied already versioned module $current_source_dir/$m to $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 "f" + set did_skip 1 + if {$is_interesting} { + puts stderr "$current_source_dir/$m [$event targetset_source_changes]" + } + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $event targetset_end SKIPPED + } + } + } + } ;#end dict for {modpath modinfo} $process_modules + + + if {$CALLDEPTH >= $max_depth} { + set subdirs [list] + } else { + set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] + set targets_existing [glob -nocomplain -dir $target_module_dir -type d -tail {*}$subdirs] + } + #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 + #} + if {$d ni $targets_existing} { + 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\ + -podglob $podglob\ + ] + } + 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 + dict for {p b} $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] + dict for {r -} $::kettle::recipe::recipe { + if {$r ni $standard_recipes} { + dict unset ::kettle::recipe::recipe $r + } + } + } + proc kettle_call {calltype args} { + variable kettle_reset_bodies + switch -- $calltype { + lib {} + shell { + #on windows - could be kettle.bat or kettle.cmd - use auto_execok to find, whatever the platform. + #for now, restrict to version sitting next to exe - REVIEW + set exedir [file dirname [info nameofexecutable]] + set kettlescript [auto_execok $exedir/kettle] + if {$kettlescript eq ""} { + error "kettle_call unable to find installed kettle application file in '$exedir'" + } + + #set kettleappfile [file dirname [info nameofexecutable]]/kettle + #set kettlebatfile [file dirname [info nameofexecutable]]/kettle.bat + + #if {(![file exists $kettleappfile]) && (![file exists $kettlebatfile])} { + # error "deck 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 + # } + #} + } + default { + error "deck kettle_call 1st argument must be one of: 'lib' for direct use of kettle module or 'shell' to call as separate process" + } + } + set startdir [pwd] + if {![file exists $startdir/build.tcl]} { + error "deck 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 "deck 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 (deck)] + } + 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 + #load standard recipes as listed in build.tcl + ::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 + } + + } + proc kettle_punk_recipes {} { + set txtdst ... + } + + } +} + + +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 + if {[catch { + punk::overlay::custom_from_base [namespace current] ::punk::mix::base + } errM]} { + puts stderr "punk::mix::cli load error: Failed to overlay punk::mix::base $errM" + error "punk::mix::cli error: $errM" + } +} + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::cli [namespace eval punk::mix::cli { + variable version + set version 0.4.0 +}] +return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/doc-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/doc-0.1.1.tm new file mode 100644 index 00000000..379adbae --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/doc-0.1.1.tm @@ -0,0 +1,324 @@ +# -*- 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.1 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + +package require punk::path ;# for treefilenames, relative +package require punk::repo +package require punk::docgen ;#inline doctools - generate doctools .man files at src/docgen prior to using kettle to producing .html .md etc +package require punk::mix::cli ;#punk::mix::cli::lib used for kettle_call +#package require punkcheck ;#for path_relative + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +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" + puts "commands: doc.status" + } + + 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 + } + #user may delete the comment containing "--- punk::docgen::overwrites" and then manually edit, and we won't overwrite + #we still generate output in src/docgen so user can diff and manually update if thats what they prefer + set oldfiles [punk::path::treefilenames -dir $projectdir/src/doc _module_*.man] + foreach maybedoomed $oldfiles { + set fd [open $maybedoomed r] + chan conf $fd -translation binary + set data [read $fd] + close $fd + if {[string match "*--- punk::docgen overwrites *" $data]} { + file delete -force $maybedoomed + } + } + set generated [lib::do_docgen modules] + if {[dict get $generated count] > 0} { + #review + set doclist [dict get $generated docs] + set source_base [dict get $generated base] + set target_base $projectdir/src/doc + foreach dinfo $doclist { + lassign $dinfo module fpath + set relpath [punk::path::relative $source_base $fpath] + set relfolder [file dirname $relpath] + if {$relfolder eq "."} { + set relfolder "" + } + file mkdir [file join $target_base $relfolder] + set target [file join $target_base $relfolder _module_[file tail $fpath]] + puts stderr "target --> $target" + if {![file exists $target]} { + file copy $fpath $target + } + } + } + + 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 { + if {"::meta" eq [info commands ::meta]} { + puts stderr "There appears to be a leftover ::meta command which is presumed to be from doctools. Destroying object" + ::meta destroy + } + 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 {args} { + set argd [punk::args::parse $args withdef { + @id -id ::punk::mix::commandset::doc::validate + -- -type none -optional 1 -help "end of options marker --" + -individual -type boolean -default 1 + @values -min 0 -max -1 + patterns -default {*.man} -type any -multiple 1 + }] + set opt_individual [tcl::dict::get $argd opts -individual] + set patterns [tcl::dict::get $argd values patterns] + + + #todo - run and validate punk::docgen output + 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] + set docroot $projectdir/src/doc + cd $docroot + + if {!$opt_individual && "*.man" in $patterns} { + if {[catch { + dtplite validate $docroot + } errM]} { + puts stderr "commandset::doc::validate failed for projectdir '$projectdir'" + puts stderr "docroot '$docroot'" + puts stderr "dtplite error was: $errM" + } + } else { + foreach p $patterns { + set treefiles [punk::path::treefilenames $p] + foreach path $treefiles { + puts stdout "dtplite validate $path" + dtplite validate $path + } + } + } + + #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 + proc do_docgen {{project_subpath modules}} { + #Extract doctools comments from source code + set projectdir [punk::repo::find_project] + set output_base [file join $projectdir src docgen] + set codesource_path [file join $projectdir $project_subpath] + if {![file isdirectory $codesource_path]} { + puts stderr "WARNING punk::mix::commandset::doc unable to find codesource_path $codesource_path during do_docgen - skipping inline doctools generation" + return + } + if {[file isdirectory $output_base]} { + if {[catch { + file delete -force $output_base + }]} { + error "do_docgen failed to delete existing output base folder: $output_base" + } + } + file mkdir $output_base + + set matched_paths [punk::path::treefilenames -dir $codesource_path -exclude-paths {**/mix/templates/** **/project_layouts/** **/decktemplates/** **/_aside **/_aside/**} *.tm] + set count 0 + set newdocs [list] + set docgen_header_comments "" + append docgen_header_comments {[comment {--- punk::docgen generated from inline doctools comments ---}]} \n + append docgen_header_comments {[comment {--- punk::docgen DO NOT EDIT DOCS HERE UNLESS YOU REMOVE THESE COMMENT LINES ---}]} \n + append docgen_header_comments {[comment {--- punk::docgen overwrites this file ---}]} \n + foreach fullpath $matched_paths { + puts stdout "do_docgen processing: $fullpath" + set doctools [punk::docgen::get_doctools_comments $fullpath] + if {$doctools ne ""} { + set fname [file tail $fullpath] + set mod_tail [file rootname $fname] + set relpath [punk::path::relative $codesource_path [file dirname $fullpath]] + if {$relpath eq "."} { + set relpath "" + } + set tailsegs [file split $relpath] + set module_fullname [join $tailsegs ::]::$mod_tail + set target_docname $fname.man + set this_outdir [file join $output_base $relpath] + + if {[string length $fname] > 99} { + #output needs to be tarballed to do checksum change tests in a reasonably straightforward and not-too-terribly slow way. + #hack - review. Determine exact limit - test if tcllib tar fixed or if it's a limit of the particular tar format + #work around tcllib tar filename length limit ( somewhere around 100?) This seems to be a limit on the length of a particular segment in the path.. not whole path length? + #this case only came up because docgen used to path munge to long filenames - but left because we know there is a limit and renaming fixes it - even if it's ugly - but still allows doc generation. + #review - if we're checking fname - should also test length of whole path and determine limits for tar + package require md5 + if {[package vsatisfies [package present md5] 2- ] } { + set md5opt "-hex" + } else { + set md5opt "" + } + set target_docname [md5::md5 {*}$md5opt [encoding convertto utf-8 $fullpath]]_overlongfilename.man + puts stderr "WARNING - overlong file name - renaming $fullpath" + puts stderr " to [file dirname $fullpath]/$target_docname" + } + + file mkdir $this_outdir + puts stdout "saving [string length $doctools] bytes of doctools output from file $relpath/$fname" + set outfile [file join $this_outdir $target_docname] + set fd [open $outfile w] + fconfigure $fd -translation binary + puts -nonewline $fd $docgen_header_comments$doctools + close $fd + incr count + lappend newdocs [list $module_fullname $outfile] + } + } + return [list count $count docs $newdocs base $output_base] + } + + } +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## 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.1 +}] +return \ No newline at end of file diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/project-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/project-0.1.1.tm new file mode 100644 index 00000000..cb395eaa --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/project-0.1.1.tm @@ -0,0 +1,1178 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'deck 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.1 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::mix::commandset::project 0 0.1.1] +#[copyright "2023"] +#[titledesc {dec commandset - project}] [comment {-- Name section and table of contents description --}] +#[moddesc {deck CLI commandset - project}] [comment {-- Description at end of page heading --}] +#[require punk::mix::commandset::project] +#[description] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::mix::commandset::project +#[para]Import into an ensemble namespace similarly to the way it is done with punk::mix::cli e.g +#[example { +# namespace eval myproject::cli { +# namespace export * +# namespace ensemble create +# package require punk::overlay +# +# 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 +# } +#}] +#[para] Where the . in the above example is the prefix/command separator +#[para]The prefix ('project' in the above example) can be any string desired to disambiguate commands imported from other commandsets. +#[para]The above results in the availability of the ensemble command: ::myproject::cli project.new, which is implemented in ::punk::mix::commandset::project::new +#[para]Similarly, procs under ::punk::mix::commandset::project::collection will be available as subcommands of the ensemble as projects. +#[para] +#[subsection Concepts] +#[para] see punk::overlay + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::mix::commandset::project +#[list_begin itemized] + +package require Tcl 8.6- +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package punk::ns] +#[item] [package sqlite3] (binary) +#[item] [package overtype] +#[item] [package textutil] (tcllib) + + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::mix::commandset::project { + namespace export * + #*** !doctools + #[subsection {Namespace punk::mix::commandset::project}] + #[para] core commandset functions for punk::mix::commandset::project + #[list_begin definitions] + + proc _default {} { + package require punk::ns + set dispatched_to [lindex [info level 2] 0] ;#e.g ::punk::mix::cli::project + set dispatch_tail [punk::ns::nstail $dispatched_to] + set dispatch_ensemble [punk::ns::nsprefix $dispatched_to] ;#e.g ::punk::mix::cli + set sibling_commands [namespace eval $dispatch_ensemble {namespace export}] + #todo - get separator? + set sep "." + set result [list] + foreach sib $sibling_commands { + if {[string match ${dispatch_tail}${sep}* $sib]} { + lappend result $sib + } + } + return [lsort $result] + } + + + namespace eval argdoc { + set layout_dict [punk::cap::call_handler punk.templates get_itemdict_projectlayouts] + variable LAYOUTNAMES [dict keys $layout_dict] + } + punk::args::define { + @id -id ::punk::mix::commandset::project::new + @cmd -name "punk::mix::commandset::project::new" -help\ + "" + @leaders -min 1 -max 1 + project -type string -help\ + "Project name or path. + If just a name is given ... (todo)" + @opts + -type -default plain + -empty -default 0 -type boolean + -force -default 0 -type boolean + -update -default 0 -type boolean + -confirm -default 1 -type boolean + -layout -default "punk.project" -choices {${$::punk::mix::commandset::project::argdoc::LAYOUTNAMES}} + } + + proc new {newprojectpath_or_name args} { + #*** !doctools + # [call [fun new] [arg newprojectpath_or_name] [opt args]] + #new project structure - may be dedicated to one module, or contain many. + #create minimal folder structure only by specifying in args: -modules {} + 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 -errorprefix "punk mix project.new" + + + set defaults [list\ + -type plain\ + -empty 0\ + -force 0\ + -update 0\ + -confirm 1\ + -modules \uFFFF\ + -layout punk.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 "deck 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_layout [dict get $opts -layout] + set opt_update [dict get $opts -update] + # -- --- --- --- --- --- --- --- --- --- --- --- --- + 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 + if {$opt_force || $opt_update} { + #generally undesirable to add default project module during an update. + #user can use dev module.new manually or supply module name in -modules + set opt_modules [list] + } else { + set opt_modules [list [string tolower $projectname]] ;#default modules to lowercase as is the modern (tip 590) recommendation for Tcl + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- + + + #todo - install support binaries on a per-project basis in a way that doesn't impact machine (e.g not added to path) - cache in user config dir if possible, supply mechanism to clear cache + # + 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 deck features." + if {[string length [set scoop_prog [auto_execok scoop]]]} { + #restrict to windows? + set answer [util::askuser "scoop detected. Would you like deck 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 "-------------------------------------------" + } + + + package require punk::cap + if {[punk::cap::capability_has_handler punk.templates]} { + set layout_dict [punk::cap::call_handler punk.templates get_itemdict_projectlayouts] + } else { + put stderr "commandset::project::new WARNING - no handler available for the 'punk.templates' capability - template providers will be unable to provide layout locations" + return + } + if {[dict exists $layout_dict $opt_layout]} { + set layout_name $opt_layout + set layout_info [dict get $layout_dict $layout_name] + set layout_path [dict get $layout_info path] + set layout_sourceinfo [dict get $layout_info sourceinfo] + } else { + puts stderr "commandset::project::new - no exact match for specified layout-name $opt_layout found" + puts stderr "layout names found: [dict keys $layout_dict]" + return + + #todo - pick highest version layout that matches opt_layout if version not specified but multiple exist + + #set layout_name ... + #set layout_info .. + #set layout_path ... + } + + + + #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 $layout_path 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} { + set warnmsg "mix new WARNING: -update 1 was supplied. Will copy layout $layout_path using -update option to add missing items" + if {$opt_confirm} { + puts stderr $warnmsg + set msg "Do you want to proceed to possibly overwrite some existing files in $projectdir? Y|N" + set answer [util::askuser $msg] + 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 prompt." + return + } + } + puts stderr $warnmsg + } + + 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 + } + #review + set fossil_repo_file $repodb_folder/$projectname.fossil + } + + 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 + + puts stdout ">>> about to call punkcheck::install $layout_path $projectdir" + set resultdict [dict create] + set antipaths [list {*}{ + src/doc/* + src/doc/include/* + src/PROJECT_LAYOUTS_* + }] + + #set exclude_paths [list {*}{ + # _ignore_* + # **/_ignore_* + #}] + set exclude_paths [list {*}{ + }] + + #default -exclude-paths-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_path $projectdir -installer project.new -createempty 1 -overwrite ALL-TARGETS -exclude-paths [concat $antipaths $exclude_paths]] + } else { + puts stdout "copying layout files - (if source file changed)" + set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite installedsourcechanged-targets -exclude-paths [concat $antipaths $exclude_paths]] + } + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + + if {[file exists $layout_path/src/doc]} { + puts stdout "copying layout src/doc files (if target missing)" + set resultdict [punkcheck::install $layout_path/src/doc $projectdir/src/doc -createdir 1 -punkcheck-folder $projectdir -installer project.new -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no src/doc in source template - update not required" + } + + #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 exclude-paths_core - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized. + ## default_excludepaths_core [list "#*" "**/#*" "_aside" "**/_aside" "_build" "**/_build" ".git" "**/.git" ".fossil*" "**/.fossil*"] + set override_excludepaths_core [list #* **/#* _aside **/_aside .git **/.git] + if {[file exists $layout_path/.fossil-custom]} { + puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)" + set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -createempty 1 -punkcheck-folder $projectdir -installer project.new -exclude-paths-core $override_excludepaths_core -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no .fossil-custom in source template - update not required" + } + + if {[file exists $layout_path/.fossil-settings]} { + puts stdout "copying layout src/.fossil-settings files (if target missing or uncustomised)" + set resultdict [punkcheck::install $layout_path/.fossil-settings $projectdir/.fossil-settings -createdir 1 -createempty 1 -punkcheck-folder $projectdir -installer project.new -exclude-paths-core $override_excludepaths_core -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no .fossil-settings in source template - update not required" + } + + #scan all files in template + # + #TODO - deck command to substitute templates? + set templateinfo_list [punk::mix::commandset::layout::lib::layout_scan_for_template_files $opt_layout] + set stripprefix [file normalize $layout_path] + + set tagmap [list [lib::template_tag project] $projectname] + if {[llength $templateinfo_list]} { + puts stdout "Filling template file placeholders with the following tag map:" + foreach {placeholder value} $tagmap { + puts stdout " $placeholder -> $value" + } + } + foreach templateinfo $templateinfo_list { + lassign $templateinfo templatefullpath template_tagnames_found + set templatetail [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] + set fpath [file join $projectdir $templatetail] + foreach t $template_tagnames_found { + if {"%$t%" ni [dict keys $tagmap]} { + puts stderr "warning: No substitution available for tag: %$t% in $fpath" + } + } + + if {[file exists $fpath]} { + set fd [open $fpath r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd + set data2 [string map $tagmap $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" + } + } + + ::cd $projectdir + + if {[file exists $projectdir/src/modules]} { + foreach m $opt_modules { + #check if mod-ver.tm file or #modpod-mod-ver folder exist + set tmfile $projectdir/src/modules/$m-[punk::mix::util::tm_version_magic].tm + set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::tm_version_magic]/$m-[punk::mix::util::tm_version_magic].tm + + set has_tm [file exists $tmfile] + set has_pod [file exists $podfile] + #puts stderr "=====> has_tm: $has_tm has_pod: $has_pod" + if {!$has_tm && !$has_pod} { + #todo - option for -module_template - and check existence at top? or change opt_modules to be a list of dicts with configuration info -template -type etc + punk::mix::commandset::module::new -project $projectname -type $opt_type $m + } else { + #we should rarely if ever want to force any src/modules to be overwritten + if {$opt_force} { + if {$has_pod} { + set answer [util::askuser "OVERWRITE the src/modules file $podfile ?? (generally not desirable) Y|N"] + set overwrite_type zip + } else { + set answer [util::askuser "OVERWRITE the src/modules file $tmfile ?? (generally not desirable) Y|N"] + set overwrite_type $opt_type + } + if {[string tolower $answer] eq "y"} { + #REVIEW - all pods zip - for now + punk::mix::commandset::module::new -project $projectname -type $overwrite_type -force 1 $m + } + } + } + } + } 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" + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::mix::commandset::project ---}] + + namespace eval collection { + #*** !doctools + #[subsection {Namespace punk::mix::commandset::project::collection}] + #[para] commandset functions for operating with multiple projects. + #[para] It would usually be imported with the prefix "projects" and separator "." to result in commands such as: projects.detail + #[list_begin definitions] + namespace export * + namespace path [namespace parent] + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::_default + @cmd -name "punk::mix::commandset::project::collection::_default"\ + -summary\ + "List projects under fossil managment."\ + -help\ + "List projects under fossil management, showing fossil db location and number of checkouts" + @values -min 0 -max -1 + glob -type string -multiple 1 -default * + } + #e.g imported as 'projects' + proc _default {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::_default] + set globlist [dict get $argd values glob] + + #*** !doctools + #[call [fun _default] [arg glob...]] + #[para]List projects under fossil management, showing fossil db location and number of checkouts + #[para]The glob argument is optional unless option/value pairs are also supplied, in which case * should be explicitly supplied + #[para]glob restricts output based on the name of the fossil db file e.g s* for all projects beginning with s + #[para]The _default function is made available in the ensemble by the name of the prefix used when importing the commandset. + #[para]e.g + #[para] punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection + #[para]Will result in the command being available as projects + package require overtype + set db_projects [lib::get_projects {*}$globlist] + 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 Repo 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] {string length $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] + set file_idx 0 + foreach dbfile $col1_dbfiles { + set project_name "" + set project_code "" + set project_desc "" + set db_error "" + if {[file exists $dbfile]} { + if {[catch { + 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) + } + } + } errM]} { + set db_error $errM + } + catch {dbp close} + } else { + set db_error "fossil file $dbfile missing" + } + lappend col4_pnames $project_name + lappend col5_pcodes $project_code + dict lappend codes $project_code $dbfile + lappend col7_pdescs $project_desc + if {$db_error ne ""} { + lset col1_dbfiles $file_idx "[a+ web-red]$dbfile[a]" + } + incr file_idx + } + + 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 Repo 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] {string length $v}]] + set col3 [string repeat " " $widest3] + set title4 "Project Name" + set widest4 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col4_pnames] {string length $v}]] + set col4 [string repeat " " $widest4] + set title5 "Project Code" + set widest5 [tcl::mathfunc::max {*}[lmap v [concat [list $title5] $col5_pcodes] {string length $v}]] + set col5 [string repeat " " $widest5] + set title6 "Dup" + set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col6_dupids] {string length $v}]] + set col6 [string repeat " " $widest6] + set title7 "Description" + #set widest7 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col7_pdescs] {string length $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]] + } + + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::work + @cmd -name punk::mix::commandset::project::collection::work\ + -summary\ + "List projects with checkout directories."\ + -help\ + "Get project info by opening the central fossil config-db to determine + fossil database files for each project, and the known checkout folders. + If -detail is true, a second operation gathers file state information + for each checkout folder." + @leaders -min 0 -max 0 + -cd -type none -help\ + "If this flag is provided, after lsting, prompt the user to enter + the row number of the checkout to 'cd' into, or an option to cancel. + If there is only one project with only a single checkout, the + cd operation will occur without prompting unless -prompt was + also supplied." + -prompt -type none -help\ + "If there is only one checkout in the result, cause a prompt to be + raised instead of automatically peforming the cd operation. + Has no effect if -cd was not supplied, or if -cd is supplied and + there are multiple checkouts, in which case user is always prompted." + -detail -type boolean -default 0 -help\ + "Include file state information for each checkout in the resulting + table. This includes information such as which files are changed, + unchanged,new,missing or extra and can take a little more time to + gather as it must examine the filesystem for each checkout folder. + + Note that although the default is false - if only a single project + matches the glob pattern(s) then file state will be gathered for + each of its checkouts. Use an explicit -detail 0 if this is not + desired." + @values -min 0 -max -1 + glob -type string -multiple 1 -default * -optional 1 -help\ + "glob patterns used to search for project. The glob is applied against + the names of the fossil repository database files - not the project-name, + which is not available in the central fossil config-db. + Case insensitive." + } + proc work {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] + lassign [dict values $argd] leaders opts values received + package require sqlite3 + set globlist [dict get $values glob] + + set db_projects [lib::get_projects {*}$globlist] + #list of lists of the form: + #{fosdb fname workdirlist} + if {[llength $db_projects] == 0} { + puts stderr "::punk::mix::commandset::project::work No Repo DB name matches found for '$globlist'" + return "" + } + # -- --- --- --- --- --- --- + set opt_cd [dict exists $received -cd] + # -- --- --- --- --- --- --- + set opt_detail [dict get $opts -detail] + if {[dict exists $received -detail] && !$opt_detail} { + set opt_detail_explicit_zero 1 + } else { + set opt_detail_explicit_zero 0 + } + set opt_prompt [dict exists $received -prompt] + # -- --- --- --- --- --- --- + 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 and opt_detail is 0 and not explicit - retrieve workingdir state for each co + if {([llength [dict keys $fosdb_cache]] == 1)} { + if {!$opt_detail_explicit_zero} { + set opt_detail 1 + } + puts stderr "Result is from a single repo db [dict keys $fosdb_cache]" + } + if {$opt_detail} { + if {!$opt_detail_explicit_zero} { + set detailmsg "Use -detail 0 to omit file state" + } else { + set detailmsg "" + } + puts stderr "Gathering file state for [llength $workdirs] checkout folder(s). $detailmsg" + set c_rev [list] + set c_rev_iso [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_rev_iso [dict get $state_dict revision_iso8601] + 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 t0b "Revision iso8601" + set w0b [tcl::mathfunc::max {*}[lmap v [concat [list $t0] $c_rev_iso] {string length $v}]] + set c0b [string repeat " " $w0b] + 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::left $c0b $t0b] [overtype::right $c1 $t1] [overtype::right $c2 $t2] [overtype::right $c3 $t3] [overtype::right $c4 $t4] [overtype::right $c5 $t5]" + foreach r $c_rev iso $c_rev_iso u $c_unchanged c $c_changed n $c_new m $c_missing e $c_extra { + lappend col_states "[overtype::left $c0 $r] [overtype::left $c0b $iso] [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 "Repo 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 { + if {![file exists $wd]} { + set row [punk::ansi::a+ strike red]$row[a] + set wd [punk::ansi::a+ red]$wd[a] + } + 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 { + if {![file exists $wd]} { + set row [punk::ansi::a+ strike red]$row[a] + set wd [punk::ansi::a+ red]$wd[a] + } + 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 && !$opt_prompt} { + 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 [deck stat] + return $workingdir + } + } + } + return $msg + } + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::cd + @cmd -name punk::mix::commandset::project::collection::cd\ + -summary\ + "List projects with checkout directories and prompt for which checkout to cd to."\ + -help\ + "List projects with checkout directories and prompt for which checkout to cd to." + @leaders -min 0 -max 0 + }\ + [punk::args::resolved_def -types opts ::punk::mix::commandset::project::collection::work -detail]\ + { + -prompt -type none -help\ + "Prompt even when result contains only one checkout location as a possible cd target. + User will always be prompted if result contains more than one checkout." + @values -min 0 -max -1 + }\ + [punk::args::resolved_def -types values ::punk::mix::commandset::project::collection::work glob] + + proc cd {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] + work -cd {*}$args + } + + #*** !doctools + #[list_end] [comment {-- end collection namespace definitions --}] + } + + namespace eval lib { + proc template_tag {tagname} { + #todo - support different tagwrappers - it shouldn't be so likely to collide with common code idioms etc. + #we need to detect presence of tags intended for punk::mix system + #consider using punk::cap to enable multiple template-substitution providers with their own set of tagnames and/or tag wrappers, where substitution providers are all run + return [string cat % $tagname %] + } + punk::args::define { + @id -id ::punk::mix::commandset::project::lib::get_projects + @cmd -name punk::mix::commandset::project::lib::get_projects\ + -summary\ + "Return a 3-element list of projects referred to by central fossil config-db."\ + -help\ + "Get project info only by opening the central fossil config-db. + Each member of the returned list is a 3-element list of: + + The shortname is simply the name based on the root name of the fossil database, + it is not necessarily the project-name by which the project is referred to in the fossil + checkout databases." + @values -min 0 -max -1 + glob -type string -multiple 1 -default * -optional 1 -help\ + "case insensitive glob for the name of the fossil database." + } + proc get_projects {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::lib::get_projects] + set globlist [dict get $argd values glob] + + set fossil_prog [auto_execok fossil] + + set configdb [punk::repo::fossil_get_configdb] + + package require sqlite3 + ::sqlite3 fosconf $configdb + #set testresult [fosconf eval {select name,value from global_config;}] + #puts stderr $testresult + #list of repositories of the form repo: + #eg repo:C:/Users/someone/.fossils/tcl.fossil + + #the command: + # fossil all ignore /repo.fossil + #will remove the {repo:/repo.fossil 1} record from global_config + #but it leaves {ckout: /repo.fossil} records, even if such checkouts are closed + #when the folder itself at is removed - then commands such as 'fossil all ls -c' automatically remove the corresponding ckout: record. + + 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;}] + #list of entries like "ckout:C:/buildtcl/2024zig/tcl90/" + 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 -nocase -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 + } + + } + + + +} + + +#*** !doctools +#[manpage_end] + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::commandset::project [namespace eval punk::mix::commandset::project { + variable version + set version 0.1.1 +}] +return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/project-0.2.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/project-0.2.0.tm new file mode 100644 index 00000000..c48c95b9 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/project-0.2.0.tm @@ -0,0 +1,1178 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'deck 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.2.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::mix::commandset::project 0 0.2.0] +#[copyright "2023"] +#[titledesc {dec commandset - project}] [comment {-- Name section and table of contents description --}] +#[moddesc {deck CLI commandset - project}] [comment {-- Description at end of page heading --}] +#[require punk::mix::commandset::project] +#[description] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::mix::commandset::project +#[para]Import into an ensemble namespace similarly to the way it is done with punk::mix::cli e.g +#[example { +# namespace eval myproject::cli { +# namespace export * +# namespace ensemble create +# package require punk::overlay +# +# 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 +# } +#}] +#[para] Where the . in the above example is the prefix/command separator +#[para]The prefix ('project' in the above example) can be any string desired to disambiguate commands imported from other commandsets. +#[para]The above results in the availability of the ensemble command: ::myproject::cli project.new, which is implemented in ::punk::mix::commandset::project::new +#[para]Similarly, procs under ::punk::mix::commandset::project::collection will be available as subcommands of the ensemble as projects. +#[para] +#[subsection Concepts] +#[para] see punk::overlay + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::mix::commandset::project +#[list_begin itemized] + +package require Tcl 8.6- +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package punk::ns] +#[item] [package sqlite3] (binary) +#[item] [package overtype] +#[item] [package textutil] (tcllib) + + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::mix::commandset::project { + namespace export * + #*** !doctools + #[subsection {Namespace punk::mix::commandset::project}] + #[para] core commandset functions for punk::mix::commandset::project + #[list_begin definitions] + + proc _default {} { + package require punk::ns + set dispatched_to [lindex [info level 2] 0] ;#e.g ::punk::mix::cli::project + set dispatch_tail [punk::ns::nstail $dispatched_to] + set dispatch_ensemble [punk::ns::nsprefix $dispatched_to] ;#e.g ::punk::mix::cli + set sibling_commands [namespace eval $dispatch_ensemble {namespace export}] + #todo - get separator? + set sep "." + set result [list] + foreach sib $sibling_commands { + if {[string match ${dispatch_tail}${sep}* $sib]} { + lappend result $sib + } + } + return [lsort $result] + } + + + namespace eval argdoc { + set layout_dict [punk::cap::call_handler punk.templates get_itemdict_projectlayouts] + variable LAYOUTNAMES [dict keys $layout_dict] + } + punk::args::define { + @id -id ::punk::mix::commandset::project::new + @cmd -name "punk::mix::commandset::project::new" -help\ + "" + @leaders -min 1 -max 1 + project -type string -help\ + "Project name or path. + If just a name is given ... (todo)" + @opts + -type -default plain + -empty -default 0 -type boolean + -force -default 0 -type boolean + -update -default 0 -type boolean + -confirm -default 1 -type boolean + -layout -default "punk.project" -choices {${$::punk::mix::commandset::project::argdoc::LAYOUTNAMES}} + } + + proc new {newprojectpath_or_name args} { + #*** !doctools + # [call [fun new] [arg newprojectpath_or_name] [opt args]] + #new project structure - may be dedicated to one module, or contain many. + #create minimal folder structure only by specifying in args: -modules {} + 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 -errorprefix "punk mix project.new" + + + set defaults [list\ + -type plain\ + -empty 0\ + -force 0\ + -update 0\ + -confirm 1\ + -modules \uFFFF\ + -layout punk.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 "deck 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_layout [dict get $opts -layout] + set opt_update [dict get $opts -update] + # -- --- --- --- --- --- --- --- --- --- --- --- --- + 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 + if {$opt_force || $opt_update} { + #generally undesirable to add default project module during an update. + #user can use dev module.new manually or supply module name in -modules + set opt_modules [list] + } else { + set opt_modules [list [string tolower $projectname]] ;#default modules to lowercase as is the modern (tip 590) recommendation for Tcl + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- + + + #todo - install support binaries on a per-project basis in a way that doesn't impact machine (e.g not added to path) - cache in user config dir if possible, supply mechanism to clear cache + # + 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 deck features." + if {[string length [set scoop_prog [auto_execok scoop]]]} { + #restrict to windows? + set answer [util::askuser "scoop detected. Would you like deck 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 "-------------------------------------------" + } + + + package require punk::cap + if {[punk::cap::capability_has_handler punk.templates]} { + set layout_dict [punk::cap::call_handler punk.templates get_itemdict_projectlayouts] + } else { + put stderr "commandset::project::new WARNING - no handler available for the 'punk.templates' capability - template providers will be unable to provide layout locations" + return + } + if {[dict exists $layout_dict $opt_layout]} { + set layout_name $opt_layout + set layout_info [dict get $layout_dict $layout_name] + set layout_path [dict get $layout_info path] + set layout_sourceinfo [dict get $layout_info sourceinfo] + } else { + puts stderr "commandset::project::new - no exact match for specified layout-name $opt_layout found" + puts stderr "layout names found: [dict keys $layout_dict]" + return + + #todo - pick highest version layout that matches opt_layout if version not specified but multiple exist + + #set layout_name ... + #set layout_info .. + #set layout_path ... + } + + + + #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 $layout_path 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} { + set warnmsg "mix new WARNING: -update 1 was supplied. Will copy layout $layout_path using -update option to add missing items" + if {$opt_confirm} { + puts stderr $warnmsg + set msg "Do you want to proceed to possibly overwrite some existing files in $projectdir? Y|N" + set answer [util::askuser $msg] + 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 prompt." + return + } + } + puts stderr $warnmsg + } + + 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 + } + #review + set fossil_repo_file $repodb_folder/$projectname.fossil + } + + 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 + + puts stdout ">>> about to call punkcheck::install $layout_path $projectdir" + set resultdict [dict create] + set antipaths [list {*}{ + src/doc/* + src/doc/include/* + src/PROJECT_LAYOUTS_* + }] + + #set exclude_paths [list {*}{ + # _ignore_* + # **/_ignore_* + #}] + set exclude_paths [list {*}{ + }] + + #default -exclude-paths-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_path $projectdir -installer project.new -createempty 1 -overwrite ALL-TARGETS -exclude-paths [concat $antipaths $exclude_paths]] + } else { + puts stdout "copying layout files - (if source file changed)" + set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite installedsourcechanged-targets -exclude-paths [concat $antipaths $exclude_paths]] + } + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + + if {[file exists $layout_path/src/doc]} { + puts stdout "copying layout src/doc files (if target missing)" + set resultdict [punkcheck::install $layout_path/src/doc $projectdir/src/doc -createdir 1 -punkcheck-folder $projectdir -installer project.new -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no src/doc in source template - update not required" + } + + #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 exclude-paths_core - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized. + ## default_excludepaths_core [list "#*" "**/#*" "_aside" "**/_aside" "_build" "**/_build" ".git" "**/.git" ".fossil*" "**/.fossil*"] + set override_excludepaths_core [list #* **/#* _aside **/_aside .git **/.git] + if {[file exists $layout_path/.fossil-custom]} { + puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)" + set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -createempty 1 -punkcheck-folder $projectdir -installer project.new -exclude-paths-core $override_excludepaths_core -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no .fossil-custom in source template - update not required" + } + + if {[file exists $layout_path/.fossil-settings]} { + puts stdout "copying layout src/.fossil-settings files (if target missing or uncustomised)" + set resultdict [punkcheck::install $layout_path/.fossil-settings $projectdir/.fossil-settings -createdir 1 -createempty 1 -punkcheck-folder $projectdir -installer project.new -exclude-paths-core $override_excludepaths_core -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { + puts stdout "no .fossil-settings in source template - update not required" + } + + #scan all files in template + # + #TODO - deck command to substitute templates? + set templateinfo_list [punk::mix::commandset::layout::lib::layout_scan_for_template_files $opt_layout] + set stripprefix [file normalize $layout_path] + + set tagmap [list [lib::template_tag project] $projectname] + if {[llength $templateinfo_list]} { + puts stdout "Filling template file placeholders with the following tag map:" + foreach {placeholder value} $tagmap { + puts stdout " $placeholder -> $value" + } + } + foreach templateinfo $templateinfo_list { + lassign $templateinfo templatefullpath template_tagnames_found + set templatetail [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] + set fpath [file join $projectdir $templatetail] + foreach t $template_tagnames_found { + if {"%$t%" ni [dict keys $tagmap]} { + puts stderr "warning: No substitution available for tag: %$t% in $fpath" + } + } + + if {[file exists $fpath]} { + set fd [open $fpath r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd + set data2 [string map $tagmap $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" + } + } + + ::cd $projectdir + + if {[file exists $projectdir/src/modules]} { + foreach m $opt_modules { + #check if mod-ver.tm file or #modpod-mod-ver folder exist + set tmfile $projectdir/src/modules/$m-[punk::mix::util::tm_version_magic].tm + set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::tm_version_magic]/$m-[punk::mix::util::tm_version_magic].tm + + set has_tm [file exists $tmfile] + set has_pod [file exists $podfile] + #puts stderr "=====> has_tm: $has_tm has_pod: $has_pod" + if {!$has_tm && !$has_pod} { + #todo - option for -module_template - and check existence at top? or change opt_modules to be a list of dicts with configuration info -template -type etc + punk::mix::commandset::module::new -project $projectname -type $opt_type $m + } else { + #we should rarely if ever want to force any src/modules to be overwritten + if {$opt_force} { + if {$has_pod} { + set answer [util::askuser "OVERWRITE the src/modules file $podfile ?? (generally not desirable) Y|N"] + set overwrite_type zip + } else { + set answer [util::askuser "OVERWRITE the src/modules file $tmfile ?? (generally not desirable) Y|N"] + set overwrite_type $opt_type + } + if {[string tolower $answer] eq "y"} { + #REVIEW - all pods zip - for now + punk::mix::commandset::module::new -project $projectname -type $overwrite_type -force 1 $m + } + } + } + } + } 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" + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::mix::commandset::project ---}] + + namespace eval collection { + #*** !doctools + #[subsection {Namespace punk::mix::commandset::project::collection}] + #[para] commandset functions for operating with multiple projects. + #[para] It would usually be imported with the prefix "projects" and separator "." to result in commands such as: projects.detail + #[list_begin definitions] + namespace export * + namespace path [namespace parent] + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::_default + @cmd -name "punk::mix::commandset::project::collection::_default"\ + -summary\ + "List projects under fossil managment."\ + -help\ + "List projects under fossil management, showing fossil db location and number of checkouts" + @values -min 0 -max -1 + glob -type string -multiple 1 -default * + } + #e.g imported as 'projects' + proc _default {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::_default] + set globlist [dict get $argd values glob] + + #*** !doctools + #[call [fun _default] [arg glob...]] + #[para]List projects under fossil management, showing fossil db location and number of checkouts + #[para]The glob argument is optional unless option/value pairs are also supplied, in which case * should be explicitly supplied + #[para]glob restricts output based on the name of the fossil db file e.g s* for all projects beginning with s + #[para]The _default function is made available in the ensemble by the name of the prefix used when importing the commandset. + #[para]e.g + #[para] punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection + #[para]Will result in the command being available as projects + package require overtype + set db_projects [lib::get_projects {*}$globlist] + 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 Repo 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] {string length $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] + set file_idx 0 + foreach dbfile $col1_dbfiles { + set project_name "" + set project_code "" + set project_desc "" + set db_error "" + if {[file exists $dbfile]} { + if {[catch { + 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) + } + } + } errM]} { + set db_error $errM + } + catch {dbp close} + } else { + set db_error "fossil file $dbfile missing" + } + lappend col4_pnames $project_name + lappend col5_pcodes $project_code + dict lappend codes $project_code $dbfile + lappend col7_pdescs $project_desc + if {$db_error ne ""} { + lset col1_dbfiles $file_idx "[a+ web-red]$dbfile[a]" + } + incr file_idx + } + + 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 Repo 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] {string length $v}]] + set col3 [string repeat " " $widest3] + set title4 "Project Name" + set widest4 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col4_pnames] {string length $v}]] + set col4 [string repeat " " $widest4] + set title5 "Project Code" + set widest5 [tcl::mathfunc::max {*}[lmap v [concat [list $title5] $col5_pcodes] {string length $v}]] + set col5 [string repeat " " $widest5] + set title6 "Dup" + set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col6_dupids] {string length $v}]] + set col6 [string repeat " " $widest6] + set title7 "Description" + #set widest7 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col7_pdescs] {string length $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]] + } + + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::work + @cmd -name punk::mix::commandset::project::collection::work\ + -summary\ + "List projects with checkout directories."\ + -help\ + "Get project info by opening the central fossil config-db to determine + fossil database files for each project, and the known checkout folders. + If -detail is true, a second operation gathers file state information + for each checkout folder." + @leaders -min 0 -max 0 + -cd -type none -help\ + "If this flag is provided, after lsting, prompt the user to enter + the row number of the checkout to 'cd' into, or an option to cancel. + If there is only one project with only a single checkout, the + cd operation will occur without prompting unless -prompt was + also supplied." + -prompt -type none -help\ + "If there is only one checkout in the result, cause a prompt to be + raised instead of automatically peforming the cd operation. + Has no effect if -cd was not supplied, or if -cd is supplied and + there are multiple checkouts, in which case user is always prompted." + -detail -type boolean -default 0 -help\ + "Include file state information for each checkout in the resulting + table. This includes information such as which files are changed, + unchanged,new,missing or extra and can take a little more time to + gather as it must examine the filesystem for each checkout folder. + + Note that although the default is false - if only a single project + matches the glob pattern(s) then file state will be gathered for + each of its checkouts. Use an explicit -detail 0 if this is not + desired." + @values -min 0 -max -1 + glob -type string -multiple 1 -default * -optional 1 -help\ + "glob patterns used to search for project. The glob is applied against + the names of the fossil repository database files - not the project-name, + which is not available in the central fossil config-db. + Case insensitive." + } + proc work {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] + lassign [dict values $argd] leaders opts values received + package require sqlite3 + set globlist [dict get $values glob] + + set db_projects [lib::get_projects {*}$globlist] + #list of lists of the form: + #{fosdb fname workdirlist} + if {[llength $db_projects] == 0} { + puts stderr "::punk::mix::commandset::project::work No Repo DB name matches found for '$globlist'" + return "" + } + # -- --- --- --- --- --- --- + set opt_cd [dict exists $received -cd] + # -- --- --- --- --- --- --- + set opt_detail [dict get $opts -detail] + if {[dict exists $received -detail] && !$opt_detail} { + set opt_detail_explicit_zero 1 + } else { + set opt_detail_explicit_zero 0 + } + set opt_prompt [dict exists $received -prompt] + # -- --- --- --- --- --- --- + 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 and opt_detail is 0 and not explicit - retrieve workingdir state for each co + if {([llength [dict keys $fosdb_cache]] == 1)} { + if {!$opt_detail_explicit_zero} { + set opt_detail 1 + } + puts stderr "Result is from a single repo db [dict keys $fosdb_cache]" + } + if {$opt_detail} { + if {!$opt_detail_explicit_zero} { + set detailmsg "Use -detail 0 to omit file state" + } else { + set detailmsg "" + } + puts stderr "Gathering file state for [llength $workdirs] checkout folder(s). $detailmsg" + set c_rev [list] + set c_rev_iso [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_rev_iso [dict get $state_dict revision_iso8601] + 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 t0b "Revision iso8601" + set w0b [tcl::mathfunc::max {*}[lmap v [concat [list $t0] $c_rev_iso] {string length $v}]] + set c0b [string repeat " " $w0b] + 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::left $c0b $t0b] [overtype::right $c1 $t1] [overtype::right $c2 $t2] [overtype::right $c3 $t3] [overtype::right $c4 $t4] [overtype::right $c5 $t5]" + foreach r $c_rev iso $c_rev_iso u $c_unchanged c $c_changed n $c_new m $c_missing e $c_extra { + lappend col_states "[overtype::left $c0 $r] [overtype::left $c0b $iso] [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 "Repo 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 { + if {![file exists $wd]} { + set row [punk::ansi::a+ strike red]$row[a] + set wd [punk::ansi::a+ red]$wd[a] + } + 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 { + if {![file exists $wd]} { + set row [punk::ansi::a+ strike red]$row[a] + set wd [punk::ansi::a+ red]$wd[a] + } + 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 && !$opt_prompt} { + 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 [deck stat] + return $workingdir + } + } + } + return $msg + } + + punk::args::define { + @id -id ::punk::mix::commandset::project::collection::cd + @cmd -name punk::mix::commandset::project::collection::cd\ + -summary\ + "List projects with checkout directories and prompt for which checkout to cd to."\ + -help\ + "List projects with checkout directories and prompt for which checkout to cd to." + @leaders -min 0 -max 0 + }\ + [punk::args::resolved_def -types opts ::punk::mix::commandset::project::collection::work -detail]\ + { + -prompt -type none -help\ + "Prompt even when result contains only one checkout location as a possible cd target. + User will always be prompted if result contains more than one checkout." + @values -min 0 -max -1 + }\ + [punk::args::resolved_def -types values ::punk::mix::commandset::project::collection::work glob] + + proc cd {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] + work -cd {*}$args + } + + #*** !doctools + #[list_end] [comment {-- end collection namespace definitions --}] + } + + namespace eval lib { + proc template_tag {tagname} { + #todo - support different tagwrappers - it shouldn't be so likely to collide with common code idioms etc. + #we need to detect presence of tags intended for punk::mix system + #consider using punk::cap to enable multiple template-substitution providers with their own set of tagnames and/or tag wrappers, where substitution providers are all run + return [string cat % $tagname %] + } + punk::args::define { + @id -id ::punk::mix::commandset::project::lib::get_projects + @cmd -name punk::mix::commandset::project::lib::get_projects\ + -summary\ + "Return a 3-element list of projects referred to by central fossil config-db."\ + -help\ + "Get project info only by opening the central fossil config-db. + Each member of the returned list is a 3-element list of: + + The shortname is simply the name based on the root name of the fossil database, + it is not necessarily the project-name by which the project is referred to in the fossil + checkout databases." + @values -min 0 -max -1 + glob -type string -multiple 1 -default * -optional 1 -help\ + "case insensitive glob for the name of the fossil database." + } + proc get_projects {args} { + set argd [punk::args::parse $args withid ::punk::mix::commandset::project::lib::get_projects] + set globlist [dict get $argd values glob] + + set fossil_prog [auto_execok fossil] + + set configdb [punk::repo::fossil_get_configdb] + + package require sqlite3 + ::sqlite3 fosconf $configdb + #set testresult [fosconf eval {select name,value from global_config;}] + #puts stderr $testresult + #list of repositories of the form repo: + #eg repo:C:/Users/someone/.fossils/tcl.fossil + + #the command: + # fossil all ignore /repo.fossil + #will remove the {repo:/repo.fossil 1} record from global_config + #but it leaves {ckout: /repo.fossil} records, even if such checkouts are closed + #when the folder itself at is removed - then commands such as 'fossil all ls -c' automatically remove the corresponding ckout: record. + + 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;}] + #list of entries like "ckout:C:/buildtcl/2024zig/tcl90/" + 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 -nocase -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 + } + + } + + + +} + + +#*** !doctools +#[manpage_end] + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::commandset::project [namespace eval punk::mix::commandset::project { + variable version + set version 0.2.0 +}] +return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/templates-0.1.3.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/templates-0.1.3.tm index be6a2b131996a8c2a663ab15981dda93a1ea8a6a..c55d1cca54ff09fb84a5a825a50341d49fa07f44 100644 GIT binary patch delta 9080 zcmY+KMO2)DvTkYI1Hs*bdvJGmmjHnPf#B}&Bf;H*ySqzpcMsNhf@=ef>pORy_wHJ6 zxcB;MQZ=Z_7uyLR*$H2dM+`TDxZ6ZX?23e)3A1Yi9~e6*!UO~Ju?q%9G}+07Hq8VV zgqWs|2f}aKq{>7FzUNG;sZ)KUU7@Ze`?EO~h`0}t6(u?vxc8uz49jUsSYc?&YZbA* zQyLo5zoCR37Vlr|LpmxE(N^$?t4+e$T4>+S7vzWMDUsF^?xi!qC-K${e8G#K@ME3- z>t8`SJ5h(mI$wmws~~wG;)53@j5oX8wc`rom$X_KR_YW46lt;tPLGXFjAC5F@a%mo zCaZA6q^9q1^u}|HSfY-=Neo1!qD_b<9lbU5G8B@R(WY1>h{H#H%`XuE3Ndc;i$Yk? z$us0H=ZUfYFs=={#->q7H_jvo1snItD#_yHjUii8Rq>F4393AhCeKPg=7aKrrp*!HiV|;1CP;8rsWL7<#9xUP_fZvKhHnDB! zXp+hfwYpnr@4|OiAeq}NmgO{rNe(*>3P@pLfyIQmP9~hhiu1{Y(MoMIrRHRTMfd_n zn-xWaT008%3IopvOIZ}suAFliIOg)vML0I>j{K$oDGq|h`d`vqMAdk2l!Ox0?po!WxcLs>n9JQO-_g-p6yG;!KV1B7F5L^)tu<%; zn!{-^Bi#W7*Qa>2J`p$h+bje^=%VwEKc;ZKb9%-6#^s23HTcfh^Tzm)RdmO0__8^H zhC&RWKWed(ocrg{^f!(>_2M_Yx@5dXt^yf}LlNKD%)f&&e&u7oCbaX65zavo*Cyl( zHZHSUB*OtYG8OMAlRvlJt-exf$07@R7_Eo=JA-GQv8DFsF<`=dWc8R_mIQcZkB^Oe zpG|_L!5prGPPProjqR(Ab5=1a8Vw2(r+wl8g``?zIrcUrC$n)~gq+9e&h==_m1fIc zYulVB!tTZbrr4p~NG4(4PaFcHs%@#nurJXf?MMuOmhr|2_mv(tT#w3gVj%{Obq;}} zrH8h|G=hc+JK7A1t#re0NGOQp(8?mK?$k~AP zPJBq>n4eZzvB2XH+3#Xf9^~+oXng8j7aD?bR5v7?3FPqO7f|pOJLFUMxOX>6XE@o< zv=$GlMW195O;^cART3QkGdZZ?*`F^2`;89%V5cdhUQb@dq<(PdIJ0?FA=RIXr)H+W zGGy(-%Olkt?(;8;k)Y3Lal$qjXzjq1H~6s2vy193W<@{O95LVfm8#}$D^WewxhCm}~+K(*cHA<9@|H2|FgT zrjKjSkUg2Q3IAe+CX?X_jFgd;m(dD>9T`JI0v2sFb?ev@@&!v-I22MJ=wehHR8t<+ z=+x-d=95D%Tp~LW#85GpOiKX|pB$?~ceVh{H)C3~?A;x$%oO>Yukv8oXXLF6@_B#m z80ArYSs9Y?hq&w(-_PrRpom1(Cl3u9#rb4ctwTBTzmCT+K~WRR!WbcoR_^Dq+bV0^ zh&CqQjYDdGR0|*~freEX6iWtji2h)c{r%~n7|Zjrtm4A^-R%x-FaaIt_sENM?8Q@i z=2ghbFA`0GW9BpTY~6~a;e)s1-NJC_$a2-(+&_cYG}dLMtc6{&V0<=BswGQ+O=lH7 zDmoVp4U+bR;h>4879KbC?Dm0Pyh2y%8X7X!$O?uhO9bCG^fjJM9%!5c&NtbzqiV=} z#$e{>K~YldwTj*bM#BJ@_WQ4^50l_(fPtiH=vh*RqsI?2aA zv(02|Yjc-L2w0U09w9X8kvS&1Cpxx%Q^tlB+Ir)14Gi<<*8w=c-M&Kg>b~}@@|mn6 z3j{PnDW2tgRuM#zo!3C-H!_pHM(f`hIC#KGm=&Ah4b>l}B6F}t3ly)OVs*$%^yxX=uSGOgckZO`fqJh&darZ8n zyAp$ex#@TF$p_eHrqdn|FAabH;C5RH-Nbf#m3kx^kKCudBRd+mDPHgps9u{sc#>Vu zUA7@;uJOB1Qd(6)SSTCSSR&uEcGTI)RhiSnOOHRTN1eZP$gO}Wrg_mSaI3SXVR>br~3Yg>EH8VmGmPZ{u-OTKk~(>rpzha4R4EFb^_`D=qJ`AF}|iQw#qwUPwq zU8lsjaR;O@Gb)d5=a=0VG|tD&B(T!%Z^b zID;0Am8T-jSx1TsTwR}4+*uoqHb%ZE`yuAg7}!7RVr;5{G;vWXMxzN;1dcwkx8X#!bon%Q6(JI6qHvo^o~}OKYx4@{EaM z@^uRn(BZ7<>#@i~?6gAD`ji#7Z=?y>t!GS)Ls0#TKJHgIfL6NaNW$5CM~&jcPVVbX zzEuXfS+C_7-jSaOM&UI6EnjJp!i3es0s2W~mV9PH0~4agVgpB$t3J_3xLIm{>G}kx zKj^n{E;ts1vbmrW67;=6F;UllRI$-LB+y*943DuF%`8IggbvHzXfM=_! zXikg6CTeAdq-XH?xuL%fNZ^ZRjyO$6SqnImqzpCpzz*jsWa^TR``44?TPa~RsAnk@ z%PxmsL>`t&wIfq{`IGF>fmej#{Sz3|l}#+0k-^nJ(n}*vr$;oa6WwElp=8HBgNpzv z`?`U{hkS#Hh)Epb?lUjB>O`9dlvKFjg#Ik(X5EDUnB*_@T}waDtlD9MyH3CASXy8+}shlv;dUp$E`~M*H$8|cpfoQbVVXeaZQY0V}f>llaLAjjqBY3;B=vnNe>}l z{>CDf$UzP*CCYe(#(&%EM|Pno6Jyezu^l#)H9}}xqST)o{t(qE_g=34fc4`h94NC< zk@vPh@M?>r`J{NEiPBd%qdI0APm^TCAE}3D!e|ss-jb8R{V)jZlngILoxmx>XEE}8 z#r$5uQLOs!UM;s-@=By1@XAi4o~HByJ*rijwey|vzjs8lsRNFkn$nrcV}PhNiHEvQ4+>)WEHjL``1L#Ir!=b&J1!zG%<% zZXt?TL2*Q!RKvqpRcWBk`wEi=L3b^|VM(gu{n&u9Fv0OcrCQztp!j)xo1lfSeDc1| z*5YwH7B%#D&t$c-nz0z*kdERcl93kD=87=yE7jGB@C#G#S4_)givROzP<3fsP(HslV7U zB&G^_L8(!8b3ies^^dG(84do>y2v^3$q~0<;>!<3o78nXY>eY9BjmCLsrdP-8rdFJ zHPL9did*_t0B9Gl#!^{s=b``;V_i6$k^AAp4lJP(Q)d6uZ~A5OBWP~Bsoat)JW+JQ z4l@?#G0dtAe8&I6t<@+ZEHn$90%wMV8_r;oON2b~OJz*HCrsuP)lMin5M`yr^OX9r zZ1@su<8p9HVVfdKhxdMq;$O$ zkg6R<^G14hEEl&~DP(*y^cu1@nCk$asrQAAbUV3MW%%;1(QUBU=n#xF1wup5<(lp~ zPe{`ff0WYL3fAJ25irGLDku_yLq*vfsaLNOv?JM+2N<#YaU|oUVe*2*D7<*{xA6GdJ7(1x41S!Y!kQ?3pjr;ljQUQ+_K-#Lu{rYRrRFPn#!5< z-xOuLD#ms$U)r>U(#HZvmsKMdw3eMz;EAMeKC_KyndP2~`;s#kCyTIWC#eTuWm5K6L_i;r9LeTXGkS}6ioe}Y zlh@T$a@yNWJh#REqFi-JXJ%S^iczA`jiFNtCvju`kMz-^M1Fo*^g(l9~bZB;75jOCk zTUU^OwN7wg5`9S5~8&zyCCFu6uXqfRpm<6*~^0hBscPr{?l?0^ukJeWv= zJr4`a5-jIy3Xrnf)9Q0&=RI$j&#A=(Hx*#i!^PBTsE5BptJ)x9!axn0O#k6gCi~%$ zjKO3zB4Tk?4Cg|<6M5!@i>ZPRS(%{c@R5TX7oty-?jd#{5-~GhFgaaJ0S~?`v7xPV zVZ9|*GwOvYc01Fdb)G|yo(=%jpUqpm+kLU9{9HaJh8OlSW>V(y6k=VMsbbk1_~Vcy z0~}YFh~NA}2^;y&{ zk+a7$Z1}ODbCVn?VUHM!VauJabHv~(I33gEOvX-Gj=gV(QnOw!UEWx$Ur0r5V%sg=mDFCwcd}OnX1NqEoBRP&u&9jVjHvWPfZTQ zfAIUkDA}PFfjJiMw&#IWE?;4Q*YMNjQNfAK0W#%VRLNDljaR7@aE#+~(${I?*%*9@ z7S5tDzVBUC)%P=#w+9-y7bL@1MAc2-9>*s>6{!^#zdb$H8V@+ra{pL#>C?V6ELT#r zVx*f_uSukgbZ2dQ`SmmG-xTI;RAheTDiLVE06OrB2mRf4A~UplHa~jOjfIg~9gS9z z+&7N&@r&ypFv}C;m)qd#{Il;Cq&R&s|CmkT=OA<8POf~!`SZCE0d^lD^W$m{tMb8| z_T0vMnsSA=e*6GyY?lK^_CO{)6HIe$Hu(p+O)qxdy1 zXh-yPCs_pR{RZVL8WSx2oN1HoC#~Uf+&3oY2#-H(pQ=TiC?I%|ZL?{!MzUTi&-Ljv z)KsHg$1_xHex@c{cUN%dq5qmch=e{m=JHUyxzWAzVk-eabkC6SUe-iuj>NoAkl3bRuN(KN7XauqaIVueR;U@f5wa6zakLtt+`@9ny`zafh6$f$lbc6qXtG(0{m9@X;zsA$8F|MS&%MNqATVrQ%JFmFatMq@*LNH44iz4v zRhZ#|%wi1;<&2_QYT^qCb&sFp=HfZF_!z)dtnA{I1R`!j-7(3tIO~Riymtwj?UyKd zYo6Pwu9M&$a=B)j%XEL)qg^t47>M}l9;P7i!%jR`@0_jN#m%(Aq8he9SmGZCe7|T| zyQ02giD!|kG0y>ovK2zY`BsfN^&vZ}Sw(Jkkb!pd^VrJa5Z@re8PAVqr8Vzb!B}8i zxr15EW|Ejq-qz433Ztd{~B-ZsF{+&b$1 zZu9gdix+%&(Rg-SgG9h}W_^f7)5&?bTyVVbk$b31zYrYWu)7#b@|OUkth0vB;^ih~ ztJp9)+V6Kx!F&OerN4k0Ky!T9_cL$HB9EO|ct^jOlU|+&l|tzTeCwD9H-LIxog?Kf z?#s0`z5PCWJn3jiA}SE?xd%|}hWTOrCc`l6;-2Nh<-T|0ylE`NrH;g?oLf;9D%+wF zBySnLY^cYaX-Fz6uE;-Yx^iAH&ChyTnl~ZswiW?juyd!qGpvqOV2R z=P0WtsViX4h2~8BY*$%YZxnR;A>4d2?qM)|lr9NxC+D)7k3JHXo(gD<;eO>T1TGOg zv)%FP_)5Hn;#5)@w5{eo6@;gR!uV+6W0C_C(;FLXR*9bNy?TyOVK*jU`^moC&Ru;t z<)MkTXs{~<1T8W_g19ESxcasj@Db4gWikVhb-a!{WU<+-J+O2ad$Bgzb*lT#w^G#a z8bN;a0}(1ljnDuU6o5qG_dz(Jt|c17V>)L)kcb=Y6C1FOVE;)Q*6iNtJG?;C%q49N z$*RAbGs<=+0cAnzHepItD7-5&-yb|PyKqlA3utU@(-B^Q~P|ZZp5<*v~E>d9ls6>Gi#NhXbB)Z7{ zuC(@!H1m+&1?hg55oOxI*p@GgIvs8~aENG;0(@@!=yJxxmNF$W7T*VN8en0@{1_g$ z$V|p}!IO5NEDXV8g0uoSZ$z+T{tVJ|OsZ{wwNWCyN-gd7YPf(AZJOTYq>9le(vWel z&p21aO$%gH;P=4A%h2X{tx6(q*dFyfszjty1YMzz7uHAI`5R-!ZH z1EDwNnz^%Y4i6}yWJ3E@!MZ^wheI#?hludlPLreauVi4hS}1i-3%-k0)4>wT%3mFQ zcK#5wUbs6Q{#uRcA;*A_cMq>y5xcRIAHUZIGp5&G%}Y6Kv?Uy#s=rKt=eq5qyI|GG zE@7Je(E$B86;*|#ImFrXMzc}^&6*q(Q4e^PZV~Asyqb^24%dvo`x-E*WaR~zgNpAS zI&}r;OMQEN^Zpt@En$n1-6PPntj#=f&1X4{_{c>*2j;w?Bhx_6D08^1tPr_xtS53i2n zhynhkgl#eeOF=BXJTisf8l*A8+Gw*yt|HL8TOoJOdlX*3v@m*!pO+U;hna(spvw5# zc*<53l$jkLrR-D#&u7;{ir)CNP!jOdgD<>R$9jh$>}k0;xN5}c@UZg+*^yp7@H&`E zd_b88eZJc$O>K7G!$!GHKpT6Zy`L0|7&nXeB|T5 zkHdHcWk%IZJ&M{)!(3O<^P6m+bP-^JYs(Sg=-4gNN9xDS_LPrd53YX51iWzWr|@s& z7dszI*bxC9j>h}tq_7G~D`yG}#dR^vOn|t?Wo<6EWTPOq zzRHl;%t6ZhN6#W&k-O|`b=YQ$RI{-kbf*juk!NmMYqVBHoEc6lzFD;*m4#k2A=auA8_Dw zXdU=d0y)mLxnuxIO;4X|4M}K^3EDPR>ss-8I%Xel=X4fE!W|V%t4OxrjcI{)>= zNAlduH>b3}^t?Ez;FQHiZu%}+(9N^)&oco}G!Rw()%cqC*Fm;Z_8q+#3vGSC9TeIwOYW96+Jt0W6!E8N9dNoI2eKR_}XXS}PN*h9c z-qDqPaw;LWRqW5O0r|P=+-7r(yuXq^S0{dyqQ`+uDU4hRU$QYIV-$2@3b>r^A*N0_ z4ntre4((Dg%G+<>g{wLPQMIezP72yLxBo&QXSdv`hj}c=j0B7;<%_`vUDZKL%wH%S z@J&qBR>)@vQ$Qju`#M{|2QnkGtG*{lsZn*>H}&Ctp3Jh4!CR9h*FV*fo8qs6eUndPP`=^oWc)G5m!0rO`x9hc1b zMAKqL&7HtN6oj*tT)CJr6j8Y(g>$uYCf18$cHeg1q;y~G(#^~}VaT6nma$Df6I*6l zrL0mooKvsrQIhP!Uik{CE#E$gde&Mo0_}c`_`HZF$T0XnU%T%DkpI;b?tNe2*bEom zvHb;;DpT~BLgSIT=jq>1`p+@%(8+}?#NPxNAH>8tCQ?Q|#@Dm$`e;>5f`7vM%=26O zeb(g972blj|0(!Tilz7L*YPLt-eboi{MrRV!uWz=4EbuKOL%}GXzZaG8) z*);h|*48U5O;O-^4Gj54Xvfs4xm9C9oHQnoVFBUxSu~a_m0T7DCwe2*U#>T%-5R4+ zsd8V%%=)q4t}`i22AlDV^~ zrHCuMciXv}JH$eU`cv&wYx$BBdVMSG&6B}c;8Ojv7{VQ~}w{yr8FdeX`DvI2Ksn7PF z#;>9J?-~`2Bblc(m*WPUdyS$m=EEnTjPQ>>Ty)sAzTYE2Bm>zBE!Vo`Y-lD5+KA-o zB~!Nki8HtR8R-0qUfzk{hU#OrRx78p;XbPXbsTP_wbgqzo$|#zsU39`ec4~iA~@{r z+Fi`DMNR|vIr5zuzc~jO z^vz1~%<&l}iY3__@-o8=zj808LU4QtB@K8vU}9Tl1TqD)vtfk^R#^!Qq8vFRS-z^Q z3B-olS;{=Vg-ZRp%BMEYxjTN0$4Dd2o89J(qsKFYQ9S(e>1Lyo#WJb0i}}flKw()2 z$7vB3uhm~F^?~7*W*jq?eU+LcNJD5_pZt*qo*KhMA@I&kk}%6N#ebEIDqJUNn32O0 z3ct!02z&z`3PiSRS&Joy)0alzgrcVt#jD9PSxN%FgxY($xtkdta0y4pns_PU;?blk zhgR6qZgciC(?zt4UwM1e9(0KJY2G5S6(vHyoQUOWhKlgtcfTipD$nPET&*<@E-dUoG|6~9G ziX}dRvAKUAgt-ZGs}5E)0OSKATq?k42b#7xbn!xKF9t7H-;nbDj;BjGKV31)LDNgnGbzEDY(|qwjC?JGnDo46xh#E)QF&+pH;r$&11Jl%? zj6M24WsHj)+lx)Y6-ZKR~ixvyse*3At^VlU!Jc%W z19s2-*yh^HC^OO})hr%Yyz`V!=!+Ggf@Ac129FJJ)I3JGB!1Ecw~A5aMCb>#&}L4F z?MXhcR_~x+>B2kF;3!iUz&pnsv>2i)*&)@2Kf?+3&r0S}Ht-)PH55|Zy8imvON)yv zqKj%O015W2y1LGnULEQ*mk0fAuOAtqu%x|rf+ zpUVN#`tcW7gG{nCczLCcS*0Hnvf9-}m>ZEHuB_KoQH?}u4N`2weN8zMPkJX)<=5tK z6K^EYr93ukxVH4)R$o!K<~W3vf5nGDdO)HvIA$b$DoVIpW!D7X=|Ukn#w|3B+bmJ1CniT zskW_Y`No6d#QUVhX;qq~FeHO!h4zZ5Gu8EuNN%79lKL*wRRNQ6n>3}89&p^)h!60v}2Z@}VFQ8xkx%I8| zl$1in$w2uy=brU69O-0k1d;P3+uOc8<6?(B5z7v#z~jlLyEzpOZr{d(3k0~)U!6Gc zQXP&Hc^I-=XrYPuh}+73v*O?M?e}PO0?&<2iMRPPzld_c{LL)*46gPtd#DM!tXmZM zq3cj5Wuqv)Xl<4k`_IuZ($D)O&v&tsoiyud>tX7v3>SYphnKm63ja3&jciSXOT0i? zJc@PXj3U2C0Zvhi-Z-gB6A%Cev%h3K#C#sex)QJ~-WonEOC2Xwe-uF+`r1_3^(I6w zS68w3b=KmuU|LI{mDs`5ldJQJeGv)vIV6yuej`RdpB)4RVfuMecC3+pM%Vlhvw_Bvx@;WrzTuVJMnF! z6aEm~sGspDw-uyZr+5RId9L=d5zURau2LctPYd2c)Ke0M(}zP z#kOJyH!WG7V^coO@M8nqU4tb13+uk)OsuZL*zp|#jyh5jf<-CL=8xLZ>7QKhqkBht zOl{6HMr=;aTT;EbBon}I#p)aRhN(fNvEK4;fi7gevI#h)xM)o4R+PPhH?(cBp>an< z6D3x(#G7&T?n)Lu-WycG8suM+)A1T;HajrYHvOf3pJ?S%$R4z>4AdblW-wP$3CmW`Jo3~1z}eKMz%pKF9ug_$2j@@rTx z=J<7p0b}t^T*}fi9~1!77CYS-7xfOWep1m*d(Uat zMxCy{oee28CB9+IH!0VZ%eD}m&Wfqpvl+of3fTN)dT1wBD0#An1A~PP;Q#b@@JX-G zR$fu=T zH?wzX%=R86YDGcgsIC&dHuZeBU+H45-K||OR}0f$9)7ud;F-aP&u0GhTv~5J)kZh) zN}(o8qp#!g-Yv6UNx+cWW*9d9nh>tIn}dHGwem(l<0G&g-59 zH6>kaI3xR%iay`+m#qYoomHafHy}Tk!QMELYf_VJOmgD~xc&f`6CD<|3yvKn{D{Bc z?YIH#iS61xe#+6*v3H_iv%6{8m&~+XH_uG67T`U)iUBEdG|->HvQ7+`$Hpk0v3`QC z9vRsezY{d8rJKKvKisl!&iB7$y)Ct5k%?V$urVNQ3F|9}F}{CeE24_Q+|hNWx^QC( zS$&Ij{uqM%WNsi02z>$G&-~O_Nu1#l41EP?&Ef0GVUv2z#(|4fJw=+!n5hn(KJO~ z)2%zq9d}*EJJh47v<8wKx#}7Db2`U`uAJ4VJoki2G=hfu&J#PI3CUn*P~4umf)SRc z{Y>p}!k#?RV+q;P_wLbU$ak=%BX3m*2ymRBgmHHDkU2pOH}WzTh^$5Ag{SzwBz4ag z23LrscS?|RR%xT?3q<+vnt_^wcV=9g8Xz?e*j;(KF^*kt*d)hsN znp|QRqy|*#e+`KSwaRc%dD_BjeW&aU^-(AKyF;$%ah+6LG;n3-%$)kF(n!$p04o?+ z?B_(Q5XT+z2Khs_CU}Ul!=Y+HSV-n%n)7b&Q7${@-`IeG9e z425>J@eK(BDJOA0vO9105wR^BfX1`1M0dIs2TK*Z75mcDIcX0*?mWsS68a6sHYK** z013>ItJh}3G4n~2X|C)-Tc*h#%W>kkfoA{n)_HpK6}|d!az5#otv{yRbzfr8XS}3v z{-tW++EQv5(2aX{B68n4sG_E{a;L}r^Kx%#S#HJu*tT|ij;3AqLNCuzj%U~~Cvx>1tt zvx6A8(c2>iSF6ab`+<~gAE@Usx6k{<(XdpQE-GH4VfwpryPa^RbdX*c8xiCaRM5W;*<#DQQX~!QN#SFHUP3I^6~Axf2NQq zr~WOc^qVT;RP@`}oxNTxXUg&~%$ie?gEn9F5grz(wC4t6Bib$BOSB)ctZ&1BVs8a$ z?>z+1)))yo*-KUIp1di=5xZF0cw_#bTKF4G`av{}nZNiS`+=>>!G#EBczO6$CSD^< zi&~BX#hnMGtOnC7VPMuXBaUX0$`j#9sm!G1^LOxjS0tM<_$UXL_DP-E`l7joVPT(H zee^V)I@vHU7~;zl(GsQeNjZrjU6AD_(LRK2vQwiHeyI>;;(9Um)6J|!!4B7XOPWt3 zID84Y8gX0+KUqsCphbUEITq>uOI_wp1T`X&!nU(w5 zN7b(kp41FJ)!{MSVXxRzrFYoVvxSabR|6Lg_U*IIJ{WGROPZyQ+&Jynl#zG#L5z1~ zldESg?9h0>52*O?$;^>jO@sRfm`63_-q}LLmyDcF$4{m$9f8Z1pZol-{7Y!zR~H!> zU!GXeZZxpIMFXO3^sOV#-WyJT_tHu2$FP!~)3a!TjG!ye;B8c2>5sH$!itmMe&rUC z69fqla!31?lYj6KbjK7y1#L$lpkpb9ROrYxHi#Zx==`or@0X@D z7YG~r>APD$@9Li6pT@FGkyUx%b?|+=SEAAqDK=-;H=}lfH(=y!Do)FssToaiY?MSz zk>Feyof#!1HMfML)H?n4v4Br--56ta1c^ji?*>4X(spG1?P{S5mzR*jr>c|SV=0^U zrkquL14$ncG;o|-tuIi*VHGlMsIXf9?#^f|v1{1UwlE<~X2)Vr&?t+xtJCw;cb~8G zV&FzGF~T!H%S)~o8G{Oy3ZtWsIu)mc3SysnO1DW8(r-6}8+Ja-ozM)jd`Z7PWe}LUPqUpMZN#SzH1YvASsz9|F8C`3!c za$+NP{;G(Lua$M9)KC6fpP6m3;t`W=3w=bCi8nEHZ-&FcBL@;|J~x_2sHnsE1q+yB zC+8VA3}h{pMSSv0Y&}sPUHk&id}xvJzRIiHqxqD|vLJ9&ACU#~6Rrirs(8^z)zP%} z#W8kC6F-eF#NyxQls^NaP-*wlpfoc71K;U-&-$MgJIykelUY=y(zzUnAFt)}b@s;w z7wME{K78a&-mt*hM5{C!E%-L`5Mv9J>=ex8M&@V~yv~Vd0*KU0#X;sQ;yXy(pRg~? zS+aTaMw9ig}&c{(9K`po>nOhy8yzT0QB99X`^n>rzY|vcW4>*?HlY{ zgxAHR$CXw~@2TSEKtGuJk2oJAb~TArhcP6UQE9nMKRMCG;I_gmeW;waeF@-lso-*P zkO_3(?NRvnJ6)&yBi}XCmKRYv;_{*5L)hu|48b4J;u2%Y!28p}>H}p~_u@j{mW%5& z)WtQw!dw#$X-;8?$WEJoTEQHASx^?Emf2&P__>V&u2ZM-=0gu$bP}Z)ChpLTE-Ed0 zWh1}JAD$0s2p$~B`k5{bN?>5KyxgnfK*{FCDV{5dM13zCMZ$ltT21huScBGd(TY(| z<4yF$cd6MCblucR%zL_Li3om{r>2^g91^>;vEE0`ZK>OF6GF;08b~FA$i2uQ%1v}> zlDiEpJki@ zo`fb_+ebLl$n z)8!zF80kj*y2j0eyQU@YB!?eUwb6up%GLMB(T`pgyxAx@jyhQiIga0a`H>~?ShbWn zLG{{4EvM=ny>ZOUky{jZAw=tCygz9rU5!$;i;m^8^LuA^i5sXpGt);_AZaAy!0#YE zj-S(skl|6crIR)_7-#Kf%+2Mmm*_O5DdBPdD(ZFE;Rp;CoL71ia`O4y)_U_wN_@Q8 z5kHo9bPgI=+;HWK^qh8Qwp@rq!ZhGY+T;|ExL(tk^+hxxx@Un0Z|?-HBwQ$-ACcR!M?EB zRXpZ-4%KwaTN?H-CEiOA-rSo?6%MJB2|X_;(!};In617%(D@Xhd$w|gb%k1&x2$-h zD*3nCsC!5<&RLiAu)Be(!Q?36;U%b_vyM!}`m=`v7y*M7Cmcn{9seY`pSgvu6oG>Ei zu7gwG3p6l~JsRQV$Zes{*YHO2lEKRlj~@Crh^&T?1=B|}pge|15~6NI4%L{6ZT2McW3gnHQii6n&0fIHg39g5@m*Av3*)<=^^9ZU|+ zA9aN3RW`l*eMS4VQjmA~F}!4nt`%TQS+E`2z{Ah1=zkc>?0$M%z})dsjvN?oc9`B& z1a9Sv?|nB+BYsd%3ltL)nVWD?5RzMn~-D88c-#j8#wiLO#t zK;#p5DxtSlhf_N#DUT2J!Ac}I!68;Y0MZ~5zNOf1zP~__Q`_eu5oJ^l0#(DK#g$}n z99;!rZl!jrmSOC(4?-5%*w3C)q&N zU{)D9tY`d{gsw9kcaC_!er>SBYQ46pF_yxe~JS7zFw9WT>e zNkh3+adV0`qn#}HE6m8dFrZsn`XkMHs0Q5&y8l=&PbFpIaVYLeXz_`sk8G%7mU3BB zneN`Qc>I^SMJ|7&o^FC;J1hM~G-5x|>Soo}0FTbeo@{k*a>?(u`}Gmhe`GI*Li|N| z|8wc$4vmq$rIl-mvyRc!{N~6rm}9s2^Xfq)A|^kP^#rnNbl)(JpZh<(y?`2VLAwKG zikXclkDG^gm*?yB#ZaXwV3+)9xP_Wh(q2k}h<)+~9Wp6wfYw>T7$R*N%zWE8KgIMM z9wT+e>HDc7*rj5R(VCg@<$FK|57A+fzgq*L6uYh>Oue2zL)TxaT7_sa=Kdb*H?m+p zQ$5Rs1UmJ2I9HQmA!>WIyS@qxeG<${?-m11PJtpU&}tkRA7gMWKwY$t$2C|Sbx7$u zOm1l~c%r~WQER4Vj#v}qw^{KDH|izA^;-`xg-+fnaw38wMHtH zqFP_gA74w8sgSNR+Fq<52bOV#%)GNm$8xovS0GF7_6)xU05-P&^{|R^qK5b+-)C_P zyy(lUu1ep&RP(6R6mhB{8=HX$-7?t>4gz|`P3O?p1^QLAoOD$Duv3>g{3>8zxF}`2 ze8QHlJ@2{ndMtt!pV!R~MYF{2NlR|TxXt#{vPre}WD;ygm+nn4v_|*wU!8FYk%x`B zvL+-uh8lQ)%$Tog!%17k8Py|*>QslFuFTjEyp!>+w(WMVj#&N%MXFAO%q_Wc;ya{f z$B(pTCJ(|HQDFScjQL|;!_$Q+_F{VZy~iJ!!)JDrVs%Zc_j!(7e?C+YGW8o$v)trV z5T#2>a(!rEmrP~4q&vp7HIlRvYQdOJ3#$ER>5d)+@H?3y+ZF4Muzt4H%xenNEw@7y z40?+BqQ=70ouD4hGVNv$x@XH zzg20>|2*2bpwOgka@~JHkX->umCux83lsLdEx34}m7C8bRc|0S)Z+zV#ZU;tYe=-U zXYOZLu`Yhdh4y9GsH%XKo1NF?%yzrS!PcvQz)~g~z4F<>kEG6uv1W6a8v&J99RGK{ zxa%t~vL~dhef9q8p)TILA6F4uy+R2H zNr>~yNa00QLs;p!#xM2vTP5$4>aYa}e{%#W_^utUXeSB};0F^B;Q~cn2`p){*u|27 z{^!Zkb!5i%t8kVBhAuGka%?e8K^05vP~Sr(F3~eA)*#X)8OcbxD)z$;KUjuMauf5iCA zXsz#!r8l0vuBQcN4ilZ5@{r!0NP8FsfhVDmdVI{R zb$!;sjhYIJAoR|KyiI5GANJ~bkDkU346V$*Ek4z;eE1TC!Z&$En00qGViFKwjkgB8 z1}330!3x?Xvn##qoyT8{y6?qk9eZW1JJGj!7ja&tB_(U$MvTrg&Qz5G+r#l?sog@` zvXlik42!L6tOc!&4+SDuROIbb-o8O5QF3UGwV)l*gy0geta+y zTv%-ZjR}N*put$*Jes@G8nS>p>kgc@=Bq^ode5&{$M_*mgw5kjFJ*`-IYV|!(bNCJ z2IL5eKj;L?IxI~L@PF4?b<}>S4eF|E8Iki^Tc3I{UF7}_gY9lP<^DiZbkX=WjJ41% z-Ok2d{Ommwr)5ov@*qg3K zJUxl<&wOJTH=?c4^0`@?;uc!?AytVdvDx>Hel1AgmFL-#;~>01ipd zdUDSnawNiwl%A#3yTYrx__u$e?Y_U(-4=65XnC0+3F(zw@$XbG8q_SGU!l7PNBzC;ZCb1$}mmp zOp6T9KNKc!5xxb(_xT!0KMi}Z{~=EKcE@nIE^Xr51Z=+oC6iR)*P<725&I2o4cHXq zEhfT7of<3}Pi-@6n1m-G2`q z_6zj$qfurlAq9~P4fvia3F)y zAJt5bbw@qqFC&m?*pz(@4S%+>Vb!Sr3mh*gD8u1fviTTU4auCnq5)n7jGW1Yx}p+J zo%)@W3N7S(N6Fw4UVl0L(za&-N8YP7)B4Tqo*I@5D^@-Se+fO9*xUbs-%N#tW%p`%_r(63-GIth zj1xw4y4QPmR!%hb=lvXGS8+ZWy|L!JfjxZtN+?<-o(rT8Kxdv+^_ZH)K`Y<@Bgt_4 z1w8q;tq{r|orB#M%b%yDbDL>MX{0_MP1k>5@D(}hYP2yjDo7TX_5Nm$w(^3)>>WJT z1`T5+P4g;VnX7njMMYT9OA`KP+^w~ouyJ9)SD$j4xo}OHec0Cj`V^Ir^T7wN@NtkiRfc_=|`J? z+~)oNB2H)q8HfiI1)U`WnZtQJ{x8W3oxuSi5GczbAj13?1pj3(G7L=l)Bm9V18y`~ AIsgCw diff --git a/src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm index 230bad31..fa63e4fb 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm @@ -1444,52 +1444,34 @@ namespace eval punk::path { return [treefile_priv::walk_treefilenames_zipfs $state] } + punk::args::define { + @id -id ::punk::path::relative + @cmd -name punk::path::relative\ + -summary\ + "Compute the relative path from a reference path to a location path."\ + -help\ + "Taking two directory paths, a reference and a location, computes the path + of the location relative to the reference. + + Will return a single dot '.' if the paths are the same. + + Both paths must be the same type - ie both absolute or both relative. + + Matching is case sensitive. On windows, the drive-letter component (only) is + not case sensitive, so punk::path::relative c:/etc C:/etc returns '.'. + The part following the driveletter is case sensitive, so + punk::path::relative c:/etc C:/Etc returns ../Etc. + + On windows, if the paths are absolute and specify different volumes, + only the location will be returned." + @leaders -min 2 -max 2 + reference -type string -help\ + "The path from which the relative path to location is determined." + location -type string -help\ + "The location path which may be above or below the reference path." + } #maint warning - also in punkcheck proc relative {reference location} { - #*** !doctools - #[call [fun relative] [arg reference] [arg location]] - #[para] Taking two directory paths, a reference and a location, computes the path - # of the location relative to the reference. - #[list_begin itemized] - #[item] - #[para] Arguments: - # [list_begin arguments] - # [arg_def string reference] The path from which the relative path to location is determined. - # [arg_def string location] The location path which may be above or below the reference path - # [list_end] - #[item] - #[para] Results: - #[para] The relative path of the location to the reference path. - #[para] Will return a single dot "." if the paths are the same - #[item] - #[para] Notes: - #[para] Both paths must be the same type - ie both absolute or both relative - #[para] Case sensitive. ie punk::path::relative /etc /etC - # will return ../etC - #[para] On windows, the drive-letter component (only) is not case sensitive - #[example_begin] - # P% punk::path::relative c:/etc C:/etc - # - . - #[example_end] - #[para] The part following the driveletter is case sensitive so in the following cases it recognises the driveletter matches but not the tail - #[example_begin] - # P% punk::path::relative c:/etc C:/Etc - # - ../Etc - #[example_end] - #[para] On windows, if the paths are absolute and specifiy different volumes, only the location will be returned. - #[example_begin] - # P% punk::path::relative c:/etc d:/etc/blah - # - d:/etc/blah - #[example_end] - #[para] Unix-like examples: - #[example_begin] - # P% punk::path::relative /usr/local/etc/ /usr/local/etc/somewhere/below - # - somewhere/below - # P% punk::path::relative /usr/local/etc/somewhere /usr/local/lib/here - # - ../../lib/here - #[example_end] - #[list_end] - #see also kettle # Modified copy of ::fileutil::relative (tcllib) # Adapted to 8.5 ({*}). diff --git a/src/vfs/_vfscommon.vfs/modules/punk/path-0.2.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/path-0.2.0.tm new file mode 100644 index 00000000..68f0b744 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/path-0.2.0.tm @@ -0,0 +1,1611 @@ +# -*- 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::path 0.2.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::path 0 0.2.0] +#[copyright "2023"] +#[titledesc {Filesystem path utilities}] [comment {-- Name section and table of contents description --}] +#[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}] +#[require punk::path] +#[description] +#[keywords module path filesystem] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::path +#[para] Filesystem path utility functions +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::path +#[list_begin itemized] + +package require Tcl 8.6- +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {punk::args}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#namespace eval punk::path::class { + #*** !doctools + #[subsection {Namespace punk::path::class}] + #[para] class definitions + #if {[info commands [namespace current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + #} +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::path { + namespace export {[a-z]*} + #variable xyz + + #*** !doctools + #[subsection {Namespace punk::path}] + #[para] Core API functions for punk::path + #[list_begin definitions] + + # -- --- + #punk::path::normjoin + # - simplify . and .. segments as far as possible whilst respecting specific types of root. + # -- --- + #a form of file normalize that supports //xxx to be treated as server path names + #(ie regardless of unices ignoring (generally) leading double slashes, and regardless of windows volumerelative path syntax) + #(sometimes //server.com used as a short form for urls - which doesn't seem too incompatible with this anyway) + # -- --- + #This is intended to be purely a string analysis - without reference to filesystem volumes or vfs or zipfs mountpoints etc + #(but this also means we won't be able to resolve windows shortnames or dos device paths - so we will preserve those as they are) - review + #(It also means we can't resolve per drive working directories on windows - so we will preserve c: as is rather than converting to absolute - review) + # + #TODO - option for caller to provide a -base below which we can't backtrack. + #This is preferable to setting policy here for example regarding forcing no trackback below //servername/share + #Our default is to allow trackback to: + # :// + # :/ + # //./ (dos device volume) + # //server (while normalizing //./UNC/server to same) + # / (ordinary unix root) + # ./../ - (track back indefinitely on relpath as we are not resolving to anything physical and can't fully simplify the leading backtracks) + # + #The caller should do the file/vfs operations to determine this - not us. + # -- --- + #simplify path with respect to /./ & /../ elements - independent of platform + #NOTE: "anomalies" in standard tcl processing on windows: + #e.g file normalize {//host} -> c:/host (or e.g d:/host if we happen to be on another volume) + #file normalize {//host/share} -> //host/share + #This is because //host is treated as volume-relative in cmd/powershell and Tcl quite reasonably follows suit. + #This prevents cwd and windows commandlines from pointing to the server (above the share) + #Explorer however does allow pointing to the //server level and seeing shares as if they are directory entries. + #we are more interested in supporting the explorer-like behaviour - as while volumerelative paths are also useful on windows - they are lesser known. + #REVIEW. + #To get back to some consistent cross platform behaviour - we will treat //something as a root/volume i.e we can't backtrack above it with ".." + #note too that file split on UNC paths doesn't give a clear indication of the root + # file split //./UNC/server/share/subpath -> //./UNC server share subpath + # file split //server/share/subpath -> //server/share subpath + #TODO - disallow all change of root or change from relative path to absolute result. + #e.g normjoin relpath/../d:/secret should not return d:/secret - but ./d:/secret + # ================ + #known issues: + #1) + # normjoin d://a//b//c -> d://a/b/c + # This is because we don't detect specific schemes. ie it's treated the same as https://a/b/c -> https://a/b/c + # Not considered a problem - just potentially surprising. + # To avoid it we would have to enumerate possible schemes. + # As it stands a unix system could define a 'scheme' that happens to match windows style driveletters. Consider a 'feature' ? review. + # won't fix? + #2) + # normjoin https:///real.com/../fake.com -> https:///fake.com + # The extra slash means effectively our servername is empty - this is potentially confusing but probably the right thing to do here. + # It's a concern only if upstream treats the tripple slash in this case as valid and maps it to https:// - which would probably be bad anyway. + # won't fix (review) + #3) + #similarly + # normjoin //./UNC//server/share/subpath -> ///server/share/subpath (when 2 or more slashes directly after UNC) + # normjoin ///server/share -> ///server/share + #This is effectively an empty servername in the input with 'server' being pushed one level down - and the output is consistent + # possibly won't fix - review + #4) inconsistency + # we return normalized //server/share for //./UNC/server share + # but other dos device paths are maintained + # e.g //./c:/etc + # This is because such paths could contain alternate segment names (windows shortnames) which we aren't in a position to resolve. + # caller should + # #as with 'case' below - caller will need to run a post 'file normalize' + #5) we don't normalize case like file normalize does on windows platform. + # This is intentional. It could only be done with reference to underlying filesystem which we don't want here. + # + # ================ + # + #relpaths all end up with leading . - while not always the simplest form, this is ok. (helps stop inadvertent conversions to absolutes) + # Tests - TODO + # normjoin /d:/..//vfs:/test -> /vfs:/test (good - not converted to //vfs:/test) + + #normjoin c: should theoretically return current per drive working directory on c: + # - would need to use win32 GetFullPathName to resolve this. + proc normjoin {args} { + set args [lmap a $args {string map "\\\\ /" $a}] + set path [plainjoin {*}$args] + switch -exact -- $path { + "" { + return "" + } + / - // { + #treated in unixlike manner - (but leading doubleslashes with subsequent data are server indication) + #// not considered a servername indicator - but /// (for consistency) is. (empty servername?) + return / + } + /// { + #if this is effectively //$emptyservername/ + #then for consistency we should trail //=3 + #todo - shortcircuit that here? + } + } + # /// + set doubleslash1_posn [string first // $path] + + # -- --- --- temp warning on windows only - no x-platform difference in result + #on windows //host is of type volumerelative + # whereas //host/share is of type absolute + if {"windows" eq $::tcl_platform(platform) && [file pathtype $path] eq "volumerelative"} { + #volumerelative probably only occurs on windows anyway + if {$doubleslash1_posn == 0} { + #e.g //something where no further slashes + #review - eventually get rid of this warning and require upstream to know the appropriate usecase + puts stderr "Warning - ambiguous path $path - treating as server path - not 'volumerelative'" + } else { + # /something/etc + # /mnt/c/stuff + #output will retain leading / as if on unix. + #on windows - the result would still be interpreted as volumerelative if the caller normalizes it + } + } + # -- --- --- + + set is_relpath 0 + + #set path [string map [list \\ /] $path] + set finalparts [list] + set is_nonunc_dosdevice 0 + if {[punk::winpath::is_dos_device_path $path]} { + #review + if {[string range $path 4 6] eq "UNC"} { + #convert to 'standard' //server/... path for processing + set path "/[string range $path 7 end]" ;# //server/... + } else { + #error "normjoin non-UNC dos device path '$path' not supported" + #first segment after //./ or //?/ represents the volume or drive. + #not applicable to unix - but unlikely to conflict with a genuine usecase there (review) + #we should pass through and stop navigation below //./vol + #!!! + #not anomaly in tcl (continues in tcl9) + #file exists //./c:/test -> 0 + #file exists //?/c:/test -> 1 + #file exists //./BootPartition/Windows -> 1 + #file exists //?/BootPartition/Windows -> 0 + set is_nonunc_dosdevice 1 + } + } + + if {$is_nonunc_dosdevice} { + #dosdevice prefix //./ or //?/ - preserve it (without trailing slash which will be put back in with join) + set prefix [string range $path 0 2] + set tail [string range $path 4 end] + set tailparts [split $tail /] + set parts [concat [list $prefix] $tailparts] + set rootindex 1 ;#disallow backtrack below //./ + } else { + #note use of ordinary ::split vs file split is deliberate. + if {$doubleslash1_posn == 0} { + #this is handled differently on different platforms as far as 'file split' is concerned. + #e.g for file split //sharehost/share/path/etc + #e.g on windows: -> //sharehost/share path + #e.g on freebsd: -> / sharehost share path etc + #however..also on windows: file split //sharehost -> / sharehost + #normalize by dropping leading slash before split - and then treating first 2 segments as a root + #set parts [file split [string range $path 1 end]] + set parts [split $path /] + #assert parts here has {} {} as first 2 entries + set rootindex 2 + #currently prefer can backtrack to the //zipfs:/ scheme (below the mountpoint - to browse other mounts) + #alternative handling for //zipfs:/path - don't go below mountpoint + #but we can't determine just from string if mountpoint is direct subpath or a lower one e.g //zipfs:/arbitraryname/actualmountpoint + #review - more generally //:/path ? + #todo - make an option for zipfs and others to determine the 'base' + #if {"zipfs:" eq [lindex $parts 2]} { + # set rootindex 3 + #} + } else { + #path may or may not begin with a single slash here. + #treat same on unix and windows + set rootindex 0 + #set parts [file split $path] + set parts [::split $path /] + #e.g /a/b/c -> {} a b c + #or relative path a/b/c -> a b c + #or c:/a/b/c -> c: a b c + if {[string match *: [lindex $parts 0]]} { + if {[lindex $parts 1] eq ""} { + #scheme://x splits to scheme: {} x + set parts [concat [list [lindex $parts 0]/] [lrange $parts 2 end]] + #e.g {scheme:/ x} + set rootindex 1 ;#disallow below first element of scheme + } else { + set rootindex 0 + } + } elseif {[lindex $parts 0] ne ""} { + #relpath a/b/c + #set parts [linsert $parts 0 .] + ledit parts -1 -1 . + set rootindex 0 + #allow backtracking arbitrarily for leading .. entries - simplify where possible + #also need to stop possible conversion to absolute path + set is_relpath 1 + } + } + } + set baseparts [lrange $parts 0 $rootindex] ;#base below which we can't retreat via ".." + #puts stderr "-->baseparts:$baseparts" + #ensure that if our rootindex already spans a dotted segment (after the first one) we remove it + #must maintain initial . for relpaths to stop them converting to absolute via backtrack + # + set finalparts [list [lindex $baseparts 0]] + foreach b [lrange $baseparts 1 end] { + if {$b ni {. ..}} { + lappend finalparts $b + } + } + set baselen [expr {$rootindex + 1}] + if {$is_relpath} { + set i [expr {$rootindex+1}] + foreach p [lrange $parts $i end] { + switch -exact -- $p { + . - "" {} + .. { + switch -exact -- [lindex $finalparts end] { + . - .. { + lappend finalparts .. + } + default { + #lpop finalparts + ledit finalparts end end + } + } + } + default { + lappend finalparts $p + } + } + incr i + } + } else { + foreach p [lrange $parts $rootindex+1 end] { + if {[llength $finalparts] <= $baselen} { + if {$p ni {. .. ""}} { + lappend finalparts $p + } + } else { + switch -exact -- $p { + . - "" {} + .. { + #lpop finalparts ;#uses punk::lib::compat::lpop if on < 8.7 + ledit finalparts end end ;#uses punk::lib::compat::ledit if on < 8.7 + } + default { + lappend finalparts $p + } + } + } + } + } + #puts "==>finalparts: '$finalparts'" + # using join - {"" "" server share} -> //server/share and {a b} -> a/b + if {[llength $finalparts] == 1 && [lindex $finalparts 0] eq ""} { + #backtracking on unix-style path can end up with empty string as only member of finalparts + #e.g /x/.. + return / + } + set result [::join $finalparts /] + #normalize volumes and mountschemes to have trailing slash if no subpath + #e.g c: -> c:/ + #//zipfs: -> //zipfs:/ + if {[set lastchar [string index $result end]] eq ":"} { + if {$result eq "//zipfs:"} { + set result "//zipfs:/" + } else { + if {[string first / $result] < 0} { + set result $result/ + } + } + } elseif {[string match //* $result]} { + if {![punk::winpath::is_dos_device_path $result]} { + #server + set tail [string range $result 2 end] + set tailparts [split $tail /] + if {[llength $tailparts] <=1} { + #empty // or //servername + append result / + } + } + } elseif {[llength $finalparts] == 2} { + if {[string range [lindex $finalparts 0] end-1 end] eq ":/"} { + #e.g https://server/ -> finalparts {https:/ server} + #e.g https:/// -> finalparts {https:/ ""} + #scheme based path should always return trailing slash after server component - even if server component empty. + lappend finalparts "" ;#force trailing / + return [join $finalparts /] + } + } + if {[file extension [lindex $finalparts end]] eq ".lnk"} { + if {![catch {package require punk::winlnk}]} { + if {![catch {punk::winlnk::target $result} path]} { + return $path + } + } + } + return $result + } + + proc trim_final_slash {str} { + if {[string index $str end] eq "/"} { + return [string range $str 0 end-1] + } + return $str + } + + + #x-platform - punk::path::pathtype - can be used in safe interps - different concept of pathtypes to 'file pathtype' + # - no volumerelative + # - no lookup of file volumes (volume is a windows concept - but with //zipfs:/ somewhat applicable to other platforms) + # - /* as absolute (covers also //zipfs:/ (volume), //server , //./etc , //./UNC) + # - xxx:// as absolute (scheme) + # - xxx:/ or x:/ as absolute + # - x: xxx: -> as absolute (volume-basic or volume-extended) + + #note also on windows - legacy name for COM devices + # COM1 = COM1: + # //./COM1 ?? review + + proc pathtype {str} { + set str [string map "\\\\ /" $str] + if {[string index $str 0] eq "/"} { + #todo - look for //xxx:/ prefix (generalisation of //zipfs:/) as a 'volume' specifically {volume mount} ?? - review + # look for //server prefix as {absolute server} + # look for //./UNC/server or //?/UNC/server as {absolute server UNC} ? + # look for //./ as {absolute dosdevice} + return absolute + } + + #only firstsegment with single colon at last position (after some non empty string) counts as volume or scheme - review + #e.g a:b:/.. or a::/.. or :/.. is not treated as volume/scheme whereas ab:/ is. + set firstslash [string first / $str] + if {$firstslash == -1} { + set firstsegment $str + } else { + set firstsegment [string range $str 0 $firstslash-1] + } + if {[set firstc [string first : $firstsegment]] > 0} { + set lhs_firstsegment [string range $firstsegment 0 $firstc-1] + set rhs_firstsegment [string range $firstsegment $firstc+1 end] ;#exclude a:b/ etc + if {$rhs_firstsegment eq ""} { + set rhs_entire_path [string range $str $firstc+1 end] + #assert lhs_firstsegment not empty since firstc > 0 + #count following / sequence + set i 0 + set slashes_after_firstsegment "" ;#run of slashes *directly* following first segment + while {$i < [string length $rhs_entire_path]} { + if {[string index $rhs_entire_path $i] eq "/"} { + append slashes_after_firstsegment / + } else { + break + } + incr i + } + switch -exact -- $slashes_after_firstsegment { + "" - / { + if {[string length $lhs_firstsegment] == 1} { + return {absolute volume basic} + } else { + return {absolute volume extended} + } + } + default { + #2 or more / + #this will return 'scheme' even for c:// - even though that may look like a windows volume - review + return {absolute scheme} + } + } + } + } + #assert first element of any return has been absolute or relative + return relative + } + + + proc plain {str} { + set str [string map "\\\\ /" $str] + set pathinfo [punk::path::pathtype $str] + if {[lindex $pathinfo 0] eq "relative" && ![string match ./* $str]} { + set str ./$str + } + if {[string index $str end] eq "/"} { + if {[string map {/ ""} $str] eq ""} { + #all slash segment + return $str + } else { + if {[lindex $pathinfo 1] ni {volume scheme}} { + return [string range $str 0 end-1] + } + } + } + return $str + } + #purely string based - no reference to filesystem knowledge + #unix-style forward slash only + proc plainjoin {args} { + set args [lmap a $args {string map "\\\\ /" $a}] + #if {[llength $args] == 1} { + # return [lindex $args 0] + #} + set out "" + foreach a $args { + if {![string length $out]} { + append out [plain $a] + } else { + set a [plain $a] + if {[string map {/ ""} $out] eq ""} { + set out [string range $out 0 end-1] + } + + if {[string map {/ ""} $a] eq ""} { + #all / segment + append out [string range $a 0 end-1] + } else { + if {[string length $a] > 2 && [string match "./*" $a]} { + set a [string range $a 2 end] + } + if {[string index $out end] eq "/"} { + append out $a + } else { + append out / $a + } + } + } + } + return $out + } + proc plainjoin1 {args} { + if {[llength $args] == 1} { + return [lindex $args 0] + } + set out [trim_final_slash [lindex $args 0]] + foreach a [lrange $args 1 end] { + set a [trim_final_slash $a] + append out / $a + } + return $out + } + + #intention? + #proc filepath_dotted_dirname {path} { + #} + + proc strip_prefixdepth {path prefix} { + if {$prefix eq ""} { + return [norm $path] + } + return [file join {*}{ + } {*}[lrange {*}{ + } [file split [norm $path]] {*}{ + } [llength [file split [norm $prefix]]] {*}{ + } end + ] + ] + } + + + ## for comparison + #proc nsglob_as_re {glob} { + # #any segment that is not just * must match exactly one segment in the path + # set pats [list] + # foreach seg [nsparts_cached $glob] { + # switch -exact -- $seg { + # "" { + # lappend pats "" + # } + # * { + # #review - ::g*t will not find ::got:it (won't match single inner colon) - this should be fixed + # #lappend pats {[^:]*} + # #negative lookahead + # #any number of chars not followed by ::, followed by any number of non : + # lappend pats {(?:.(?!::))*[^:]*} + # } + # ** { + # lappend pats {.*} + # } + # default { + # set seg [string map {. [.]} $seg] + # if {[regexp {[*?]} $seg]} { + # #set pat [string map [list ** {.*} * {[^:]*} ? {[^:]}] $seg] + # set pat [string map [list ** {.*} * {(?:.(?!::))*[^:]*} ? {[^:]}] $seg] + # lappend pats "$pat" + # } else { + # lappend pats "$seg" + # } + # } + # } + # } + # return "^[join $pats ::]\$" + #} + proc pathglob_as_re {pathglob} { + #*** !doctools + #[call [fun pathglob_as_re] [arg pathglob]] + #[para] Returns a regular expression for matching a path to a glob pattern which can contain glob chars *|? in any segment of the path structure + #[para] Does not support square bracket globs or character classes. + #[para] ** matches any number of subdirectories. + #[para] e.g /etc/**/*.txt will match any .txt files at any depth below /etc (except directly within /etc itself) + #[para] e.g /etc/**.txt will match any .txt files at any depth below /etc + #[para] any segment that does not contain ** must match exactly one segment in the path + #[para] e.g the glob /etc/*/*.doc - will match any .doc files that are exactly one tree level below /etc + #[para] The pathglob doesn't have to contain glob characters, in which case the returned regex will match the pathglob exactly as specified. + #[para] Regular expression syntax is deliberateley not supported within the pathglob string so that supplied regex characters will be treated as literals + + + #todo - consider whether a way to escape the glob chars ? * is practical - to allow literals ? * + # - would require counting immediately-preceding backslashes + set pats [list] + foreach seg [file split $pathglob] { + if {[string range $seg end end] eq "/"} { + set seg [string range $seg 0 end-1] ;# e.g c:/ -> c: / -> "" so that join at end doesn't double up + } + switch -- $seg { + * {lappend pats {[^/]*}} + ** {lappend pats {.*}} + default { + set seg [string map [list ^ {\^} $ {\$} \[ {\[} \] {\]} ( {\(} ) {\)} \{ \\\{ \\ {\\}] $seg] ;#treat regex characters (or tcl glob square bracket chars) in the input as literals + #set seg [string map [list . {[.]}] $seg] + set seg [string map {. [.]} $seg] + if {[regexp {[*?]} $seg]} { + set pat [string map [list ** {.*} * {[^/]*} ? {[^/]}] $seg] + lappend pats "$pat" + } else { + lappend pats "$seg" + } + } + } + } + return "^[join $pats /]\$" + } + + punk::args::define { + @id -id ::punk::path::globmatchpath + @cmd -name punk::path::globmatchpath\ + -summary\ + "Match path to *|**|? glob patterns"\ + -help\ + "Return a boolean indicating whether the path matches the specialised glob pattern. + A pattern such as /usr/*/bin will match any path that has /usr as the first segment and bin as the third segment, + with any single segment in between. + A pattern such as /usr/**/bin will match any path that has /usr as the first segment and bin as the last segment, + with 1 or more segments in between (so it will not match /usr/bin). + A pattern such as /usr/** will match any path that has /usr as the first segment, with 1 or more segments + following (so it will not match /usr itself). + A pattern such as **/*.txt will match any path that ends with .txt, with 1 or more leading segments + (so it will not match test.txt or .txt). + A pattern such as ** will match any path. + The glob characters * and ? are the only special characters in the pathglob syntax. + - they are treated as glob characters regardless of where they appear in the pathglob string. + Note that this is different from other Tcl glob contexts where square brackets can be used. + The pathglob syntax treats other characters, including square brackets as literals. + For example, the pattern /usr/te?t will match /usr/test and /usr/text but not /usr/texxt, and the pattern /usr/te*t + will match /usr/test, /usr/teat, and /usr/teeeet but not /usr/te/t. + The pathglob syntax does not support escaping of glob characters - any glob characters in the pathglob are treated + as glob characters. For example, the pattern /usr/* will match any path that has /usr as the first segment and any + single segment as the second segment, but there is no way to specify a pattern that matches any path that has /usr + as the first segment and a literal * as the second segment. + Caller must ensure that file separator is forward slash. (e.g use file normalize on windows) + + options: + -nocase 0|1 (default 0 - case sensitive) + If -nocase is not supplied - default to case sensitive *except for driveletter* + ie - the driveletter alone in paths such as c:/etc will still be case insensitive. (ie c:/ETC/* will match C:/ETC/blah but not C:/etc/blah) + Explicitly specifying -nocase 0 will require the entire case to match including the driveletter. + " + @leaders + pathglob -type string -help "glob pattern to match path against. See [fun pathglob_as_re] for syntax of glob patterns" + path -type string -help "path to match against glob pattern" + @opts + -nocase -type boolean -default 0 -help\ + "case insensitive matching (default false - case sensitive) + - except for driveletter on windows which is always case insensitive + unless -nocase 0 is explicitly specified" + @values -min 0 -max 0 + } + # -id + proc globmatchpath {pathglob path args} { + #*** !doctools + #[call [fun globmatchpath] [arg pathglob] [arg path] [opt {option value...}]] + #[para] Return true if the pathglob matches the path + #[para] see [fun pathglob_as_re] for pathglob description + #[para] Caller must ensure that file separator is forward slash. (e.g use file normalize on windows) + #[para] + #[para] Known options: + #[para] -nocase 0|1 (default 0 - case sensitive) + #[para] If -nocase is not supplied - default to case sensitive *except for driveletter* + #[para] ie - the driveletter alone in paths such as c:/etc will still be case insensitive. (ie c:/ETC/* will match C:/ETC/blah but not C:/etc/blah) + #[para] Explicitly specifying -nocase 0 will require the entire case to match including the driveletter. + + set opts [dict create {*}{ + -nocase \uFFFF + }] + foreach {k v} $args { + switch -- $k { + -nocase { + dict set opts $k $v + } + default { + error "Unrecognised option '$k'. Known-options: [dict keys $opts]" + } + } + } + # -- --- --- --- --- --- + set opt_nocase [dict get $opts -nocase] + set explicit_nocase 1 ;#default to disprove + if {$opt_nocase eq "\uFFFF"} { + set opt_nocase 0 + set explicit_nocase 0 + } + # -- --- --- --- --- --- + if {$opt_nocase} { + return [regexp -nocase [pathglob_as_re $pathglob] $path] + } else { + set re [pathglob_as_re $pathglob] + if {$explicit_nocase} { + set ismatch [regexp $re $path] ;#explicit -nocase 0 - require exact match of path literals including driveletter + } else { + #caller is using default for -nocase - which indicates case sensitivity - but we have an exception for the driveletter. + set re_segments [file split $re] ;#Note that file split c:/etc gives {c:/ etc} but file split ^c:/etc gives {^c: etc} + set first_seg [lindex $re_segments 0] + if {[regexp {^\^(.{1}):$} $first_seg _match driveletter]} { + #first part of re is like "^c:" i.e a drive letter + set chars [string tolower $driveletter][string toupper $driveletter] + set re [join [concat "^\[$chars\]:" [lrange $re_segments 1 end]] /] ;#rebuild re with case insensitive driveletter only - use join - not file join. file join will misinterpret leading re segment. + } + #puts stderr "-->re: $re" + set ismatch [regexp $re $path] + } + } + return $ismatch + } + punk::args::define { + @id -id ::punk::path::subfolders1 + @cmd -name punk::path::subfolders1\ + -summary\ + "Listing of directories below supplied path."\ + -help\ + "List of folders below path. + The resulting list is unsorted." + @opts + -recursive -type none -help\ + "" + -exclude-paths -type list -default {} -help\ + "list of path patterns to exclude from results. + May include * and ** path segments e.g /usr/** + A single /*/ will match any single segment in the path, and a single /**/ will match any number of segments in the path. + + e.g to exclude any path with _aside as a segment in the middle: -exclude-paths **/_aside/** + i.e this would exclude /usr/_aside/etc and /usr/x/_aside/etc but not /usr/x/_aside or _aside/etc + + To exclude all paths with _aside as a segment anywhere: -exclude-paths { **/_aside/** **/_aside _aside/**} + " + #todo -depth + @values -min 0 -max 1 + path -type directory -optional 1 -help\ + "Path of folder. If not supplied current directory is used. + This may be a relative or absolute path. Relative paths are treated as relative to current directory. + When using relative paths - the result will also be relative paths with the same relative prefix. + (e.g if path is ../test - the results will be ../test/subfolder1 ../test/subfolder2 etc) + Patterns in -exclude-paths are matched against the resulting paths + (so should be written to match the same relative prefix if path is relative)" + } + + proc subfolders1 {args} { + #NOTE - this algorithm based on omit_only_patterns and prune_base_patterns was suggested by a 2026 AI model - it is apparent to this programmer that it is inadequate for the purpose. + #e.g consider subfolders1 -recursion -exclude {**/vfs/** **/src/**} + #This can still return something like c:/repo/etc/src/vfs - which should be excluded by the pattern **/src/** + #todo - review and fix properly. + set argd [punk::args::parse $args withid ::punk::path::subfolders1] + lassign [dict values $argd] leaders opts values received + set do_recursion [dict exists $received -recursive] + set exclude_paths [dict get $opts -exclude-paths] + if {"**" in $exclude_paths} { + #if ** is in exclude_paths - then we can skip all glob matching and just return empty list + #This is likely user error - so we'll be loud about it for now but will still return empty list rather than erroring. + #If user code is building exclude_paths dynamically - they can check for this case themselves and avoid the call to subfolders1 to suppress this message. + puts stderr "punk::path::subfolders1 Warning - exclude_paths contains '**' - all paths will be excluded" + return [list] + } + if {[dict exists $received path]} { + set path [dict get $values path] + } else { + set path [pwd] + } + + set all_subfolders [glob -nocomplain -directory $path -types d *] + + + #example of expected exclude_paths pattern behaviour when recursion is enabled: + # **/dirname -> omit /x/y/dirname, but still visit /x/y/dirname/* + + # **/dirname/* -> include /x/y/dirname and /x/y/dirname/a/b but omit directories that are a single level below /x/y/dirname such as /x/y/dirname/a + + #c:/** - would exclude all subfolders below c: but not c: itself + + # **/test/** - would exclude any path with test as a segment and all its subfolders + #- but not paths with test as a segment that is the final segment + + set folders [list] + set recurse_subdirs [list] + + foreach f $all_subfolders { + set include_in_results 1 + set allow_recurse 1 + foreach pat $exclude_paths { + set pat_parts [file split $pat] ;#note file split c:/test gives {c:/ test} but file split **/test gives {** test} + #also note that file split on windows treats forward slashes and backslashes the same. + #by using file split, we gain some flexibility in syntax of paths and patterns, + #but lose the ability to use backslashes as escapes to allow literal glob characters in path segments. + #This is almost always a non-issue on windows since * and ? are not valid in path segments there, and is rarely an issue on unix even though + # * and ? are technically valid in path segments, but it is inadvisable there anyway for compatibility with shells etc. + if {[llength $pat_parts] >= 2 && [lindex $pat_parts end] eq "**"} { + set base_pat [file join {*}[lrange $pat_parts 0 end-1]] + if {[globmatchpath $pat $f]} { + set include_in_results 0 + set allow_recurse 0 + } elseif {[globmatchpath $base_pat $f]} { + set allow_recurse 0 + } + } elseif {[globmatchpath $pat $f]} { + set include_in_results 0 + } + if {!$include_in_results && !$allow_recurse} { + break + } + } + if {$include_in_results} { + lappend folders $f + } + if {$allow_recurse} { + lappend recurse_subdirs $f + } + } + if {$do_recursion} { + foreach subdir $recurse_subdirs { + lappend folders {*}[subfolders1 -exclude-paths $exclude_paths -recursive $subdir] + } + } + return $folders + } + + namespace eval subfolder_priv { + proc classify_exclude_pattern {pat} { + set parts [file split $pat] + if {[llength $parts] >= 2 && [lindex $parts end] eq "**"} { + set boundary_pat [file join {*}[lrange $parts 0 end-1]] + return [dict create {*}{ + } pattern $pat {*}{ + } kind subtree {*}{ + } boundary_pat $boundary_pat {*}{ + } descend_pat $pat {*}{ + } + ] + } + if {[llength $parts] >= 2 && [lindex $parts end] eq "*"} { + return [dict create {*}{ + } pattern $pat {*}{ + } kind child_only {*}{ + } match_pat $pat {*}{ + } + ] + } + return [dict create {*}{ + } pattern $pat {*}{ + } kind exact {*}{ + } match_pat $pat {*}{ + } + ] + } + + proc compile_exclude_rules {exclude_paths} { + set rules [list] + foreach pat $exclude_paths { + lappend rules [classify_exclude_pattern $pat] + } + return $rules + } + + proc match_rule_at_node {rule path} { + set kind [dict get $rule kind] + switch -- $kind { + exact - child_only { + if {[::punk::path::globmatchpath [dict get $rule match_pat] $path]} { + return [dict create include_current 0 recurse_below 1 child_rules [list $rule]] + } + return [dict create include_current 1 recurse_below 1 child_rules [list $rule]] + } + subtree { + set descend_pat [dict get $rule descend_pat] + set boundary_pat [dict get $rule boundary_pat] + if {[::punk::path::globmatchpath $descend_pat $path]} { + return [dict create include_current 0 recurse_below 0 child_rules [list]] + } + if {[::punk::path::globmatchpath $boundary_pat $path]} { + return [dict create include_current 1 recurse_below 0 child_rules [list]] + } + return [dict create include_current 1 recurse_below 1 child_rules [list $rule]] + } + default { + error "Unknown exclude rule kind '$kind'" + } + } + } + + proc walk_subfolders {path rules do_recursion} { + set all_subfolders [glob -nocomplain -directory $path -types d *] + set folders [list] + foreach f $all_subfolders { + set include_current 1 + set recurse_below $do_recursion + set child_rules [list] + foreach rule $rules { + set outcome [match_rule_at_node $rule $f] + if {![dict get $outcome include_current]} { + set include_current 0 + } + if {![dict get $outcome recurse_below]} { + set recurse_below 0 + } + if {$do_recursion} { + lappend child_rules {*}[dict get $outcome child_rules] + } + if {!$include_current && !$recurse_below} { + break + } + } + if {$include_current} { + lappend folders $f + } + if {$do_recursion && $recurse_below} { + lappend folders {*}[walk_subfolders $f $child_rules $do_recursion] + } + } + return $folders + } + } + + punk::args::define { + @id -id ::punk::path::subfolders + @cmd -name punk::path::subfolders\ + -summary\ + "Listing of directories below supplied path."\ + -help\ + "List of folders below path. + The resulting list is unsorted. + " + @opts + -recursive -type none -help\ + "" + -exclude-paths -type list -default {} -help\ + "list of path patterns to exclude from results. + May include * and ** path segments e.g /usr/** + A single /*/ will match any single segment in the path, and a single /**/ will match any number of segments in the path. + + e.g to exclude any path with _aside as a segment in the middle: -exclude-paths **/_aside/** + i.e this would exclude /usr/_aside/etc and /usr/x/_aside/etc but not /usr/x/_aside or _aside/etc + + To exclude all paths with _aside as a segment anywhere: -exclude-paths { **/_aside/** **/_aside ./_aside/**} + " + #todo -depth + @values -min 0 -max 1 + path -type directory -optional 1 -help\ + "Path of base folder. If not supplied current directory is used. + This may be a relative or absolute path. Relative paths are treated as relative to current directory. + When using relative paths - the result will also be relative paths with the same relative prefix. + (e.g if path is ../test - the results will be ../test/subfolder1 ../test/subfolder2 etc) + Patterns in -exclude-paths are matched against the resulting paths + (so should be written to match the same relative prefix if path is relative)" + } + + proc subfolders {args} { + set argd [punk::args::parse $args withid ::punk::path::subfolders] + lassign [dict values $argd] leaders opts values received + set do_recursion [dict exists $received -recursive] + set exclude_paths [dict get $opts -exclude-paths] + if {"**" in $exclude_paths} { + puts stderr "punk::path::subfolders Warning - exclude_paths contains '**' - all paths will be excluded" + return [list] + } + if {[dict exists $received path]} { + set path [dict get $values path] + } else { + set path [pwd] + } + set compiled_rules [subfolder_priv::compile_exclude_rules $exclude_paths] + return [subfolder_priv::walk_subfolders $path $compiled_rules $do_recursion] + } + + namespace eval treefile_priv { + proc _path_segment_matches {pattern_segment path_segment} { + if {[::punk::path::globmatchpath $pattern_segment $path_segment]} { + return 1 + } + if {[string range $pattern_segment end end] eq "/" && [string range $path_segment end end] eq "/"} { + set root_probe __punk_path_root_probe__ + return [::punk::path::globmatchpath [file join $pattern_segment $root_probe] [file join $path_segment $root_probe]] + } + return 0 + } + + proc _pattern_prefix_viable_parts {pattern_parts path_parts} { + if {![llength $path_parts]} { + return 1 + } + if {![llength $pattern_parts]} { + return 0 + } + + set pattern_head [lindex $pattern_parts 0] + set path_head [lindex $path_parts 0] + + if {$pattern_head eq "**"} { + if {[_pattern_prefix_viable_parts [lrange $pattern_parts 1 end] $path_parts]} { + return 1 + } + return [_pattern_prefix_viable_parts $pattern_parts [lrange $path_parts 1 end]] + } + + if {[_path_segment_matches $pattern_head $path_head]} { + return [_pattern_prefix_viable_parts [lrange $pattern_parts 1 end] [lrange $path_parts 1 end]] + } + return 0 + } + + proc pattern_prefix_viable {pattern path} { + return [_pattern_prefix_viable_parts [file split $pattern] [file split $path]] + } + + proc pattern_boundary {pattern} { + set parts [file split $pattern] + if {[llength $parts] >= 2 && [lindex $parts end] eq "**"} { + return [file join {*}[lrange $parts 0 end-1]] + } + return "" + } + + proc directory_state {glob_paths path inherited_allbelow} { + if {$inherited_allbelow} { + return [dict create include_files 1 recurse_below 1 next_allbelow 1] + } + + set include_files 0 + set recurse_below 0 + set next_allbelow 0 + + foreach gp $glob_paths { + if {[::punk::path::globmatchpath $gp $path]} { + set include_files 1 + set recurse_below 1 + set next_allbelow 1 + break + } + + set boundary [pattern_boundary $gp] + if {$boundary ne "" && [::punk::path::globmatchpath $boundary $path]} { + set recurse_below 1 + set next_allbelow 1 + continue + } + + if {[pattern_prefix_viable $gp $path]} { + set recurse_below 1 + } + } + + return [dict create {*}{ + } include_files $include_files {*}{ + } recurse_below $recurse_below {*}{ + } next_allbelow $next_allbelow {*}{ + } + ] + } + + proc child_path_state {glob_paths child_path inherited_allbelow} { + if {$inherited_allbelow} { + return 1 + } + foreach gp $glob_paths { + if {[pattern_prefix_viable $gp $child_path]} { + return 1 + } + } + return 0 + } + + proc _sort_paths {paths sortmode} { + switch -- $sortmode { + ascii { + return [lsort $paths] + } + dictionary { + return [lsort -dictionary $paths] + } + natural { + return [natsort::sort $paths] + } + default { + return $paths + } + } + } + + proc _path_matches_any {patterns path} { + foreach pattern $patterns { + if {[::punk::path::globmatchpath $pattern $path]} { + return 1 + } + } + return 0 + } + + proc _tailbase_relative {tailbase path} { + if {$tailbase eq ""} { + return $path + } + return [::punk::path::relative $tailbase $path] + } + + proc _tailbase_match_path {tailbase path} { + set match_path [_tailbase_relative $tailbase $path] + if {$match_path eq "."} { + return "" + } + return $match_path + } + + proc _tailbase_relative_list {tailbase paths} { + if {$tailbase eq ""} { + return $paths + } + set relative_paths [list] + foreach path $paths { + lappend relative_paths [_tailbase_relative $tailbase $path] + } + return $relative_paths + } + + proc _retain_files {matches exclude_files sortmode} { + set retained [list] + foreach match $matches { + set skip 0 + set file_tail [file tail $match] + foreach anti $exclude_files { + if {[string match $anti $file_tail]} { + set skip 1 + break + } + } + if {!$skip} { + lappend retained $match + } + } + return [_sort_paths $retained $sortmode] + } + + proc _state_from_argd {argd} { + set opts [dict get $argd opts] + set values [dict get $argd values] + set received [dict get $argd received] + + if {[dict exists $received -directory]} { + set directory [dict get $opts -directory] + } else { + set directory [pwd] + } + + set glob_paths [dict get $opts -include-paths] + if {"*" in $glob_paths} { + set glob_paths {*} + } + + set sortmode [dict get $opts -sort] + if {$sortmode eq "natural"} { + package require natsort + } + + return [dict create {*}{ + depth 0 + subvector {} + allbelow 0 + } sort $sortmode {*}{ + } directory $directory {*}{ + } tailbase [dict get $opts -tailbase] {*}{ + } exclude_paths [dict get $opts -exclude-paths] {*}{ + } exclude_files [dict get $opts -exclude-files] {*}{ + } glob_paths $glob_paths {*}{ + } tailglobs [dict get $values tailglobs] {*}{ + } + ] + } + + proc walk_treefilenames {state} { + set opt_dir [dict get $state directory] + set opt_tailbase [dict get $state tailbase] + set depth [dict get $state depth] + set subvector [dict get $state subvector] + set callallbelow [dict get $state allbelow] + set opt_sort [dict get $state sort] + set opt_exclude_paths [dict get $state exclude_paths] + set opt_exclude_files [dict get $state exclude_files] + set opt_glob_paths [dict get $state glob_paths] + set tailglobs [dict get $state tailglobs] + + if {![file isdirectory $opt_dir]} { + return [list] + } + if {[string match //zipfs:/* $opt_dir]} { + return [walk_treefilenames_zipfs $state] + } + set opt_dir_match [_tailbase_match_path $opt_tailbase $opt_dir] + if {[_path_matches_any $opt_exclude_paths $opt_dir_match]} { + return [list] + } + + set files [list] + set dir_state [directory_state $opt_glob_paths $opt_dir_match $callallbelow] + if {[dict get $dir_state include_files]} { + if {[catch {glob -nocomplain -dir $opt_dir -type f -- {*}$tailglobs} matches]} { + puts stderr "treefilenames error while listing files in dir $opt_dir\n $matches" + set dirfiles [list] + } else { + #also match hidden files (e.g dotfiles on windows where glob -type f misses them) + if {![catch {glob -nocomplain -dir $opt_dir -types {hidden f} -- {*}$tailglobs} hidden_matches]} { + foreach h $hidden_matches { + if {$h ni $matches} { + lappend matches $h + } + } + } + set dirfiles [_retain_files $matches $opt_exclude_files $opt_sort] + } + lappend files {*}[_tailbase_relative_list $opt_tailbase $dirfiles] + } + + if {![dict get $dir_state recurse_below]} { + return $files + } + + if {[catch {glob -nocomplain -dir $opt_dir -type d *} dirdirs]} { + puts stderr "treefilenames error while listing subdirs in dir $opt_dir\n $dirdirs" + set dirdirs [list] + } + #also match hidden directories + if {![catch {glob -nocomplain -dir $opt_dir -types {hidden d} *} hidden_dirdirs]} { + foreach h $hidden_dirdirs { + switch -- $h { + "." - ".." {continue} + default { + if {$h ni $dirdirs} { + lappend dirdirs $h + } + } + } + } + } + set okdirs [list] + foreach dir $dirdirs { + if {![_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $dir]]} { + lappend okdirs $dir + } + } + + if {$opt_glob_paths eq "*"} { + set matchdirs $okdirs + } else { + set matchdirs [list] + foreach dir $okdirs { + if {$callallbelow || [child_path_state $opt_glob_paths [_tailbase_match_path $opt_tailbase $dir] $callallbelow]} { + lappend matchdirs $dir + } + } + } + + set finaldirs [_sort_paths $matchdirs $opt_sort] + set childallbelow [expr {$callallbelow || [dict get $dir_state next_allbelow]}] + set nextsubvector [list {*}$subvector [file tail $opt_dir]] + foreach dir $finaldirs { + set child_state [dict merge $state [dict create {*}{ + } directory $dir {*}{ + } depth [expr {$depth + 1}] {*}{ + } subvector $nextsubvector {*}{ + } allbelow $childallbelow {*}{ + } + ]] + lappend files {*}[walk_treefilenames $child_state] + } + return $files + } + + proc walk_treefilenames_zipfs {state} { + set opt_dir [dict get $state directory] + set opt_tailbase [dict get $state tailbase] + set opt_exclude_paths [dict get $state exclude_paths] + set opt_exclude_files [dict get $state exclude_files] + set opt_glob_paths [dict get $state glob_paths] + set opt_sort [dict get $state sort] + set tailglobs [dict get $state tailglobs] + + if {![string match [zipfs root]* $opt_dir]} { + error "treefilenames_zipfs can only be used on paths beginning with [zipfs root] on this systems" + } + set dir [string trimright $opt_dir "/"] + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $dir]]} { + return [list] + } + set dirlen [string length $dir] + set subpaths [zipfs list $dir/*] + set dirlist [list] + set skipdirs [list] + set filelist [list] + foreach sub $subpaths { + set tail [string range $sub $dirlen+1 end] + set tailparts [file split $tail] + set accum "" + set skipdir 0 + foreach tailpart [lrange $tailparts 0 end-1] { + append accum "/$tailpart" + set superpath "${dir}${accum}" + if {$superpath in $skipdirs} { + set skipdir 1 + break + } + if {$superpath ni $dirlist} { + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $superpath]]} { + lappend skipdirs $superpath + set skipdir 1 + break + } else { + lappend dirlist $superpath + } + } + } + if {!$skipdir} { + append accum "/[lindex $tailparts end]" + set finalpart "${dir}${accum}" + if {$finalpart ni $dirlist} { + if {[file type $finalpart] eq "file"} { + set file_tail [lindex $tailparts end] + set match 0 + if {"*" ni $tailglobs} { + foreach tailglob $tailglobs { + if {[string match $tailglob $file_tail]} { + set match 1 + break + } + } + } else { + set match 1 + } + if {$match && $opt_glob_paths ne "*"} { + set file_dir_match [_tailbase_match_path $opt_tailbase [file dirname $finalpart]] + set file_dir_state [directory_state $opt_glob_paths $file_dir_match 0] + set match [dict get $file_dir_state include_files] + } + if {$match} { + set skipfile 0 + foreach anti $opt_exclude_files { + if {[string match $anti $file_tail]} { + set skipfile 1 + break + } + } + if {!$skipfile} { + lappend filelist [_tailbase_relative $opt_tailbase $finalpart] + } + } + } else { + if {$finalpart ni $dirlist} { + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $finalpart]]} { + lappend skipdirs $finalpart + } else { + lappend dirlist $finalpart + } + } + } + } + } + } + return [_sort_paths $filelist $opt_sort] + } + } + + #todo - treefolders with similar search caps as treefilenames + + punk::args::define { + @id -id ::punk::path::treefilenames + @cmd -name punk::path::treefilenames\ + -summary\ + "List of filenames below supplied path."\ + -help\ + "List of filenames below path. + The resulting list is unsorted. + + The path globbing syntax supports *, ** and ? as glob characters in any segment of the path, with the following semantics: + * matches any single segment in the path + ** matches 1 or more segments in the path (so /usr/**/bin will match /usr/x/bin and user/x/y/bin but not /usr/bin ) + ? matches any single character in a single segment of the path (so /usr/te?t will match /usr/test and /usr/text but not /usr/texxt) + " + -directory -type directory -help\ + "folder in which to begin recursive scan for files." + -tailbase -type string -default "" -help\ + "if supplied, only the relative path compared to the tailbase will be returned for each file. + So if tailbase is /usr and a file is found at /usr/x/y/file.txt, the returned path for that file would be x/y/file.txt. + If tailbase is not supplied, the full path to each file will be returned. + + If tailbase is supplied, it should be a prefix of the directory supplied (or the directory itself) + The patterns in -exclude-paths should be written to match the returned paths (i.e with the tailbase prefix removed) if -tailbase is supplied. + If the tailbase is not a prefix of the directory supplied, the resulting paths may have /../ components in them to account for the difference, + but the behaviour is not well defined in this case and it is recommended to ensure tailbase is a prefix of the directory supplied if using -tailbase. + + see: punk::path::relative to compute relative paths + " + -sort -type any -default natural -choices {none ascii dictionary natural} + -exclude-paths -default {} -help\ + "list of path patterns to exclude + may include * and ** path segments e.g + /usr/** (exclude subfolders based at /usr but not + files within /usr itself) + **/_aside (exclude files where _aside is last segment) + **/_aside/* (exclude folders one below an _aside folder) + **/_aside/** (exclude files in all folders with _aside as a segment)" + -exclude-files -default {} + -include-paths -default {**} -help\ + "list of path patterns to include + may include * and ** path segments e.g + /usr/** (include files in subfolders based at /usr but not + files within /usr itself) + **/_aside (include files where _aside is last segment in the folder) + **/_aside/* (include files in folders one below an _aside folder) + **/_aside/** (include all files in folders with _aside as a segment)" + @values -min 0 -max -1 -optional 1 -type string + tailglobs -default * -multiple 1 -help\ + "Patterns to match against filename portion (last segment) of each file path + within the directory tree being searched." + } + + #todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/ + #then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase) + proc treefilenames {args} { + set argd [punk::args::parse $args withid ::punk::path::treefilenames] + set state [treefile_priv::_state_from_argd $argd] + return [treefile_priv::walk_treefilenames $state] + } + punk::args::set_idalias ::punk::path::treefilenames_zipfs ::punk::path::treefilenames + proc treefilenames_zipfs {args} { + #seems to be 2 or 3 times faster than treefilenames for //zipfs:/ paths - REVIEW + # is sort order the same? + set argd [punk::args::parse $args withid ::punk::path::treefilenames] + set state [treefile_priv::_state_from_argd $argd] + if {![file isdirectory [dict get $state directory]]} { + return [list] + } + return [treefile_priv::walk_treefilenames_zipfs $state] + } + + punk::args::define { + @id -id ::punk::path::relative + @cmd -name punk::path::relative\ + -summary\ + "Compute the relative path from a reference path to a location path."\ + -help\ + "Taking two directory paths, a reference and a location, computes the path + of the location relative to the reference. + + Will return a single dot '.' if the paths are the same. + + Both paths must be the same type - ie both absolute or both relative. + + Matching is case sensitive. On windows, the drive-letter component (only) is + not case sensitive, so punk::path::relative c:/etc C:/etc returns '.'. + The part following the driveletter is case sensitive, so + punk::path::relative c:/etc C:/Etc returns ../Etc. + + On windows, if the paths are absolute and specify different volumes, + only the location will be returned." + @leaders -min 2 -max 2 + reference -type string -help\ + "The path from which the relative path to location is determined." + location -type string -help\ + "The location path which may be above or below the reference path." + } + #maint warning - also in punkcheck + proc relative {reference location} { + #see also kettle + # Modified copy of ::fileutil::relative (tcllib) + # Adapted to 8.5 ({*}). + + #review - check volume info on windows.. UNC paths? + if {[file pathtype $reference] ne [file pathtype $location]} { + return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $reference] vs. [file pathtype $location], ($reference vs. $location)" + } + + #avoid normalizing if possible (file normalize *very* expensive on windows) + set do_normalize 0 + if {[file pathtype $reference] eq "relative"} { + #if reference is relative so is location + if {[regexp {[.]{2}} [list $reference $location]]} { + set do_normalize 1 + } + if {[regexp {[.]/} [list $reference $location]]} { + set do_normalize 1 + } + } else { + set do_normalize 1 + } + if {$do_normalize} { + set reference [file normalize $reference] + set location [file normalize $location] + } + + set save $location + set reference [file split $reference] + set location [file split $location] + + while {[lindex $location 0] eq [lindex $reference 0]} { + set location [lrange $location 1 end] + set reference [lrange $reference 1 end] + if {![llength $location]} {break} + } + + set location_len [llength $location] + set reference_len [llength $reference] + + if {($location_len == 0) && ($reference_len == 0)} { + # Cases: + # (a) reference == location + + set location . + } else { + # Cases: + # (b) ref is: ref/sub = sub + # loc is: ref = {} + + # (c) ref is: ref = {} + # loc is: ref/sub = sub + + while {$reference_len > 0} { + #set location [linsert $location 0 ..] + ledit location -1 -1 .. + incr reference_len -1 + } + set location [file join {*}$location] + } + return $location + } + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::path ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::path::lib { + namespace export * + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace punk::path::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::path::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +namespace eval punk::path::system { + #*** !doctools + #[subsection {Namespace punk::path::system}] + #[para] Internal functions that are not part of the API + + + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::path [namespace eval punk::path { + variable pkg punk::path + variable version + set version 0.2.0 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/vfs/_vfscommon.vfs/modules/punkcheck-0.2.0.tm b/src/vfs/_vfscommon.vfs/modules/punkcheck-0.2.0.tm new file mode 100644 index 00000000..351647d0 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punkcheck-0.2.0.tm @@ -0,0 +1,2479 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'dev 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 punkcheck 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + +package require punk::tdl +package require punk::path +package require punk::repo +package require punk::mix::util + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Punkcheck uses the TDL format which is a list of lists in Tcl format +# It is intended primarily for source build/distribution tracking within a punk project or single filesystem - with relative paths. +# +#see following article regarding the many problems with using mtime for build-decisions: https://apenwarr.ca/log/20181113 +# +namespace eval punkcheck { + namespace export {*}{ + uuid + installtrack + install + install_tm_files + install_non_tm_files + summarize_install_resultdict + } + + #exclude-paths entries match against the full relative path using globmatchpath. + #They may include ** to match across path segments and / to match within a segment. + #Each dir-seg pattern is expanded to both top-level and nested (**/) forms to preserve + #the "matches at any directory level" semantics of the former dir-seg mechanism. + variable default_excludepaths_core [list "#*" "**/#*" "_aside" "**/_aside" "_build" "**/_build" ".git" "**/.git" ".fossil*" "**/.fossil*"] + variable default_excludefiletail_core "" + #backward-compat: retained for callers that still read default_excludedirseg_core + variable default_excludedirseg_core [list "#*" "_aside" "_build" ".git" ".fossil*"] + + set has_twapi 0 + if {"windows" eq $::tcl_platform(platform)} { + set has_twapi [expr {![catch {package require twapi}]}] + } + if {$has_twapi} { + interp alias "" ::punkcheck::uuid "" ::twapi::new_uuid + } else { + catch {package require uuid} + interp alias "" ::punkcheck::uuid "" ::uuid::uuid generate + } + + proc default_excludepaths_core {} { + variable default_excludepaths_core + return $default_excludepaths_core + } + #backward-compat alias for the former segment-based default + proc default_excludedirseg_core {} { + variable default_excludedirseg_core + return $default_excludedirseg_core + } + proc default_excludefiletail_core {} { + variable default_excludefiletail_core + if {$default_excludefiletail_core eq ""} { + set default_excludefiletail_core [list "*.swp" "*[punk::mix::util::tm_version_magic]*" "*-buildversion.txt" ".punkcheck"] + } + return $default_excludefiletail_core + } + + + proc load_records_from_file {punkcheck_file} { + set record_list [list] + if {[file exists $punkcheck_file]} { + set tdlscript [punk::mix::util::fcat $punkcheck_file] + if {[catch { + set record_list [punk::tdl::prettyparse $tdlscript] + } errparse]} { + error "punkcheck::load_records_from_file failed to parse '$punkcheck_file'\n error:$errparse" + } + } + return $record_list + } + proc save_records_to_file {recordlist punkcheck_file {trigger {}} {debugchannel ""}} { + set newtdl [punk::tdl::prettyprint $recordlist] + set linecount [llength [split $newtdl \n]] + + if {$debugchannel ne "" && $trigger ne ""} { + puts $debugchannel "\x1b\[36mSaving [llength $recordlist] records as $linecount lines to file '$punkcheck_file' trigger: \x1b\[32m$trigger\x1b\[m" + } + #puts stdout $newtdl + set fd [open $punkcheck_file w] + chan configure $fd -translation binary + puts -nonewline $fd $newtdl + flush $fd + close $fd + return [list recordcount [llength $recordlist] linecount $linecount] + } + + + #todo - work out way to use same punkcheck file for multiple installers running concurrently. Thread? + #an installtrack objects represents an installation path from sourceroot to targetroot + #The source and target folders should be as specific as possible but it is valid to specify for example c:/ -> c:/ (or / -> /) if source and targets within the installation operation are spread around. + # + set objname [namespace current]::installtrack + if {$objname ni [info commands $objname]} { + package require oolib + + #FILEINFO record - target fileset with body records: INSTALL-RECORD,INSTALL-INPROGRESS,INSTALL-SKIPPED,DELETE-RECORD,DELETE-INPROGRESS,MODIFY-INPROGRESS,MODIFY-RECORD + #each FILEINFO body being a list of SOURCE records + oo::class create targetset { + variable o_targets + variable o_keep_installrecords + variable o_keep_skipped + variable o_keep_inprogress + variable o_records + constructor {args} { + #set o_records [oolib::collection create [namespace current]::recordcollection] + set o_records [list] + + } + + method as_record {} { + dict create {*}{ + } tag FILEINFO {*}{ + } -targets $o_targets {*}{ + } -keep_installrecords $o_keep_installrecords {*}{ + } -keep_skipped $o_keep_skipped {*}{ + } -keep_inprogress $o_keep_inprogress {*}{ + } body $o_records {*}{ + } + } + + #retrieve last completed record for the fileset ie exclude SKIPPED,INSTALL-INPROGRESS,DELETE-INPROGRESS,MODIFY-INPROGRESS + method get_last_record {fileset_record} { + set body [dict_getwithdefault $fileset_record body [list]] + set previous_records [lrange $body 0 end-1] + #get last previous that is tagged INSTALL-RECORD,MODIFY-RECORD,DELETE-RECORD + set revlist [lreverse $previous_records] + foreach rec $revlist { + switch -- [dict get $rec tag] { + INSTALL-RECORD - MODIFY-RECORD - DELETE-RECORD - VIRTUAL-RECORD { + return $rec + } + } + } + return [list] + } + } + + #instances created by an installtrack object in method start_event + #also in installtrack constructor - to represent existing events from the .punkcheck data + oo::class create installevent { + variable o_id + variable o_rel_sourceroot + variable o_rel_targetroot + variable o_ts_begin + variable o_ts_end + variable o_types + variable o_configdict + variable o_targets + variable o_operation + variable o_operation_start_ts + variable o_path_cksum_cache + variable o_fileset_record + variable o_installer ;#parent object + variable o_debugchannel + constructor {installer rel_sourceroot rel_targetroot args} { + set o_installer $installer + set o_debugchannel [$installer get_debugchannel] + set o_operation_start_ts "" + set o_path_cksum_cache [dict create] + set o_operation "" + set defaults [dict create {*}{ + -id "" + -tsbegin "" + -config {} + -tsend "" + -types {} + }] + set opts [dict merge $defaults $args] + if {[dict get $opts -id] eq ""} { + set o_id [punkcheck::uuid] + } else { + set o_id [dict get $opts -id] + } + if {[dict get $opts -tsbegin] eq ""} { + set o_ts_begin [clock microseconds] + } else { + set o_ts_begin [dict get $opts -tsbegin] + } + set o_ts_end [dict get $opts -tsend] + set o_types [dict get $opts -types] + set o_configdict [dict get $opts -config] + + set o_rel_sourceroot $rel_sourceroot + set o_rel_targetroot $rel_targetroot + } + destructor { + #puts "[self] destructor called" + } + method as_record {} { + set begin_seconds [expr {$o_ts_begin / 1000000}] + set tsiso_begin [clock format $begin_seconds -format "%Y-%m-%dT%H:%M:%S"] + if {$o_ts_end ne ""} { + set end_seconds [expr {$o_ts_end / 1000000}] + set tsiso_end [clock format $end_seconds -format "%Y-%m-%dT%H:%M:%S"] + } else { + set tsiso_end "" + } + + dict create {*}{ + } tag EVENT {*}{ + } -tsiso_begin $tsiso_begin {*}{ + } -ts_begin $o_ts_begin {*}{ + } -tsiso_end $tsiso_end {*}{ + } -ts_end $o_ts_end {*}{ + } -id $o_id {*}{ + } -source $o_rel_sourceroot {*}{ + } -targets $o_rel_targetroot {*}{ + } -types $o_types {*}{ + } -config $o_configdict {*}{ + } + } + method get_id {} { + return $o_id + } + method get_operation {} { + return $o_operation + } + method get_targets {} { + return $o_targets + } + method get_targets_exist {} { + set punkcheck_folder [file dirname [$o_installer get_checkfile]] + #puts stdout "### punkcheck glob -dir $punkcheck_folder -tails {*}$o_targets" + #targets can be paths such as punk/mix/commandset/module-0.1.0.tm - glob can search levels below supplied -dir + set existing [glob -nocomplain -dir $punkcheck_folder -tails {*}$o_targets] + + return $existing + } + method end {} { + set o_ts_end [clock microseconds] + } + method targetset_dict {} { + punk::records_as_target_dict [$o_installer get_recordlist] + } + + #related - installfile_begin + #call init before we know if we are going to run the operation vs skip + method targetset_init {operation targetset} { + set known_ops [list QUERY INSTALL MODIFY DELETE VIRTUAL] + if {[string toupper $operation] ni $known_ops} { + error "[self] add_target unknown operation '$operation'. Known operations $known_ops" + } + set o_operation [string toupper $operation] + + if {$o_operation_start_ts ne ""} { + error "[self] targetset_init $o_operation operation already in progress. Use targetset_finished or targetset_complete to finish." + } + set o_operation_start_ts [clock microseconds] + set seconds [expr {$o_operation_start_ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] + + set relativepath_targetset [list] + if {$o_operation eq "VIRTUAL"} { + foreach p $targetset { + lappend relativepath_targetset $p + } + } else { + foreach p $targetset { + if {[file pathtype $p] eq "absolute"} { + lappend relativepath_targetset [punkcheck::lib::path_relative $punkcheck_folder $p] + } else { + lappend relativepath_targetset $p + } + } + } + + + set fields [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $o_operation_start_ts {*}{ + } -installer [$o_installer get_name] {*}{ + } -eventid $o_id {*}{ + } + ] + + set o_targets [lsort -dictionary -increasing $relativepath_targetset] ;#exact sort order not critical - but must be consistent + + + set record_list [punkcheck::load_records_from_file $punkcheck_file] + + #--------------------------------------------------------------------------- + #load as dict to test for dupes + #set _targetdict [my targetset_dict] + if {[catch { + set _targetdict [punkcheck::recordlist::records_as_target_dict $record_list] + } errMsg]} { + error "targetset_init operation:$operation error verifying existing records from file $punkcheck_file. Error: $errMsg" + } + #--------------------------------------------------------------------------- + + set extractioninfo [punkcheck::recordlist::extract_or_create_fileset_record $o_targets $record_list] + set o_fileset_record [dict get $extractioninfo record] + set record_list [dict get $extractioninfo recordset] ;#if fileset wasn't present, same as original record_list, otherwise full recordset with the fileset record removed, ready for reinsertion. + set isnew [dict get $extractioninfo isnew] + set oldposition [dict get $extractioninfo oldposition] + unset extractioninfo + + #INSTALL-INPROGRESS will become INSTALL-RECORD or INSTALL-FAILED or INSTALL-SKIPPED upon finalisation + #-installer and -eventid keys are added here + set new_inprogress_record [dict create tag [string toupper $operation]-INPROGRESS {*}$fields -tempcontext [my as_record] body {}] + #set existing_body [dict_getwithdefault $o_fileset_record body [list]] + #todo - look for existing "-INPROGRESS" records - mark as failed or incomplete? + dict lappend o_fileset_record body $new_inprogress_record + + if {$isnew} { + lappend record_list $o_fileset_record + } else { + #set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record] + ledit record_list $oldposition -1 $o_fileset_record + } + if {$o_operation ne "QUERY"} { + punkcheck::save_records_to_file $record_list $punkcheck_file "targetset_init $o_operation [llength $targetset] targets" + } + return $o_fileset_record + + } + #operation has been started + #todo - upgrade .punkcheck format to hold more than just list of SOURCE entries in each record. + # - allow arbitrary targetset_startphase targetset_endphase calls to store timestamps and calculate elapsed time + method targetset_started {} { + set punkcheck_folder [file dirname [$o_installer get_checkfile]] + if {$o_operation eq "QUERY"} { + set fileinfo_body [dict get $o_fileset_record body] ;#body of FILEINFO record + set installing_record [lindex $fileinfo_body end] + + set ts_start [dict get $installing_record -ts] + set ts_now [clock microseconds] + set metadata_us [expr {$ts_now - $ts_start}] + + #?? + #JJJ + #dict set installing_record -metadata_us $metadata_us + dict set installing_record -ts_start_transfer $ts_now + + lset fileinfo_body end $installing_record + + return [dict set o_fileset_record body $fileinfo_body] + } else { + #legacy call + #saves to .punkcheck file + return [set o_fileset_record [punkcheck::installfile_started_install $punkcheck_folder $o_fileset_record]] + } + } + method targetset_end {status args} { + set defaults [dict create {*}{ + -note \uFFFF + }] + set known_opts [dict keys $defaults] + if {[llength $args] % 2} { + error "targetset_end arguments after status must be in the form of -flag value pairs. known flags: $known_opts" + } + set opts [dict merge $defaults $args] + if {[dict get $opts -note] eq "\uFFFF"} { + dict unset opts -note + } + + set status [string toupper $status] + set statusdict [dict create OK RECORD SKIPPED SKIPPED FAILED FAILED] + if {$o_operation_start_ts eq ""} { + error "[self] targetset_end $status - no current operation - call targetset_started first" + } + if {$status ni [dict keys $statusdict]} { + error "[self] targetset_end unrecognized status:$status known values: [dict keys $statusdict]" + } + if {![punkcheck::lib::is_file_record_inprogress $o_fileset_record]} { + error "targetset_end $status error: bad fileset_record - expected FILEINFO with last body element *-INPROGRESS" + } + set targetlist [dict get $o_fileset_record -targets] + if {$targetlist ne $o_targets} { + error "targetset_end $status error. targetlist mismatch between file : $targetlist vs $o_targets" + } + set operation_end_ts [clock microseconds] + set elapsed_us [expr {$operation_end_ts - $o_operation_start_ts}] + set file_record_body [dict get $o_fileset_record body] + set installing_record [lindex $file_record_body end] + set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] + set record_list [punkcheck::load_records_from_file $punkcheck_file] + if {[dict exists $installing_record -ts_start_transfer]} { + set ts_start_transfer [dict get $installing_record -ts_start_transfer] + set transfer_us [expr {$operation_end_ts - $ts_start_transfer}] + dict set installing_record -transfer_us $transfer_us + } + if {[dict exists $opts -note]} { + dict set installing_record -note [dict get $opts -note] + } + + dict set installing_record -elapsed_us $elapsed_us + dict unset installing_record -tempcontext + dict set installing_record tag "${o_operation}-[dict get $statusdict $status]" ;# e.g INSTALL-RECORD, INSTALL-SKIPPED + if {$o_operation in [list INSTALL MODIFY] && [dict get $statusdict $status] eq "RECORD"} { + #only calculate and store post operation target cksums on successful INSTALL or MODIFY, doesn't make sense for DELETE or VIRTUAL operations + set new_targets_cksums [list] ;#ordered list of cksums matching targetset order + set cksum_all_opts "" ;#same cksum opts for each target so we store it once + set ts_begin_cksum [clock microseconds] + foreach p $o_targets { + set tgt_cksum_info [punk::mix::base::lib::cksum_path [file join $punkcheck_folder $p]] + lappend new_targets_cksums [dict get $tgt_cksum_info cksum] + if {$cksum_all_opts eq ""} { + set cksum_all_opts [dict get $tgt_cksum_info opts] + } + } + set cksum_us [expr {[clock microseconds] - $ts_begin_cksum}] + dict set installing_record -targets_cksums $new_targets_cksums + dict set installing_record -cksum_all_opts $cksum_all_opts + dict set installing_record -cksum_us $cksum_us + } + lset file_record_body end $installing_record + dict set o_fileset_record body $file_record_body + set o_fileset_record [punkcheck::recordlist::file_record_prune $o_fileset_record] + + set oldrecordinfo [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $oldrecordinfo position] + if {$old_posn == -1} { + lappend record_list $o_fileset_record + } else { + lset record_list $old_posn $o_fileset_record + } + if {$o_operation ne "QUERY"} { + punkcheck::save_records_to_file $record_list $punkcheck_file "targetset_end $o_operation $status [llength $o_targets] targets" + } + set o_operation_start_ts "" + set o_operation "" + return $o_fileset_record + } + #can supply empty cksum value + # - that will influence the opts used if there is no existing install record + method targetset_cksumcache_set {path_cksum_dict} { + set o_path_cksum_cache $path_cksum_dict + } + method targetset_cksumcache_configure {path {cksuminfodict {}}} { + if {$cksuminfodict eq {}} { + if {[dict exists $o_path_cksum_cache $path]} { + return [dict get $o_path_cksum_cache $path] + } else { + return + } + } + dict for {k v} $cksuminfodict { + switch -- $k { + cksum - opts {} + default { + error "targetset_cksumcache_configure error. Unknown dict value $k. Allowed values {cksum opts}" + } + } + } + dict set o_path_cksum_cache $path $cksuminfodict + } + method targetset_addsource {source_path} { + set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] + if {[file pathtype $source_path] eq "absolute"} { + set rel_source_path [punkcheck::lib::path_relative $punkcheck_folder $source_path] + } else { + set rel_source_path $source_path + } + + #installfile_add_source_and_fetch_metadata accepts list of {cksum opt } dictionaries - although we only have one per path from our configured cksumcache + if {[dict exists $o_path_cksum_cache $rel_source_path]} { + set path_cksum_caches [list [dict get $o_path_cksum_cache $rel_source_path]] + } else { + set path_cksum_caches [list] + } + set o_fileset_record [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $rel_source_path $o_fileset_record $path_cksum_caches] + #JJJ - update -metadata_us here? + + } + method targetset_last_complete {} { + #retrieve last completed record for the fileset ie exclude SKIPPED,INSTALL-INPROGRESS,DELETE-INPROGRESS,MODIFY-INPROGRESS + set body [punkcheck::dict_getwithdefault $o_fileset_record body [list]] + set previous_records [lrange $body 0 end] + #get last that is tagged INSTALL-RECORD,MODIFY-RECORD,DELETE-RECORD + set revlist [lreverse $previous_records] + foreach rec $revlist { + if {[dict get $rec tag] in [list "INSTALL-RECORD" "MODIFY-RECORD" "DELETE-RECORD" "VIRTUAL-RECORD"]} { + return $rec + } + } + return [list] + + } + method targetset_source_changes {} { + punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $o_fileset_record body] end] + } + + } + + + oo::class create installtrack { + variable o_name + variable o_tsiso + variable o_ts + variable o_keep_events + variable o_checkfile + variable o_sourceroot + variable o_rel_sourceroot + variable o_targetroot + variable o_rel_targetroot + variable o_record_list + variable o_active_event + variable o_events + variable o_debugchannel + constructor {installername punkcheck_file {debugchannel ""}} { + set o_debugchannel $debugchannel + set o_active_event "" + set o_name $installername + + set o_checkfile [file normalize $punkcheck_file] + set o_sourceroot "" + set o_targetroot "" + set o_rel_sourceroot "" + set o_rel_targetroot "" + set o_record_list [list] + + #todo - validate punkcheck file location further?? + set punkcheck_folder [file dirname $o_checkfile] + if {![file isdirectory $punkcheck_folder]} { + error "[self] constructor error. Folder for punkcheck_file not found - $o_checkfile" + } + + my load_all_records + if {![llength $o_record_list] && $o_debugchannel ne ""} { + puts $o_debugchannel "\x1b\[32mNo existing records found in punkcheck file '$o_checkfile' for installer '$installername'. Starting with empty record list.\x1b\[m" + } else { + #verify no duplicate installer records for this installer. + #JMN + set sanity_dict [dict create] + set insane "" + foreach rec $o_record_list { + if {[dict get $rec tag] eq "INSTALLER"} { + set name [dict get $rec -name] + if {[dict exists $sanity_dict $name]} { + #todo - warn - duplicate record for same targetlist - shouldn't happen as we should be using get_file_record to find existing records + if {$o_debugchannel ne ""} { + puts $o_debugchannel "\x1b\[31mpunkcheck installtrack - multiple INSTALLER records with same name '$name'\x1b\[m" + } + set insane "$name" + break + } + dict set sanity_dict $name {} + } + } + if {$insane ne ""} { + set msg "Sanity check: punkcheck file '$o_checkfile' contains multiple records for INSTALLER -name '$insane'." + append msg \n "This may indicate a problem such as multiple concurrent installtrack instances using the same punkcheck file," + append msg \n " or a previous installtrack instance that did not complete properly." + append msg \n " Do you want to DELETE the .punkcheck file?" + append msg \n " It is safe to delete .punkcheck files, at the cost of loss of history and checksums used to optimize installs." + append msg \n " They are a record of installation events and checksums used to avoid unnecessary reinstalls." + append msg \n " If not confirmed, an error will be raised - likely aborting the current operation." + append msg \n "confirm deletion and continue by regenerating the file, by typing the 3 letters: 'yes'." + set answer [punk::lib::askuser $msg] + if {[string tolower $answer] ne "yes"} { + error "Failing due to sanity check failure. User did not confirm with 'yes'." + } + if {[file exists $o_checkfile] && [file isfile $o_checkfile]} { + file delete $o_checkfile + } + if {[file exists $o_checkfile]} { + error "Failed to delete punkcheck file '$o_checkfile' after sanity check failure. Please investigate and resolve the issue before proceeding." + } + set o_record_list [list] + } else { + if {$o_debugchannel ne ""} { + puts $o_debugchannel "\x1b\[32mSanity check passed: no duplicate INSTALLER records found for installer '$installername' in punkcheck file '$o_checkfile'.\x1b\[m" + } + } + unset sanity_dict + } + + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + set this_installer_record [punkcheck::recordlist::new_installer_record $o_name] + #set o_record_list [linsert $o_record_list 0 $this_installer_record] + ledit o_record_list -1 -1 $this_installer_record + } else { + set this_installer_record [dict get $resultinfo record] + } + set o_tsiso [dict get $this_installer_record -tsiso] + set o_ts [dict get $this_installer_record -ts] + set o_keep_events [dict get $this_installer_record -keep_events] + + set o_events [oolib::collection create [namespace current]::eventcollection] + set eventlist [punkcheck::dict_getwithdefault $this_installer_record body [list]] + foreach e $eventlist { + set eobj [punkcheck::installevent create [namespace current]::event_[my events count] [self] [dict get $e -source] [dict get $e -targets] {*}$e] + #$o_events add $e [dict get $e -id] + $o_events add $eobj [dict get $e -id] + } + + } + destructor { + #puts "[self] destructor called" + } + method test {} { + return [self] + } + method get_name {} { + return $o_name + } + method get_checkfile {} { + return $o_checkfile + } + method get_debugchannel {} { + return $o_debugchannel + } + + #call set_source_target before calling start_event/end_event + #each event can have different source->target pairs - but may often have same, so set on installtrack as defaults. Only persisted in event records. + method set_source_target {sourceroot targetroot} { + if {[file pathtype $sourceroot] ne "absolute"} { + error "[self] set_source_target error: sourceroot must be absolute path. Received '$sourceroot'" + } + if {[file pathtype $targetroot] ne "absolute"} { + error "[self] set_source_target error: targetroot must be absolute path. Received '$targetroot'" + } + set punkcheck_folder [file dirname $o_checkfile] + set o_sourceroot $sourceroot + set o_targetroot $targetroot + set o_rel_sourceroot [punkcheck::lib::path_relative $punkcheck_folder $sourceroot] + set o_rel_targetroot [punkcheck::lib::path_relative $punkcheck_folder $targetroot] + return [list $o_rel_sourceroot $o_rel_targetroot] + } + #review/fix to allow multiple installtrack objects on same punkcheck file. + method load_all_records {} { + set o_record_list [punkcheck::load_records_from_file $o_checkfile] + } + + #does not include associated FILEINFO records - as a targetset (FILEINFO record) can be associated with events from multiple installers over time. + #e.g a logfile common to installers, or a separate installer that updates a previous output. + method as_record {} { + set eventrecords [list] + foreach eobj [my events items] { + lappend eventrecords [$eobj as_record] + } + set fields [list {*}{ + } -tsiso $o_tsiso {*}{ + } -ts $o_ts {*}{ + } -name $o_name\ {*}{ + } -keep_events $o_keep_events {*}{ + } body $eventrecords {*}{ + } + ] + set record [dict create tag INSTALLER {*}$fields] + } + #open file and save only own records + method save_all_records {} { + my save_installer_record + #todo - save FILEINFO targetset records + } + method save_installer_record {} { + set file_records [punkcheck::load_records_from_file $o_checkfile] + + set this_installer_record [my as_record] + + set persistedinfo [punkcheck::recordlist::get_installer_record $o_name $file_records] + set existing_header_posn [dict get $persistedinfo position] + if {$existing_header_posn == -1} { + #set file_records [linsert $file_records 0 $this_installer_record] + ledit file_records -1 -1 $this_installer_record + } else { + lset file_records $existing_header_posn $this_installer_record + } + punkcheck::save_records_to_file $file_records $o_checkfile "save_installer_record" + } + method events {args} { + tailcall $o_events {*}$args + } + method start_event {configdict} { + if {$o_active_event ne ""} { + error "[self] start_event error - event already started: $o_active_event" + } + if {$o_rel_sourceroot eq "" || $o_rel_targetroot eq ""} { + error "[self] No configured sourceroot or targetroot. Call [self] set_source_target first" + } + + if {[llength $configdict] %2 != 0} { + error "[self] new_event configdict must have an even number of elements" + } + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + error "[self] start_event - installer record missing. installer: $o_name" + } else { + set this_installer_record [dict get $resultinfo record] + } + + set eventobj [punkcheck::installevent create [namespace current]::event_[my events count] [self] $o_rel_sourceroot $o_rel_targetroot -config $configdict] + set eventid [$eventobj get_id] + set event_record [$eventobj as_record] + + set this_installer_record [punkcheck::recordlist::installer_record_add_event $this_installer_record $event_record] + set this_installer_record [punkcheck::recordlist::installer_record_pruneevents $this_installer_record $o_record_list] + + #replace + lset o_record_list $existing_header_posn $this_installer_record + + punkcheck::save_records_to_file $o_record_list $o_checkfile "start_event $eventid" + set o_active_event $eventobj + my events add $eventobj $eventid + return $eventobj + } + method installer_record_from_file {} { + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + } + method get_recordlist {} { + return $o_recordlist + } + method end_event {} { + if {$o_active_event eq ""} { + error "[self] end_event error - no active event" + } + $o_active_event end + } + method get_event {} { + return $o_active_event + } + } + } + proc start_installer_event {punkcheck_file installername from_fullpath to_fullpath config} { + set eventid [punkcheck::uuid] + if {[file pathtype $from_fullpath] ne "absolute"} { + error "start_installer_event error: from_fullpath must be absolute path. Received '$from_fullpath'" + } + if {[file pathtype $to_fullpath] ne "absolute"} { + error "start_installer_event error: to_fullpath must be absolute path. Received '$to_fullpath'" + } + set punkcheck_folder [file dirname $punkcheck_file] + set rel_source [punkcheck::lib::path_relative $punkcheck_folder $from_fullpath] + set rel_target [punkcheck::lib::path_relative $punkcheck_folder $to_fullpath] + + + set record_list [punkcheck::load_records_from_file $punkcheck_file] + set resultinfo [punkcheck::recordlist::get_installer_record $installername $record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + set this_installer_record [punkcheck::recordlist::new_installer_record $installername] + } else { + set this_installer_record [dict get $resultinfo record] + } + + set event_record [punkcheck::recordlist::new_installer_event_record install {*}{ + -id $eventid + -source $rel_source + -targets $rel_target + -config $config + }] + + set this_installer_record [punkcheck::recordlist::installer_record_add_event $this_installer_record $event_record] + set this_installer_record [punkcheck::recordlist::installer_record_pruneevents $this_installer_record $record_list] + + if {$existing_header_posn == -1} { + #not found - prepend + #set record_list [linsert $record_list 0 $this_installer_record] + ledit record_list -1 -1 $this_installer_record + } else { + #replace + lset record_list $existing_header_posn $this_installer_record + } + + punkcheck::save_records_to_file $record_list $punkcheck_file "start_installer_event $eventid" + return [list eventid $eventid recordset $record_list] + } + #----------------------------------------------- + proc installfile_help {} { + set msg "" + append msg "Call in order:" \n + append msg " start_installer_event (get dict with eventid and recordset keys)" + append msg " installfile_begin (to return a new INSTALLING record) - must pass in a valid eventid" \n + append msg " installfile_add_source_and_fetch_metadata (1+ times to update SOURCE record with checksum/timestamp info from source)" \n + append msg " ( - possibly with same algorithm as previous installrecord)" \n + append msg " ( - todo - search/load metadata for this source from other FILEINFO records for same installer)" \n + append msg "Finalize by calling:" \n + append msg " installfile_started_install" \n + append msg " (install the file e.g file copy)" \n + append msg " installfile_finished_install" \n + append msg " OR" \n + append msg " installfile_skipped_install" \n + } + proc installfile_begin {punkcheck_folder target_relpath installername args} { + if {[llength $args] %2 !=0} { + error "punkcheck installfile_begin args must be name-value pairs" + } + set target_relpath [lsort -dictionary -increasing $target_relpath] ;#exact sort order not critical - but must be consistent + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set defaults [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $ts {*}{ + } -installer $installername {*}{ + } -eventid unspecified {*}{ + } + ] + set opts [dict merge $defaults $args] + set opt_eventid [dict get $opts -eventid] + + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set resultinfo [punkcheck::recordlist::get_installer_record $installername $record_list] + set installer_record_position [dict get $resultinfo position] + if {$installer_record_position == -1} { + error "installfile_begin error: Failed to retrieve installer record for installer name:'$installername' - ensure start_installer_event has been called with same installer, and -eventid is passed to installfile_begin" + } + set this_installer_record [dict get $resultinfo record] + set events [dict get $this_installer_record body] + set active_event [list] + foreach evt [lreverse $events] { + if {[dict get $evt -id] eq $opt_eventid} { + set active_event $evt + break + } + } + if {![llength $active_event]} { + error "installfile_begin error: eventid $opt_eventid not found for installer '$installername' - aborting" + } + + + set extractioninfo [punkcheck::recordlist::extract_or_create_fileset_record $target_relpath $record_list] + set file_record [dict get $extractioninfo record] + set record_list [dict get $extractioninfo recordset] + set isnew [dict get $extractioninfo isnew] + set oldposition [dict get $extractioninfo oldposition] + unset extractioninfo + + #INSTALL-INPROGRESS will become INSTALL-RECORD or INSTALL-FAILED or INSTALL-SKIPPED upon finalisation + #-installer and -eventid keys are added here + set new_installing_record [dict create tag INSTALL-INPROGRESS {*}$opts -tempcontext $active_event body {}] + #set existing_body [dict_getwithdefault $file_record body [list]] + #todo - look for existing "INSTALL-INPROGRESS" records - mark as failed? + dict lappend file_record body $new_installing_record + + if {$isnew} { + lappend record_list $file_record + } else { + #set record_list [linsert $record_list[unset record_list] $oldposition $file_record] + ledit record_list $oldposition -1 $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_begin $installername $opt_eventid $target_relpath" + return $file_record + } + + #todo - ensure that removing a dependency is noticed as a change + #e.g previous installrecord had 2 source records - but we now only depend on one. + #The files we depended on for the previous record haven't changed themselves - but the list of files has (reduced by one) + #cached_cksums is list of dicts with keys cksum & opts + #Will only be used if any opts values present match those from file_record's -cksum_all_opts (in last install record) or first cached_cksum will be used if no last install record values + proc installfile_add_source_and_fetch_metadata {punkcheck_folder source_relpath file_record {cached_cksums {}}} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_add_source_and_fetch_metadata error: bad file_record - expected FILEINFO with last body element *-INPROGRESS ($file_record)" + } + #validate any passed cached_cksums + foreach cacheinfo $cached_cksums { + if {[llength $cacheinfo] % 2 != 0} { + error "installfile_add_source_and_fetch_metadata error.If cached_cksums is supplied, it must be a list of dicts containing keys cksum & opts" + } + dict for {k v} $cacheinfo { + switch -- $k { + cksum {} + opts { + #todo - validate $v keys + } + default { + error "installfile_add_source_and_fetch_metadata error. Unrecognised key $k. Known keys {cksum opts}" + } + } + + } + } + set ts_start [clock microseconds] + set last_installrecord [lib::file_record_get_last_installrecord $file_record] + set prev_ftype "" + set prev_fsize "" + set prev_cksum "" + set prev_cksum_opts "" + if {[llength $last_installrecord]} { + set src [lib::install_record_get_matching_source_record $last_installrecord $source_relpath] + if {[llength $src]} { + if {[dict_getwithdefault $src -path ""] eq $source_relpath} { + set prev_ftype [dict_getwithdefault $src -type ""] + set prev_fsize [dict_getwithdefault $src -size ""] + set prev_cksum [dict_getwithdefault $src -cksum ""] + set prev_cksum_opts [dict_getwithdefault $src -cksum_all_opts ""] + } + } + } + #check that this relpath not already added as child of *-INPROGRESS + set file_record_body [dict_getwithdefault $file_record body [list]] ;#new file_record may have no body + set installing_record [lindex $file_record_body end] + set already_present_record [lib::install_record_get_matching_source_record $installing_record $source_relpath] + if {[llength $already_present_record]} { + error "installfile_add_source_and_fetch_metadata error: source path $source_relpath already exists in the file_record - cannot add again" + } + + set use_cache 0 + if {$prev_cksum_opts ne ""} { + set cksum_opts $prev_cksum_opts + #find first cached_cksum that is compatible with cksum opts used in latest install record + foreach cacheinfo $cached_cksums { + set cachedopts [dict get $cacheinfo opts] + set cache_is_match 1 + dict for {k v} $cachedopts { + if {[dict exists $prev_cksum_opts $k] && $v ne [dict get $prev_cksum_opts $k]} { + set cache_is_match 0 + break + } + } + if {$cache_is_match} { + set use_cache_record $cacheinfo + set use_cache 1 + break + } + } + + } else { + #no cksum opts available from an install record + set cksum_opts "" + #use first entry in cached_cksums if we can + if {[llength $cached_cksums]} { + set use_cache 1 + set use_cache_record [lindex $cached_cksums 0] + } + } + + #todo - accept argument of cached source cksum info (for client calling multiple targets with same source in quick succession e.g when building .vfs kits with multiple runtimes) + #if same cksum_opts - then use cached data instead of checksumming here. + + #allow nonexistant as a source + set fpath [file join $punkcheck_folder $source_relpath] + #windows: file exist + file type = 2ms vs 500ms for 2x glob + set floc [file dirname $fpath] + set fname [file tail $fpath] + set file_set [glob -nocomplain -dir $floc -type f -tails -- $fname] + set dir_set [glob -nocomplain -dir $floc -type d -tails -- $fname] + set link_set [glob -nocomplain -dir $floc -type l -tails -- $fname] + if {[llength $file_set] == 0 && [llength $dir_set] == 0 && [llength $link_set] == 0} { + #could also theoretically exist as less common types, b,c,p,s (block,char,pipe,socket) + #- we don't expect them here - REVIEW - ever possible? + #- installing/examining such things an unlikely usecase and would require special handling anyway. + set ftype "missing" + set fsize "" + } else { + if {[llength $dir_set]} { + set ftype "directory" + set fsize "NA" + } elseif {[llength $link_set]} { + set ftype "link" + set fsize 0 + } else { + set ftype "file" + #todo - optionally use mtime instead of cksum (for files only)? + #mtime is not reliable across platforms and filesystems though.. see article linked at top. + set fsize [file size $fpath] + } + } + + #if {![file exists $fpath]} { + # set ftype "missing" + # set fsize "" + #} else { + # set ftype [file type $fpath] + # if {$ftype eq "directory"} { + # set fsize "NA" + # } else { + # #todo - optionally use mtime instead of cksum (for files only)? + # #mtime is not reliable across platforms and filesystems though.. see article linked at top. + # set fsize [file size $fpath] + # } + #} + #get_relativecksum_from_base and fill_relativecksums_from_base_and_relativepathdict will set cksum to if fpath doesn't exist + if {$use_cache} { + set source_cksum_info [punk::mix::base::lib::fill_relativecksums_from_base_and_relativepathdict $punkcheck_folder [dict create $source_relpath $use_cache_record]] + } else { + set source_cksum_info [punk::mix::base::lib::get_relativecksum_from_base $punkcheck_folder $source_relpath {*}$cksum_opts] + } + + + lassign $source_cksum_info pathkey ckinfo + if {$pathkey ne $source_relpath} { + error "installfile_add_source_and_fetch_metadata error: cksum returned wrong path info '$pathkey' expected '$source_relpath'" + } + set cksum [dict get $ckinfo cksum] + #set cksum_all_opts [dict get $ckinfo cksum_all_opts] + set cksum_all_opts [dict get $ckinfo opts] + if {$cksum ne $prev_cksum || $ftype ne $prev_ftype || $fsize ne $prev_fsize} { + set changed 1 + } else { + set changed 0 + } + set installing_record_sources [dict_getwithdefault $installing_record body [list]] + set ts_now [clock microseconds] ;#gathering metadata - especially checksums on folder can take some time - calc and store elapsed us for time taken to gather metadata + set metadata_us [expr {$ts_now - $ts_start}] + set this_source_record [dict create tag SOURCE -type $ftype -size $fsize -path $source_relpath -cksum $cksum -cksum_all_opts $cksum_all_opts -changed $changed -metadata_us $metadata_us] + lappend installing_record_sources $this_source_record + dict set installing_record body $installing_record_sources + + lset file_record_body end $installing_record + + dict set file_record body $file_record_body + return $file_record + } + + #write back to punkcheck - don't accept recordset - invalid to update anything other than the installing_record at this time + proc installfile_started_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_started_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set ts_now [clock microseconds] + set metadata_us [expr {$ts_now - $ts_start}] + + dict set installing_record -metadata_us $metadata_us + dict set installing_record -ts_start_transfer $ts_now + + lset file_record_body end $installing_record + + dict set file_record body $file_record_body + + + set getresult [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $getresult position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_started_install [llength $targetlist] targets" + return $file_record + } + proc installfile_finished_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_finished_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set ts_start_transfer [dict get $installing_record -ts_start_transfer] + set ts_now [clock microseconds] + set elapsed_us [expr {$ts_now - $ts_start}] + set transfer_us [expr {$ts_now - $ts_start_transfer}] + dict set installing_record -transfer_us $transfer_us + dict set installing_record -elapsed_us $elapsed_us + dict unset installing_record -tempcontext + dict set installing_record tag "INSTALL-RECORD" + + lset file_record_body end $installing_record + dict set file_record body $file_record_body + + set file_record [punkcheck::recordlist::file_record_prune $file_record] + + set oldrecordinfo [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $oldrecordinfo position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_finished_install [llength $targetlist] targets" + return $file_record + } + proc installfile_skipped_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + set msg "installfile_skipped_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + append msg \n "received:" + append msg \n $file_record + error $msg + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set tsnow [clock microseconds] + set elapsed_us [expr {$tsnow - $ts_start}] + dict set installing_record -elapsed_us $elapsed_us + dict set installing_record tag "INSTALL-SKIPPED" + + lset file_record_body end $installing_record + dict set file_record body $file_record_body + + set file_record [punkcheck::recordlist::file_record_prune $file_record] + + set getresult [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $getresult position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file "installfile_skipped_install [llength $targetlist] targets" + return $file_record + } + #----------------------------------------------- + #then: file_record_add_installrecord + + namespace eval lib { + set pkg punkcheck + namespace path ::punkcheck + proc is_file_record_inprogress {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + return 0 + } + set installing_record [lindex [dict_getwithdefault $file_record body [list]] end] + if {[dict_getwithdefault $installing_record tag [list]] ni [list QUERY-INPROGRESS INSTALL-INPROGRESS MODIFY-INPROGRESS DELETE-INPROGRESS VIRTUAL-INPROGRESS]} { + return 0 + } + return 1 + } + proc is_file_record_installing {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + return 0 + } + set installing_record [lindex [dict_getwithdefault $file_record body [list]] end] + if {[dict_getwithdefault $installing_record tag [list]] ne "INSTALL-INPROGRESS"} { + return 0 + } + return 1 + } + proc file_record_get_last_installrecord {file_record} { + set body [dict_getwithdefault $file_record body [list]] + set previous_install_records [lrange $body 0 end-1] + #get last previous that is tagged INSTALL-RECORD,MODIFY-RECORD,VIRTUAL-RECORD + #REVIEW DELETERECORD ??? + set revlist [lreverse $previous_install_records] + foreach rec $revlist { + if {[dict get $rec tag] in [list "INSTALL-RECORD" "MODIFY-RECORD" "VIRTUAL-RECORD"]} { + return $rec + } + } + return [list] + } + + #should work on *-INPROGRESS or INSTALL(etc) record - don't restrict tag to INSTALL + proc install_record_get_matching_source_record {install_record source_relpath} { + set body [dict_getwithdefault $install_record body [list]] + foreach src $body { + if {[dict get $src tag] eq "SOURCE"} { + if {[dict_getwithdefault $src -path ""] eq $source_relpath} { + return $src + } + } + } + return [list] + } + + + + # Delegate to punk::path::relative (verified equivalent implementation) + proc path_relative {base dst} { + return [punk::path::relative $base $dst] + } + } + #skip writing punkcheck during checksum/timestamp checks + + #todo - punk::args - fetch from punkcheck::install (with overrides) + proc install_tm_files {srcdir basedir args} { + set defaults [list {*}{ + -glob *.tm + -installer punkcheck::install_tm_files + } -exclude-filetails [list "*[punk::mix::util::tm_version_magic]*"] {*}{ + } + ] + set opts [dict merge $defaults $args] + punkcheck::install $srcdir $basedir {*}$opts + } + proc install_non_tm_files {srcdir basedir args} { + #set keys [dict keys $args] + #adjust the default exclude-paths_core entries so that .fossil-custom, .fossil-settings are copied + set excludepaths_core [punkcheck::default_excludepaths_core] + #remove .fossil* entries (both top-level and **/ forms) so fossil folders are not excluded + set excludepaths_core [lsearch -inline -all -not $excludepaths_core ".fossil*"] + set excludepaths_core [lsearch -inline -all -not $excludepaths_core "**/.fossil*"] + set defaults [list {*}{ + } -glob * {*}{ + } -exclude-filetails [list "*.tm" "*-buildversion.txt" "*.exe"] {*}{ + } -exclude-paths-core $excludepaths_core {*}{ + } -installer punkcheck::install_non_tm_files {*}{ + } + ] + set opts [dict merge $defaults $args] + punkcheck::install $srcdir $basedir {*}$opts + } + + #for tcl8.6 - tcl8.7+ has dict getwithdefault (dict getdef) + proc dict_getwithdefault {dictValue args} { + if {[llength $args] < 2} { + error {wrong # args: should be "dict_getdef dictionary ?key ...? key default"} + } + set keys [lrange $args 0 end-1] + if {[dict exists $dictValue {*}$keys]} { + return [dict get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + lappend PUNKARGS [list { + @id -id ::punkcheck::install + @cmd -name ::punkcheck::install -help\ + "Unidirectional file transfer to possibly non-empty target folder. + This is the simpler form of the API, performing a transfer from one + directory tree to another, copying each file when changes in the source + file are detected. + Changes are detected by content checksum. The first install will record + source checksums in a .punkcheck file (ideally located at the root of the + target folder). Subsequent installs will compare stored checksums with + the current checksums of the source files. + For more advanced install operations, the object command installtrack + can be used to define install operations. e.g when the transfer is not + one-to-one and a target file depends on multiple source files." + @leaders -min 2 -max 2 + srcdir -type directory + tgtdir -type directory + -call-depth-internal -type integer -default 0 -help "(internal recursion tracker)" + -subdirlist -type list -default "" -help "(primarily internal - length generally matching -call-depth-internal)" + -max-depth -type integer -default 1000 -help\ + "Deepest subdirectory - use -1 for no limit." + -createdir -type boolean -default 0 -help\ + "Whether to create the folder at tgtdir. + Any required subdirectories are created regardless of this setting." + -createempty -type boolean -default 0 -help\ + "Whether to create folders at target that had no matches for our glob" + -glob -type string -default "*" -help\ + "Pattern matching for source file(s) to copy. Can be glob based or exact match." + -exclude-filetails-core -default {${[::punkcheck::default_excludefiletail_core]}} -help\ + "Non-overridable default file-tail exclusion patterns. + These are applied in addition to -exclude-filetails and cannot be + disabled by the caller - they can only be replaced by passing + -exclude-filetails-core with a different list. + Patterns use string match against the file tail (basename) at any + level in the tree. They must not contain path separators." + -exclude-filetails -default "" -help\ + "List of glob patterns to match against file tails (basenames). + Patterns use string match and must not contain path separators. + e.g {*.swp *.tmp} excludes swap and temp files at any level." + -exclude-paths-core -default {${[::punkcheck::default_excludepaths_core]}} -help\ + "Non-overridable default path-glob exclusion patterns. + These are applied in addition to -exclude-paths and cannot be + disabled by the caller - they can only be replaced by passing + -exclude-paths-core with a different list. + Patterns are matched against the full relative source path using + punk::path::globmatchpath." + -exclude-paths -default {} -help\ + "List of path-glob patterns to exclude from installation. + Patterns are matched against the full relative source path using + punk::path::globmatchpath, so they may include ** to match across + path segments and / to match within a segment. + e.g to exclude all AGENTS.md files at any depth: {AGENTS.md **/AGENTS.md}" + #backward-compat aliases (accepted but deprecated - converted internally to -exclude-paths) + -exclude-dirsegments-core -default {${[::punkcheck::default_excludedirseg_core]}} -help\ + "DEPRECATED: use -exclude-paths-core instead. + Legacy segment-glob patterns matched against directory tail names. + Converted internally to path-glob form by expanding each segment + S to {S **/S}." + -exclude-dirsegments -default "" -help\ + "DEPRECATED: use -exclude-paths instead. + Legacy segment-glob patterns matched against directory tail names + at any level. Each pattern must not contain path separators." + -antiglob-paths -default {} -help\ + "DEPRECATED: use -exclude-paths instead. + Legacy path-glob patterns matched against the full relative source + path using punk::path::globmatchpath. Merged into -exclude-paths + internally." + -overwrite -default no-targets\ + -choices {no-targets newer-targets older-targets all-targets installedsourcechanged-targets synced-targets}\ + -choicecolumns 1\ + -choicelabels { + no-targets "only copy files that are missing at the target" + newer-targets "copy files with older source timestamp over newer + target timestamp and those missing at the target + (a form of 'restore' operation)" + older-targets "copy files with newer source timestamp over older + target timestamp and those missing at the target" + all-targets "copy regardless of timestamp at target" + installedsourcechanged-targets "copy if the target doesn't exist or the source changed" + synced-targets "copy if the target doesn't exist or the source changed + and the target cksum is the same as the last INSTALL-RECORD -targets_cksums entry" + } + -source-checksum -default comparestore -choicecolumns 3 -choices {compare store comparestore false true} -help\ + "Checksum behavior for source files. + compare: checksum and compare against last record, but do not store. + store: checksum and store, but do not compare against last record. + comparestore: checksum, compare against last record, and store. + false: do not checksum (not recommended - changes cannot be detected). + true: same as comparestore." + -punkcheck-folder -default target -choices {target source project} -choicerestricted 0 -help\ + "The location of the .punkcheck file to track installations and checksums. + The default value 'target' is generally recommended. + Can also be an absolute path to a folder." + -punkcheck-eventid -default "" -help\ + "Event ID for the install operation. When empty (default), a new UUID + is generated automatically. Pass a specific ID to group multiple + install calls under the same event in the .punkcheck file." + -punkcheck-records -default "" -help\ + "Empty string or a parsed TDL records structure. + e.g + {tag FILEINFO - ... body { + {tag INSTALL-RECORD - ... body {}} + ... + }... + }" + -installer -default "punkcheck::install" -help\ + "A user nominated string that is stored in the .punkcheck file + This might be the name of a script or installation process." + -progresschannel -default none -type string -help\ + "Name of channel e.g stderr, stdout to which progress messages are written. + This includes the tree-like output consisting of dots (or green U) for each + file processed. As the number of files in a tree is not known beforehand, + it isn't useful for a percentage-based progress meter, but it could potentially + be used to drive a spinner if the textual data is not desired. + Setting to none or an invalid channel will deactivate the output." + }] + ## unidirectional file transfer to possibly non empty folder + #default of -overwrite no-targets will only copy files that are missing at the target + # -overwrite newer-targets will copy files with older source timestamp over newer target timestamp and those missing at the target (a form of 'restore' operation) + # -overwrite older-targets will copy files with newer source timestamp over older target timestamp and those missing at the target + # -overwrite all-targets will copy regardless of timestamp at target + # -overwrite installedsourcechanged-targets will copy if the target doesn't exist or the source changed + # -overwrite synced-targets will copy if the target doesn't exist or the source changed and the target cksum is the same as the last INSTALL-RECORD -targets_cksums entry + # review - timestamps unreliable + # - what about slightly mismatched system clocks and mounted filesystems? caller responsibility to verify first? + # if timestamp exactly equal - should we check content-hash? This is presumably only likely to occur deliberately(maliciously?) + # e.g some process that digitally signs or otherwise modifies a file and preserves update timestmp? + # if such a content-mismatch - what default behaviour and what options would make sense? + # probably it's reasonable that only all-targets would overwrite such files. + # consider -source_fudge_seconds +-X ?, -source_override_timestamp ts ??? etc which only adjust timestamp for calculation purposes? Define a specific need/usecase when reviewing. + # + # valid filetypes for src tgt + # src dir tgt dir + # todo - review and consider enabling symlink src and dst + # no need for src file - as we use -glob with no glob characters to match one source file file + # no ability to target file with different name - keep it simpler and caller will have to use an intermediate folder/file if they need to rename something? + # + # todo - determine what happens if mismatch between file type of a src vs target e.g target has dir matching filename at source + # A pre-scan to determine no such conflict - before attempting to copy anything might provide the most integrity at slight cost in speed. + # REVIEW we should only expect dirs to be created as necessary to hold files? i.e target folder won't be created if no source file matches for that folder + # -source-checksum compare|store|comparestore|false|true where true == comparestore + # -punkcheck-folder target|source|project| target is default and is generally recommended + # -punkcheck-records empty string | parsed TDL records ie {tag xxx k v} structure + # install creates FILEINFO records with a single entry in the -targets field (it is legitimate to have a list of targets for an installation operation - the oo interface supports this) + proc install {srcdir tgtdir args} { + # Backward-compat: normalize old underscore flag names to hyphenated forms + set flag_aliases [dict create {*}{ + -max_depth -max-depth + -exclude-filetails_core -exclude-filetails-core + -exclude-paths_core -exclude-paths-core + -exclude-dirsegments_core -exclude-dirsegments-core + -antiglob_paths -antiglob-paths + -source_checksum -source-checksum + -punkcheck_folder -punkcheck-folder + -punkcheck_eventid -punkcheck-eventid + -punkcheck_records -punkcheck-records + }] + if {[llength $args]} { + set normalized [list] + foreach {k v} $args { + if {[dict exists $flag_aliases $k]} { + lappend normalized [dict get $flag_aliases $k] $v + } else { + lappend normalized $k $v + } + } + set args $normalized + } + + set defaults [list {*}{ + -call-depth-internal 0 + -max-depth 1000 + -subdirlist {} + -createdir 0 + -createempty 0 + -glob * + -exclude-filetails-core "\uFFFF" + -exclude-filetails "" + -exclude-paths-core "\uFFFF" + -exclude-paths {} + -exclude-dirsegments-core "\uFFFF" + -exclude-dirsegments {} + -antiglob-paths {} + -overwrite no-targets + -source-checksum comparestore + -punkcheck-folder target + -punkcheck-eventid "\uFFFF" + -punkcheck-records "" + -installer punkcheck::install + -progresschannel none + }] + + if {([llength $args] %2) != 0} { + error "punkcheck::install requires option-style arguments to be in pairs. Received args: $args" + } + foreach {k -} $args { + if {$k ni [dict keys $defaults]} { + error "punkcheck::install unrecognised option '$k' known options: '[dict keys $defaults]'" + } + } + set opts [dict merge $defaults $args] + + #The choice to recurse using the original values of srcdir & tgtdir, and passing the subpath down as a list in -subdirlist seems an odd one. + #(as opposed to a more 'standard' mechanism of adjusting srcdir & tgtdir as we move down the tree) + #It comes from build_modules_from_source_to_base where we need to keep track of position relative to our targetdir starting point to handle submodules e.g pkg::something::mypkg-0.1.tm + #It could have been handled with some other parameter such as -depth, but this -subdirlist mechanism, whilst perhaps not beautiful, is straightforward enough + #and may be less error prone than doing slightly more opaque path manipulations at each recursion level to determine where we started + #For consistency - we'll use the same mechanism in various recursive directory walking procedures such as this one. + set CALLDEPTH [dict get $opts -call-depth-internal] ;#added for extra debug/sanity checking - clearer test for initial function call ie CALLDEPTH = 0 + set max_depth [dict get $opts -max-depth] ;# -1 for no limit + set subdirlist [dict get $opts -subdirlist] ;# generally should be same length as CALLDEPTH - but user could prefill + set fileglob [dict get $opts -glob] + set createdir [dict get $opts -createdir] ;#defaults to zero to help avoid mistakes with initial target dir - required target subdirs are created regardless of this setting + set opt_createempty [dict get $opts -createempty] + set opt_progresschannel [dict get $opts -progresschannel] + if {$opt_progresschannel in {"" none} || [catch {chan configure $opt_progresschannel}]} { + set opt_progresschannel "" + } + + if {$CALLDEPTH == 0} { + #expensive to normalize but we need to do it at least once + set srcdir [file normalize $srcdir] + set tgtdir [file normalize $tgtdir] + if {$createdir} { + file mkdir $tgtdir + } else { + if {![file exists $tgtdir]} { + error "punkcheck::install base target dir:'$tgtdir' doesn't exist (srcdir:$srcdir tgtdir:$tgtdir args:'$args')" + } + } + if {([file type $srcdir] ni [list directory]) || ([file type $tgtdir] ni [list directory])} { + error "punkcheck::install requires source and target dirs to be of type 'directory' type current source: [file type $srcdir] type current target: [file type $tgtdir]" + } + #now the values we build from these will be properly cased + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_excludefiletail_core [dict get $opts -exclude-filetails-core] + if {$opt_excludefiletail_core eq "\uFFFF"} { + set opt_excludefiletail_core [default_excludefiletail_core] + dict set opts -exclude-filetails-core $opt_excludefiletail_core + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_excludefiletail [dict get $opts -exclude-filetails] + #validate no path seps + foreach af $opt_excludefiletail { + if {[llength [file split $af]] > 1} { + error "punkcheck::install received invalid -exclude-filetails entry '$af'. -exclude-filetails entries are meant to match to a file name at any level so cannot contain path separators" + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # Unified -exclude-paths initialization (replaces -exclude-dirsegments + -antiglob-paths) + # Precedence: -exclude-paths-core > -exclude-dirsegments-core (legacy) > default + set opt_excludepaths_core [dict get $opts -exclude-paths-core] + set legacy_excludedirseg_core [dict get $opts -exclude-dirsegments-core] + if {$opt_excludepaths_core ne "\uFFFF"} { + # User explicitly passed -exclude-paths-core → use as-is (path-glob form) + } elseif {$legacy_excludedirseg_core ne "\uFFFF"} { + # User explicitly passed legacy -exclude-dirsegments-core → convert to path-glob form + set opt_excludepaths_core [list] + foreach seg $legacy_excludedirseg_core { + lappend opt_excludepaths_core $seg + lappend opt_excludepaths_core **/$seg + } + dict set opts -exclude-paths-core $opt_excludepaths_core + } else { + # Neither passed → use new default + set opt_excludepaths_core [default_excludepaths_core] + dict set opts -exclude-paths-core $opt_excludepaths_core + } + set opt_excludepaths [dict get $opts -exclude-paths] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # Backward-compat: convert legacy -exclude-dirsegments to path-glob form and merge + # Each segment-glob S is expanded to {S **/S} to match at any directory level, + # preserving the former string-match-against-tail semantics. + set opt_excludedirseg_core $legacy_excludedirseg_core + if {$opt_excludedirseg_core eq "\uFFFF"} { + set opt_excludedirseg_core [default_excludedirseg_core] + dict set opts -exclude-dirsegments-core $opt_excludedirseg_core + } + set opt_excludedirseg [dict get $opts -exclude-dirsegments] + #validate no path seps + foreach ad $opt_excludedirseg { + if {[llength [file split $ad]] > 1} { + error "punkcheck::install received invalid -exclude-dirsegments entry '$ad'. -exclude-dirsegments entries are meant to match to a directory name at any level so cannot contain path separators" + } + } + #convert legacy dir-seg user globs (NOT core) to path-glob form and append to opt_excludepaths + foreach seg $opt_excludedirseg { + lappend opt_excludepaths $seg + lappend opt_excludepaths **/$seg + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # Backward-compat: merge legacy -antiglob-paths into opt_excludepaths + set opt_antiglob_paths [dict get $opts -antiglob-paths] ;#todo - combine with config file in source tree .punkcheckpublish (?) + #antiglob_paths will usually contain file separators - and may contain glob patterns within each segment + foreach ap $opt_antiglob_paths { + lappend opt_excludepaths $ap + } + set antiglob_paths_matched [list] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set known_whats [list no-targets newer-targets older-targets all-targets installedsourcechanged-targets synced-targets] + set overwrite_what [string tolower [dict get $opts -overwrite]]; #accept any case for value to allow emphasis by caller e.g -overwrite NEWER-TARGETS + if {$overwrite_what ni $known_whats} { + error "punkcheck::install received unrecognised value for -overwrite. Received value '$overwrite_what' vs known values '$known_whats'" + } + if {$overwrite_what in [list newer-targets older-targets]} { + error "punkcheck::install newer-target, older-targets not implemented - sorry" + #TODO - check crossplatform availability of ctime (on windows it still seems to be creation time, but on bsd/linux it's last attribute mod time) + # external pkg? use twapi and ctime only on other platforms? + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_source_checksum [dict get $opts -source-checksum] + if {[string is boolean $opt_source_checksum]} { + if {$opt_source_checksum} { + set opt_source_checksum "comparestore" + } else { + set opt_source_checksum 0 + } + dict set opts -source-checksum $opt_source_checksum + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_punkcheck_folder [dict get $opts -punkcheck-folder] + if {$opt_punkcheck_folder eq "target"} { + set punkcheck_folder $tgtdir + } elseif {$opt_punkcheck_folder eq "source"} { + set punkcheck_folder $srcdir + } elseif {$opt_punkcheck_folder eq "project"} { + set sourceprojectinfo [punk::repo::find_repos $srcdir] + set targetprojectinfo [punk::repo::find_repos $tgtdir] + set srcproj [lindex [dict get $sourceprojectinfo project] 0] + set tgtproj [lindex [dict get $targetprojectinfo project] 0] + if {$srcproj eq $tgtproj} { + set punkcheck_folder $tgtproj + } else { + error "copy_files_from_source_to_target error: Unable to find common project dir for source and target folder - use absolutepath for -punkcheck-folder if source and target are not within same project" + } + } else { + set punkcheck_folder $opt_punkcheck_folder + } + if {$punkcheck_folder ne ""} { + if {[file pathtype $punkcheck_folder] ne "absolute"} { + error "copy_files_from_source_to_target error: -punkcheck-folder '$punkcheck_folder' must be an absolute path, or one of: target|source|project" + } + if {![file isdirectory $punkcheck_folder]} { + error "copy_files_from_source_to_target error: -punkcheck-folder '$punkcheck_folder' not found" + } + } else { + #review - leave empty? use pwd? + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set punkcheck_records [dict get $opts -punkcheck-records] + set punkcheck_records_init $punkcheck_records ;#change-detection + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_installer [dict get $opts -installer] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_punkcheck_eventid [dict get $opts -punkcheck-eventid] + + + + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + + if {$CALLDEPTH == 0} { + set punkcheck_eventid "" + if {$punkcheck_folder ne ""} { + set config $opts + dict unset config -call-depth-internal + dict unset config -max-depth + dict unset config -subdirlist + dict unset config -progresschannel + tcl::dict::for {k v} $config { + if {$v eq "\uFFFF"} { + dict unset config $k + } + } + lassign [punkcheck::start_installer_event $punkcheck_file $opt_installer $srcdir $tgtdir $config] _eventid punkcheck_eventid _recordset punkcheck_records + } + } else { + set punkcheck_eventid $opt_punkcheck_eventid + } + + + + if {$opt_source_checksum != 0} { + #we need to read the file even if only set to store (or we would overwrite entries) + set compare_cksums 1 + } else { + set compare_cksums 0 + } + + if {[string match *store* $opt_source_checksum]} { + set store_source_cksums 1 + } else { + set store_source_cksums 0 + } + + + + + + if {[llength $subdirlist] == 0} { + set current_source_dir $srcdir + set current_target_dir $tgtdir + } else { + set current_source_dir $srcdir/[file join {*}$subdirlist] + set current_target_dir $tgtdir/[file join {*}$subdirlist] + } + + + set relative_target_dir [lib::path_relative $tgtdir $current_target_dir] + if {$relative_target_dir eq "."} { + set relative_target_dir "" + } + set relative_source_dir [lib::path_relative $srcdir $current_source_dir] + if {$relative_source_dir eq "."} { + set relative_source_dir "" + } + set target_relative_to_punkcheck_dir [lib::path_relative $punkcheck_folder $current_target_dir] + if {$target_relative_to_punkcheck_dir eq "."} { + set target_relative_to_punkcheck_dir "" + } + foreach unpub $opt_antiglob_paths { + #puts "testing folder - globmatchpath $unpub $relative_source_dir" + if {[punk::path::globmatchpath $unpub $relative_source_dir]} { + lappend antiglob_paths_matched $current_source_dir + return [list files_copied {} files_skipped {} sources_unchanged {} punkcheck_records $punkcheck_records antiglob_paths_matched $antiglob_paths_matched srcdir $srcdir tgtdir $tgtdir punkcheck_folder $punkcheck_folder] + } + } + + + if {![file exists $current_source_dir]} { + error "punkcheck::install current source dir:'$current_source_dir' doesn't exist (srcdir:$srcdir tgtdir:$tgtdir args:'$args')" + } + + set files_copied [list] + set files_skipped [list] + set sources_unchanged [list] + + + set candidate_list [glob -nocomplain -dir $current_source_dir -type f -tail -- $fileglob] + set hidden_candidate_list [glob -nocomplain -dir $current_source_dir -types {hidden f} -tail -- $fileglob] + foreach h $hidden_candidate_list { + if {$h ni $candidate_list} { + lappend candidate_list $h + } + } + set match_list [list] + foreach m $candidate_list { + set suppress 0 + foreach anti [concat $opt_excludefiletail_core $opt_excludefiletail] { + if {[string match $anti $m]} { + #puts stderr "anti: $anti vs m:$m" + set suppress 1 + break + } + } + if {$suppress == 0} { + lappend match_list $m + } + } + + #sample .punkcheck file record (raw form) to make the code clearer + #punk::tdl converts to dict form e.g: tag FILEINFO -targets filename body sublist + #Valid installrecord types are INSTALL-RECORD SKIPPED INSTALL-INPROGRESS, MODIFY-RECORD MODIFY-INPROGRESS DELETE-RECORD DELETE-INPROGRESS + # + #FILEINFO -targets jjjetc-0.1.0.tm -keep_installrecords 2 -keep_skipped 1 -keep_inprogress 2 { + # INSTALL-RECORD -tsiso 2023-09-20T07:30:30 -ts 1695159030266610 -installer punk::mix::cli::build_modules_from_source_to_base -metadata_us 18426 -ts_start_transfer 1695159030285036 -transfer_us 10194 -elapsed_us 28620 { + # SOURCE -type file -path ../src/modules/jjjetc-buildversion.txt -cksum c7c71839c36b3d21c8370fed106192fcd659eca9 -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 3423 + # SOURCE -type file -path ../src/modules/jjjetc-0.2.0.tm -cksum b646fc2ee88cbd068d2e946fe929b7aea96bd39d -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 3413 + # } + # INSTALL-SKIPPED -tsiso 2023-09-20T08:14:26 -ts 1695161666087880 -installer punk::mix::cli::build_modules_from_source_to_base -elapsed_us 18914 { + # SOURCE -type file -path ../src/modules/jjjetc-buildversion.txt -cksum c7c71839c36b3d21c8370fed106192fcd659eca9 -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 0 -metadata_us 3435 + # SOURCE -type file -path ../src/modules/jjjetc-0.2.0.tm -cksum b646fc2ee88cbd068d2e946fe929b7aea96bd39d -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 0 -metadata_us 3338 + # } + #} + + if {[llength $match_list]} { + #example - target dir has a file where there is a directory at the source + if {[file exists $current_target_dir] && ([file type $current_target_dir] ni [list directory])} { + error "punkcheck::install target subfolder $current_target_dir exists but is not of type 'directory'. Type current target folder: [file type $current_target_dir]" + } + } + + #proc get_relativecksum_from_base_and_fullpath {base fullpath args} + + + #puts stdout "Current target dir: $current_target_dir" + set last_depth "" + foreach m $match_list { + set new_tgt_cksum_info [list] + set relative_target_path [file join $relative_target_dir $m] + set relative_source_path [file join $relative_source_dir $m] + set punkcheck_target_relpath [file join $target_relative_to_punkcheck_dir $m] + set is_antipath 0 + foreach pathglob [concat $opt_excludepaths_core $opt_excludepaths] { + #puts "testing file - globmatchpath $pathglob vs $relative_source_path" + if {[punk::path::globmatchpath $pathglob $relative_source_path]} { + lappend antiglob_paths_matched $current_source_dir + set is_antipath 1 + break + } + } + if {$is_antipath} { + continue + } + + set ts_start [clock microseconds] + set seconds [expr {$ts_start / 1000000}] + set ts_start_iso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + + + #puts stdout " rel_target: $punkcheck_target_relpath" + + set fetch_filerec_result [punkcheck::recordlist::get_file_record $punkcheck_target_relpath $punkcheck_records] + #change to use extract_or_create_fileset_record ? + set existing_filerec_posn [dict get $fetch_filerec_result position] + if {$existing_filerec_posn == -1} { + if {$opt_progresschannel ne ""} { + puts stdout "\nNO existing record for $punkcheck_target_relpath" + } + set has_filerec 0 + set new_filerec [dict create tag FILEINFO -targets $punkcheck_target_relpath] + set filerec $new_filerec + } else { + set has_filerec 1 + #puts stdout " TDL existing FILEINFO record for $punkcheck_target_relpath" + #puts stdout " $existing_install_record" + set filerec [dict get $fetch_filerec_result record] + } + set filerec [punkcheck::recordlist::file_record_set_defaults $filerec] + + #new INSTALLREC must be tagged as INSTALL-INPROGRESS to use recordlist::installfile_ method + set new_install_record [dict create tag INSTALL-INPROGRESS -tsiso $ts_start_iso -ts $ts_start -installer $opt_installer -eventid $punkcheck_eventid] + dict lappend filerec body $new_install_record ;#can't use recordlist::file_record_add_installrecord as '*-INPROGRESS' isn't a final tag - so pruning would be mucked up. No need to prune now anyway. + unset new_install_record + + + if {$opt_progresschannel ne ""} { + if {$last_depth ne $CALLDEPTH} { + if {$CALLDEPTH <=1} { + puts -nonewline $opt_progresschannel \n[string repeat " " $CALLDEPTH][file tail $relative_source_dir] + } + flush $opt_progresschannel + ##set last_depth $CALLDEPTH ;# done down below + } + } + + + + set relative_source_path [lib::path_relative $punkcheck_folder $current_source_dir/$m] + #puts stdout " rel_source: $relative_source_path" + #if {[file pathtype $relative_source_path] ne "relative"} { + #REVIEW + #different volume or root + #} + #Note this isn't a recordlist function - so it doesn't purely operate on the records + #this hits the filesystem for the sourcepath - gets checksums/timestamps depending on config. + #It doesn't save to .punkcheck (the only punkcheck::installfile_ method which doesn't) + set ts1 [clock milliseconds] + set filerec [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $relative_source_path $filerec] + set ts2 [clock milliseconds] + set diff [expr {$ts2 - $ts1}] + if {$diff > 100} { + #todo -errorchannel + set errprefix ">>> punkcheck:" + puts stderr "\n$errprefix performance warning: fetch_metadata for $m took $diff ms." + set lb [lindex [dict get $filerec body] end] + #puts stderr "$errprefix filerec last body record:$lb" + set records [dict get $lb body] + set lr [lindex $records end] + set alg [dict get $lr -cksum_all_opts -cksum_algorithm] + if {$alg eq "sha1"} { + puts stderr "$errprefix cksum_algorithm: sha1 (accelerators: [::sha1::Implementations])" + puts stderr "$errprefix sha1 from: [package ifneeded sha1 [package present sha1]]" + } else { + puts stderr "$errprefix cksum_algorithm: $alg" + } + } + + + + #changeinfo comes from last record in body - which is the record we are working on and so will always exist + set changeinfo [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $filerec body] end]] + set changed [dict get $changeinfo changed] + set unchanged [dict get $changeinfo unchanged] + + if {[llength $unchanged]} { + lappend sources_unchanged $current_source_dir/$m + } + + set is_skip 0 + set is_new 0 + if {$overwrite_what eq "all-targets"} { + file mkdir $current_target_dir + #-------------------------------------------- + #sometimes we get the error: 'error copying "file1" to "file2": invalid argument' + #-------------------------------------------- + puts stderr "punkcheck: about to: file copy -force $current_source_dir/$m $current_target_dir" + file copy -force $current_source_dir/$m $current_target_dir + lappend files_copied $current_source_dir/$m + } else { + if {![file exists $current_target_dir/$m]} { + #puts stderr "punkcheck: first copy to $current_target_dir/$m " + file mkdir $current_target_dir + puts stderr "punkcheck: about to: file copy $current_source_dir/$m $current_target_dir" + file copy $current_source_dir/$m $current_target_dir + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + lappend files_copied $current_source_dir/$m + incr filecount_new + set is_new 1 + } else { + switch -- $overwrite_what { + installedsourcechanged-targets { + if {[llength $changed]} { + #An unrecorded installation is considered a source change (from unknown/unrecorded source to recorded) + puts -nonewline stderr "punkcheck: about to: file copy -force $current_source_dir/$m $current_target_dir" + set ts1 [clock milliseconds] + file mkdir $current_target_dir + file copy -force $current_source_dir/$m $current_target_dir + set ts2 [clock milliseconds] + puts -nonewline stderr " (copy time [expr {$ts2 - $ts1}] ms)" + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + set ts3 [clock milliseconds] + puts stderr " (cksum time [expr {$ts2 - $ts1}] ms)" + lappend files_copied $current_source_dir/$m + } else { + set is_skip 1 + lappend files_skipped $current_source_dir/$m + } + } + synced-targets { + #disallow overwriting of target that has been modified by some other mechanism + #review + if {[llength $changed]} { + #only overwrite if the target file checksum equals the last installed checksum (ie target is in sync with previous source-set and so hasn't been customized) + set existing_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + set is_target_unmodified_since_install 0 + set target_cksum_compare "unknown" + set latest_install_record [punkcheck::recordlist::file_record_latest_installrecord $filerec] ;#may be no such record - in which case we get an empty list + if {[dict exists $latest_install_record -targets_cksums]} { + set last_install_cksum [dict get $latest_install_record -targets_cksums] ;#in this case we know there is only one as 'install' always uses targetset size of 1. (FILEINFO record per file in source folder) + if {[dict get $existing_tgt_cksum_info cksum] eq $last_install_cksum} { + set is_target_unmodified_since_install 1 + set target_cksum_compare "match" + } else { + set target_cksum_compare "nomatch" + } + } else { + set target_cksum_compare "norecord" + } + if {$is_target_unmodified_since_install} { + file mkdir $current_target_dir + puts stderr "punkcheck: synced-targets about to: file copy -force $current_source_dir/$m $current_target_dir" + file copy -force $current_source_dir/$m $current_target_dir + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + lappend files_copied $current_source_dir/$m + } else { + #either cksum is different or we were unable to verify the record. Either way we can't know if the target is in sync so we must skip it + set is_skip 1 + puts stderr "Skipping file copy $m target $current_target_dir/$m - require synced_target to overwrite - current target cksum compared to previous install: $target_cksum_compare" + lappend files_skipped $current_source_dir/$m + } + } else { + set is_skip 1 + lappend files_skipped $current_source_dir/$m + } + } + default { + set is_skip 1 + puts stderr "Skipping file copy $m target $current_target_dir/$m already exists (use -overwrite all-targets to overwrite)" + #TODO! implement newer-targets older-targets? (note ctimes/mtimes are unreliable - may not be worth implementing) + lappend files_skipped $current_source_dir/$m + } + } + } + } + #target dir was created as necessary if files matched above + #now ensure target dir exists if -createempty true + if {$opt_createempty && ![file exists $current_target_dir]} { + file mkdir $current_target_dir + } + + + + + set ts_now [clock microseconds] + set elapsed_us [expr {$ts_now - $ts_start}] + + #if {$store_source_cksums} { + #} + + set install_records [dict get $filerec body] + set current_install_record [lindex $install_records end] + #change the tag from *-INPROGRESS to INSTALL-RECORD/SKIPPED + if {$is_skip} { + set tag INSTALL-SKIPPED + } else { + set tag INSTALL-RECORD + } + dict set current_install_record tag $tag + dict set current_install_record -elapsed_us $elapsed_us + if {[llength $new_tgt_cksum_info]} { + dict set current_install_record -targets_cksums [list [dict get $new_tgt_cksum_info cksum]] + dict set current_install_record -cksum_all_opts [dict get $new_tgt_cksum_info opts] + } + lset install_records end $current_install_record + dict set filerec body $install_records + set filerec [punkcheck::recordlist::file_record_prune $filerec] ;#prune now that tag is finalized + if {!$has_filerec} { + #not found in original recordlist - append + lappend punkcheck_records $filerec + } else { + lset punkcheck_records $existing_filerec_posn $filerec + } + + + #------------------------------------------------------------ + if {$is_skip} { + set mark . + } else { + if {$is_new} { + set mark \x1b\[32\;1mN\x1b\[m + } else { + #updated + set mark \x1b\[32\;1mU\x1b\[m + } + } + if {$opt_progresschannel ne ""} { + if {$last_depth ne $CALLDEPTH} { + puts -nonewline $opt_progresschannel \n[string repeat " " $CALLDEPTH]$mark + flush $opt_progresschannel + set last_depth $CALLDEPTH + } else { + puts -nonewline $opt_progresschannel $mark + } + } + #------------------------------------------------------------ + + } + + if {$max_depth != -1 && $CALLDEPTH >= $max_depth} { + #don't process any more subdirs + #sometimes deliberately called with max_depth 1 - so don't warn here. review + #puts stderr "punkcheck::install warning - reached max_depth $max_depth" + set subdirs [list] + } else { + set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] + set hiddensubdirs [glob -nocomplain -dir $current_source_dir -type {hidden d} -tail *] + foreach h $hiddensubdirs { + switch -- $h { + "." - ".." { + continue + } + default { + if {$h ni $subdirs} { + lappend subdirs $h + } + } + } + } + } + #puts stderr "subdirs: $subdirs" + foreach d $subdirs { + set relative_source_path [file join $relative_source_dir $d] + set skipd 0 + foreach pathglob [concat $opt_excludepaths_core $opt_excludepaths] { + #puts "testing folder - globmatchpath $pathglob vs $relative_source_path" + if {[punk::path::globmatchpath $pathglob $relative_source_path]} { + lappend antiglob_paths_matched [file join $current_source_dir $d] + #puts stdout "SKIPPING FOLDER $relative_source_path due to exclude-path-match: $pathglob " + set skipd 1 + break + } + } + if {$skipd} { + continue + } + + #if {![file exists $current_target_dir/$d]} { + # file mkdir $current_target_dir/$d + #} + + + set sub_opts_1 [list {*}{ + } -call-depth-internal [expr {$CALLDEPTH + 1}] {*}{ + } -subdirlist [list {*}$subdirlist $d] {*}{ + } -glob $fileglob {*}{ + } -exclude-filetails-core $opt_excludefiletail_core {*}{ + } -exclude-filetails $opt_excludefiletail {*}{ + } -exclude-paths-core $opt_excludepaths_core {*}{ + } -exclude-paths $opt_excludepaths {*}{ + } -overwrite $overwrite_what {*}{ + } -source-checksum $opt_source_checksum {*}{ + } -punkcheck-folder $punkcheck_folder {*}{ + } -punkcheck-eventid $punkcheck_eventid {*}{ + } -punkcheck-records $punkcheck_records {*}{ + } -installer $opt_installer {*}{ + } + ] + set sub_opts [list {*}{ + } -call-depth-internal [expr {$CALLDEPTH + 1}] {*}{ + } -subdirlist [list {*}$subdirlist $d] {*}{ + } -punkcheck-folder $punkcheck_folder {*}{ + } -punkcheck-eventid $punkcheck_eventid {*}{ + } -punkcheck-records $punkcheck_records {*}{ + } -progresschannel $opt_progresschannel {*}{ + } + ] + set sub_opts [dict merge $opts $sub_opts] + set sub_result [punkcheck::install $srcdir $tgtdir {*}$sub_opts] + + lappend files_copied {*}[dict get $sub_result files_copied] + lappend files_skipped {*}[dict get $sub_result files_skipped] + lappend sources_unchanged {*}[dict get $sub_result sources_unchanged] + lappend antiglob_paths_matched {*}[dict get $sub_result antiglob_paths_matched] + set punkcheck_records [dict get $sub_result punkcheck_records] + } + + if {[string match *store* $opt_source_checksum]} { + #puts "subdirlist: $subdirlist" + if {$CALLDEPTH == 0} { + if {[llength $files_copied] || [llength $files_skipped]} { + #puts stdout ">>>>>>>>>>>>>>>>>>>" + set saveresult [punkcheck::save_records_to_file $punkcheck_records $punkcheck_file "install $srcdir to $tgtdir"] + puts stdout "\npunkcheck::install [dict get $saveresult recordcount] records saved as [dict get $saveresult linecount] lines to $punkcheck_file copied: [llength $files_copied] skipped: [llength $files_skipped]" + #puts stdout ">>>>>>>>>>>>>>>>>>>" + } else { + #todo - write db INSTALLER record if -debug true + + } + #puts stdout "sources_unchanged" + #puts stdout "$sources_unchanged" + #puts stdout "- -- --- --- --- ---" + } + } + + return [list files_copied $files_copied files_skipped $files_skipped sources_unchanged $sources_unchanged antiglob_paths_matched $antiglob_paths_matched punkcheck_records $punkcheck_records punkcheck_folder $punkcheck_folder srcdir $srcdir tgtdir $tgtdir] + } + + + lappend PUNKARGS [list { + @id -id ::punkcheck::summarize_install_resultdict + @cmd -name punkcheck::summarize_install_resultdict -help\ + "Emits a string summarizing a punkcheck resultdict, showing + how many items were copied, and the source, target locations" + @opts + -title -type string -default "" + -forcecolour -type boolean -default 0 -help\ + "When true, passes the forcecolour tag to punk::ansi functions. + This enables ANSI sgr colours even when colour + is off. (ignoring env(NO_COLOR)) + To disable colour - ensure the NO_COLOR env var is set, + or use: + namespace eval ::punk::console {variable colour_disabled 1}" + @values -min 1 -max 1 + resultdict -type dict + }] + proc summarize_install_resultdict {args} { + set argd [punk::args::parse $args withid ::punkcheck::summarize_install_resultdict] + lassign [dict values $argd] leaders opts values received + set title [dict get $opts -title] + set forcecolour [dict get $opts -forcecolour] + set resultdict [dict get $values resultdict] + + set has_ansi [expr {![catch {package require punk::ansi}]}] + if {$has_ansi} { + if {$forcecolour} { + set fc "forcecolour" + } else { + set fc "" + } + set R [punk::ansi::a] ;#reset + set LINE_COLOUR [punk::ansi::a+ {*}$forcecolour bold cyan] + set LOW_COLOUR [punk::ansi::a+ {*}$forcecolour bold green] + set HIGH_COLOUR [punk::ansi::a+ {*}$forcecolour bold yellow] + } else { + set R "" + set LINE_COLOUR "" + set LOW_COLOUR "" + set HIGH_COLOUR "" + } + + set msg "" + if {[dict size $resultdict]} { + set copied [dict get $resultdict files_copied] + if {[llength $copied] == 0} { + set HIGHLIGHT $LOW_COLOUR + } else { + set HIGHLIGHT $HIGH_COLOUR + } + set ruler $LINE_COLOUR[string repeat - 78]$R + if {$title ne ""} { + append msg $ruler \n + append msg $title \n + } + append msg $ruler \n + #append msg "[dict keys $resultdict]" \n + set tgtdir [dict get $resultdict tgtdir] + set checkfolder [dict get $resultdict punkcheck_folder] + append msg "${HIGHLIGHT}Copied [llength $copied] files from [dict get $resultdict srcdir] to [dict get $resultdict tgtdir]$R" \n + foreach f $copied { + append msg "COPIED [punkcheck::lib::path_relative $checkfolder $f]" \n + append msg " TO $tgtdir" \n + } + append msg "[llength [dict get $resultdict sources_unchanged]] unchanged source files" \n + append msg "[llength [dict get $resultdict files_skipped]] skipped files" \n + append msg $ruler \n + } + return $msg + } + + namespace eval recordlist { + set pkg punkcheck + namespace path ::punkcheck + + proc records_as_target_dict {record_list} { + set result [dict create] + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + set tgtlist [dict get $rec -targets] + if {[dict exists $result $tgtlist]} { + #todo - warn - duplicate record for same targetlist - shouldn't happen as we should be using get_file_record to find existing records + error "punkcheck::recordlist::records_as_target_dict - multiple records with same targetlist '$tgtlist'" + } + dict set result $tgtlist $rec + } + } + return $result + } + + + #will only match if same base was used.. and same targetlist + proc get_file_record {targetlist record_list} { + set posn 0 + set found_posn -1 + set record "" + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + if {[dict get $rec -targets] eq $targetlist} { + set found_posn $posn + set record $rec + break + } + } + incr posn + } + return [list position $found_posn record $record] + } + proc file_install_record_source_changes {install_record} { + #reject INSTALLFAILED items ? + switch -- [dict get $install_record tag] { + "QUERY-INPROGRESS" - + "INSTALL-RECORD" - + "INSTALL-SKIPPED" - + "INSTALL-INPROGRESS" - + "MODIFY-INPROGRESS" - + "MODIFY-RECORD" - + "MODIFY-SKIPPED" - + "VIRTUAL-INPROGRESS" - + "VIRTUAL-RECORD" - + "VIRTUAL-SKIPPED" - + "DELETE-RECORD" - + "DELETE-INPROGRESS" - + "DELETE-SKIPPED" { + } + default { + error "file_install_record_source_changes bad install record: tag '[dict get $install_record tag]' not INSTALL-RECORD|SKIPPED|INSTALL-INPROGRESS|MODIFY-RECORD|MODIFY-INPROGRESS|VIRTUAL-RECORD|VIRTUAL-INPROGRESS|DELETE-RECORD|DELETE-INPROGRESS" + } + } + set source_list [dict_getwithdefault $install_record body [list]] + set changed [list] + set unchanged [list] + foreach src $source_list { + if {[dict exists $src -changed]} { + if {[dict get $src -changed] !=0} { + lappend changed [dict get $src -path] + } else { + lappend unchanged [dict get $src -path] + } + } else { + lappend changed [dict get $src -path] + } + } + return [dict create changed $changed unchanged $unchanged] + } + + #assume only one for name - use first encountered? + proc get_installer_record {name record_list} { + set posn 0 + set found_posns [list] + set record "" + #puts ">>>> checking [llength $record_list] punkcheck records" + foreach rec $record_list { + if {[dict get $rec tag] eq "INSTALLER"} { + if {[dict get $rec -name] eq $name} { + set found_posn $posn + set record $rec + lappend found_posns $posn + } + } + incr posn + } + if {[llength $found_posns] > 1} { + error "punkcheck::recordlist::get_installer_record - multiple installer records with name '$name' found at positions $found_posns" + } elseif {[llength $found_posns] == 0} { + return [list position -1 record ""] + } else { + #single record found + return [list position [lindex $found_posn 0] record $record] + } + + } + + proc new_installer_record {name args} { + if {[llength $args] %2 !=0} { + error "punkcheck new_installer_record args must be name-value pairs" + } + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + + #put -tsiso first so it lines up with -tsiso in event records + set defaults [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $ts {*}{ + } -name $name {*}{ + } -keep_events 5 {*}{ + } + ] + set opts [dict merge $defaults $args] + + #set this_installer_record_list [punk::tdl::prettyparse [list INSTALLER name $opt_installer ts $ts tsiso $tsiso keep_events 5 {}]] + #set this_installer_record [lindex $this_installer_record_list 0] + + set record [dict create tag INSTALLER {*}$opts body {}] + + + return $record + } + proc new_installer_event_record {type args} { + if {[llength $args] %2 !=0} { + error "punkcheck new_installer_event_record args must be name-value pairs" + } + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set defaults [list {*}{ + } -tsiso $tsiso {*}{ + } -ts $ts {*}{ + } -type $type {*}{ + } + ] + set opts [dict merge $defaults $args] + + set record [dict create tag EVENT {*}$opts] + } + #need to scan entire set if filerecords to check if event is still referenced + proc installer_record_pruneevents {installer_record record_list} { + set keep 5 + if {[dict exists $installer_record -keep_events]} { + set keep [dict get $installer_record -keep_events] + } + + if {[dict exists $installer_record body]} { + set body_items [dict get $installer_record body] + } else { + set body_items [list] + } + set kept_body_items [list] + set kcount 0 + foreach item [lreverse $body_items] { + if {[dict get $item tag] eq "EVENT"} { + incr kcount + if {$keep < 0 || $kcount <= $keep} { + lappend kept_body_items $item + } else { + set eventid "" + if {[dict exists $item -id]} { + set eventid [dict get $item -id] + } + if {$eventid ne "" && $eventid ne "unspecified"} { + #keep if referenced, discard if not, or if eventid empty/unspecified + set is_referenced 0 + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + if {[dict exists $rec body]} { + foreach install [dict get $rec body] { + if {[dict exists $install -eventid] && [dict get $install -eventid] eq $eventid} { + set is_referenced 1 + break + } + } + } + } + if {$is_referenced} { + break + } + } + if {$is_referenced} { + lappend kept_body_items $item + } + } + } + } else { + lappend kept_body_items $item + } + } + set kept_body_items [lreverse $kept_body_items] + dict set installer_record body $kept_body_items + return $installer_record + } + proc installer_record_add_event {installer_record event} { + if {[dict get $installer_record tag] ne "INSTALLER"} { + error "installer_record_add_event bad installer record: tag not INSTALLER" + } + if {[dict get $event tag] ne "EVENT"} { + error "installer_record_add_event bad event record: tag not EVENT" + } + if {[dict exists $installer_record body]} { + set body_items [dict get $installer_record body] + } else { + set body_items [list] + } + lappend body_items $event + dict set installer_record body $body_items + return $installer_record + } + proc file_record_latest_installrecord {file_record} { + tailcall file_record_latest_operationrecord INSTALL $file_record + } + proc file_record_latest_operationrecord {operation file_record} { + set operation [string toupper $operation] + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_latest_operationrecord bad file_record: tag not FILEINFO" + } + if {![dict exists $file_record body]} { + return [list] + } + set body_items [dict get $file_record body] + foreach item [lreverse $body_items] { + if {[dict get $item tag] eq "$operation-RECORD"} { + return $item + } + } + return [list] + } + + + proc file_record_set_defaults {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_set_defaults bad file_record: tag not FILEINFO" + } + set defaults [list -keep_installrecords 3 -keep_skipped 1 -keep_inprogress 2] + foreach {k v} $defaults { + if {![dict exists $file_record $k]} { + dict set file_record $k $v + } + } + return $file_record + } + + #negative keep_ value will keep all + proc file_record_prune {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_prune bad file_record: tag not FILEINFO" + } + set file_record [file_record_set_defaults $file_record] + set kmap [list -keep_installrecords *-RECORD -keep_skipped *-SKIPPED -keep_inprogress *-INPROGRESS] + foreach {key rtype} $kmap { + set keep [dict get $file_record $key] + if {[dict exists $file_record body]} { + set body_items [dict get $file_record body] + } else { + set body_items [list] + } + set kept_body_items [list] + set kcount 0 + foreach item [lreverse $body_items] { + if {[string match $rtype [dict get $item tag]]} { + incr kcount + if {$keep < 0 || $kcount <= $keep} { + lappend kept_body_items $item + } + } else { + lappend kept_body_items $item + } + } + set kept_body_items [lreverse $kept_body_items] + dict set file_record body $kept_body_items + } + return $file_record + } + + #extract new or existing filerecord for path given + #REVIEW - locking/concurrency + proc extract_or_create_fileset_record {relative_target_paths recordset} { + set fetch_record_result [punkcheck::recordlist::get_file_record $relative_target_paths $recordset] + set existing_posn [dict get $fetch_record_result position] + if {$existing_posn == -1} { + puts stdout "punkcheck NO existing record for $relative_target_paths" + set isnew 1 + set fileset_record [dict create tag FILEINFO -targets $relative_target_paths body {}] + } else { + #set recordset [lreplace $recordset[unset recordset] $existing_posn $existing_posn] + #set recordset [lreplace $recordset[set recordset {}] $existing_posn $existing_posn] + ledit recordset $existing_posn $existing_posn + set isnew 0 + set fileset_record [dict get $fetch_record_result record] + } + return [list record $fileset_record recordset $recordset isnew $isnew oldposition $existing_posn] + } + + } + +} + + + + +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punkcheck +} + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punkcheck [namespace eval punkcheck { + set pkg punkcheck + variable version + set version 0.2.0 +}] +return