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.
981 lines
45 KiB
981 lines
45 KiB
package provide punk::mix::base [namespace eval punk::mix::base { |
|
variable version |
|
set version 0.1 |
|
}] |
|
|
|
package require punk::path |
|
package require punk::lib ;#format_number etc |
|
|
|
#base internal plumbing functions |
|
namespace eval punk::mix::base { |
|
proc set_alias {cmdname args} { |
|
#--------- |
|
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
|
lassign [_split_args $args] _opts opts _args args |
|
if {[dict exists $opts -extension]} { |
|
set extension [dict get $opts -extension] |
|
} else { |
|
set extension "" |
|
} |
|
#--------- |
|
|
|
uplevel #0 [list interp alias {} $cmdname {} punk::mix::base::_cli -extension $extension] |
|
} |
|
proc _cli {args} { |
|
#--------- |
|
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
|
lassign [_split_args $args] _opts opts _args args |
|
if {[dict exists $opts -extension]} { |
|
set extension [dict get $opts -extension] |
|
} else { |
|
set extension "" |
|
} |
|
#--------- |
|
if {![string length $extension]} { |
|
set extension [namespace qualifiers [lindex [info level -1] 0]] |
|
} |
|
#puts stderr "punk::mix::base extension: [string trimleft $extension :]" |
|
if {![string length $extension]} { |
|
#if still no extension - must have been called directly as punk::mix::base::_cli |
|
if {![llength $args]} { |
|
set args "help" |
|
} |
|
set extension [namespace current] |
|
} |
|
#init usually used to load commandsets (and export their names) into the extension namespace/ensemble |
|
${extension}::_init |
|
if {![llength $args]} { |
|
if {[info exists ${extension}::default_command]} { |
|
tailcall $extension [set ${extension}::default_command] |
|
} |
|
tailcall $extension |
|
} else { |
|
tailcall $extension {*}$args |
|
} |
|
} |
|
proc _unknown {ns args} { |
|
#--------- |
|
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
|
lassign [_split_args $args] _opts opts _args args |
|
if {[dict exists $opts -extension]} { |
|
set extension [dict get $opts -extension] |
|
} else { |
|
set extension "" |
|
} |
|
#--------- |
|
|
|
if {![string length $extension]} { |
|
set extension [namespace qualifiers [lindex [info level -1] 0]] |
|
} |
|
#puts stderr "arglen:[llength $args]" |
|
#puts stdout "_unknown '$ns' '$args'" |
|
|
|
set d_commands [get_commands -extension $extension] |
|
set all_commands [list {*}[dict get $d_commands main] {*}[dict get $d_commands base]] |
|
|
|
|
|
error "Unknown subcommand \"[lindex $args 0]\": must be one of: $all_commands" "punk::mix::base _unknown $ns $args" [list unknown_ensemble_subcommand ensemble punk::mix::base] |
|
} |
|
proc _redirected {from_ns subcommand args} { |
|
#puts stderr "_redirected from_ns: $from_ns subcommand:$subcommand args:$args" |
|
set pname [namespace current]::$subcommand |
|
if {$pname in [info procs $pname]} { |
|
set argnames [info args $pname] |
|
#puts stderr "_redirected $subcommand argnames: $argnames" |
|
if {[lindex $argnames end] eq "args"} { |
|
set pos_argnames [lrange $argnames 0 end-1] |
|
} else { |
|
set pos_argnames $argnames |
|
} |
|
set argvals [list] |
|
set numargs [llength $pos_argnames] |
|
if {$numargs > 0} { |
|
set argvals [lrange $args 0 $numargs-1] |
|
set args [lrange $args $numargs end] |
|
} |
|
if {[llength $argvals] < $numargs} { |
|
error "wrong # args: $from_ns $subcommand requires args: $pos_argnames" |
|
} |
|
tailcall [namespace current] $subcommand {*}$argvals {*}$args -extension $from_ns |
|
} else { |
|
if {[regexp {.*[*?].*} $subcommand]} { |
|
set d_commands [get_commands -extension $from_ns] |
|
set all_commands [list {*}[dict get $d_commands main] {*}[dict get $d_commands base]] |
|
set matched_commands [lsearch -all -inline $all_commands $subcommand] |
|
set commands "" |
|
foreach m $matched_commands { |
|
append commands $m \n |
|
} |
|
return $commands |
|
} |
|
tailcall [namespace current] $subcommand {*}$args -extension $from_ns |
|
} |
|
} |
|
proc _split_args {arglist} { |
|
#don't assume arglist is fully paired. |
|
set posn [lsearch $arglist -extension] |
|
set opts [list] |
|
if {$posn >= 0} { |
|
if {$posn+2 <= [llength $arglist]} { |
|
set opts [list -extension [lindex $arglist $posn+1]] |
|
set argsremaining [lreplace $arglist $posn $posn+1] |
|
} else { |
|
#no value supplied to -extension |
|
error "punk::mix::base::_split_args - no value found for option '-extension'. Supply a value or omit the option." |
|
} |
|
} else { |
|
set argsremaining $arglist |
|
} |
|
|
|
return [list opts $opts args $argsremaining] |
|
} |
|
} |
|
|
|
|
|
#base API (potentially overridden functions - may also be called from overriding namespace) |
|
#commands should either handle or silently ignore -extension <namespace/ensemble> |
|
namespace eval punk::mix::base { |
|
namespace ensemble create |
|
namespace export help dostuff get_commands set_alias |
|
namespace ensemble configure [namespace current] -unknown punk::mix::base::_unknown |
|
proc get_commands {args} { |
|
#--------- |
|
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
|
lassign [_split_args $args] _opts opts _args args |
|
if {[dict exists $opts -extension]} { |
|
set extension [dict get $opts -extension] |
|
} else { |
|
set extension "" |
|
} |
|
#--------- |
|
if {![string length $extension]} { |
|
set extension [namespace qualifiers [lindex [info level -1] 0]] |
|
} |
|
|
|
set maincommands [list] |
|
#extension may still be blank e.g if punk::mix::base::get_commands called directly |
|
if {[string length $extension]} { |
|
set nsmain $extension |
|
#puts stdout "get_commands nsmain: $nsmain" |
|
set parentpatterns [namespace eval $nsmain [list namespace export]] |
|
set nscommands [list] |
|
foreach p $parentpatterns { |
|
lappend nscommands {*}[info commands ${nsmain}::$p] |
|
} |
|
foreach c $nscommands { |
|
set cmd [namespace tail $c] |
|
lappend maincommands $cmd |
|
} |
|
set maincommands [lsort $maincommands] |
|
} |
|
|
|
|
|
|
|
|
|
set nsbase [namespace current] |
|
set basepatterns [namespace export] |
|
#puts stdout "basepatterns:$basepatterns" |
|
set nscommands [list] |
|
foreach p $basepatterns { |
|
lappend nscommands {*}[info commands ${nsbase}::$p] |
|
} |
|
|
|
set basecommands [list] |
|
foreach c $nscommands { |
|
set cmd [namespace tail $c] |
|
if {$cmd ni $maincommands} { |
|
lappend basecommands $cmd |
|
} |
|
} |
|
set basecommands [lsort $basecommands] |
|
|
|
|
|
return [list main $maincommands base $basecommands] |
|
} |
|
proc help {args} { |
|
#' **%ensemblecommand% help** *args* |
|
#' |
|
#' Help for ensemble commands in the command line interface |
|
#' |
|
#' |
|
#' Arguments: |
|
#' |
|
#' * args - first word of args is the helptopic requested - usually a command name |
|
#' - calling help with no arguments will list available commands |
|
#' |
|
#' Returns: help text (text) |
|
#' |
|
#' Examples: |
|
#' |
|
#' ``` |
|
#' %ensemblecommand% help <commandname> |
|
#' ``` |
|
#' |
|
#' |
|
|
|
|
|
#extension.= @@opts/@?@-extension,args@@args=>. [_split_args $args] {| |
|
# >} inspect -label a {| |
|
# >} .=e>end,data>end pipeswitch { |
|
# pipecase ,0/1/#= $switchargs {| |
|
# e/0 |
|
# >} .=>. {set e} |
|
# pipecase /1,1/1/#= $switchargs |
|
#} |@@ok/result> <e/0| [namespace qualifiers [lindex [info level -1] 0]] |
|
|
|
|
|
#--------- |
|
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
|
lassign [_split_args $args] _opts opts _args args |
|
if {[dict exists $opts -extension]} { |
|
set extension [dict get $opts -extension] |
|
} else { |
|
set extension "" |
|
} |
|
#--------- |
|
|
|
|
|
|
|
if {![string length $extension]} { |
|
set extension [namespace qualifiers [lindex [info level -1] 0]] |
|
} |
|
#puts stderr "-1:[info level -1]" |
|
|
|
set command_info [punk::mix::base::get_commands -extension $extension] |
|
set subhelp1 [lindex $args 0] |
|
if {[string length $subhelp1]} { |
|
if {[regexp {[*?]} $subhelp1]} { |
|
set helpstr "" |
|
append helpstr "matched commands:\n" |
|
dict for {source cmdlist} $command_info { |
|
set matches [lsearch -all -inline -glob $cmdlist $subhelp1] |
|
if {[llength $matches]} { |
|
append helpstr \n " $source" |
|
foreach cmd $matches { |
|
append helpstr \n " - $cmd" |
|
} |
|
} |
|
} |
|
return $helpstr |
|
} else { |
|
dict for {source cmdlist} $command_info { |
|
if {$subhelp1 in $cmdlist} { |
|
if {$source eq "base"} { |
|
set ns [namespace current] |
|
} else { |
|
set ns $extension |
|
} |
|
set procname ${ns}::$subhelp1 |
|
if {$procname in [info procs $procname]} { |
|
return "proc: $subhelp1 arguments: [info args $procname]" |
|
} else { |
|
set a [interp alias {} ${ns}::$subhelp1] |
|
if {[string length $a]} { |
|
return "alias: $subhelp1 target: $a" |
|
} else { |
|
return "command: $subhelp1 (No info available)" |
|
} |
|
} |
|
} |
|
} |
|
|
|
return "No info found" |
|
} |
|
|
|
} |
|
#result for just 'pmix help' |
|
puts stderr "-->$args" |
|
set helpstr "" |
|
append helpstr "limit commandlist with a glob search such as *word*" |
|
append helpstr "commands:\n" |
|
|
|
foreach {source cmdlist} $command_info { |
|
append helpstr \n " $source" |
|
foreach cmd $cmdlist { |
|
append helpstr \n " - $cmd" |
|
} |
|
} |
|
return $helpstr |
|
} |
|
#proc dostuff {args} { |
|
# extension@@opts/@?@-extension,args@@args= [_split_args $args] |
|
# puts stdout "base doingstuff-with-args:'$args'-in-namespace:'[namespace current]'" |
|
#} |
|
namespace eval lib { |
|
variable sha3_implementation "" ;#set by cksum_algorithms (which is called by cksum_path) It looks for fossil or sqlite3. Todo - add proper Tcl implementation. |
|
namespace export * |
|
|
|
#----------------------------------------------------- |
|
#literate-programming style naming for some path tests |
|
#Note the naming of the operator portion of a_op_b is consistent in that it is the higher side of the filesystem tree first. |
|
#hence aboveorat vs atorbelow |
|
#These names also sort in the logical order of higher to lower in the filesystem (when considering the root as 'higher' in the filesystem) |
|
proc path_a_above_b {path_a path_b} { |
|
#stripPath prefix path |
|
return [expr {[fileutil::stripPath $path_a $path_b] ni [list . $path_b]}] |
|
} |
|
proc path_a_aboveorat_b {path_a path_b} { |
|
return [expr {[fileutil::stripPath $path_a $path_b] ne $path_b}] |
|
} |
|
proc path_a_at_b {path_a path_b} { |
|
return [expr {[fileutil::stripPath $path_a $path_b] eq "." }] |
|
} |
|
proc path_a_atorbelow_b {path_a path_b} { |
|
return [expr {[fileutil::stripPath $path_b $path_a] ne $path_a}] |
|
} |
|
proc path_a_below_b {path_a path_b} { |
|
return [expr {[fileutil::stripPath $path_b $path_a] ni [list . $path_a]}] |
|
} |
|
proc path_a_inlinewith_b {path_a path_b} { |
|
return [expr {[path_a_aboveorat_b $path_a $path_b] || [path_a_below_b $path_a $path_b]}] |
|
} |
|
#----------------------------------------------------- |
|
|
|
|
|
|
|
#find src/something folders which are not certain known folders with other purposes, (such as: bootsupport .vfs folders or vendor folders etc) and contain .tm file(s) |
|
proc find_source_module_paths {{path {}}} { |
|
if {![string length [set candidate [punk::repo::find_candidate $path]]]} { |
|
error "find_source_module_paths cannot determine a suitable project root at or above path '$path' - path supplied should be within a project" |
|
} |
|
#we can return module paths even if the project isn't yet under revision control |
|
set src_subs [glob -nocomplain -dir [file join $candidate src] -type d -tail *] |
|
set antipatterns [list *.vfs vendor* lib _build doc embedded runtime bootsupport] |
|
set tm_folders [list] |
|
foreach sub $src_subs { |
|
set is_ok 1 |
|
foreach anti $antipatterns { |
|
if {[string match $anti $sub]} { |
|
set is_ok 0 |
|
break |
|
} |
|
} |
|
if {!$is_ok} { |
|
continue |
|
} |
|
set testfolder [file join $candidate src $sub] |
|
#ensure that if src/modules exists - it is always included even if empty |
|
if {[string tolower $sub] eq "modules"} { |
|
lappend tm_folders $testfolder |
|
continue |
|
} |
|
#set tmfiles [glob -nocomplain -dir $testfolder -type f -tail *.tm] |
|
#set podfolders [glob -nocomplain -dir $testfolder -type d -tail #modpod-*] |
|
if {[llength [glob -nocomplain -dir $testfolder -type f -tail *.tm]] || [llength [glob -nocomplain -dir $testfolder -type d -tail #modpod-*]]} { |
|
lappend tm_folders $testfolder |
|
} |
|
} |
|
return $tm_folders |
|
} |
|
|
|
proc mix_templates_dir {} { |
|
puts stderr "mix_templates_dir WARNING: deprecated - use get_template_basefolders instead" |
|
set provide_statement [package ifneeded punk::mix [package require punk::mix]] |
|
set tmdir [file dirname [lindex $provide_statement end]] |
|
set tpldir $tmdir/mix/templates |
|
if {![file exists $tpldir]} { |
|
error "punk::mix::lib::mix_templates_dir unable to locate mix templates folder at '$tpldir'" |
|
} |
|
return $tpldir |
|
} |
|
|
|
#get_template_basefolders |
|
# startpath - file or folder |
|
# It represents the base point from which to search for templates folders either directly related to the scriptpath (../) or in the containing project if any |
|
# The cwd will also be searched for project root - but with lower precedence in the resultset (later in list) |
|
proc get_template_basefolders {{startpath ""}} { |
|
# templates from punk.templates provider packages (ordered by order in which packages registered with punk::cap) |
|
if {[file isfile $startpath]} { |
|
set startpath [file dirname $startpath] |
|
} |
|
|
|
package require punk::cap |
|
if {[punk::cap::capability_has_handler punk.templates]} { |
|
set template_folder_dict [punk::cap::call_handler punk.templates folders -startdir $startpath] |
|
} else { |
|
put stderr "get_template_basefolders WARNING - no handler available for the 'punk.templates' capability - template providers will be unable to provide template locations" |
|
} |
|
|
|
#don't sort - order in which encountered defines the precedence - with later overriding earlier |
|
return $template_folder_dict |
|
} |
|
|
|
proc module_subpath {modulename} { |
|
set modulename [string trim $modulename :] |
|
set nsq [namespace qualifiers $modulename] |
|
return [string map {:: /} $nsq] |
|
} |
|
|
|
proc get_build_workdir {path} { |
|
set repo_info [punk::repo::find_repos $path] |
|
set base [lindex [dict get $repo_info project] 0] |
|
if {![string length $base]} { |
|
error "get_build_workdir unable to determine project base for path '$path'" |
|
} |
|
if {![file exists $base/src] || ![file writable $base/src]} { |
|
error "get_build_workdir unable to access $base/src" |
|
} |
|
file mkdir $base/src/_build |
|
return $base/src/_build |
|
} |
|
|
|
|
|
|
|
#todo - move cksum stuff to punkcheck - more logical home |
|
proc cksum_path_content {path args} { |
|
dict set args -cksum_content 1 |
|
dict set args -cksum_meta 0 |
|
tailcall cksum_path $path {*}$args |
|
} |
|
|
|
#not just used by cksum_path. used by caller (e.g fill_relativecksums_from_base_and_relativepathdict via cksum_filter_opts) to determine what opt names passed through |
|
variable cksum_default_opts |
|
set cksum_default_opts [dict create -cksum_content 1 -cksum_meta auto -cksum_acls 0 -cksum_usetar auto -cksum_algorithm sha1] |
|
proc cksum_default_opts {} { |
|
variable cksum_default_opts |
|
return $cksum_default_opts |
|
} |
|
|
|
#crc::cksum is extremely slow in tcllib as at 2023 e.g 20x slower (no c implementation?) |
|
# - try builtin zlib crc instead? |
|
#sha1 is performant - and this is not being used in a cryptographic or adversarial context - so performance and practical unlikelihood of accidental collisions should be the main consideration. |
|
#adler32 is fastest for some larger files of a few MB but slower on small files (possibly due to Tcl-based file load?) |
|
#sha1 as at 2023 seems a reasonable default |
|
proc cksum_algorithms {} { |
|
variable sha3_implementation |
|
#sha2 is an alias for sha256 |
|
#2023 - no sha3 available in tcllib - we can exec fossil for now - which will be very slow |
|
set algs [list md5 sha1 sha2 sha256 cksum adler32] |
|
set sha3_algs [list sha3 sha3-224 sha3-256 sha3-384 sha3-512] |
|
if {[auto_execok sqlite3] ne ""} { |
|
lappend algs {*}$sha3_algs |
|
set sha3_implementation sqlite3_sha3 |
|
} else { |
|
if {[auto_execok fossil] ne ""} { |
|
lappend algs {*}$sha3_algs |
|
set sha3_implementation fossil_sha3 |
|
} |
|
} |
|
return $algs |
|
} |
|
|
|
proc sqlite3_sha3 {bits filename} { |
|
return [exec sqlite3 :memory: "select lower(hex(sha3(readfile('$filename'),$bits)))"] |
|
} |
|
proc fossil_sha3 {bits filename} { |
|
return [lindex [exec fossil sha3sum -$bits $filename] 0] |
|
} |
|
|
|
#adler32 via file-slurp |
|
proc cksum_adler32_file {filename} { |
|
#2024 - zlib should be builtin - otherwise fallback to trf + zlibtcl? |
|
set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename] |
|
#set data [fileutil::cat -translation binary $filename] ;#no significant performance diff on windows - and doesn't handle win-illegal names |
|
zlib adler32 $data |
|
} |
|
#zlib crc via file-slurp |
|
proc cksum_crc_file {filename} { |
|
set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename] |
|
zlib crc32 $data |
|
} |
|
|
|
proc cksum_md5_data {data} { |
|
if {[package vsatisfies [package present md5] 2-]} { |
|
return [md5::md5 -hex $data] |
|
} else { |
|
return [md5::md5 $data] |
|
} |
|
} |
|
#fallback md5 via file-slurp - shouldn't be needed if have md5 2- |
|
proc cksum_md5_file {filename} { |
|
set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename] |
|
cksum_md5_data $data |
|
} |
|
|
|
|
|
#required to be able to accept relative paths |
|
#for full cksum - using tar could reduce number of hashes to be made.. |
|
#but as it stores metadata such as permission - we don't know if/how the archive will vary based on platform/filesystem |
|
#-noperms only available on extraction - so that doesn't help |
|
#Needs to operate on non-existant paths and return empty string in cksum field |
|
proc cksum_path {path args} { |
|
variable sha3_implementation |
|
if {$path eq {}} { set path [pwd] } |
|
if {[file pathtype $path] eq "relative"} { |
|
set path [file normalize $path] |
|
} |
|
set base [file dirname $path] |
|
set startdir [pwd] |
|
|
|
set defaults [cksum_default_opts] |
|
set known_opts [dict keys $defaults] |
|
foreach {k v} $args { |
|
if {$k ni $known_opts} { |
|
error "cksum_path unknown option '$k' known_options: $known_opts" |
|
} |
|
} |
|
|
|
set opts [dict merge $defaults $args] |
|
set opts_actual $opts ;#default - auto updated to 0 or 1 later |
|
|
|
#if {![file exists $path]} { |
|
# return [list cksum "" opts $opts] |
|
#} |
|
|
|
if {[catch {file type $path} ftype]} { |
|
return [list cksum "<PATHNOTFOUND>" opts $opts] |
|
} |
|
|
|
#review - links? |
|
switch -- $ftype { |
|
file - directory {} |
|
default { |
|
error "cksum_path error file type '$ftype' not supported" |
|
} |
|
} |
|
|
|
|
|
set opt_cksum_algorithm [dict get $opts -cksum_algorithm] |
|
if {$opt_cksum_algorithm ni [cksum_algorithms]} { |
|
return [list error unsupported_cksum_algorithm cksum "<ERR>" opts $opts known_algorithms [cksum_algorithms]] |
|
} |
|
set opt_cksum_acls [dict get $opts -cksum_acls] |
|
if {$opt_cksum_acls} { |
|
puts stderr "cksum_path is not yet able to cksum ACLs" |
|
return |
|
} |
|
|
|
set opt_cksum_meta [dict get $opts -cksum_meta] |
|
set opt_use_tar [dict get $opts -cksum_usetar] |
|
switch -- $ftype { |
|
file { |
|
switch -- $opt_use_tar { |
|
auto { |
|
if {$opt_cksum_meta eq "1"} { |
|
set opt_use_tar 1 |
|
} else { |
|
#prefer no tar if meta not required - faster/simpler |
|
#meta == auto or 0 |
|
set opt_cksum_meta 0 |
|
set opt_use_tar 0 |
|
} |
|
} |
|
0 { |
|
if {$opt_cksum_meta eq "1"} { |
|
puts stderr "cksum_path doesn't yet support a non-tar cksum with metadata for a file" |
|
return [list error unsupported_meta_without_tar cksum "<ERR>" opts $opts] |
|
} else { |
|
#meta == auto or 0 |
|
set opt_cksum_meta 0 |
|
} |
|
} |
|
default { |
|
#tar == 1 |
|
if {$opt_cksum_meta eq "0"} { |
|
puts stderr "cksum_path doesn't yet support a tar cksum without metadata for a file" |
|
return [list error unsupported_tar_without_meta cksum "<ERR>" opts $opts] |
|
} else { |
|
#meta == auto or 1 |
|
set opt_cksum_meta 1 |
|
} |
|
} |
|
} |
|
} |
|
directory { |
|
switch -- $opt_use_tar { |
|
auto { |
|
if {$opt_cksum_meta in [list "auto" "1"]} { |
|
set opt_use_tar 1 |
|
set opt_cksum_meta 1 |
|
} else { |
|
puts stderr "cksum_path doesn't yet support a content-only cksum of a folder structure. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto" |
|
return [list error unsupported_directory_cksum_without_meta cksum "<ERR>" opts $opts] |
|
} |
|
} |
|
0 { |
|
puts stderr "cksum_path doesn't yet support a cksum of a folder structure without tar. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" |
|
return [list error unsupported_directory_cksum_without_tar cksum "<ERR>" opts $opts] |
|
} |
|
default { |
|
#tar 1 |
|
if {$opt_cksum_meta eq "0"} { |
|
puts stderr "cksum_path doesn't yet support a tar checksum of a folder structure without metadat. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" |
|
return [list error unsupported_without_meta cksum "<ERR>" opts $opts] |
|
} else { |
|
#meta == auto or 1 |
|
set opt_cksum_meta 1 |
|
} |
|
} |
|
} |
|
} |
|
} |
|
|
|
dict set opts_actual -cksum_meta $opt_cksum_meta |
|
dict set opts_actual -cksum_usetar $opt_use_tar |
|
|
|
|
|
if {$opt_use_tar} { |
|
package require tar ;#from tcllib |
|
} |
|
|
|
if {$path eq $base} { |
|
#attempting to cksum at root/volume level of a filesystem.. extra work |
|
#This needs fixing for general use.. not necessarily just for project repos |
|
puts stderr "cksum_path doesn't yet support cksum of entire volume. (todo)" |
|
return [list error unsupported_path opts $opts] |
|
} |
|
switch -- $opt_cksum_algorithm { |
|
sha1 { |
|
package require sha1 |
|
#review - any utf8 issues in tcl9? |
|
set cksum_command [list sha1::sha1 -hex -file] |
|
} |
|
sha2 - sha256 { |
|
package require sha256 |
|
set cksum_command [list sha2::sha256 -hex -file] |
|
} |
|
md5 { |
|
package require md5 |
|
if {[package vsatisfies [package present md5] 2- ] } { |
|
set cksum_command [list md5::md5 -hex -file] |
|
} else { |
|
set cksum_comand [list cksum_md5_file] |
|
} |
|
} |
|
cksum { |
|
package require cksum ;#tcllib |
|
set cksum_command [list crc::cksum -format 0x%X -file] |
|
} |
|
crc { |
|
set cksum_command [list cksum_crc_file] |
|
} |
|
adler32 { |
|
set cksum_command [list cksum_adler32_file] |
|
} |
|
sha3 - sha3-256 { |
|
#todo - replace with something that doesn't call another process - only if tcllibc not available! |
|
#set cksum_command [list apply {{file} {lindex [exec fossil sha3sum -256 $file] 0}}] |
|
set cksum_command [list $sha3_implementation 256] |
|
} |
|
sha3-224 - sha3-384 - sah3-512 { |
|
set bits [lindex [split $opt_cksum_algorithm -] 1] |
|
#set cksum_command [list apply {{bits file} {lindex [exec fossil sha3sum -$bits $file] 0}} $bits] |
|
set cksum_command [list $sha3_implementation $bits] |
|
} |
|
} |
|
|
|
set cksum "" |
|
if {$opt_use_tar != 0} { |
|
set target [file tail $path] |
|
set tmplocation [punk::mix::util::tmpdir] |
|
set archivename $tmplocation/[punk::mix::util::tmpfile].tar |
|
|
|
cd $base ;#cd is process-wide.. keep cd in effect for as small a scope as possible. (review for thread issues) |
|
|
|
#temp emission to stdout.. todo - repl telemetry channel |
|
puts stdout "cksum_path: creating temporary tar archive for $path" |
|
puts -nonewline stdout " at: $archivename ..." |
|
set tsstart [clock millis] |
|
if {[set tarpath [auto_execok tar]] ne ""} { |
|
#using an external binary is *significantly* faster than tar::create - but comes with some risks |
|
#review - need to check behaviour/flag variances across platforms |
|
#don't use -z flag. On at least some tar versions the zipped file will contain a timestamped subfolder of filename.tar - which ruins the checksum |
|
#also - tar is generally faster without the compression (although this may vary depending on file size and disk speed?) |
|
exec {*}$tarpath -cf $archivename $target ;#{*} needed in case spaces in tarpath |
|
set tsend [clock millis] |
|
set ms [expr {$tsend - $tsstart}] |
|
puts stdout " tar -cf done ($ms ms)" |
|
} else { |
|
set tsstart [clock millis] ;#don't include auto_exec search time for tar::create |
|
tar::create $archivename $target |
|
set tsend [clock millis] |
|
set ms [expr {$tsend - $tsstart}] |
|
puts stdout " tar::create done ($ms ms)" |
|
puts stdout " NOTE: install tar executable for potentially *much* faster directory checksum processing" |
|
} |
|
|
|
if {$ftype eq "file"} { |
|
set sizeinfo "(size [punk::lib::format_number [file size $target]] bytes)" |
|
} else { |
|
set sizeinfo "(file type $ftype - tarred size [punk::lib::format_number [file size $archivename]] bytes)" |
|
} |
|
set tsstart [clock millis] |
|
puts -nonewline stdout "cksum_path: calculating cksum using $opt_cksum_algorithm for $target $sizeinfo ... " |
|
set cksum [{*}$cksum_command $archivename] |
|
set tsend [clock millis] |
|
set ms [expr {$tsend - $tsstart}] |
|
puts stdout " cksum done ($ms ms)" |
|
puts stdout " cksum: $cksum" |
|
file delete -force $archivename |
|
cd $startdir |
|
|
|
} else { |
|
#todo |
|
if {$ftype eq "file"} { |
|
if {$opt_cksum_meta} { |
|
return [list error unsupported_opts_combo cksum "<ERR>" opts $opts] |
|
} else { |
|
set cksum [{*}$cksum_command $path] |
|
} |
|
} else { |
|
error "cksum_path unsupported $opts for path type [file type $path]" |
|
} |
|
} |
|
set result [dict create] |
|
dict set result cksum $cksum |
|
dict set result opts $opts_actual |
|
return $result |
|
} |
|
|
|
#dict_path_cksum keyed on path - with value as a dict that must contain cksum key - but can contain other keys |
|
#e.g -cksum_usetar which is one of the keys understood by the punk::mix::base::lib::cksum_path function - or unrelated keys which will also be passed through |
|
#cksum only calculated for keys in dict where cksum is empty - ie return same dict but with empty cksums filled out. |
|
#base can be empty string in which case paths must be absolute |
|
#expect dict_path_cksum to be a dict keyed on relpath where each value is a dictionary with keys cksum and opts |
|
# ie subdict for <path> can be created from output of cksum_path <path> (for already known values not requiring filling) |
|
# or cksum "" opts [cksum_default_opts] or cksum "" opts {} (for cksum to be filled using supplied cksum opts if any) |
|
proc fill_relativecksums_from_base_and_relativepathdict {base {dict_path_cksum {}}} { |
|
if {$base eq ""} { |
|
set error_paths [list] |
|
dict for {path pathinfo} $dict_path_cksum { |
|
if {[file pathtype $path] ne "absolute"} { |
|
lappend error_paths $path |
|
} |
|
} |
|
if {[llength $error_paths]} { |
|
puts stderr "get_relativecksums_from_base_and_relativepathdict has empty base - and non-absolute paths in the supplied checksum dict - aborting" |
|
puts stderr "error_paths: $error_paths" |
|
error "fill_relativecksums_from_base_and_relativepathdict error: non-absolute paths when base empty. $error_paths" |
|
} |
|
} else { |
|
if {[file pathtype $base] ne "absolute"} { |
|
error "fill_relativecksums_from_base_and_relativepathdict error: base supplied but was not absolute path. $base" |
|
} |
|
#conversely now we have a base - so we require all paths are relative. |
|
#We will ignore/disallow volume-relative - as these shouldn't be used here either |
|
set error_paths [list] |
|
dict for {path pathinfo} $dict_path_cksum { |
|
if {[file pathtype $path] ne "relative"} { |
|
lappend error_paths $path |
|
} |
|
} |
|
if {[llength $error_paths]} { |
|
puts stderr "fill_relativecksums_from_base_and_relativepathdict has a supplied absolute base path, but some of the paths in the supplied dict are not relative - aborting" |
|
error "fill_relativecksums_from_base_and_relativepathdict error: non-relative paths when base supplied. $error_paths" |
|
} |
|
} |
|
|
|
|
|
dict for {path pathinfo} $dict_path_cksum { |
|
if {![dict exists $pathinfo cksum]} { |
|
dict set pathinfo cksum "" |
|
} else { |
|
if {[dict get $pathinfo cksum] ne "" && ![cksum_is_tag [dict get $pathinfo cksum]]} { |
|
continue ;#already filled with non-tag value |
|
} |
|
} |
|
if {$base ne ""} { |
|
set fullpath [file join $base $path] |
|
} else { |
|
set fullpath $path |
|
} |
|
|
|
if {[dict exists $pathinfo opts]} { |
|
set ckopts [cksum_filter_opts {*}[dict get $pathinfo opts]] |
|
} else { |
|
set ckopts {} |
|
} |
|
|
|
if {![file exists $fullpath]} { |
|
dict set dict_path_cksum $path cksum "<PATHNOTFOUND>" |
|
} else { |
|
set ckinfo [cksum_path $fullpath {*}$ckopts] |
|
dict set dict_path_cksum $path cksum [dict get $ckinfo cksum] |
|
dict set dict_path_cksum $path cksum_all_opts [dict get $ckinfo opts] |
|
if {[dict exists $ckinfo error]} { |
|
dict set dict_path_cksum $path cksum_error [dict get $ckinfo error] |
|
} |
|
} |
|
} |
|
|
|
return $dict_path_cksum |
|
} |
|
#whether cksum is <XXX> e.g <ERR> <PATHNOTFOUND> |
|
proc cksum_is_tag {cksum} { |
|
expr {[string index $cksum 0] eq "<" && [string index $cksum end] eq ">"} |
|
} |
|
proc cksum_filter_opts {args} { |
|
set ck_opt_names [dict keys [cksum_default_opts]] |
|
set ck_opts [dict create] |
|
foreach {k v} $args { |
|
if {$k in $ck_opt_names} { |
|
dict set ck_opts $k $v |
|
} |
|
} |
|
return $ck_opts |
|
} |
|
|
|
#convenience so caller doesn't have to pre-calculate the relative path from the base |
|
#Note semantic difference from fill_relativecksums_from_base_and_relativepathdict (hence get_ vs fill_) |
|
#Here we will raise an error if cksum exists and is not empty or a tag - whereas the multiple path version will honour valid-looking prefilled cksum values (ie will pass them through) |
|
#base is the presumed location to store the checksum file. The caller should retain (normalize if relative) |
|
proc get_relativecksum_from_base {base specifiedpath args} { |
|
if {$base ne ""} { |
|
#targetpath ideally should be within same project tree as base if base supplied - but not necessarily below it |
|
#we don't necessarily want to restrict this to use in punk projects though - so we'll allow anything with a common prefix |
|
if {[file pathtype $specifiedpath] eq "relative"} { |
|
if {[file pathtype $base] eq "relative"} { |
|
set normbase [file normalize $base] |
|
set normtarg [file normalize [file join $normbase $specifiedpath]] |
|
set targetpath $normtarg |
|
set storedpath [punk::path::relative $normbase $normtarg] |
|
} else { |
|
set targetpath [file join $base $specifiedpath] |
|
set storedpath $specifiedpath |
|
} |
|
} else { |
|
#specifed absolute |
|
if {[file pathtype $base] eq "relative"} { |
|
#relative to cwd or to specifiedpath? For consistency it should arguably be cwd but a case could be made that when one path is relative it is in reference to the other |
|
#there is a strong possibility that allowing this combination will cause confusion - better to disallow |
|
error "get_relativecksum_from_base error: disallowed pathtype combination. Base must be empty or absolute when specified path is absolute" |
|
} |
|
#both absolute - compute relative path if they share a common prefix |
|
set commonprefix [punk::mix::util::path_common_prefix $base $specifiedpath] |
|
if {$commonprefix eq ""} { |
|
#absolute base with no shared prefix doesn't make sense - we could ignore it - but better to error-out and require the caller specify an empty base |
|
error "get_relativecksum_from_base error: base '$base' and specifiedpath '$specifiedpath' don't share a common root. Use empty-string for base if independent absolute path is required" |
|
} |
|
set targetpath $specifiedpath |
|
set storedpath [punk::path::relative $base $specifiedpath] |
|
|
|
} |
|
} else { |
|
if {[file type $specifiedpath] eq "relative"} { |
|
#if specifiedpath is relative - and we don't have a base, we now need to convert relative to cwd to an absolute path for storage |
|
set targetpath [file normalize $specifiedpath] |
|
set storedpath $targetpath |
|
} else { |
|
set targetpath $specifiedpath |
|
set storedpath $targetpath |
|
} |
|
} |
|
|
|
# |
|
#NOTE: specifiedpath can be a relative path (to cwd) when base is empty |
|
#OR - a relative path when base itself is relative e.g base: somewhere targetpath somewhere/etc |
|
#possibly also: base: somewhere targetpath: ../elsewhere/etc |
|
# |
|
#todo - write tests |
|
|
|
|
|
if {[llength $args] % 2} { |
|
error "get_relativecksum_from_base error. args supplied must be in the form of key-value pairs. received '$args' " |
|
} |
|
if {[dict exists $args cksum]} { |
|
if {[dict get $args cksum] ne "" && ![cksum_is_tag [dict get $args cksum]]} { |
|
error "get_relativecksum_from_base called with existing cksum value (and is not a tag or empty-value to be replaced) cksum: [dict get $args cksum] Set cksum to be empty, any tag such as <REPLACE> or remove the key and try again." |
|
} |
|
} |
|
|
|
|
|
set ckopts [cksum_filter_opts {*}$args] |
|
set ckinfo [cksum_path $targetpath {*}$ckopts] |
|
|
|
set keyvals $args ;# REVIEW |
|
dict set keyvals cksum [dict get $ckinfo cksum] |
|
#dict set keyvals cksum_all_opts [dict get $ckinfo opts] |
|
dict set keyvals opts [dict get $ckinfo opts] |
|
if {[dict exists $ckinfo error]} { |
|
dict set keyvals cksum_error [dict get $ckinfo error] |
|
} |
|
|
|
#set relpath [punk::repo::path_strip_alreadynormalized_prefixdepth $fullpath $base] ;#empty base ok noop |
|
#storedpath is relative if possible |
|
return [dict create $storedpath $keyvals] |
|
} |
|
|
|
#calculate the runtime checksum and vfs checksums |
|
proc get_all_vfs_build_cksums {path {cksum_opts {}}} { |
|
set buildfolder [get_build_workdir $path] |
|
set cksum_base_folder [file dirname $buildfolder] ;#this is the <project>/src folder - a reasonable base for our vfs cksums |
|
set dict_cksums [dict create] |
|
|
|
set buildrelpath [punk::repo::path_strip_alreadynormalized_prefixdepth $buildfolder $cksum_base_folder] |
|
set vfs_tail_list [glob -nocomplain -dir $cksum_base_folder -type d -tails *.vfs] |
|
|
|
foreach vfstail $vfs_tail_list { |
|
set vname [file rootname $vfstail] |
|
dict set dict_cksums $vfstail [list cksum ""] |
|
dict set dict_cksums [file join $buildrelpath $vname.exe] [list cksum ""] |
|
} |
|
|
|
#buildruntime.exe obsolete.. |
|
set fullpath_buildruntime $buildfolder/buildruntime.exe |
|
|
|
set ckinfo_buildruntime [cksum_path $fullpath_buildruntime] |
|
set ck [dict get $ckinfo_buildruntime cksum] |
|
|
|
|
|
set relpath [file join $buildrelpath "buildruntime.exe"] |
|
dict set dict_cksums $relpath [list cksum $ck opts $cksum_opts] |
|
|
|
set dict_cksums [fill_relativecksums_from_base_and_relativepathdict $cksum_base_folder $dict_cksums] |
|
|
|
return $dict_cksums |
|
} |
|
|
|
proc get_vfs_build_cksums_stored {vfsfolder} { |
|
set vfscontainer [file dirname $vfsfolder] |
|
set buildfolder $vfscontainer/_build |
|
set vfs [file tail $vfsfolder] |
|
set vname [file rootname $vfs] |
|
set dict_vfs [list $vname.vfs "" $vname.exe "" buildruntime.exe ""] |
|
set ckfile $buildfolder/$vname.cksums |
|
if {[file exists $ckfile]} { |
|
set data [punk::mix::util::fcat -translation binary $ckfile] |
|
foreach ln [split $data \n] { |
|
if {[string trim $ln] eq ""} {continue} |
|
lassign $ln path cksum |
|
dict set dict_vfs $path $cksum |
|
} |
|
} |
|
return $dict_vfs |
|
} |
|
proc get_all_build_cksums_stored {path} { |
|
set buildfolder [get_build_workdir $path] |
|
|
|
set vfscontainer [file dirname $buildfolder] |
|
set vfslist [glob -nocomplain -dir $vfscontainer -type d -tail *.vfs] |
|
set dict_cksums [dict create] |
|
foreach vfs $vfslist { |
|
set vname [file rootname $vfs] |
|
set dict_vfs [get_vfs_build_cksums_stored $vfscontainer/$vfs] |
|
|
|
dict set dict_cksums $vname $dict_vfs |
|
} |
|
return $dict_cksums |
|
} |
|
|
|
proc store_vfs_build_cksums {vfsfolder} { |
|
if {![file isdirectory $vfsfolder]} { |
|
error "Unable to find supplied vfsfolder: $vfsfolder" |
|
} |
|
set vfscontainer [file dirname $vfsfolder] |
|
set buildfolder $vfscontainer/_build |
|
set dict_vfs [get_vfs_build_cksums $vfsfolder] |
|
set data "" |
|
dict for {path cksum} $dict_vfs { |
|
append data "$path $cksum" \n |
|
} |
|
set fd [open $buildfolder/$vname.cksums w] |
|
chan configure $fd -translation binary |
|
puts $fd $data |
|
close $fd |
|
return $dict_vfs |
|
} |
|
|
|
|
|
|
|
} |
|
}
|
|
|