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.
1233 lines
53 KiB
1233 lines
53 KiB
# -*- 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.1 |
|
# 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 fileutil; #tcllib |
|
package require punk::path |
|
package require punk::mix::base ;#uses core functions from punk::mix::base::lib namespace e.g cksum_path |
|
package require punk::mix::util ;#do_in_path |
|
|
|
|
|
# -- --- --- --- --- --- --- --- --- --- --- |
|
# 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 { |
|
|
|
#Todo - investigate proper way to install a client-side commit hook in the fossil project |
|
#Then we may still use this proxy to check the hook - but the required checks will occur when another shell used |
|
proc fossil_proxy {args} { |
|
set start_dir [pwd] |
|
set fosroot [find_fossil $start_dir] |
|
set fossilcmd [lindex $args 0] |
|
|
|
set no_warning_commands [list "help" "dbstat" "grep" "diff" "xdiff" "cat" "version"] |
|
if {$fossilcmd ni $no_warning_commands } { |
|
set repostate [find_repos $start_dir] |
|
} |
|
|
|
set no_prompt_commands [list "status" "info" {*}$no_warning_commands] |
|
|
|
|
|
if {$fossilcmd ni $no_prompt_commands} { |
|
set fossilrepos [dict get $repostate fossil] |
|
if {[llength $fossilrepos] > 1} { |
|
puts stdout [dict get $repostate warnings] |
|
puts stdout "Operating on inner fossil repository: [lindex $fossilrepos 0]" |
|
puts stdout "Use FOSSIL instead of fossil to avoid this prompt and warning" |
|
set answer [askuser "Are you sure you want to perform the operation on this repo? Y/N"] |
|
if {[string tolower $answer] ne "y"} { |
|
return |
|
} |
|
} |
|
} |
|
if {$fossilcmd eq "init"} { |
|
#check if the path to .fossil is within an outer repo area.. offer to locate it somewhere else |
|
set repos [dict get $repostate repos] |
|
if {[llength $repos]} { |
|
set chosenfossil [lindex $args end] |
|
#if the user is naming it other than .fossil - assume they know what they're doing. |
|
if {[string match *.fossil $chosenfossil]} { |
|
set norm_chosen [file normalize $chosenfossil] |
|
set fdir [file dirname $norm_chosen] |
|
set toprepo_info [lindex $repos end] ;#choose shortest path ie topmost |
|
set toprepo [lindex $toprepo_info 0] |
|
if {[punk::mix::base::lib::path_a_atorbelow_b $fdir $toprepo]} { |
|
set fproj [file rootname [file tail $norm_chosen]] |
|
puts stdout "Chosen .fossil location is within outer repository at $toprepo" |
|
set answer [askuser "Would you like the opportunity to choose a different location for the .fossil file from a menu? Y/N"] |
|
if {[string tolower $answer] eq "y"} { |
|
set repodir [fossil_get_repository_folder_for_project $fproj -extrachoice $fdir] |
|
if {[string length $repodir]} { |
|
puts stdout "LOCATION: $repodir/$fproj.fossil" |
|
set args [lrange $args 0 end-1] |
|
lappend args $repodir/$fproj.fossil |
|
} else { |
|
puts stderr "No directory found/selected - aborting" |
|
return |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
if {$fossilcmd eq "commit"} { |
|
if {[llength [file split $fosroot]]} { |
|
if {[file exists [file join $fosroot src/buildsuites]]} { |
|
puts stderr "Todo - check buildsites/suite/projects for current branch/tag and update download_and_build_config" |
|
} |
|
} |
|
} elseif {$fossilcmd in [list "info" "status"]} { |
|
#emit warning whether or not multiple fossil repos |
|
puts stdout [dict get $repostate warnings] |
|
} |
|
set fossil_prog [auto_execok fossil] |
|
if {$fossil_prog ne ""} { |
|
{*}$fossil_prog {*}$args |
|
} else { |
|
puts stderr "fossil command not found. Please install fossil" |
|
} |
|
} |
|
interp alias "" fossil "" punk::repo::fossil_proxy |
|
|
|
if {[auto_execok fossil] ne ""} { |
|
interp alias "" FOSSIL "" {*}[auto_execok fossil] |
|
} |
|
|
|
proc askuser {question} { |
|
puts stdout $question |
|
flush stdout |
|
set stdin_state [fconfigure stdin] |
|
try { |
|
fconfigure stdin -blocking 1 |
|
set answer [gets stdin] |
|
} finally { |
|
fconfigure stdin -blocking [dict get $stdin_state -blocking] |
|
} |
|
return $answer |
|
} |
|
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 {[punk::mix::base::lib::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 |
|
} |
|
|
|
#review - is a .git folder sufficient? |
|
#consider git rev-parse --git-dir ? |
|
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"} { |
|
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 |
|
} |
|
|
|
#review/tests |
|
#todo - deleted items (e.g for git 1 .D ... ) |
|
#punkcheck uses this to check when copying a source-file to a repo-external location that the file can be tied to a revision. |
|
#we are primarily concerned with the status of existent files (caller should check existence) and whether they belong to the revision that currently applies to the folder being examined. |
|
#we are not concerned with git's staging facility - other than that it needs to be looked at to work out whether the file on disk is currently in a state matching the revision. |
|
# |
|
# -repotypes is an ordered list - if the closest repo is multi-typed the order will determine which is used. |
|
# This deliberately doesn't allow bypassing a sub-repo to look for a higher-level repo in a repo-nest. |
|
# The theory is that sub-repos shouldn't have their contents directly tracked directly by higher-level repos anyway |
|
proc workingdir_state {{abspath {}} args} { |
|
set defaults [list\ |
|
-repotypes [list fossil git]\ |
|
-repopaths ""\ |
|
] |
|
#prefer fossil if first repo is dual git/fossil |
|
if {$abspath in [dict keys $defaults]} { |
|
set args [list $abspath {*}$args] |
|
set abspath "" |
|
} |
|
set opts [dict merge $defaults $args] |
|
# -- --- --- --- --- --- --- --- --- --- --- --- |
|
set opt_repotypes [dict get $opts -repotypes] |
|
set opt_repopaths [dict get $opts -repopaths] |
|
if {"$opt_repopaths" ne ""} { |
|
if {([llength $opt_repopaths] % 2 != 0) || ![dict exists $opt_repopaths closest]} { |
|
error "workingdir_state error: -repopaths argument invalid. Expected a dict as retrieved using punk::repo::find_repos" |
|
} |
|
set repopaths $opt_repopaths |
|
} else { |
|
set repopaths [find_repos $abspath] |
|
} |
|
# -- --- --- --- --- --- --- --- --- --- --- --- |
|
|
|
if {$abspath eq ""} {set abspath [pwd]} |
|
if {[file pathtype $abspath] ne "absolute"} { |
|
error "workingdir_state error: absolute path required. Got '$abspath'" |
|
} |
|
if {![file isdirectory $abspath]} { |
|
#shouldn't be passed a file.. but just use containing folder if we were |
|
set abspath [file dirname $abspath] |
|
} |
|
set repodir [dict get $repopaths closest] |
|
set ondisk_repotypes [dict get $repopaths closest_types] |
|
set repotypes_to_query [list] |
|
foreach r $opt_repotypes { |
|
if {$r in $ondisk_repotypes} { |
|
lappend repotypes_to_query $r |
|
} |
|
} |
|
|
|
if {$repodir eq ""} { |
|
error "workingdir_state error: No repository found at or above path '$abspath'" |
|
} |
|
set subpath [punk::path::relative $repodir $abspath] |
|
if {$subpath eq "."} { |
|
set subpath "" |
|
} |
|
|
|
set resultdict [dict create repodir $repodir subpath $subpath] |
|
set pathdict [dict create] |
|
|
|
if {![llength $repotypes_to_query]} { |
|
error "No tracking information available for project at $repodir with the chosen repotypes '$opt_repotypes'. Ensure project workingdir is a fossil (or git) checkout" |
|
} |
|
foreach rt $repotypes_to_query { |
|
#We need entire list of files in the revision because there is no easy way to get the list of files configured to be ignored |
|
#(aside from attempting to calculate from .fossil-settings ignore-glob or .gitignore) |
|
#This means we can't just use fossil extras or the list of git untracked files |
|
#i.e a file not showing as EDITED/MISSING/EXTRA can't be assumed to be in the revision as it may match an ignore-glob or .gitignore entry |
|
#For this reason we will store 'unchanged' records for both git and fossil so that the combined dict should represent all files in the revision |
|
if {$rt eq "fossil"} { |
|
dict set resultdict repotype fossil |
|
set fossil_cmd [auto_execok fossil] |
|
if {$fossil_cmd eq ""} { |
|
error "workingdir_state error: fossil executable doesn't seem to be available" |
|
} |
|
if {[catch {punk::mix::util::do_in_path $repodir [list exec {*}$fossil_cmd status --all --differ --merge $abspath]} fossilstate]} { |
|
error "workingdir_state error: Unable to retrieve workingdir state using fossil. Errormsg: $fossilstate" |
|
} |
|
# line: checkout: fb971... |
|
set revision [lindex [grep {checkout:*} $fossilstate] 0 1] |
|
#set checkrevision [fossil_revision $abspath] |
|
|
|
|
|
dict set resultdict ahead "" |
|
dict set resultdict behind "" |
|
|
|
foreach ln [split $fossilstate \n] { |
|
if {[string trim $ln] eq ""} {continue} |
|
set space1 [string first " " $ln] |
|
if {$space1 > 1} { |
|
set word1 [string range $ln 0 $space1-1] |
|
if {[string index $word1 end] eq ":"} { |
|
#we've already examined any xxx: header lines we're interested in. |
|
continue |
|
} |
|
} |
|
if {[string match "EDITED *" $ln]} { |
|
set path [string trim [string range $ln [string length "EDITED "] end]] ;#should handle spaced paths |
|
dict set pathdict $path "changed" |
|
} elseif {[string match "ADDED *" $ln]} { |
|
set path [string trim [string range $ln [string length "ADDED "] end]] |
|
dict set pathdict $path "new" |
|
} elseif {[string match "DELETED *" $ln]} { |
|
set path [string trim [string range $ln [string length "DELETED "] end]] |
|
dict set pathdict $path "missing" |
|
} elseif {[string match "MISSING *" $ln]} { |
|
set path [string trim [string range $ln [string length "MISSING "] end]] |
|
dict set pathdict $path "missing" |
|
} elseif {[string match "EXTRA *" $ln]} { |
|
#fossil will explicitly list files in a new folder - as opposed to git which shows just the folder |
|
set path [string trim [string range $ln [string length "EXTRA "] end]] |
|
dict set pathdict $path "extra" |
|
} elseif {[string match "UNCHANGED *" $ln]} { |
|
set path [string trim [string range $ln [string length "UNCHANGED "] end]] |
|
dict set pathdict $path "unchanged" |
|
} else { |
|
#emit for now |
|
puts stderr "unprocessed fossilstate line: $ln" |
|
} |
|
#other entries?? |
|
} |
|
break |
|
} elseif {$rt eq "git"} { |
|
dict set resultdict repotype git |
|
set git_cmd [auto_execok git] |
|
# -uno = suppress ? lines. |
|
# -b = show ranch and tracking info |
|
if {[catch {punk::mix::util::do_in_path $repodir [list exec {*}$git_cmd status --porcelain=2 -b -- $abspath]} gitstate]} { |
|
error "workingdir_state error: Unable to retrieve workingdir state using git. Errormsg: $gitstate" |
|
} |
|
# line: # branch.oid f2d2a... |
|
set revision [lindex [grep {# branch.oid *} $gitstate] 0 2] |
|
if {$revision eq "(initial)"} { |
|
puts stderr "workingdir_state: git revision is (initial) - no file state to gather" |
|
break |
|
} |
|
dict set resultdict ahead "" |
|
dict set resultdict behind "" |
|
set aheadbehind [lindex [grep {# branch.ab *} $gitstate] 0] |
|
if {[llength $aheadbehind] > 0} { |
|
lassign [lrange $aheadbehind 2 3] a b |
|
if {$a > 0} { |
|
dict set resultdict ahead [expr {abs($a)}] |
|
} |
|
if {$b < 0} { |
|
dict set resultdict behind [expr {abs($b)}] |
|
} |
|
} |
|
#set checkrevision [git_revision $abspath] |
|
if {[catch {punk::mix::util::do_in_path $repodir [list exec {*}$git_cmd ls-tree -r $revision $abspath]} gitfiles]} { |
|
error "workingdir_state error: Unable to retrieve files for revision '$revision' using git. Errormsg: $gitfiles" |
|
} |
|
|
|
#paths will be relative to $repodir/$subpath |
|
foreach ln [split $gitfiles \n] { |
|
if {[string trim $ln] eq ""} {continue} |
|
#review - spaced paths? |
|
set path [lindex $ln end] |
|
dict set pathdict $path "unchanged" ;#default only - to be overridden with info from gitstate |
|
} |
|
|
|
foreach ln [split $gitstate \n] { |
|
if {[string trim $ln] eq ""} {continue} |
|
if {[string match "#*" $ln]} {continue} |
|
if {[string match "1 *" $ln]} { |
|
# ordinary changed entries |
|
# format: 1 <XY> <sub> <mH> <mI> <mW> <hH> <hI> <path> |
|
#review - what does git do for spaced paths? |
|
#for now we will risk treating as a list |
|
set path [lindex $ln end] |
|
set xy [lindex $ln 1] |
|
lassign [split $xy ""] staged unstaged |
|
if {[string match "*M*" $xy]} { |
|
#e.g .M when unstaged M. when staged |
|
dict set pathdict $path "changed" |
|
} elseif {[string match "*D*" $xy]} { |
|
dict set pathdict $path "missing" |
|
} elseif {[string match "*A*" $xy]} { |
|
#e.g A. for new file that has been staged |
|
dict set pathdict $path "new" |
|
} else { |
|
dict set pathdict $path "UNKNOWN" ;#review - fix |
|
} |
|
} elseif {[string match "? *" $ln]} { |
|
#note that git will list a folder entry without going deeper to list contents |
|
set path [string trim [string range $ln [string length "? "] end]] ;#should handle spaced paths |
|
dict set pathdict $path "extra" |
|
} elseif {[string match "2 *" $ln]} { |
|
# renamed or copied entries |
|
# as we don't supply -z option - <sep> is tab char. |
|
# format: 2 <XY> <sub> <mH> <mI> <mW> <hH> <hI> <X><score> <path><sep><origPath> |
|
#we should mark target of rename as 'new' - consistent with fossil - and stops caller from seeing no entry for an existent file and assuming it already belongs to the revision checkout |
|
lassign [split $ln \t] pretab posttab |
|
set path [lindex $pretab end] |
|
dict set pathdict $path "new" ;#review - if file was first deleted then renamed - is it more appropriately flagged as 'changed' - possibly doesn't matter for revision-membership detection new or changed should be ok |
|
|
|
set pathorig [string trim $posttab] |
|
dict set pathdict $pathorig "missing" |
|
} elseif {[string match "u *" $ln]} { |
|
#Unmerged entries |
|
# format: u <XY> <sub> <m1> <m2> <m3> <mW> <h1> <h2> <h3> <path> |
|
# |
|
#presume file on disk not as per revision - treat as changed (?review) |
|
set path [lindex $ln end] |
|
dict set pathdict $path "changed" |
|
} elseif {[string match "! *" $ln]} { |
|
#ignored files - not part of revision |
|
|
|
} else { |
|
#emit for now |
|
puts stderr "unprocessed gitstat line $ln" |
|
} |
|
} |
|
break |
|
} else { |
|
puts stderr "workingdir_state - repotype $rt not supported" |
|
} |
|
} |
|
dict set resultdict revision $revision |
|
dict set resultdict paths $pathdict |
|
return $resultdict |
|
} |
|
proc workingdir_state_summary {repostate args} { |
|
if {![dict exists $repostate repotype] || ![dict exists $repostate paths]} { |
|
error "workingdir_state_summary error repostate doesn't appear to be a repostate dict. (use workingdir_state <path> to create)" |
|
} |
|
package require overtype |
|
set defaults [dict create\ |
|
-fields {ahead behind unchanged changed new missing extra}\ |
|
] |
|
set opts [dict merge $defaults $args] |
|
# -- --- --- --- --- --- --- --- --- --- |
|
set opt_fields [dict get $opts -fields] |
|
# -- --- --- --- --- --- --- --- --- --- |
|
|
|
set summary_dict [workingdir_state_summary_dict $repostate] |
|
set repotype [dict get $summary_dict repotype] |
|
set fieldnames [dict create\ |
|
repodir repodir\ |
|
subpath subpath\ |
|
revision revision\ |
|
ahead ahead\ |
|
behind behind\ |
|
repotype repotype\ |
|
unchanged unchanged\ |
|
changed changed\ |
|
new new\ |
|
missing missing\ |
|
extra extra\ |
|
] |
|
foreach f $opt_fields { |
|
if {$f ni [dict keys $fieldnames]} { |
|
error "workingdir_state_summary error: unknown field $f. known-values: [dict keys $fieldnames]" |
|
} |
|
} |
|
if {$repotype eq "git"} { |
|
dict set fieldnames extra "extra (files/folders)" |
|
} |
|
set col1_fields [list] |
|
set col2_values [list] |
|
foreach f $opt_fields { |
|
lappend col1_fields [dict get $fieldnames $f] |
|
lappend col2_values [dict get $summary_dict $f] |
|
} |
|
set title1 "" |
|
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1_fields] {string length $v}]] |
|
set col1 [string repeat " " $widest1] |
|
set title2 "" |
|
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2_values] {string length $v}]] |
|
set col2 [string repeat " " $widest2] |
|
|
|
set result "" |
|
foreach f $col1_fields v $col2_values { |
|
append result "[overtype::left $col1 $f]: [overtype::right $col2 $v]" \n |
|
} |
|
set result [string trimright $result \n] |
|
return $result |
|
} |
|
proc workingdir_state_summary_dict {repostate} { |
|
if {![dict exists $repostate repotype] || ![dict exists $repostate paths]} { |
|
error "workingdir_state_summary_dict error repostate doesn't appear to be a repostate dict. (use workingdir_state <path> to create)" |
|
} |
|
set filestates [dict values [dict get $repostate paths]] |
|
set path_count_fields [list unchanged changed new missing extra] |
|
set state_fields [list ahead behind repodir subpath repotype revision] |
|
set dresult [dict create] |
|
foreach f $state_fields { |
|
dict set dresult $f [dict get $repostate $f] |
|
} |
|
foreach f $path_count_fields { |
|
dict set dresult $f [llength [lsearch -all $filestates $f]] |
|
} |
|
return $dresult |
|
} |
|
#determine nature of possibly-nested repositories (of various types) at and above this path |
|
#Treat an untracked 'candidate' folder as a sort of repository |
|
proc find_repos {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 |
|
#ie 'project' is a derived repo-type |
|
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 fos_search_from $start_dir |
|
set fossils_bottom_to_top [list] |
|
while {[string length [set fosroot [punk::repo::find_fossil $fos_search_from]]]} { |
|
lappend fossils_bottom_to_top $fosroot |
|
set fos_search_from [file dirname $fosroot] |
|
} |
|
dict set root_dict fossil $fossils_bottom_to_top |
|
|
|
set git_search_from $start_dir |
|
set gits_bottom_to_top [list] |
|
while {[string length [set gitroot [punk::repo::find_git $git_search_from]]]} { |
|
lappend gits_bottom_to_top $gitroot |
|
set git_search_from [file dirname $gitroot] |
|
} |
|
dict set root_dict git $gits_bottom_to_top |
|
|
|
set cand_search_from $start_dir |
|
set candidates_bottom_to_top [list] |
|
while {[string length [set candroot [punk::repo::find_candidate $cand_search_from]]]} { |
|
lappend candidates_bottom_to_top $candroot |
|
set cand_search_from [file dirname $candroot] |
|
} |
|
dict set root_dict candidate $candidates_bottom_to_top |
|
|
|
|
|
set projects_bottom_to_top [list] |
|
set pathinfo [list] ;#list of {path plen} elements - for sorting on plen |
|
set path_dict [dict create] ;#key on path - store repo-types as list |
|
foreach repotype [list fossil git candidate] { |
|
set repos [dict get $root_dict $repotype] |
|
if {[llength $repos]} { |
|
foreach p $repos { |
|
if {![dict exists $path_dict $p]} { |
|
dict set path_dict $p $repotype |
|
} else { |
|
if {$repotype eq "candidate"} { |
|
#path exists so this path is tracked and a candidate - therefore a punk 'project' |
|
dict lappend path_dict $p "candidate" "project" |
|
lappend projects_bottom_to_top $p |
|
} else { |
|
dict lappend path_dict $p $repotype |
|
} |
|
} |
|
set plen [llength [file split $p]] |
|
} |
|
} |
|
} |
|
dict set root_dict project $projects_bottom_to_top |
|
|
|
dict for {path repotypes} $path_dict { |
|
lappend pathinfo [list $repotypes $path [llength [file split $path]]] |
|
} |
|
#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 -decreasing -index 2 $pathinfo] |
|
set repos [list] |
|
foreach pinfo $longest_first { |
|
lassign $pinfo types p len |
|
lappend repos [list $p $types] |
|
} |
|
dict set root_dict repos $repos |
|
|
|
set is_fossil_and_project 0; #fossil repo *and* candidate |
|
foreach fos [dict get $root_dict fossil] { |
|
if {$fos in [dict get $root_dict candidate]} { |
|
set is_fossil_and_project 1 |
|
break |
|
} |
|
} |
|
if {(!$is_fossil_and_project)} { |
|
append msg "Not a punk fossil project" \n |
|
} |
|
|
|
if {![llength $longest_first]} { |
|
#no repos or candidate |
|
append msg "No fossil or git tracking found - No candidate project root found" \n |
|
} else { |
|
dict set root_dict closest [lindex $longest_first 0 1] ;#the *path* of the closest to start_dir |
|
dict set root_dict closest_types [lindex $longest_first 0 0] |
|
} |
|
|
|
|
|
set closest_fossil [lindex [dict get $root_dict fossil] 0] |
|
set closest_fossil_len [llength [file split $closest_fossil]] |
|
set closest_git [lindex [dict get $root_dict git] 0] |
|
set closest_git_len [llength [file split $closest_git]] |
|
set closest_candidate [lindex [dict get $root_dict candidate] 0] |
|
set closest_candidate_len [llength [file split $closest_candidate]] |
|
|
|
if {$closest_candidate_len > $closest_fossil_len && $closest_candidate_len > $closest_git_len} { |
|
#only warn if this candidate is *within* a found repo root |
|
append msg "**" \n |
|
append msg "** found folder with /src at or above starting folder - that is below a fossil and/or git repo" \n |
|
append msg "** starting folder : $start_dir" \n |
|
append msg "** untracked : $candroot" \n |
|
if {$closest_fossil_len} { |
|
append msg "** fossil root : $closest_fossil ([punk::path::relative $start_dir $closest_fossil])" \n |
|
} |
|
if {$closest_git_len} { |
|
append msg "** git root : $closest_git ([punk::path::relative $start_dir $closest_git])" \n |
|
} |
|
append msg "**" \n |
|
} |
|
|
|
|
|
#don't warn if not git - unless also not fossil |
|
if {(![llength [dict get $root_dict fossil]]) && (![llength [dict get $root_dict git]])} { |
|
append msg "No repository located at or above starting folder $start_dir" \n |
|
if {![llength [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 : $closest_candidate" \n |
|
append msg " - consider putting this folder under fossil control (and/or git)" \n |
|
} |
|
} |
|
|
|
set nestinfo [list] |
|
if {[llength $longest_first] > 1} { |
|
foreach pinfo $longest_first { |
|
lassign $pinfo types p len |
|
lappend nestinfo [list $p [join $types -]] |
|
} |
|
} |
|
if {[string length $nestinfo]} { |
|
set rnestinfo [lreverse $nestinfo] |
|
set col1items [lsearch -all -inline -index 0 -subindices $rnestinfo *] |
|
set col2items [lsearch -all -inline -index 1 -subindices $rnestinfo *] |
|
|
|
package require overtype |
|
set title1 "Path" |
|
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1items] {punk::strlen $v}]] |
|
set col1 [string repeat " " $widest1] |
|
set title2 "Repo-type(s)" |
|
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {punk::strlen $v}]] |
|
set col2 [string repeat " " $widest2] |
|
set tablewidth [expr {$widest1 + 1 + $widest2}] |
|
|
|
append msg [string repeat "=" $tablewidth] \n |
|
append msg "Found nested repository structure" \n |
|
append msg "[overtype::left $col1 $title1] [overtype::left $col2 $title2]" \n |
|
|
|
append msg "[string repeat - $widest1] [string repeat - $widest2]" \n |
|
|
|
foreach p $col1items tp $col2items { |
|
append msg "[overtype::left $col1 $p] [overtype::left $col2 $tp]" \n |
|
} |
|
append msg [string repeat "=" $tablewidth] \n |
|
} |
|
|
|
dict set root_dict warnings $msg |
|
|
|
return $root_dict |
|
} |
|
proc fossil_get_repository_file {{path {}}} { |
|
if {$path eq {}} { set path [pwd] } |
|
set fossilcmd [auto_execok fossil] |
|
if {[llength $fossilcmd]} { |
|
do_in_path $path { |
|
set fossilinfo [::exec {*}$fossilcmd info] |
|
} |
|
set matching_lines [punk::repo::grep {repository:*} $fossilinfo] |
|
if {![llength $matching_lines]} { |
|
return "" |
|
} |
|
set trimmedline [string trim [lindex $matching_lines 0]] |
|
set firstcolon [string first : $trimmedline] |
|
set repofile_path [string trim [string range $trimmedline $firstcolon+1 end]] |
|
if {![file exists $repofile_path]} { |
|
puts stderr "Repository file pointed to by fossil configdb doesn't exist: $repofile_path" |
|
return "" |
|
} |
|
return $repofile_path |
|
} else { |
|
puts stderr "fossil_get_repository_file: fossil command unavailable" |
|
return "" |
|
} |
|
} |
|
proc fossil_get_repository_folder_for_project {projectname args} { |
|
|
|
set defaults [list -parentfolder \uFFFF -extrachoice \uFFFF] |
|
set opts [dict merge $defaults $args] |
|
|
|
set opt_parentfolder [dict get $opts -parentfolder] |
|
if {$opt_parentfolder eq "\uFFFF"} { |
|
set opt_parentfolder [pwd] |
|
} |
|
set opt_extrachoice [dict get $opts -extrachoice] |
|
set extrachoice "" |
|
if {$opt_extrachoice ne "\uFFFF"} { |
|
set extrachoice $opt_extrachoice |
|
} |
|
|
|
set startdir $opt_parentfolder |
|
|
|
set fossil_prog [auto_execok fossil] |
|
if {$fossil_prog eq ""} { |
|
puts stderr "Fossil not found. Please install fossil" |
|
return |
|
} |
|
|
|
set fossilinfo [exec {*}$fossil_prog info] ;#will give us the necessary config-db info whether in a project folder or not |
|
set matching_lines [punk::repo::grep {config-db:*} $fossilinfo] |
|
if {[llength $matching_lines] != 1} { |
|
puts stderr "Unable to find config-db info from fossil. Check your fossil installation." |
|
puts stderr "Fossil output was:" |
|
puts stderr "-------------" |
|
puts stderr "$fossilinfo" |
|
puts stderr "-------------" |
|
puts stderr "config-db info:" |
|
puts stderr "$matching_lines" |
|
return |
|
} |
|
set trimmedline [string trim [lindex $matching_lines 0]] |
|
set firstcolon [string first : $trimmedline] |
|
set config_db_path [string trim [string range $trimmedline $firstcolon+1 end]] |
|
if {![file exists $config_db_path]} { |
|
puts stderr "Unable to verify fossil global configuration info at path: $config_db_path" |
|
return |
|
} |
|
set config_db_folder [file dirname $config_db_path] |
|
|
|
#NOTE: we could use fossil all info to detect all locations of .fossil files - but there may be many that are specific to projects if the user wasn't in the habit of using a default location |
|
#Whilst it might detect a central repo folder in a non-standard location - it might also be annoying. |
|
#Todo - a separate environment variable for users to declare one or more locations where they would like to store project .fossil repositories? |
|
|
|
set candidate_repo_folder_locations [list] |
|
#- choose a sensible default based on where fossil put the global config dir - or on the existence of a .fossils folder in a 'standard' location |
|
#verify with user before creating a .fossils folder |
|
#always check env(FOSSIL_HOME) first - but this is designed to locate the global .fossil (or _fossil) file - .fossils repository folder doesn't have to be at the same location |
|
set usable_repo_folder_locations [list] |
|
#If we find one, but it's not writable - add it to another list |
|
set readonly_repo_folder_locations [list] |
|
|
|
#Examine a few possible locations for .fossils folder set |
|
#if containing folder is writable add to candidate list |
|
set testpaths [list] |
|
|
|
if {[info exists ::env(FOSSIL_HOME)]} { |
|
set fossilhome_raw [string trim $::env(FOSSIL_HOME)] |
|
if {![catch {package require Tcl 8.7-}]} { |
|
set fossilhome [file normalize [file tildeexpand $fossilhome_raw]] |
|
} else { |
|
#8.6 |
|
set fossilhome [file normalize $fossilhome_raw] |
|
} |
|
|
|
lappend testpaths [file join $fossilhome .fossils] |
|
} |
|
|
|
if {[info exists ::env(HOME)]} { |
|
set homedir $::env(HOME) ;#use capital for cross-platform |
|
set tp [file join $homedir .fossils] |
|
if {$tp ni $testpaths} { |
|
lappend testpaths $tp |
|
} |
|
} |
|
set tp [file join $config_db_folder .fossils] |
|
if {$tp ni $testpaths} { |
|
lappend testpaths $tp |
|
} |
|
#test our current startdir too in case the user likes to keep their fossils closer to the projects |
|
set tp [file join $startdir .fossils] |
|
if {$tp ni $testpaths} { |
|
lappend testpaths $tp |
|
} |
|
if {[string length $extrachoice]} { |
|
set tp $extrachoice |
|
if {$tp ni $testpaths} { |
|
lappend testpaths $tp |
|
} |
|
} |
|
|
|
|
|
foreach testrepodir $testpaths { |
|
if {[file isdirectory $testrepodir]} { |
|
if {[file writable $testrepodir]} { |
|
lappend usable_repo_folder_locations $testrepodir |
|
} else { |
|
lappend readonly_repo_folder_locations $testrepodir |
|
} |
|
} else { |
|
set repo_parent [file dirname $testrepodir] |
|
if {[file writable $repo_parent]} { |
|
lappend candidate_repo_folder_locations $testrepodir |
|
} |
|
} |
|
} |
|
|
|
set startdir_fossils [glob -nocomplain -dir $startdir -type f *.fossil] |
|
if {[llength $startdir_fossils]} { |
|
#user is already keeping .fossil files directly in curent dir - give them the option to easily keep doing this |
|
#(we don't add it if no .fossil files there already - as it is probably a niche requirement - or a sign the user hasn't thought about a better/central location) |
|
if {$startdir ni $usable_repo_folder_locations} { |
|
lappend usable_repo_folder_locations $startdir |
|
} |
|
} |
|
set choice_folders [list] |
|
set i 1 |
|
foreach fld $usable_repo_folder_locations { |
|
set existing_fossils [glob -nocomplain -dir $fld -type f -tails *.fossil] |
|
if {[set ecount [llength $existing_fossils]]} { |
|
if {$ecount ==1} {set s ""} else {set s "s"} |
|
set existingfossils "( $ecount existing .fossil$s )" |
|
} else { |
|
set existingfossils "( no existing .fossil files found )" |
|
} |
|
if {"$projectname.fossil" in $existing_fossils} { |
|
set conflict "CONFLICT - $projectname.fossil already exists in this folder" |
|
} else { |
|
set conflict "" |
|
} |
|
lappend choice_folders [list index $i folder $fld folderexists 1 existingfossils $existingfossils conflict $conflict] |
|
incr i |
|
} |
|
|
|
if {![llength $choice_folders]} { |
|
#no existing writable .fossil folders (and no existing .fossil files in startdir) |
|
#offer the (writable) candidate_repo_folder_locations |
|
foreach fld $candidate_repo_folder_locations { |
|
lappend choice_folders [list index $i folder $fld folderexists 0 existingfossils "" conflict ""] |
|
incr i |
|
} |
|
} |
|
|
|
set menu_message "" |
|
if {[llength $choice_folders]} { |
|
append menu_message "Select the number of the folder to use to store the .fossil repository file" \n |
|
} else { |
|
append menu_message "--- NO suitable writable folders or locations found for .fossil file. Consider setting FOSSIL_HOME environment variable and check that folders are writable.--" \n |
|
} |
|
|
|
set conflicted_options [list] |
|
foreach option $choice_folders { |
|
set i [dict get $option index] ;# 1-based |
|
set fld [dict get $option folder] |
|
set existingfossils [dict get $option existingfossils] |
|
set conflict [dict get $option conflict] |
|
if {[string length $conflict]} { |
|
lappend conflicted_options $i ;#1+ |
|
} |
|
set folderexists [dict get $option folderexists] |
|
if {$folderexists} { |
|
set folderstatus "(existing folder)" |
|
} else { |
|
set folderstatus "(CREATE folder for .fossil repository files)" |
|
} |
|
append menu_message "$i $folderstatus $fld $existingfossils $conflict" \n |
|
} |
|
|
|
|
|
#append the readonly_repo_folder_locations so that user is aware of them as it may affect their choice |
|
if {[llength $readonly_repo_folder_locations]} { |
|
append menu_message "--------------------------------------------------" \n |
|
foreach readonly $readonly_repo_folder_locations { |
|
append menu_message "<unavailable not writable> $readonly" \n |
|
} |
|
append menu_message "--------------------------------------------------" \n |
|
} |
|
|
|
#see if we can reasonably use the only available option and not bug the user |
|
#Todo - option to always prompt? |
|
#we will not auto-select if there is even one conflicted_option - as that seems like something you should know about |
|
if {![llength $conflicted_options] && ([llength $choice_folders] == 1)} { |
|
set repo_folder_choice [lindex $choice_folders 0] |
|
set repository_folder [dict get $repo_folder_choice folder] |
|
} else { |
|
if {[llength $choice_folders]} { |
|
puts stdout $menu_message |
|
set max [llength $choice_folders] |
|
if {$max == 1} { |
|
set rangemsg "the number 1" |
|
} else { |
|
set rangemsg "a number from 1 to $max" |
|
} |
|
set answer [askuser "Enter $rangemsg to select location. (or N to abort)"] |
|
if {![string is integer -strict $answer]} { |
|
puts stderr "Aborting" |
|
return |
|
} |
|
|
|
set index [expr {int($answer) -1}] |
|
if {$index >= 0 && $index <= $max-1} { |
|
set repo_folder_choice [lindex $choice_folders $index] |
|
set repository_folder [dict get $repo_folder_choice folder] |
|
puts stdout "Selected fossil location $repository_folder" |
|
} else { |
|
puts stderr " No menu number matched - aborting." |
|
return |
|
} |
|
} else { |
|
puts stdout $menu_message |
|
set answer [askuser "Hit enter to exit"] |
|
return |
|
} |
|
} |
|
return $repository_folder |
|
} |
|
|
|
#------------------------------------ |
|
#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 $info] |
|
} else { |
|
return Unknown |
|
} |
|
} |
|
#------------------------------------ |
|
|
|
#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] |
|
} |
|
|
|
|
|
#todo - review |
|
proc ensure-cleanup {path} { |
|
#::atexit [lambda {path} { |
|
#file delete -force $path |
|
#} [norm $path]] |
|
|
|
file delete -force $path |
|
} |
|
|
|
|
|
#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} { |
|
error "unimplmented" |
|
} |
|
|
|
#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) |
|
} |
|
|
|
#No - don't do this sort of path translation here - leave as option for specific utils only such as ./ |
|
#Windows volume-relative syntax with specific volume specified is somewhat broken in Tcl - but leading slash volume-relative does work |
|
#We shouldn't break it totally just because accessing WSL/mingw paths is slightly more useful |
|
#if {$platform eq "windows"} { |
|
#return [file dirname [file normalize [punk::unixywindows::towinpath $path]/__]] |
|
#} |
|
|
|
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} { |
|
if {$prefix eq ""} { |
|
return [norm $path] |
|
} |
|
return [file join \ |
|
{*}[lrange \ |
|
[file split [norm $path]] \ |
|
[llength [file split [norm $prefix]]] \ |
|
end]] |
|
} |
|
|
|
#Must accept empty prefix - which is effectively noop. |
|
#MUCH faster version for absolute path prefix (pre-normalized) |
|
proc path_strip_alreadynormalized_prefixdepth {path prefix} { |
|
if {$prefix eq ""} { |
|
return $path |
|
} |
|
return [file join \ |
|
{*}[lrange \ |
|
[file split $path] \ |
|
[llength [file split $prefix]] \ |
|
end]] |
|
} |
|
#fs agnostic - so file normalize must be done by caller |
|
proc strip_if_prefix {prefix path args} { |
|
set known_opts [list -nocase] |
|
set opts [list] |
|
foreach a $args { |
|
lappend opts [tcl::prefix match -message "option" $known_opts $a] |
|
} |
|
if {"-nocase" in $opts} { |
|
set lp [tcl::prefix longest [string tolower $path] [string tolower $prefix]] |
|
} else { |
|
set lp [tcl::prefix longest $path $prefix] |
|
} |
|
#return in original casing whether or not -nocase specified. -nocase only applies to the comparison |
|
if {![llength $lp]} { |
|
return $path |
|
} else { |
|
return [string range $path [string length $prefix] end] |
|
} |
|
} |
|
|
|
|
|
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.1 |
|
}] |
|
return
|
|
|