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