7 changed files with 470 additions and 948 deletions
@ -0,0 +1,9 @@ |
|||||||
|
INSTALLER -tsiso 2023-10-05T01:17:29 -ts 1696429049063279 -name manual -keep_events 5 { |
||||||
|
EVENT -tsiso 2023-10-05T01:17:29 -ts 1696429049063338 -type install -id 600bfdac-284e-488f-b8bb-62984640f12b -source ../../modules -target . -config {-glob repo-0.1.1.tm -antiglob_file_core {*.swp *999999.0a1.0* *-buildversion.txt .punkcheck} -antiglob_file {} -antiglob_dir_core {{#*} _aside .git .fossil*} -antiglob_dir {}} |
||||||
|
EVENT -tsiso 2023-10-05T01:19:05 -ts 1696429145153107 -type install -id cb25e965-965f-4ebb-bd3d-cac901273bf0 -source ../../../modules -target . -config {-glob repo-0.1.1.tm -antiglob_file_core {*.swp *999999.0a1.0* *-buildversion.txt .punkcheck} -antiglob_file {} -antiglob_dir_core {{#*} _aside .git .fossil*} -antiglob_dir {}} |
||||||
|
} |
||||||
|
FILEINFO -target punk/repo-0.1.1.tm -keep_installrecords 2 -keep_skipped 1 -keep_installing 2 { |
||||||
|
INSTALLRECORD -tsiso 2023-10-05T01:19:05 -ts 1696429145155747 -installer manual -eventid cb25e965-965f-4ebb-bd3d-cac901273bf0 -elapsed_us 16897 { |
||||||
|
SOURCE -type file -path ../../../modules/punk/repo-0.1.1.tm -cksum eaf21ef8df7355cfe077b1da8aeca3b4a7a9d7f7 -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 10894 |
||||||
|
} |
||||||
|
} |
||||||
@ -1,814 +0,0 @@ |
|||||||
# -*- tcl -*- |
|
||||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
|
||||||
# |
|
||||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
|
||||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
#Copyright (c) 2023 Julian Noble |
|
||||||
#Copyright (c) 2012-2018 Andreas Kupries |
|
||||||
# - code from A.K's 'kettle' project used in this module |
|
||||||
# |
|
||||||
# @@ Meta Begin |
|
||||||
# Application punk::repo 0.1.0 |
|
||||||
# Meta platform tcl |
|
||||||
# Meta license BSD |
|
||||||
# @@ Meta End |
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
## Requirements |
|
||||||
##e.g package require frobz |
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
# |
|
||||||
# path/repo functions |
|
||||||
# |
|
||||||
if {$::tcl_platform(platform) eq "windows"} { |
|
||||||
package require punk::winpath |
|
||||||
} else { |
|
||||||
catch {package require punk::winpath} |
|
||||||
} |
|
||||||
package require cksum ;#tcllib |
|
||||||
package require fileutil; #tcllib |
|
||||||
|
|
||||||
|
|
||||||
# -- --- --- --- --- --- --- --- --- --- --- |
|
||||||
# For performance/efficiency reasons - use file functions on paths in preference to string operations |
|
||||||
# e.g use file join |
|
||||||
# branch to avoid unnecessary calls to 'pwd' or 'file normalize' - which can be surprisingly expensive operations (as at tcl 8.7 2023) |
|
||||||
# pwd is only expensive if we treat it as a string instead of a list/path |
|
||||||
# e.g |
|
||||||
# > time {set x [pwd]} |
|
||||||
# 5 microsoeconds.. no problem |
|
||||||
# > time {set x [pwd]} |
|
||||||
# 4 microsoeconds.. still no problem |
|
||||||
# > string length $x |
|
||||||
# 45 |
|
||||||
# > time {set x [pwd]} |
|
||||||
# 1372 microseconds per iteration ;#!! values above 0.5ms common.. and that's a potential problem in loops that trawl filesystem |
|
||||||
# The same sorts of timings occur with file normalize |
|
||||||
# also.. even if we build up a path with file join from a base value that has already been normalized - the subsequent normalize will be expensive |
|
||||||
# -- --- --- --- --- --- --- --- --- --- --- |
|
||||||
|
|
||||||
namespace eval punk::repo { |
|
||||||
variable tmpfile_counter 0 ;#additional tmpfile collision avoidance |
|
||||||
|
|
||||||
proc is_fossil {{path {}}} { |
|
||||||
if {$path eq {}} { set path [pwd] } |
|
||||||
return [expr {[find_fossil $path] ne {}}] |
|
||||||
} |
|
||||||
proc is_git {{path {}}} { |
|
||||||
if {$path eq {}} { set path [pwd] } |
|
||||||
return [expr {[find_git $path] ne {}}] |
|
||||||
} |
|
||||||
#tracked repo - but may not be a project |
|
||||||
proc is_repo {{path {}}} { |
|
||||||
if {$path eq {}} { set path [pwd] } |
|
||||||
return [expr {[isfossil] || [is_git]}] |
|
||||||
} |
|
||||||
proc is_candidate {{path {}}} { |
|
||||||
if {$path eq {}} { set path [pwd] } |
|
||||||
return [expr {[find_candidate $path] ne {}}] |
|
||||||
} |
|
||||||
proc is_project {{path {}}} { |
|
||||||
if {$path eq {}} { set path [pwd] } |
|
||||||
return [expr {[find_project $path] ne {}}] |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
proc find_fossil {{path {}}} { |
|
||||||
if {$path eq {}} { set path [pwd] } |
|
||||||
scanup $path is_fossil_root |
|
||||||
} |
|
||||||
proc find_git {{path {}}} { |
|
||||||
if {$path eq {}} { set path [pwd] } |
|
||||||
scanup $path is_git_root |
|
||||||
} |
|
||||||
proc find_candidate {{path {}}} { |
|
||||||
if {$path eq {}} { set path [pwd] } |
|
||||||
scanup $path is_candidate_root |
|
||||||
} |
|
||||||
proc find_repo {{path {}}} { |
|
||||||
if {$path eq {}} { set path [pwd] } |
|
||||||
#find the closest (lowest in dirtree) repository |
|
||||||
set f_root [find_fossil $path] |
|
||||||
set g_root [find_git $path] |
|
||||||
if {[string length $f_root]} { |
|
||||||
if {[string length $g_root]} { |
|
||||||
if {[path_a_below_b $f_root $g_root]} { |
|
||||||
return $f_root |
|
||||||
} else { |
|
||||||
return $g_root |
|
||||||
} |
|
||||||
} else { |
|
||||||
return $f_root |
|
||||||
} |
|
||||||
} else { |
|
||||||
if {[string length $g_root]} { |
|
||||||
return $g_root |
|
||||||
} else { |
|
||||||
return "" |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
proc find_project {{path {}}} { |
|
||||||
if {$path eq {}} { set path [pwd] } |
|
||||||
scanup $path is_project_root |
|
||||||
} |
|
||||||
|
|
||||||
proc is_fossil_root {{path {}}} { |
|
||||||
if {$path eq {}} { set path [pwd] } |
|
||||||
#from kettle::path::is.fossil |
|
||||||
foreach control { |
|
||||||
_FOSSIL_ |
|
||||||
.fslckout |
|
||||||
.fos |
|
||||||
} { |
|
||||||
set control $path/$control |
|
||||||
if {[file exists $control] && [file isfile $control]} {return 1} |
|
||||||
} |
|
||||||
return 0 |
|
||||||
} |
|
||||||
proc is_git_root {{path {}}} { |
|
||||||
if {$path eq {}} { set path [pwd] } |
|
||||||
set control [file join $path .git] |
|
||||||
expr {[file exists $control] && [file isdirectory $control]} |
|
||||||
} |
|
||||||
proc is_repo_root {{path {}}} { |
|
||||||
if {$path eq {}} { set path [pwd] } |
|
||||||
expr {[is_fossil_root $path] || [is_git_root $path]} |
|
||||||
} |
|
||||||
#require a minimum of /src and /modules|lib|scriptapps|*.vfs - and that it's otherwise sensible |
|
||||||
proc is_candidate_root {{path {}}} { |
|
||||||
if {$path eq {}} { set path [pwd] } |
|
||||||
if {[file pathtype $path] eq "relative"} { |
|
||||||
if {$::tcl_platform(platform) eq "windows"} { |
|
||||||
set normpath [punk::repo::norm [punk::winpath::winpath $path]] |
|
||||||
} else { |
|
||||||
set normpath [punk::repo::norm $path] |
|
||||||
} |
|
||||||
} else { |
|
||||||
set normpath $path |
|
||||||
} |
|
||||||
set unwise_paths [list "/" "/usr/local" "/usr/local/bin" "/usr/local/lib" "c:/windows"] |
|
||||||
if {[string tolower $normpath] in $unwise_paths} { |
|
||||||
return 0 |
|
||||||
} |
|
||||||
if {[file pathtype [string trimright $normpath /]] eq "volumerelative"} { |
|
||||||
#tcl 8.6/8.7 cd command doesn't preserve the windows "ProviderPath" (per drive current working directory) |
|
||||||
return 0 |
|
||||||
} |
|
||||||
|
|
||||||
#review - adjust to allow symlinks to folders? |
|
||||||
foreach required { |
|
||||||
src |
|
||||||
} { |
|
||||||
set req $path/$required |
|
||||||
if {(![file exists $req]) || ([file type $req] ne "directory") } {return 0} |
|
||||||
} |
|
||||||
|
|
||||||
set src_subs [glob -nocomplain -dir $path/src -types d -tail *] |
|
||||||
if {"modules" in $src_subs || "lib" in $src_subs || "scriptapps" in $src_subs} { |
|
||||||
return 1 |
|
||||||
} |
|
||||||
foreach sub $src_subs { |
|
||||||
if {[string match *.vfs $sub]} { |
|
||||||
return 1 |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
#todo - breadth first search with depth limit (say depth 3?) for *.tm or *.tcl as another positive qualifier for this dir to be a project-root |
|
||||||
#we probably don't want to deep search a src folder in case the user is accidentally in some other type of project's tree |
|
||||||
#such a src tree could be very large, so if we don't find tcl indicators near the root it's a good bet this isn't a candidate |
|
||||||
|
|
||||||
return 0 |
|
||||||
} |
|
||||||
#keep this message in sync with the programmed requirements of is_candidate_root |
|
||||||
#message is not titled - it is intended to be output along with more contextual information from the calling site. |
|
||||||
proc is_candidate_root_requirements_msg {} { |
|
||||||
set msg "" |
|
||||||
append msg "./src directory must exist." \n |
|
||||||
append msg "At least one of ./src/lib ./src/modules ./src/scriptapps or a ./src/<something>.vfs folder should exist." \n |
|
||||||
#append msg "Alternatively - the presence of any .tm or .tcl files within the top few levels of ./src will suffice." \n |
|
||||||
return $msg |
|
||||||
} |
|
||||||
|
|
||||||
proc is_project_root {path} { |
|
||||||
#review - find a reliable simple mechanism. Noting we have projects based on different templates. |
|
||||||
#Should there be a specific required 'project' file of some sort? |
|
||||||
|
|
||||||
#test for file/folder items indicating fossil or git workdir base |
|
||||||
if {(![punk::repo::is_fossil_root $path]) && (![punk::repo::is_git_root $path])} { |
|
||||||
return 0 |
|
||||||
} |
|
||||||
#exclude some known places we wouldn't want to put a project |
|
||||||
if {![is_candidate_root $path]} { |
|
||||||
return 0 |
|
||||||
} |
|
||||||
return 1 |
|
||||||
} |
|
||||||
|
|
||||||
proc find_roots_and_warnings_dict {path} { |
|
||||||
set start_dir $path |
|
||||||
|
|
||||||
#root is a 'project' if it it meets the candidate requrements and is under repo control |
|
||||||
#therefore if project is in the closest_types list - candidate will always be there too - and at least one of git or fossil |
|
||||||
set root_dict [list closest {} closest_types {} fossil {} git {} candidate {} project {} warnings {}] |
|
||||||
set msg "" |
|
||||||
|
|
||||||
#we're only searching in a straight path up the tree looking for a few specific marker files/folder |
|
||||||
set fosroot [punk::repo::find_fossil $start_dir] |
|
||||||
dict set root_dict fossil $fosroot |
|
||||||
set gitroot [punk::repo::find_git $start_dir] |
|
||||||
dict set root_dict git $gitroot |
|
||||||
set candroot [punk::repo::find_candidate $start_dir] |
|
||||||
dict set root_dict candidate $candroot |
|
||||||
|
|
||||||
|
|
||||||
if {[string length $fosroot]} { |
|
||||||
if {([string length $candroot]) && ([string tolower $fosroot] ne [string tolower $candroot])} { |
|
||||||
|
|
||||||
#todo - only warn if this candidate is *within* the found repo root? |
|
||||||
append msg "**" \n |
|
||||||
append msg "** found folder with /src at or above starting folder - that isn't the fossil root" \n |
|
||||||
append msg "** starting folder : $start_dir" \n |
|
||||||
append msg "** unexpected : $candroot" \n |
|
||||||
append msg "** fossil root : $fosroot ([punk::repo::path_relative $start_dir $fosroot])" \n |
|
||||||
append msg "** reporting based on the fossil root found." |
|
||||||
append msg "**" \n |
|
||||||
|
|
||||||
} |
|
||||||
|
|
||||||
} else { |
|
||||||
if {[string length $gitroot]} { |
|
||||||
|
|
||||||
if {([string length $candroot]) && ([string tolower $gitroot] ne [string tolower $candroot])} { |
|
||||||
|
|
||||||
append msg "**" \n |
|
||||||
append msg "** found folder with /src at or above current folder - that isn't the git root" \n |
|
||||||
append msg "** starting folder : $start_dir" \n |
|
||||||
append msg "** unexpected : $candroot ([punk::repo::path_relative $start_dir $candroot])" \n |
|
||||||
append msg "** git root : $gitroot ([punk::repo::path_relative $start_dir $gitroot])" \n |
|
||||||
append msg "** reporting based on the git root found." |
|
||||||
append msg "**" \n |
|
||||||
|
|
||||||
} |
|
||||||
} else { |
|
||||||
|
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
if {(![string length [dict get $root_dict fossil]])} { |
|
||||||
append msg "Not a punk fossil project" \n |
|
||||||
} |
|
||||||
#don't warn if not git - unless also not fossil |
|
||||||
if {(![string length [dict get $root_dict fossil]]) && (![string length [dict get $root_dict git]])} { |
|
||||||
append msg "No repository located at or above starting folder $start_dir" \n |
|
||||||
if {![string length [dict get $root_dict candidate]]} { |
|
||||||
append msg "No candidate project root found. " \n |
|
||||||
append msg "Searched upwards from '$start_dir' expecting a folder with the following requirements: " \n |
|
||||||
append msg [punk::repo::is_candidate_root_requirements_msg] \n |
|
||||||
} else { |
|
||||||
append msg "Candidate project root found at : $candidate" \n |
|
||||||
append msg " - consider putting this folder under fossil control (and/or git)" \n |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
set pathinfo [list];#exclude not found |
|
||||||
foreach repotype [list fossil git candidate] { |
|
||||||
set path [dict get $root_dict $repotype] |
|
||||||
if {[string length $path]} { |
|
||||||
set plen [llength [file split $path]] |
|
||||||
lappend pathinfo [list $repotype $path $plen] |
|
||||||
} |
|
||||||
} |
|
||||||
#these root are all inline towards root of drive - so anything of same length should be same path - shorter path must be above another |
|
||||||
#we will check equal depth paths are equal strings and raise an error just in case there are problems with the coding for the various path functions used here |
|
||||||
#longest path is 'closest' to start_dir |
|
||||||
set longest_first [lsort -index 2 $pathinfo] |
|
||||||
if {![llength $longest_first]} { |
|
||||||
#no repos or candidate - we have already created msg above |
|
||||||
} else { |
|
||||||
dict set root_dict closest [lindex $longest_first 0 1] ;#the *path* of the closest to start_dir - now we need to find all the types of this len |
|
||||||
#see if others same len |
|
||||||
set longestlen [lindex $longest_first 0 2] |
|
||||||
set equal_longest [lsearch -all -inline -index 2 $longest_first $longestlen] |
|
||||||
set ctypes [list] |
|
||||||
foreach pinfo $equal_longest { |
|
||||||
lappend ctypes [lindex $pinfo 0] |
|
||||||
} |
|
||||||
dict set root_dict closest_types $ctypes |
|
||||||
} |
|
||||||
|
|
||||||
if {[string length [set fosroot [dict get $root_dict fossil]]] && [string length [set gitroot [dict get $root_dict git]]]} { |
|
||||||
if {$fosroot ne $gitroot} { |
|
||||||
if {[path_a_above_b $fosroot $gitroot]} { |
|
||||||
append msg "Found git repo nested within fossil repo - be careful" \n |
|
||||||
append msg "** fos root : $fosroot ([punk::repo::path_relative $start_dir $fosroot])" \n |
|
||||||
append msg " * git root : $gitroot ([punk::repo::path_relative $start_dir $gitroot])" \n |
|
||||||
} else { |
|
||||||
append msg "Found fossil repo nested within git repo - be careful" \n |
|
||||||
append msg "** git root : $gitroot ([punk::repo::path_relative $start_dir $gitroot])" \n |
|
||||||
append msg " * fos root : $fosroot ([punk::repo::path_relative $start_dir $fosroot])" \n |
|
||||||
|
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
dict set root_dict warnings $msg |
|
||||||
#some quick sanity checks.. |
|
||||||
set ctypes [dict get $root_dict closest_types] |
|
||||||
if {"project" in $ctypes} { |
|
||||||
if {"candidate" ni $ctypes} { |
|
||||||
set errmsg "find_roots_and_warnings_dict logic error: have project but not also classified as candidate (coding error in punk::repo) - inform developer\n" |
|
||||||
append errmsg " warnings gathered before error:\n $msg" |
|
||||||
error $errmsg |
|
||||||
} |
|
||||||
if {("git" ni $ctypes) && ("fossil" ni $ctypes)} { |
|
||||||
set errmsg "find_roots_and_warnings_dict logic error: have project but not also at least one of 'git', 'fossil' (coding error in punk::repo) - inform developer\n" |
|
||||||
append errmsg " warnings gathered before error:\n $msg" |
|
||||||
error $errmsg |
|
||||||
} |
|
||||||
} |
|
||||||
set ctype_paths [list] |
|
||||||
foreach ctype [dict get $root_dict closest_types] { |
|
||||||
lappend ctype_paths [lindex [dict get $root_dict $ctype] 1] ;# type, path, len |
|
||||||
} |
|
||||||
set unique [lsort -unique $ctype_paths] |
|
||||||
if {[llength $unique] > 1} { |
|
||||||
# this may be a filesystem path representation issue? case? normalisation? |
|
||||||
set errmsg "find_roots_and_warnings_dict logic error: different paths for closest folders found (error in punk::repo) - inform developer\n" |
|
||||||
append errmsg " warnings gathered before error:\n $msg" |
|
||||||
error $errmsg |
|
||||||
} |
|
||||||
|
|
||||||
return $root_dict |
|
||||||
} |
|
||||||
|
|
||||||
#------------------------------------ |
|
||||||
#limit to exec so full punk shell not required in scripts |
|
||||||
proc git_revision {{path {}}} { |
|
||||||
if {$path eq {}} { set path [pwd] } |
|
||||||
# ::kettle::path::revision.git |
|
||||||
do_in_path $path { |
|
||||||
try { |
|
||||||
#git describe will error with 'No names found' if repo has no tags |
|
||||||
#set v [::exec {*}[auto_execok git] describe] |
|
||||||
set v [::exec {*}[auto_execok git] rev-parse HEAD] ;# consider 'git rev-parse --short HEAD' |
|
||||||
} on error {e o} { |
|
||||||
set v [lindex [split [dict get $o -errorinfo] \n] 0] |
|
||||||
} |
|
||||||
} |
|
||||||
return [string trim $v] |
|
||||||
} |
|
||||||
proc git_remote {{path {{}}}} { |
|
||||||
if {$path eq {}} { set path [pwd] } |
|
||||||
do_in_path $path { |
|
||||||
try { |
|
||||||
#git describe will error with 'No names found' if repo has no tags |
|
||||||
#set v [::exec {*}[auto_execok git] describe] |
|
||||||
set v [::exec {*}[auto_execok git] -remote -v] ;# consider 'git rev-parse --short HEAD' |
|
||||||
} on error {e o} { |
|
||||||
set v [lindex [split [dict get $o -errorinfo] \n] 0] |
|
||||||
} |
|
||||||
} |
|
||||||
return [string trim $v] |
|
||||||
} |
|
||||||
|
|
||||||
proc fossil_revision {{path {}}} { |
|
||||||
if {$path eq {}} { set path [pwd] } |
|
||||||
# ::kettle::path::revision.fossil |
|
||||||
set fossilcmd [auto_execok fossil] |
|
||||||
if {[llength $fossilcmd]} { |
|
||||||
do_in_path $path { |
|
||||||
set info [::exec {*}$fossilcmd info] |
|
||||||
} |
|
||||||
return [lindex [grep {checkout:*} $info] 0 1] |
|
||||||
} else { |
|
||||||
return Unknown |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
proc fossil_remote {{path {}}} { |
|
||||||
if {$path eq {}} { set path [pwd] } |
|
||||||
# ::kettle::path::revision.fossil |
|
||||||
set fossilcmd [auto_execok fossil] |
|
||||||
if {[llength $fossilcmd]} { |
|
||||||
do_in_path $path { |
|
||||||
set info [::exec {*}$fossilcmd remote ls] |
|
||||||
} |
|
||||||
return [string trim $v] |
|
||||||
} else { |
|
||||||
return Unknown |
|
||||||
} |
|
||||||
} |
|
||||||
#------------------------------------ |
|
||||||
|
|
||||||
proc cksum_path_content {path args} { |
|
||||||
dict set args -cksum_content 1 |
|
||||||
dict set args -cksum_meta 0 |
|
||||||
tailcall cksum_path $path {*}args |
|
||||||
} |
|
||||||
#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} { |
|
||||||
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 [list -cksum_content 1 -cksum_meta 1 -cksum_acls 0 -use_tar 1] |
|
||||||
set opts [dict merge $defaults $args] |
|
||||||
if {![file exists $path]} { |
|
||||||
return [list cksum "" opts $opts] |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
set opt_cksum_acls [dict get $opts -cksum_acls] |
|
||||||
if {$opt_cksum_acls} { |
|
||||||
puts stderr "cksum_path is not yet able to cksum ACLs" |
|
||||||
return |
|
||||||
} |
|
||||||
set opt_cksum_meta [dict get $opts -cksum_meta] |
|
||||||
if {$opt_cksum_meta} { |
|
||||||
|
|
||||||
} else { |
|
||||||
if {[file type $path] ne "file"} { |
|
||||||
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" |
|
||||||
return [list error unsupported opts $opts] |
|
||||||
} |
|
||||||
} |
|
||||||
set opt_use_tar [dict get $opts -use_tar] |
|
||||||
if {$opt_use_tar} { |
|
||||||
package require tar ;#from tcllib |
|
||||||
} else { |
|
||||||
if {[file type $path] eq "directory"} { |
|
||||||
puts stderr "cksum_path doesn't yet support -use_tar 0 for folders" |
|
||||||
return [list error unsupported opts $opts] |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
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 opts $opts] |
|
||||||
} |
|
||||||
set cksum "" |
|
||||||
if {$opt_use_tar} { |
|
||||||
set target [file tail $path] |
|
||||||
set tmplocation [tmpdir] |
|
||||||
set archivename $tmplocation/[tmpfile].tar |
|
||||||
|
|
||||||
cd $base ;#cd is process-wide.. keep cd in effect for as small a scope as possible. (review for thread issues) |
|
||||||
|
|
||||||
#temp emission to stdout.. todo - repl telemetry channel |
|
||||||
puts stdout "cksum_path: creating temporary tar archive at: $archivename .." |
|
||||||
tar::create $archivename $target |
|
||||||
puts stdout "cksum_path: calculating cksum for $target (size [file size $target])..." |
|
||||||
set cksum [crc::cksum -format 0x%X -file $archivename] |
|
||||||
puts stdout "cksum_path: cleaning up.. " |
|
||||||
file delete -force $archivename |
|
||||||
cd $startdir |
|
||||||
|
|
||||||
} else { |
|
||||||
#todo |
|
||||||
if {[file type $path] eq "file"} { |
|
||||||
if {$opt_cksum_meta} { |
|
||||||
return [list error unsupported opts $opts] |
|
||||||
} else { |
|
||||||
set cksum [crc::cksum -format 0x%X -file $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 |
|
||||||
return $result |
|
||||||
} |
|
||||||
#temporarily cd to workpath to run script - return to correct path even on failure |
|
||||||
proc do_in_path {path script} { |
|
||||||
#from ::kettle::path::in |
|
||||||
set here [pwd] |
|
||||||
try { |
|
||||||
cd $path |
|
||||||
uplevel 1 $script |
|
||||||
} finally { |
|
||||||
cd $here |
|
||||||
} |
|
||||||
} |
|
||||||
proc scanup {path cmd} { |
|
||||||
if {$path eq {}} { set path [pwd] } |
|
||||||
#based on kettle::path::scanup |
|
||||||
if {[file pathtype $path] eq "relative"} { |
|
||||||
set path [file normalize $path] |
|
||||||
} |
|
||||||
while {1} { |
|
||||||
# Found the proper directory, per the predicate. |
|
||||||
if {[{*}$cmd $path]} { return $path } |
|
||||||
|
|
||||||
# Not found, walk to parent |
|
||||||
set new [file dirname $path] |
|
||||||
|
|
||||||
# Stop when reaching the root. |
|
||||||
if {$new eq $path} { return {} } |
|
||||||
if {$new eq {}} { return {} } |
|
||||||
|
|
||||||
# Ok, truly walk up. |
|
||||||
set path $new |
|
||||||
} |
|
||||||
return {} |
|
||||||
} |
|
||||||
#get content part of content/zip delimited by special \x1a (ctrl-z) char as used in tarjr and kettle::path::c/z |
|
||||||
proc c/z {content} { |
|
||||||
return [lindex [split $content \x1A] 0] |
|
||||||
} |
|
||||||
proc grep {pattern data} { |
|
||||||
set data [string map [list \r\n \n] $data] |
|
||||||
return [lsearch -all -inline -glob [split $data \n] $pattern] |
|
||||||
} |
|
||||||
|
|
||||||
proc rgrep {pattern data} { |
|
||||||
set data [string map [list \r\n \n] $data] |
|
||||||
return [lsearch -all -inline -regexp [split $data \n] $pattern] |
|
||||||
} |
|
||||||
|
|
||||||
proc tmpfile {{prefix tmp_}} { |
|
||||||
#note risk of collision if pregenerating a list of tmpfile names |
|
||||||
#we will maintain an icrementing id so the caller doesn't have to bear that in mind |
|
||||||
variable tmpfile_counter |
|
||||||
global tcl_platform |
|
||||||
return .punkrepo_$prefix[pid]_[clock microseconds]_[incr tmpfile_counter]_[info hostname]_$tcl_platform(user) |
|
||||||
} |
|
||||||
|
|
||||||
proc tmpdir {} { |
|
||||||
# Taken from tcllib fileutil. |
|
||||||
global tcl_platform env |
|
||||||
|
|
||||||
set attempdirs [list] |
|
||||||
set problems {} |
|
||||||
|
|
||||||
foreach tmp {TMPDIR TEMP TMP} { |
|
||||||
if { [info exists env($tmp)] } { |
|
||||||
lappend attempdirs $env($tmp) |
|
||||||
} else { |
|
||||||
lappend problems "No environment variable $tmp" |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
switch $tcl_platform(platform) { |
|
||||||
windows { |
|
||||||
lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP" |
|
||||||
} |
|
||||||
macintosh { |
|
||||||
lappend attempdirs $env(TRASH_FOLDER) ;# a better place? |
|
||||||
} |
|
||||||
default { |
|
||||||
lappend attempdirs \ |
|
||||||
[file join / tmp] \ |
|
||||||
[file join / var tmp] \ |
|
||||||
[file join / usr tmp] |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
lappend attempdirs [pwd] |
|
||||||
|
|
||||||
foreach tmp $attempdirs { |
|
||||||
if { [file isdirectory $tmp] && |
|
||||||
[file writable $tmp] } { |
|
||||||
return [file normalize $tmp] |
|
||||||
} elseif { ![file isdirectory $tmp] } { |
|
||||||
lappend problems "Not a directory: $tmp" |
|
||||||
} else { |
|
||||||
lappend problems "Not writable: $tmp" |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
# Fail if nothing worked. |
|
||||||
return -code error "Unable to determine a proper directory for temporary files\n[join $problems \n]" |
|
||||||
} |
|
||||||
|
|
||||||
#todo - review |
|
||||||
proc ensure-cleanup {path} { |
|
||||||
#::atexit [lambda {path} { |
|
||||||
#file delete -force $path |
|
||||||
#} [norm $path]] |
|
||||||
|
|
||||||
file delete -force $path |
|
||||||
} |
|
||||||
|
|
||||||
proc path_relative {base dst} { |
|
||||||
#see also kettle |
|
||||||
# Modified copy of ::fileutil::relative (tcllib) |
|
||||||
# Adapted to 8.5 ({*}). |
|
||||||
# |
|
||||||
# Taking two _directory_ paths, a base and a destination, computes the path |
|
||||||
# of the destination relative to the base. |
|
||||||
# |
|
||||||
# Arguments: |
|
||||||
# base The path to make the destination relative to. |
|
||||||
# dst The destination path |
|
||||||
# |
|
||||||
# Results: |
|
||||||
# The path of the destination, relative to the base. |
|
||||||
|
|
||||||
# Ensure that the link to directory 'dst' is properly done relative to |
|
||||||
# the directory 'base'. |
|
||||||
|
|
||||||
if {[file pathtype $base] ne [file pathtype $dst]} { |
|
||||||
return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)" |
|
||||||
} |
|
||||||
|
|
||||||
set base [norm $base] |
|
||||||
set dst [norm $dst] |
|
||||||
|
|
||||||
set save $dst |
|
||||||
set base [file split $base] |
|
||||||
set dst [file split $dst] |
|
||||||
|
|
||||||
while {[lindex $dst 0] eq [lindex $base 0]} { |
|
||||||
set dst [lrange $dst 1 end] |
|
||||||
set base [lrange $base 1 end] |
|
||||||
if {![llength $dst]} {break} |
|
||||||
} |
|
||||||
|
|
||||||
set dstlen [llength $dst] |
|
||||||
set baselen [llength $base] |
|
||||||
|
|
||||||
if {($dstlen == 0) && ($baselen == 0)} { |
|
||||||
# Cases: |
|
||||||
# (a) base == dst |
|
||||||
|
|
||||||
set dst . |
|
||||||
} else { |
|
||||||
# Cases: |
|
||||||
# (b) base is: base/sub = sub |
|
||||||
# dst is: base = {} |
|
||||||
|
|
||||||
# (c) base is: base = {} |
|
||||||
# dst is: base/sub = sub |
|
||||||
|
|
||||||
while {$baselen > 0} { |
|
||||||
set dst [linsert $dst 0 ..] |
|
||||||
incr baselen -1 |
|
||||||
} |
|
||||||
set dst [file join {*}$dst] |
|
||||||
} |
|
||||||
|
|
||||||
return $dst |
|
||||||
} |
|
||||||
|
|
||||||
#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]}] |
|
||||||
} |
|
||||||
|
|
||||||
#whether path is at and/or below one of the vfs mount points |
|
||||||
#The design should facilitate nested vfs mountpoints |
|
||||||
proc path_vfs_info {filepath} { |
|
||||||
|
|
||||||
} |
|
||||||
|
|
||||||
#file normalize is expensive so this is too |
|
||||||
proc norm {path {platform env}} { |
|
||||||
#kettle::path::norm |
|
||||||
#see also wiki |
|
||||||
#full path normalization |
|
||||||
|
|
||||||
set platform [string tolower $platform] |
|
||||||
if {$platform eq "env"} { |
|
||||||
set platform $::tcl_platform(platform) |
|
||||||
} |
|
||||||
if {$platform eq "windows"} { |
|
||||||
return [file dirname [file normalize [punk::winpath::winpath $path]/__]] |
|
||||||
} else { |
|
||||||
return [file dirname [file normalize $path/__]] |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
#This taken from kettle::path::strip |
|
||||||
#It doesn't compare the prefix contents presumably for speed when used in kettle::path::scan |
|
||||||
#renamed to better indicate its behaviour |
|
||||||
|
|
||||||
proc path_strip_prefixdepth {path prefix} { |
|
||||||
return [file join \ |
|
||||||
{*}[lrange \ |
|
||||||
[file split [norm $path]] \ |
|
||||||
[llength [file split [norm $prefix]]] \ |
|
||||||
end]] |
|
||||||
} |
|
||||||
#MUCH faster version for absolute path prefix (pre-normalized) |
|
||||||
proc path_strip_alreadynormalized_prefixdepth {path prefix} { |
|
||||||
return [file join \ |
|
||||||
{*}[lrange \ |
|
||||||
[file split $path] \ |
|
||||||
[llength [file split $prefix]] \ |
|
||||||
end]] |
|
||||||
} |
|
||||||
|
|
||||||
proc fcat {args} { |
|
||||||
if {$::tcl_platform(platform) ne "windows"} { |
|
||||||
return [fileutil::cat {*}$args] |
|
||||||
} |
|
||||||
|
|
||||||
set knownopts [list -eofchar -translation -encoding --] |
|
||||||
set last_opt 0 |
|
||||||
for {set i 0} {$i < [llength $args]} {incr i} { |
|
||||||
set ival [lindex $args $i] |
|
||||||
#puts stdout "i:$i a: $ival known: [expr {$ival in $knownopts}]" |
|
||||||
if {$ival eq "--"} { |
|
||||||
set last_opt $i |
|
||||||
break |
|
||||||
} else { |
|
||||||
if {$ival in $knownopts} { |
|
||||||
#puts ">known at $i : [lindex $args $i]" |
|
||||||
if {($i % 2) != 0} { |
|
||||||
error "unexpected option at index $i. known options: $knownopts must come in -opt val pairs." |
|
||||||
} |
|
||||||
incr i |
|
||||||
set last_opt $i |
|
||||||
} else { |
|
||||||
set last_opt [expr {$i - 1}] |
|
||||||
break |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
set first_non_opt [expr {$last_opt + 1}] |
|
||||||
|
|
||||||
#puts stderr "first_non_opt: $first_non_opt" |
|
||||||
set opts [lrange $args -1 $first_non_opt-1] |
|
||||||
set paths [lrange $args $first_non_opt end] |
|
||||||
if {![llength $paths]} { |
|
||||||
error "Unable to find file in the supplied arguments: $args. Ensure options are all -opt val pairs and that file name(s) follow" |
|
||||||
} |
|
||||||
#puts stderr "opts: $opts paths: $paths" |
|
||||||
set finalpaths [list] |
|
||||||
foreach p $paths { |
|
||||||
if {[punk::winpath::illegalname_test $p]} { |
|
||||||
lappend finalpaths [punk::winpath::illegalname_fix $p] |
|
||||||
} else { |
|
||||||
lappend finalpaths $p |
|
||||||
} |
|
||||||
} |
|
||||||
fileutil::cat {*}$opts {*}$finalpaths |
|
||||||
} |
|
||||||
|
|
||||||
interp alias {} is_fossil {} ::punk::repo::is_fossil |
|
||||||
interp alias {} is_fossil_root {} ::punk::repo::is_fossil_root |
|
||||||
interp alias {} find_fossil {} ::punk::repo::find_fossil |
|
||||||
interp alias {} fossil_revision {} ::punk::repo::fossil_revision |
|
||||||
interp alias {} is_git {} ::punk::repo::is_git |
|
||||||
interp alias {} is_git_root {} ::punk::repo::is_git_root |
|
||||||
interp alias {} find_git {} ::punk::repo::find_git |
|
||||||
interp alias {} git_revision {} ::punk::repo::git_revision |
|
||||||
|
|
||||||
|
|
||||||
interp alias {} gs {} git status -sb |
|
||||||
interp alias {} gr {} ::punk::repo::git_revision |
|
||||||
interp alias {} gl {} git log --oneline --decorate ;#decorate so stdout consistent with what we see on console |
|
||||||
interp alias {} glast {} git log -1 HEAD --stat |
|
||||||
interp alias {} gconf {} git config --global -l |
|
||||||
|
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
## Ready |
|
||||||
package provide punk::repo [namespace eval punk::repo { |
|
||||||
variable version |
|
||||||
set version 0.1.0 |
|
||||||
}] |
|
||||||
return |
|
||||||
Loading…
Reference in new issue