jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1002 Commits
1 Branch
1 Tag
189 MiB
 
 
 
 
 
 
Tree: b158bb499a
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from 'b158bb499a'
${ noResults }
punkshell/src/bootsupport/modules/punkcheck-0.6.0.tm

2783 lines
159 KiB
Raw Blame History

# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'dev make' or src/make.tcl to update from <pkg>-buildversion.txt
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2023
#
# @@ Meta Begin
# Application punkcheck 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ 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 ""} {
#.punkcheck.* covers the G-095 protocol siblings (.punkcheck.lock, .punkcheck.tmp.<pid>)
set default_excludefiletail_core [list "*.swp" "*[punk::mix::util::tm_version_magic]*" "*-buildversion.txt" ".punkcheck" ".punkcheck.*"]
}
return $default_excludefiletail_core
}
proc load_records_from_file {punkcheck_file} {
set record_list [list]
if {[file exists $punkcheck_file]} {
#G-095: the atomic-rename save keeps content untorn, but on Windows a reader's open can
#transiently be denied while a writer's MoveFileEx replace is in flight - retry the read
#with backoff. Parse errors stay strict (they indicate real corruption, never a race).
set backoff 10
set deadline [expr {[clock milliseconds] + 2000}]
while {1} {
if {![catch {punk::mix::util::fcat $punkcheck_file} tdlscript]} {
break
}
if {![file exists $punkcheck_file]} {
#genuinely deleted between our checks - same as never present
return $record_list
}
if {[clock milliseconds] >= $deadline} {
error "punkcheck::load_records_from_file failed to read '$punkcheck_file'\n error:$tdlscript"
}
after $backoff
set backoff [expr {min($backoff * 2,100)}]
}
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"
}
#G-095: write-temp-then-atomic-rename so readers never observe torn content.
#The temp file lives in the same directory (same volume) as the target; the rename is retried
#with backoff for Windows sharing violations (a concurrent reader holding the target open).
set tmpfile "${punkcheck_file}.tmp.[pid]"
set fd [open $tmpfile w]
chan configure $fd -translation binary
puts -nonewline $fd $newtdl
flush $fd
close $fd
set renamed 0
set backoff 20
set deadline [expr {[clock milliseconds] + 2000}]
while {1} {
if {![catch {file rename -force -- $tmpfile $punkcheck_file} errRename]} {
set renamed 1
break
}
if {[clock milliseconds] >= $deadline} {
break
}
after $backoff
set backoff [expr {min($backoff * 2,250)}]
}
if {!$renamed} {
catch {file delete -- $tmpfile}
error "punkcheck::save_records_to_file failed to atomically replace '$punkcheck_file' (trigger: $trigger) - last rename error: $errRename"
}
#hygiene: clear abandoned temp files from crashed/killed writers (age-gated; own pattern only)
foreach leftover [glob -nocomplain -types f -- "${punkcheck_file}.tmp.*"] {
if {![catch {file mtime $leftover} lmt] && ([clock seconds] - $lmt) > 600} {
catch {file delete -- $leftover}
}
}
return [list recordcount [llength $recordlist] linecount $linecount]
}
#-----------------------------------------------
#G-095 advisory lockfile protocol: serializes whole installer events per punkcheck root.
#Cross-platform primitive: open {WRONLY CREAT EXCL} is an atomic create-new on Windows and
#POSIX under Tcl 8.6 and 9 with no extra packages. The holder keeps the channel open for the
#lock's duration (on Windows an open handle also resists deletion by other processes).
#In-process re-acquisition is reference-counted: sequential installtrack instances over one
#.punkcheck file in one process are an established make.tcl pattern and must not self-deadlock.
#The lock is advisory - readers (punkcheck::cli status, load_records_from_file) never take it;
#their torn-read immunity comes from the atomic rename in save_records_to_file.
namespace eval lock {
namespace path ::punkcheck
variable held
if {![info exists held]} {
set held [dict create] ;#normalized lockfile path -> dict {channel <chan> refcount <n>}
}
namespace eval argdoc {
lappend PUNKARGS [list {
@id -id ::punkcheck::lock::acquire
@cmd -name "punkcheck::lock::acquire"\
-summary\
"Acquire the advisory event lock for a punkcheck file."\
-help\
"Acquires the advisory sibling lockfile <punkcheck_file>.lock via an atomic
create-new open, serializing whole installer events per punkcheck root
across processes. The holder identity (pid/host/installer/timestamp) is
written into the lockfile and the channel is held open for the lock's
duration. In-process re-acquisition is reference-counted.
On contention the acquisition retries with backoff until -timeout, breaking
stale locks early (provably-dead holder pid on this host when a liveness
capability is present, or lockfile age beyond -staleage), then errors with
errorcode {PUNKCHECK LOCK TIMEOUT <lockfile>} naming the holder.
Returns a token for punkcheck::lock::release.
The lock is advisory: readers never take it (torn-read immunity comes from
the atomic-rename save)."
@leaders -min 1 -max 1
punkcheck_file -type file -help\
"Path of the .punkcheck file whose sibling lockfile governs the root."
@opts
-timeout -type integer -help\
"Milliseconds to keep retrying on contention before erroring.
Default 15000, or env(PUNKCHECK_LOCK_TIMEOUT) when set."
-staleage -type integer -help\
"Seconds beyond which a contended lockfile is broken on age alone.
Default 300, or env(PUNKCHECK_LOCK_STALEAGE) when set."
-installer -type string -default "" -help\
"Holder identity recorded in the lockfile contents."
-warnchannel -type string -default stderr -help\
"Channel receiving stale-break warnings."
}]
lappend PUNKARGS [list {
@id -id ::punkcheck::lock::release
@cmd -name "punkcheck::lock::release"\
-summary\
"Release a token from punkcheck::lock::acquire."\
-help\
"Reference-counted: the lockfile channel is closed and the file deleted when
the in-process count reaches zero. Unknown tokens return 0 (idempotent for
cleanup paths); handled tokens return 1."
@values -min 1 -max 1
token -type string -help\
"Token returned by punkcheck::lock::acquire."
}]
}
#acquire the advisory event lock for a punkcheck file. Returns a token for release.
# -timeout ms to keep retrying on contention before erroring (names the holder)
# -staleage seconds after which a contended lockfile is broken on age alone
# -installer holder identity recorded in the lockfile contents
#env overrides PUNKCHECK_LOCK_TIMEOUT / PUNKCHECK_LOCK_STALEAGE apply when options are not passed.
proc acquire {punkcheck_file args} {
variable held
set default_timeout 15000
set default_staleage 300
if {[info exists ::env(PUNKCHECK_LOCK_TIMEOUT)] && [string is integer -strict $::env(PUNKCHECK_LOCK_TIMEOUT)]} {
set default_timeout $::env(PUNKCHECK_LOCK_TIMEOUT)
}
if {[info exists ::env(PUNKCHECK_LOCK_STALEAGE)] && [string is integer -strict $::env(PUNKCHECK_LOCK_STALEAGE)]} {
set default_staleage $::env(PUNKCHECK_LOCK_STALEAGE)
}
set defaults [dict create -timeout $default_timeout -staleage $default_staleage -installer "" -warnchannel stderr]
if {[llength $args] % 2} {
error "punkcheck::lock::acquire arguments after punkcheck_file must be -flag value pairs. known flags: [dict keys $defaults]"
}
foreach {k v} $args {
if {$k ni [dict keys $defaults]} {
error "punkcheck::lock::acquire unrecognised flag '$k'. known flags: [dict keys $defaults]"
}
}
set opts [dict merge $defaults $args]
set timeout [dict get $opts -timeout]
set staleage [dict get $opts -staleage]
set installer [dict get $opts -installer]
set warnchannel [dict get $opts -warnchannel]
set lockfile [file normalize "${punkcheck_file}.lock"]
if {[dict exists $held $lockfile]} {
#in-process re-acquisition (sequential or nested installers on one punkcheck root)
dict set held $lockfile refcount [expr {[dict get $held $lockfile refcount] + 1}]
return $lockfile
}
set deadline [expr {[clock milliseconds] + $timeout}]
set backoff 50
while {1} {
if {![catch {open $lockfile {WRONLY CREAT EXCL}} fd]} {
chan configure $fd -translation lf
set holderinfo [dict create pid [pid] host [info hostname] installer $installer tsiso [clock format [clock seconds] -format "%Y-%m-%dT%H:%M:%S"] ts [clock microseconds]]
puts $fd $holderinfo
flush $fd
dict set held $lockfile [dict create channel $fd refcount 1]
return $lockfile
}
#contended - identify the holder (best effort: the file can vanish between the
#failed EXCL open and this read)
set holderinfo ""
catch {
set rfd [open $lockfile r]
set holderinfo [string trim [read $rfd]]
close $rfd
}
set holder_pid ""
set holder_host ""
if {[llength $holderinfo] % 2 == 0} {
set holder_pid [dict_getwithdefault $holderinfo pid ""]
set holder_host [dict_getwithdefault $holderinfo host ""]
}
set broke 0
#liveness stale-break: holder recorded on this host and provably dead (capability-gated)
if {[string is integer -strict $holder_pid] && $holder_host eq [info hostname] && $holder_pid != [pid]} {
if {[pid_liveness $holder_pid] eq "dead"} {
catch {puts $warnchannel "punkcheck::lock warning: breaking stale lock '$lockfile' - holder pid $holder_pid on this host is no longer running (holder: $holderinfo)"}
catch {file delete -- $lockfile}
set broke 1
}
}
if {!$broke} {
#age-based stale-break: the portable baseline
if {[catch {file mtime $lockfile} lockmtime]} {
#lockfile vanished since the failed open - retry immediately
set broke 1
} elseif {([clock seconds] - $lockmtime) > $staleage} {
catch {puts $warnchannel "punkcheck::lock warning: breaking stale lock '$lockfile' - older than ${staleage}s (holder: $holderinfo)"}
catch {file delete -- $lockfile}
set broke 1
}
}
if {!$broke} {
if {[clock milliseconds] >= $deadline} {
if {$holderinfo eq ""} {
set holderdesc "(holder unknown - lockfile unreadable)"
} else {
set holderdesc $holderinfo
}
return -code error -errorcode [list PUNKCHECK LOCK TIMEOUT $lockfile] "punkcheck::lock::acquire timeout after ${timeout}ms waiting for '$lockfile' held by: $holderdesc"
}
after $backoff
set backoff [expr {min($backoff * 2,500)}]
}
}
}
#release a token from acquire. Reference-counted; the lockfile is closed and deleted when
#the count reaches zero. Unknown tokens return 0 (idempotent for cleanup paths).
proc release {token} {
variable held
if {![dict exists $held $token]} {
return 0
}
set refcount [expr {[dict get $held $token refcount] - 1}]
if {$refcount > 0} {
dict set held $token refcount $refcount
return 1
}
catch {close [dict get $held $token channel]}
catch {file delete -- $token}
dict unset held $token
return 1
}
#alive | dead | unknown for a pid on this host (capability-gated liveness)
proc pid_liveness {pid} {
if {"windows" eq $::tcl_platform(platform)} {
if {![catch {package require twapi}]} {
if {[catch {twapi::process_exists $pid} exists]} {
return unknown
}
return [expr {$exists ? "alive" : "dead"}]
}
return unknown
} else {
if {![catch {exec kill -0 $pid}]} {
return alive
} else {
#kill -0 errors for both nonexistent (No such process) and not-permitted (alive,
#other user) - only the former is a confident 'dead'
catch {exec kill -0 $pid} errkill
if {[string match -nocase "*no such process*" $errkill]} {
return dead
}
return unknown
}
}
}
}
#Concurrent multi-process writer safety (G-095) lives at the single save chokepoint (installtrack
#method save_working_recordset) and its callers: saves are write-temp-then-atomic-rename, whole
#installer events hold the advisory .punkcheck.lock (punkcheck::lock, start_event through end),
#deferred flushes merge own records into freshly-loaded file state, and an optimistic
#mtime/size tripwire warns when a non-protocol writer touched the file between load and save.
#an installtrack object 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.
#
#Record lifecycle (G-094): the installtrack/installevent OO layer is the sole implementation of the
#.punkcheck record lifecycle (targetset init / add-source / started / end). Each event carries a
#persistence policy chosen at start_event:
# eager (default) - every non-QUERY targetset operation is an independent read-modify-write of the file
# deferred - targetset operations update the installtrack's in-memory working recordset only;
# the recordset is persisted by an explicit $installer flush (event-scoped save).
# An ended deferred event that was never flushed deliberately discards its updates
# (this is how -source-checksum compare mode avoids storing).
#QUERY operations are never persisted in either mode and never touch the working recordset.
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
#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
variable o_persistence
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 {}
-persistence eager
}]
set opts [dict merge $defaults $args]
set o_persistence [dict get $opts -persistence]
if {$o_persistence ni [list eager deferred]} {
error "[self] constructor error: -persistence must be 'eager' or 'deferred'. Received '$o_persistence'"
}
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_persistence {} {
return $o_persistence
}
method get_installer {} {
return $o_installer
}
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]
#notify parent so its active-event slot clears and a subsequent start_event is valid
$o_installer event_ended [self]
}
method targetset_dict {} {
punkcheck::recordlist::records_as_target_dict [$o_installer get_recordlist]
}
#merge the event's current fileset record into the parent installtrack's working recordset
#(replace the record with matching -targets, or append when absent). The parent also
#records the targetlist as touched - the 'own records' set its merge-on-flush carries
#into freshly-loaded file state.
method MergeFilesetToWorking {} {
set record_list [$o_installer get_recordlist]
set targetlist [dict get $o_fileset_record -targets]
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
}
$o_installer set_recordlist $record_list
$o_installer touched_target $targetlist
}
#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
#working recordset acquisition per persistence policy:
# eager - refresh the parent installtrack's working recordset from the file (each op is an independent read-modify-write)
# deferred - the parent's in-memory working recordset is authoritative between flushes; no file access
# QUERY - reads the freshest available state but never touches the working recordset (never persisted)
if {$o_operation eq "QUERY"} {
if {$o_persistence eq "deferred"} {
set record_list [$o_installer get_recordlist]
} else {
set record_list [punkcheck::load_records_from_file $punkcheck_file]
}
} else {
if {$o_persistence eq "eager"} {
$o_installer load_all_records
}
set record_list [$o_installer get_recordlist]
}
if {$o_persistence eq "eager"} {
#---------------------------------------------------------------------------
#load as dict to test for dupes (skipped in deferred mode - per-op scan cost, and the
#pre-G-094 batch recordset handling this mode inherits from never ran it either)
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
if {$isnew && $o_debugchannel ne ""} {
puts $o_debugchannel "punkcheck: no existing FILEINFO record for targetset '$o_targets' - creating"
}
#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 {}]
#todo - look for existing "-INPROGRESS" records - mark as failed or incomplete?
dict lappend o_fileset_record body $new_inprogress_record
if {$o_operation ne "QUERY" && $o_persistence eq "eager"} {
#reinsert the inprogress-marked record and persist - crash evidence in the file during long operations
if {$isnew} {
lappend record_list $o_fileset_record
} else {
ledit record_list $oldposition -1 $o_fileset_record
}
$o_installer set_recordlist $record_list
$o_installer save_working_recordset "targetset_init $o_operation [llength $targetset] targets"
}
#deferred: the *-INPROGRESS state stays event-local (o_fileset_record) - only finalized records
#reach the working recordset (targetset_end), mirroring the pre-G-094 batch recordset handling.
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 <name> targetset_endphase <name> calls to store timestamps and calculate elapsed time
method targetset_started {} {
if {$o_operation_start_ts eq ""} {
error "[self] targetset_started - no current operation - call targetset_init first"
}
if {![punkcheck::lib::is_file_record_inprogress $o_fileset_record]} {
error "targetset_started error: bad fileset_record - expected FILEINFO with last body element *-INPROGRESS"
}
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}]
dict set installing_record -metadata_us $metadata_us
dict set installing_record -ts_start_transfer $ts_now
lset fileinfo_body end $installing_record
dict set o_fileset_record body $fileinfo_body
if {$o_operation ne "QUERY" && $o_persistence eq "eager"} {
$o_installer load_all_records
my MergeFilesetToWorking
$o_installer save_working_recordset "targetset_started $o_operation [llength $o_targets] targets"
}
return $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]
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]
if {$o_operation ne "QUERY"} {
if {$o_persistence eq "eager"} {
$o_installer load_all_records
my MergeFilesetToWorking
$o_installer save_working_recordset "targetset_end $o_operation $status [llength $o_targets] targets"
} else {
#deferred - finalized record joins the in-memory working recordset; persisted at flush
my MergeFilesetToWorking
}
}
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 <val> opt <cksum opts>} 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?
}
#add a named value (not a filesystem path) as a source - e.g the resolved build version of a module target.
#compared by -value against the last completed install record, so it participates in targetset_source_changes.
method targetset_addsource_virtual {id value} {
set o_fileset_record [punkcheck::installsource_add_virtual $o_fileset_record $id $value]
}
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
variable o_event_lock ;#advisory lock token while an event (or transient flush) holds it
variable o_touched_targets ;#targetlists this instance's events merged - the 'own records' set for merge-on-flush
variable o_load_sig ;#file signature {mtime size} at last load - optimistic tripwire vs non-protocol writers
constructor {installername punkcheck_file {debugchannel ""}} {
set o_debugchannel $debugchannel
set o_active_event ""
set o_event_lock ""
set o_touched_targets [dict create]
set o_load_sig ""
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 ""} {
if {![punkcheck::lib::stdin_is_interactive]} {
#G-095: unattended runs get a clean actionable error instead of a prompt
#that would block on open stdin or mis-answer on closed/piped stdin
set errmsg "punkcheck installtrack sanity check failed: punkcheck file '$o_checkfile' contains multiple INSTALLER records with -name '$insane'."
append errmsg \n "Likely cause: concurrent writers racing the file (writers predating the G-095 lock protocol) or an interrupted run."
append errmsg \n "Session is non-interactive - not prompting. Recovery: inspect the file, or delete it and rerun."
append errmsg \n "Deleting loses install history and checksums (unnecessary recopies next run); for synced-targets consumers (e.g bin/ deploys) existing targets then skip until manually reconciled, since skipped records never store target cksums."
error $errmsg
}
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 " Caveat: for synced-targets consumers (e.g bin/ deploys) deletion wedges existing targets into skip-until-manually-reconciled - skipped records never store the target cksums that mode compares against."
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 {
#map the persisted EVENT record fields to constructor options explicitly.
#(the record keys are -ts_begin/-ts_end - passing the raw record gave the constructor's
# -tsbegin/-tsend defaults, so reconstructed events took 'now' as begin and empty end,
# and any later flush/save_installer_record rewrote prior event history with those values)
set eargs [list]
lappend eargs -id [punkcheck::dict_getwithdefault $e -id ""]
lappend eargs -tsbegin [punkcheck::dict_getwithdefault $e -ts_begin ""]
lappend eargs -tsend [punkcheck::dict_getwithdefault $e -ts_end ""]
lappend eargs -types [punkcheck::dict_getwithdefault $e -types {}]
lappend eargs -config [punkcheck::dict_getwithdefault $e -config {}]
set eobj [punkcheck::installevent create [namespace current]::event_[my events count] [self] [dict get $e -source] [dict get $e -targets] {*}$eargs]
$o_events add $eobj [dict get $e -id]
}
}
destructor {
#release any lock still held (an abandoned event, or an error path that skipped end)
if {$o_event_lock ne ""} {
catch {punkcheck::lock::release $o_event_lock}
set o_event_lock ""
}
}
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]
set o_load_sig [my Checkfile_signature]
}
#file signature for the optimistic tripwire ({} when the file doesn't exist yet)
method Checkfile_signature {} {
if {[catch {list [file mtime $o_checkfile] [file size $o_checkfile]} sig]} {
return {}
}
return $sig
}
#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]
}
#working recordset accessors - the installtrack's o_record_list is the working copy of the
#.punkcheck recordset. Eager operations and start_event refresh it from the file; deferred
#operations treat it as authoritative between flushes.
method set_recordlist {records} {
set o_record_list $records
}
#record a targetlist as touched by this instance's events - the 'own records' set that
#merge-on-flush carries into freshly-loaded file state
method touched_target {targetlist} {
dict set o_touched_targets $targetlist 1
}
method lock_held {} {
return [expr {$o_event_lock ne ""}]
}
#single save chokepoint: every .punkcheck write from the record lifecycle funnels through here.
#G-095 measures live here: the write itself is write-temp-then-atomic-rename
#(save_records_to_file), a caller without the event lock gets a transient one, and the
#optimistic tripwire warns when the file changed on disk since this installer last loaded
#it (a writer bypassing the advisory protocol - e.g an older vendored punkcheck during
#the transition window).
method save_working_recordset {{trigger save_working_recordset}} {
set transient 0
if {$o_event_lock eq ""} {
set o_event_lock [punkcheck::lock::acquire $o_checkfile -installer $o_name]
set transient 1
}
try {
set current_sig [my Checkfile_signature]
if {$o_load_sig ne {} && $current_sig ne {} && $current_sig ne $o_load_sig} {
catch {puts stderr "punkcheck warning: '$o_checkfile' changed on disk since this installer last loaded it (advisory lock protocol bypassed by another writer?) - saving anyway (trigger: $trigger installer: $o_name)"}
}
set saveresult [punkcheck::save_records_to_file $o_record_list $o_checkfile $trigger $o_debugchannel]
set o_load_sig [my Checkfile_signature]
return $saveresult
} finally {
if {$transient} {
punkcheck::lock::release $o_event_lock
set o_event_lock ""
}
}
}
#sync this installer's own records into freshly-loaded file state and persist via the
#chokepoint - the event-scoped persistence point for deferred events.
#Merge-on-flush (G-095): the file is re-loaded under the lock and only this installer's
#own records are carried over - the INSTALLER record by -name and touched FILEINFO
#records by -targets - so records other processes wrote since our load are preserved
#instead of being wholesale-overwritten.
method flush {{trigger flush}} {
set transient 0
if {$o_event_lock eq ""} {
set o_event_lock [punkcheck::lock::acquire $o_checkfile -installer $o_name]
set transient 1
}
try {
#fresh file state under the lock
set base [punkcheck::load_records_from_file $o_checkfile]
#merge own FILEINFO records (by -targets)
foreach targetlist [dict keys $o_touched_targets] {
set owninfo [punkcheck::recordlist::get_file_record $targetlist $o_record_list]
if {[dict get $owninfo position] == -1} {
continue
}
set ownrec [dict get $owninfo record]
set baseinfo [punkcheck::recordlist::get_file_record $targetlist $base]
set base_posn [dict get $baseinfo position]
if {$base_posn == -1} {
lappend base $ownrec
} else {
lset base $base_posn $ownrec
}
}
#merge own INSTALLER record (by -name), event-pruned against the merged set
set this_installer_record [my as_record]
set persistedinfo [punkcheck::recordlist::get_installer_record $o_name $base]
set existing_header_posn [dict get $persistedinfo position]
if {$existing_header_posn == -1} {
ledit base -1 -1 $this_installer_record
set existing_header_posn 0
} else {
lset base $existing_header_posn $this_installer_record
}
set this_installer_record [punkcheck::recordlist::installer_record_pruneevents $this_installer_record $base]
lset base $existing_header_posn $this_installer_record
set o_record_list $base
set o_load_sig [my Checkfile_signature]
my save_working_recordset $trigger
} finally {
if {$transient} {
punkcheck::lock::release $o_event_lock
set o_event_lock ""
}
}
}
#save the working recordset (installer record synced) - historical name retained.
method save_all_records {} {
my flush save_all_records
}
method save_installer_record {} {
my flush save_installer_record
}
method events {args} {
tailcall $o_events {*}$args
}
method start_event {configdict args} {
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 <abspath_sourceroot> <abspath_targetroot> first"
}
if {[llength $configdict] %2 != 0} {
error "[self] start_event configdict must have an even number of elements"
}
set defaults [dict create -persistence eager]
if {[llength $args] % 2} {
error "[self] start_event arguments after configdict must be -flag value pairs. known flags: [dict keys $defaults]"
}
foreach {k v} $args {
if {$k ni [dict keys $defaults]} {
error "[self] start_event unrecognised flag '$k'. known flags: [dict keys $defaults]"
}
}
set opts [dict merge $defaults $args]
set persistence [dict get $opts -persistence]
#G-095: acquire the advisory event lock before reading - held from here until the
#event ends (event_ended releases). This serializes whole installer events per
#punkcheck root across processes; in-process sequential installers re-enter via the
#lock registry's refcount.
set acquired_here 0
if {$o_event_lock eq ""} {
set o_event_lock [punkcheck::lock::acquire $o_checkfile -installer $o_name]
set acquired_here 1
}
try {
#refresh the working recordset from the file so this event starts from persisted state.
#(coherence: a prior event's targetset writes - eager per-op saves or a deferred flush - must not
# be discarded by saving a stale constructor-era recordset here. Unflushed deferred updates are
# deliberately abandoned by this refresh - an ended deferred event that wasn't flushed chose not
# to persist.)
my load_all_records
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} {
#no persisted installer record yet (first event since construction - the constructor only
#creates the record in memory; this save is the first write)
set this_installer_record [punkcheck::recordlist::new_installer_record $o_name]
ledit o_record_list -1 -1 $this_installer_record
set existing_header_posn 0
} 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 -persistence $persistence]
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
my save_working_recordset "start_event $eventid"
set o_active_event $eventobj
my events add $eventobj $eventid
return $eventobj
} on error {result erropts} {
if {$acquired_here && $o_event_lock ne ""} {
catch {punkcheck::lock::release $o_event_lock}
set o_event_lock ""
}
return -options $erropts $result
}
}
method installer_record_from_file {} {
set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list]
}
method get_recordlist {} {
return $o_record_list
}
method end_event {} {
if {$o_active_event eq ""} {
error "[self] end_event error - no active event"
}
$o_active_event end
}
#called by installevent end - clears the active slot so a subsequent start_event on this
#installtrack is valid (sequential events on one instance), and releases the advisory
#event lock (G-095: lock scope is the whole installer event, start_event through end)
method event_ended {eventobj} {
if {$o_active_event eq $eventobj} {
set o_active_event ""
if {$o_event_lock ne ""} {
catch {punkcheck::lock::release $o_event_lock}
set o_event_lock ""
}
}
}
method get_event {} {
return $o_active_event
}
}
}
#-----------------------------------------------
#G-094: the legacy proc pipeline (start_installer_event + installfile_begin/started/finished/skipped)
#is retired. The installtrack/installevent OO layer above is the sole implementation of the record
#lifecycle. These shims error with a pointer so stale callers fail loud and actionable.
proc start_installer_event {args} {
error "punkcheck::start_installer_event retired (G-094). Use: set obj \[punkcheck::installtrack new <name> <punkcheckfile>\]; \$obj set_source_target <src> <tgt>; \$obj start_event <configdict> ?-persistence eager|deferred? - see punkcheck::installfile_help"
}
proc installfile_begin {args} {
error "punkcheck::installfile_begin retired (G-094). Use the installevent method: \$event targetset_init INSTALL <targetset> - see punkcheck::installfile_help"
}
proc installfile_started_install {args} {
error "punkcheck::installfile_started_install retired (G-094). Use the installevent method: \$event targetset_started - see punkcheck::installfile_help"
}
proc installfile_finished_install {args} {
error "punkcheck::installfile_finished_install retired (G-094). Use the installevent method: \$event targetset_end OK - see punkcheck::installfile_help"
}
proc installfile_skipped_install {args} {
error "punkcheck::installfile_skipped_install retired (G-094). Use the installevent method: \$event targetset_end SKIPPED - see punkcheck::installfile_help"
}
#-----------------------------------------------
proc installfile_help {} {
set msg ""
append msg "punkcheck record lifecycle - installtrack/installevent object API (G-094)" \n
append msg "The legacy proc pipeline (start_installer_event, installfile_begin," \n
append msg "installfile_started_install, installfile_finished_install, installfile_skipped_install)" \n
append msg "is retired - those procs now raise errors pointing here." \n
append msg "" \n
append msg "Call in order:" \n
append msg " set installer \[punkcheck::installtrack new <installername> <path/.punkcheck>\]" \n
append msg " \$installer set_source_target <abs_sourceroot> <abs_targetroot>" \n
append msg " set event \[\$installer start_event <configdict> ?-persistence eager|deferred?\]" \n
append msg " per targetset:" \n
append msg " \$event targetset_init <QUERY|INSTALL|MODIFY|DELETE|VIRTUAL> <targetset>" \n
append msg " \$event targetset_addsource <path> (1+ times - records source metadata/cksums)" \n
append msg " \$event targetset_addsource_virtual <id> <value> (named-value sources e.g build versions)" \n
append msg " decide skip/proceed via \$event targetset_source_changes and \$event get_targets_exist" \n
append msg " \$event targetset_started (immediately before performing the operation)" \n
append msg " \$event targetset_end OK|SKIPPED|FAILED ?-note <note>?" \n
append msg " \$event end (or \$installer end_event - allows a subsequent start_event)" \n
append msg "" \n
append msg "Persistence policy (chosen per event at start_event):" \n
append msg " eager (default): each non-QUERY targetset operation is an immediate read-modify-write" \n
append msg " of the .punkcheck file (crash evidence via *-INPROGRESS records)." \n
append msg " deferred: targetset operations update the installtrack's in-memory recordset only;" \n
append msg " call \$installer flush to persist (event-scoped batch save - punkcheck::install uses this)." \n
append msg " An ended deferred event that was never flushed deliberately discards its record updates." \n
append msg " QUERY operations are never persisted in either mode." \n
append msg "" \n
append msg "Concurrent-writer safety (G-095):" \n
append msg " Saves are write-temp-then-atomic-rename - readers never see torn content." \n
append msg " start_event acquires the advisory sibling lockfile <punkcheckfile>.lock (released at event" \n
append msg " end), serializing whole installer events per punkcheck root across processes; flushes and" \n
append msg " chokepoint saves outside an event take a transient lock. Contention retries with backoff" \n
append msg " until timeout, then errors naming the holder (pid/host/installer/timestamp from the" \n
append msg " lockfile). Stale locks break on provably-dead holder pid (capability-gated) or age." \n
append msg " Env overrides: PUNKCHECK_LOCK_TIMEOUT (ms, default 15000), PUNKCHECK_LOCK_STALEAGE" \n
append msg " (seconds, default 300). Deferred flushes merge own records (INSTALLER by -name," \n
append msg " touched FILEINFO by -targets) into freshly-loaded file state." \n
return $msg
}
#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 <PATHNOTFOUND> if fpath doesn't exist
if {[file pathtype $source_relpath] eq "absolute"} {
#source shares no common root with the punkcheck folder, so path_relative left it absolute
#(e.g a //zipfs:/ module-mounted layout installing to the filesystem - G-087 module-carried layouts).
#Use the helpers' independent-absolute mode (empty base) - they error on unrelatable roots otherwise.
set ck_base ""
} else {
set ck_base $punkcheck_folder
}
if {$use_cache} {
set source_cksum_info [punk::mix::base::lib::fill_relativecksums_from_base_and_relativepathdict $ck_base [dict create $source_relpath $use_cache_record]]
} else {
set source_cksum_info [punk::mix::base::lib::get_relativecksum_from_base $ck_base $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
}
#Add a 'virtual' source to the current *-INPROGRESS record - a named value rather than a filesystem path.
#Stored as a SOURCE record with -type virtual and -path virtual:<id> so it can never collide with a real relative path.
#The -changed flag is computed by comparing -value against the matching virtual SOURCE in the last completed
#install record (no filesystem access) - so virtual sources participate in targetset_source_changes like file sources.
#Typical use: recording the resolved build version of a module target, so records identify which product of an
#unchanging source fileset (e.g <module>-0.6.0.tm + <module>-buildversion.txt) the target represents.
proc installsource_add_virtual {file_record id value} {
if {![lib::is_file_record_inprogress $file_record]} {
error "installsource_add_virtual error: bad file_record - expected FILEINFO with last body element *-INPROGRESS ($file_record)"
}
set ts_start [clock microseconds]
set virtualpath virtual:$id
set last_installrecord [lib::file_record_get_last_installrecord $file_record]
set prev_found 0
set prev_value ""
if {[llength $last_installrecord]} {
set src [lib::install_record_get_matching_source_record $last_installrecord $virtualpath]
if {[llength $src]} {
set prev_found 1
set prev_value [dict_getwithdefault $src -value ""]
}
}
set file_record_body [dict_getwithdefault $file_record body [list]]
set installing_record [lindex $file_record_body end]
set already_present_record [lib::install_record_get_matching_source_record $installing_record $virtualpath]
if {[llength $already_present_record]} {
error "installsource_add_virtual error: virtual source $virtualpath already exists in the file_record - cannot add again"
}
if {$prev_found && $prev_value eq $value} {
set changed 0
} else {
set changed 1
}
set installing_record_sources [dict_getwithdefault $installing_record body [list]]
set metadata_us [expr {[clock microseconds] - $ts_start}]
set this_source_record [dict create tag SOURCE -type virtual -size NA -path $virtualpath -value $value -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
}
#-----------------------------------------------
#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]
}
#Is stdin a terminal a user can be prompted on? (G-095: the duplicate-INSTALLER recovery
#must not block or garble unattended runs with an interactive prompt.)
#Detection is tiered and defaults to NOT interactive when no probe is available - the
#non-interactive path raises a clean actionable error, which an interactive user can act
#on just as well, whereas a prompt in an unattended run blocks or mis-answers.
proc stdin_is_interactive {} {
if {"windows" eq $::tcl_platform(platform)} {
#strict check on the actual std handle: GetConsoleMode errors for pipe/file/NUL
#stdin (twapi::get_console_handle is unsuitable - it succeeds for piped children
#of console shells; same finding as runtests.tcl colour autodetection)
if {![catch {package require twapi}]} {
return [expr {![catch {twapi::GetConsoleMode [twapi::GetStdHandle -10]}]}]
}
return 0
} else {
#tcl 9 (and 8.7) unix terminal channels expose -inputmode; pipes/files do not
if {[dict exists [chan configure stdin] -inputmode]} {
return 1
}
#tcl 8.6 unix: POSIX test(1) isatty on fd 0
if {![catch {exec test -t 0 <@stdin}]} {
return 1
}
return 0
}
}
}
#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\
-choiceprefix 0\
-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} -choiceprefix 0 -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 -choiceprefix 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\
"DEPRECATED/ignored (G-094) - retained for call compatibility.
The working recordset lives in a punkcheck::installtrack instance for
the duration of the install walk; the passed value is not consulted
(pre-G-094 behaviour also replaced it from the file at depth 0)."
-punkcheck-eventobj -default "" -help\
"(internal recursion carrier - the installevent object shared by all
levels of the install walk)"
-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|<absolutepath> 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 ""
-punkcheck-eventobj ""
-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?
}
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
#-punkcheck-records is vestigial as of G-094 (the working recordset lives in the installtrack
#instance) - the option remains accepted for call compatibility. Pre-G-094 behaviour also
#discarded the passed value at depth 0 (replaced from the file via start_installer_event).
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_installer [dict get $opts -installer]
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_punkcheck_eventid [dict get $opts -punkcheck-eventid]
set opt_punkcheck_eventobj [dict get $opts -punkcheck-eventobj]
set punkcheck_file [file join $punkcheck_folder/.punkcheck]
if {$CALLDEPTH == 0} {
if {$punkcheck_folder eq ""} {
#pre-G-094 code silently skipped event setup for an empty -punkcheck-folder and then failed
#during path relativization - fail early and clearly instead. (folder resolution above yields
#"" only when the caller explicitly passes -punkcheck-folder "")
error "punkcheck::install requires a resolvable -punkcheck-folder (target|source|project|<absolutepath>) - received an empty value"
}
set config $opts
dict unset config -call-depth-internal
dict unset config -max-depth
dict unset config -subdirlist
dict unset config -progresschannel
dict unset config -punkcheck-eventobj
tcl::dict::for {k v} $config {
if {$v eq "\uFFFF"} {
dict unset config $k
}
}
#G-094: batch install is a tree-walking consumer of the OO layer in deferred persistence mode.
#The installtrack working recordset accumulates finalized records in memory; one flush at the
#end of the walk persists them (event-scoped save), preserving the original batch write pattern.
set punkcheck_installer [punkcheck::installtrack new $opt_installer $punkcheck_file]
$punkcheck_installer set_source_target $srcdir $tgtdir
set punkcheck_eventobj [$punkcheck_installer start_event $config -persistence deferred]
set punkcheck_eventid [$punkcheck_eventobj get_id]
} else {
set punkcheck_eventobj $opt_punkcheck_eventobj
set punkcheck_installer [$punkcheck_eventobj get_installer]
set punkcheck_eventid $opt_punkcheck_eventid
}
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
set punkcheck_records [$punkcheck_installer get_recordlist]
if {$CALLDEPTH == 0} {
$punkcheck_eventobj end
$punkcheck_eventobj destroy
$punkcheck_installer destroy
}
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.6.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.6.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 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
}
#puts stdout " rel_target: $punkcheck_target_relpath"
if {$opt_progresschannel ne ""} {
#pre-G-094 output parity: announce first-seen targets when progress output is active
set fetch_filerec_result [punkcheck::recordlist::get_file_record $punkcheck_target_relpath [$punkcheck_installer get_recordlist]]
if {[dict get $fetch_filerec_result position] == -1} {
puts stdout "\nNO existing record for $punkcheck_target_relpath"
}
}
#G-094: per-target record lifecycle through the OO layer (deferred persistence - no per-file saves,
#finalized records accumulate in the installtrack working recordset until the end-of-walk flush)
$punkcheck_eventobj targetset_init INSTALL $punkcheck_target_relpath
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
#}
#targetset_addsource hits the filesystem for the sourcepath - gets checksums/timestamps
#depending on config - and returns the updated fileset record (no save in deferred mode)
set ts1 [clock milliseconds]
set filerec [$punkcheck_eventobj targetset_addsource $relative_source_path]
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_eventobj targetset_source_changes]
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"} {
$punkcheck_eventobj targetset_started
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 "
$punkcheck_eventobj targetset_started
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
lappend files_copied $current_source_dir/$m
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)
$punkcheck_eventobj targetset_started
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 stderr " (copy 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} {
$punkcheck_eventobj targetset_started
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
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
}
#finalize the record: targetset_end sets the tag, -elapsed_us, and computes/stores post-install
#target cksums (-targets_cksums/-cksum_all_opts/-cksum_us) for successful installs, then merges
#the finalized record into the installtrack working recordset (in-memory - deferred mode)
if {$is_skip} {
$punkcheck_eventobj targetset_end SKIPPED
} else {
$punkcheck_eventobj targetset_end OK
}
#------------------------------------------------------------
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 [list {*}{
} -call-depth-internal [expr {$CALLDEPTH + 1}] {*}{
} -subdirlist [list {*}$subdirlist $d] {*}{
} -punkcheck-folder $punkcheck_folder {*}{
} -punkcheck-eventid $punkcheck_eventid {*}{
} -punkcheck-eventobj $punkcheck_eventobj {*}{
} -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]
#the evolving recordset is shared state in the installtrack instance - nothing to carry back
}
if {$CALLDEPTH == 0} {
#event-scoped deferred flush: one save persists the whole walk's finalized records.
#compare-only runs (-source-checksum compare) never flush - the in-memory updates are
#deliberately discarded, matching the pre-G-094 batch behaviour (the start_event save
#already registered the event itself in both cases).
if {[string match *store* $opt_source_checksum] && ([llength $files_copied] || [llength $files_skipped])} {
set saveresult [$punkcheck_installer flush "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]"
}
set punkcheck_records [$punkcheck_installer get_recordlist]
$punkcheck_eventobj end
$punkcheck_eventobj destroy
$punkcheck_installer destroy
} else {
set punkcheck_records [$punkcheck_installer get_recordlist]
}
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
#locking/concurrency: G-095 (this is a pure record transform - no file access; the isnew key
#tells the caller whether a record existed, callers own any reporting)
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} {
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 ::punkcheck::lock
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punkcheck [namespace eval punkcheck {
set pkg punkcheck
variable version
set version 0.6.0
}]
return