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.
1698 lines
76 KiB
1698 lines
76 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 |
|
# |
|
|
|
#REVIEW punk::repo required early by punk boot script to find projectdir |
|
#todo - split off basic find_project chain of functions to a smaller package and import as necessary here |
|
#Then we can reduce early dependencies in punk boot |
|
|
|
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 { |
|
variable PUNKARGS |
|
variable PUNKARGS_aliases |
|
|
|
proc get_fossil_usage {} { |
|
set allcmds [runout -n fossil help -a] |
|
set mainhelp [runout -n fossil help] |
|
set maincommands [list] |
|
foreach ln [split $mainhelp \n] { |
|
set ln [string trim $ln] |
|
if {$ln eq "" || [regexp {^[A-Z]+} $ln]} { |
|
continue |
|
} |
|
lappend maincommands {*}$ln |
|
} |
|
set othercmds [punk::lib::ldiff $allcmds $maincommands] |
|
|
|
set result "@leaders -min 0\n" |
|
|
|
append result [tstr -return string { |
|
subcommand -type string -choicecolumns 8 -choicegroups { |
|
"frequently used commands" {${$maincommands}} |
|
"" {${$othercmds}} |
|
} |
|
}] |
|
|
|
return $result |
|
} |
|
|
|
|
|
#lappend PUNKARGS [list -dynamic 1 { |
|
# @id -id ::punk::repo::fossil_proxy |
|
# @cmd -name fossil -help "fossil executable |
|
# " |
|
# @argdisplay -header "fossil help" -body {${[runout -n fossil help]}} |
|
# } ""] |
|
|
|
lappend PUNKARGS [list -dynamic 1 { |
|
@id -id ::punk::repo::fossil_proxy |
|
@cmd -name fossil -help "fossil executable" |
|
${[punk::repo::get_fossil_usage]} |
|
} ] |
|
|
|
|
|
|
|
#experiment |
|
lappend PUNKARGS [list -dynamic 1 { |
|
@id -id "::punk::repo::fossil_proxy diff" |
|
@cmd -name "fossil diff" -help "fossil diff |
|
" |
|
@argdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}} |
|
} ""] |
|
lappend PUNKARGS [list -dynamic 1 { |
|
@id -id "::punk::repo::fossil_proxy add" |
|
@cmd -name "fossil add" -help "fossil add |
|
" |
|
@argdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} |
|
} ""] |
|
#TODO |
|
#lappend PUNKARGS [list -dynamic 1 { |
|
# @id -glob 1 -id "::punk::repo::fossil_proxy *" -aliases {fs} |
|
# @cmd -name "fossil add" -help "fossil add |
|
# " |
|
# @argdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} |
|
# } ""] |
|
lappend PUNKARGS_aliases {"::fossil" "::punk::repo::fossil_proxy"} |
|
lappend PUNKARGS_aliases {"::fossil diff" "::punk::repo::fossil_proxy diff"} |
|
|
|
|
|
#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" |
|
} |
|
} |
|
|
|
|
|
# --- |
|
# Calling auto_execok on an external tool can be too slow to do during package load (e.g could be 150ms) |
|
|
|
#safe interps can't call auto_execok |
|
#At least let them load the package even though much of it may be unusable depending on the safe configuration |
|
#catch { |
|
# if {[auto_execok fossil] ne ""} { |
|
# interp alias "" FOSSIL "" {*}[auto_execok fossil] |
|
# } |
|
#} |
|
# --- |
|
# ---------- |
|
# |
|
|
|
|
|
#uppercase FOSSIL to bypass fossil as alias to fossil_proxy |
|
proc establish_FOSSIL {args} { |
|
if {![info exists ::auto_execs(FOSSIL)]} { |
|
set ::auto_execs(FOSSIL) [auto_execok fossil] ;#may fail in safe interp |
|
} |
|
interp alias "" FOSSIL "" ;#delete establishment alias |
|
FOSSIL {*}$args |
|
} |
|
# ---------- |
|
|
|
proc askuser {question} { |
|
if {![catch {package require punk::lib}]} { |
|
return [punk::lib::askuser $question] ;#takes account of punk::console raw vs line |
|
} |
|
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 src/modules|src/scriptapps|src/*/*.vfs - and that it's otherwise sensible |
|
#we still run a high chance of picking up unintended candidates - but hopefully it's a reasonable balance. |
|
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 |
|
} |
|
#we're not pickup all possible unwise paths - mainly ones that are likely to be above us, or some that are probably just really bad ideas. |
|
set unwise_paths [list "/" "/dev" "/bin" "/root" "/etc" "/opt" "/usr" "/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 *] |
|
#test for $path/src/lib is too common to be a useful indicator |
|
if {"modules" 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 |
|
#REVIEW - if closest repo is both fossil and git - we only return info for one, with fossil being preferenced |
|
#This may not make sense if we want to allow fossil tracking of projects where git is the primary repotype and fossil is just used to enable us to enumerate projects? |
|
#does a dual git/fossil repo make sense if both are committing?? |
|
# see: https://fossil-scm.org/home/doc/trunk/www/inout.wiki for bidirectional sync info |
|
proc workingdir_state {{abspath {}} args} { |
|
|
|
#we should try to minimize executable calls |
|
#an extra git/fossil executable call required for tags |
|
#git seems to require more executable calls |
|
|
|
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) || ![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 ""} { |
|
puts stderr "workingdir_state error: No repository found at or above path '$abspath'" |
|
puts stderr "args: $args" |
|
dict set resultdict revision {} |
|
dict set resultdict revision_iso8601 {} |
|
dict set resultdict paths {} |
|
dict set resultdict ahead "" |
|
dict set resultdict behind "" |
|
dict set resultdict error {reason "no_repo_found"} |
|
dict set resultdict repotype none |
|
return $resultdict |
|
} |
|
set subpath [punk::path::relative $repodir $abspath] |
|
if {$subpath eq "."} { |
|
set subpath "" |
|
} |
|
|
|
set resultdict [dict create repodir $repodir subpath $subpath] |
|
#set defaults in case no supported repotype found |
|
set revision "" |
|
set revision_iso8601 "" |
|
set pathdict [dict create] |
|
set branch "" |
|
set tags "" |
|
|
|
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... Y-m-d H:M:S TZ |
|
set checkout_info [lindex [grep {checkout:*} $fossilstate] 0] ;#grep returns a list - but it should always be a single match in this case |
|
set revision [lindex $checkout_info 0 1] |
|
#set checkrevision [fossil_revision $abspath] |
|
lassign $checkout_info _key revision revision_ymd revision_hms revision_tz |
|
if {$revision_tz eq "UTC"} { |
|
set revision_tz "+0000" ;#normalize UTC for consistency with git tz output - review - should do date-math if necessary on git and fossil to bring all to +0000 (is fossil always UTC? git ) |
|
} |
|
set revision_iso8601 "${revision_ymd}T${revision_hms}${revision_tz}" |
|
|
|
#REVIEW! what are the semantic difference between tags in fossil v git? |
|
#fossil has tagtypes such as propagated and singleton(onetime) |
|
#if we get all tag info for the revision - we can get the current branch (branch=somename tag) at the same time |
|
#by retrieving with --raw - we have to process some prefixes such as sym- but probably best not done here |
|
#we will return all tags that apply to the current revision and let the caller decide the meanings |
|
if {![catch {punk::mix::util::do_in_path $repodir [list exec {*}$fossil_cmd tag ls --raw $revision]} cmdresult]} { |
|
set branchinfo [lindex [grep {branch=*} $cmdresult] 0] ;#first line match - should only be one |
|
set branch [lindex [split $branchinfo =] 1] |
|
set tags [list] |
|
foreach ln [split $cmdresult \n] { |
|
if {[string trim $ln] eq ""} { |
|
continue |
|
} |
|
lappend tags [string trim $ln] |
|
} |
|
} |
|
|
|
#set tags_info [lindex [grep {tags:*} $fossilstate 0] ;#first line match - should only be one |
|
#we get lines like: |
|
#tags: trunk, main |
|
#tags: trunk |
|
#set rawtags [lrange $tags_info 1 end] ;#REVIEW |
|
#set tags [list] |
|
#foreach t $rawtags { |
|
# lappend tags [string trimright $t ,] |
|
#} |
|
|
|
|
|
#if {![catch {punk::mix::util::do_in_path $repodir [list exec {*}$fossil_cmd branch current]} cmdresult]} { |
|
# set branch $cmdresult ;#command result doesn't include newline etc |
|
#} |
|
|
|
|
|
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 |
|
} |
|
} |
|
switch -glob -- $ln { |
|
"EDITED *" { |
|
set path [string trim [string range $ln [string length "EDITED "] end]] ;#should handle spaced paths |
|
dict set pathdict $path "changed" |
|
} |
|
"ADDED *" { |
|
set path [string trim [string range $ln [string length "ADDED "] end]] |
|
dict set pathdict $path "new" |
|
} |
|
"DELETED *" { |
|
set path [string trim [string range $ln [string length "DELETED "] end]] |
|
dict set pathdict $path "missing" |
|
} |
|
"MISSING *" { |
|
set path [string trim [string range $ln [string length "MISSING "] end]] |
|
dict set pathdict $path "missing" |
|
} |
|
"EXTRA *" { |
|
#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" |
|
} |
|
"UNCHANGED *" { |
|
set path [string trim [string range $ln [string length "UNCHANGED "] end]] |
|
dict set pathdict $path "unchanged" |
|
} |
|
default { |
|
#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 |
|
#our basic parsing/grepping assumes --porcelain=2 |
|
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 |
|
} |
|
# line: # branch.head somebranchname |
|
set branch [lindex [grep {# branch.head *} $gitstate] 0 2] |
|
|
|
if {![catch {punk::mix::util::do_in_path $repodir [list exec {*}$git_cmd describe --exact-match --tags]} cmdresult]} { |
|
set tags $cmdresult ;#review - we have short tags vs longer.. e.g v0.1a vs v0.1a-184-g856fab4 - which is returned? Also how are multiple separated? |
|
} |
|
#often there will be no tag - so the common case is actually an error "fatal: not ag exactly matchs 'xxxx...'" |
|
|
|
# -- --- --- --- --- |
|
#could use %ci for ISO8601 data - see git-show manpage, but this will be in timezone of developer's machine - we need it in UTC for comparison to fossil outputs and other devs |
|
set had_TZ 0 |
|
if {[info exists ::env(TZ)]} { |
|
set TZ_prev $::env(TZ) |
|
set had_TZ 1 |
|
} |
|
set ::env(TZ) "UTC0" |
|
if {[catch {punk::mix::util::do_in_path $repodir [list exec {*}$git_cmd show -s --date=format-local:%Y:%m:%dT%H:%M:%S+0000 --format=format:%cd -- $abspath]} revision_iso8601]} { |
|
puts stderr "workingdir_state warning: Unable to retrieve workingdir state using git. Errormsg: $gitstate" |
|
} |
|
if {$had_TZ} { |
|
set ::env(TZ) $TZ_prev |
|
} else { |
|
unset ::env(TZ) |
|
} |
|
# -- --- --- --- --- |
|
|
|
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 branch $branch |
|
dict set resultdict tags $tags |
|
dict set resultdict revision $revision |
|
dict set resultdict revision_iso8601 $revision_iso8601 |
|
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 |
|
|
|
#the revision branch and tags are highly relevant to the file state - and workingdir_state currently retrieves them anyway |
|
# - so we'll include them in the defaults |
|
# - when we are including working dir state as part of other output - we could be duplicating branch/tag retrievals |
|
# - todo - flags to stop duplicating effort ?? |
|
set defaults [dict create\ |
|
-fields {revision branch tags 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\ |
|
revision_iso8601 revision_iso8601\ |
|
branch branch\ |
|
tags tags\ |
|
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 [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 |
|
} |
|
|
|
#todo - describe purpose and possibly rename |
|
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 revision_iso8601 branch tags] |
|
set dresult [dict create] |
|
if {[dict exists $repostate error]} { |
|
foreach f $state_fields { |
|
dict set dresult $f "" |
|
} |
|
foreach f $path_count_fields { |
|
dict set dresult $f "" |
|
} |
|
#todo? |
|
return $dresult |
|
} |
|
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] {lib::strlen $v}]] |
|
set col1 [string repeat " " $widest1] |
|
set title2 "Repo-type(s)" |
|
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {string length $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 opts [list\ |
|
-parentfolder \uFFFF\ |
|
-extrachoices \uFFFF\ |
|
-askpath 0\ |
|
-ansi \uFFFF\ |
|
-ansi_prompt \uFFFF\ |
|
-ansi_warning \uFFFF\ |
|
] |
|
if {[llength $args] % 2 != 0} { |
|
error "fossil_get_repository_folder requires args to be option-value pairs. Received '$args'" |
|
} |
|
foreach {k v} $args { |
|
switch -- $k { |
|
-parentfolder - -extrachoices - -askpath - -ansi - -ansi_prompt - -ansi_warning { |
|
dict set opts $k $v |
|
} |
|
default { |
|
error "fossil_get_repository_folder unrecognised option $k. Known options: [dict keys $opts]" |
|
} |
|
} |
|
} |
|
# -- --- --- --- --- --- |
|
set opt_parentfolder [dict get $opts -parentfolder] |
|
if {$opt_parentfolder eq "\uFFFF"} { |
|
set opt_parentfolder [pwd] |
|
} |
|
# -- --- --- --- --- --- |
|
set opt_extrachoices [dict get $opts -extrachoices] |
|
set extrachoices [list] |
|
if {$opt_extrachoices ne "\uFFFF"} { |
|
set extrachoices $opt_extrachoices |
|
} |
|
# -- --- --- --- --- --- |
|
set opt_askpath [dict get $opts -askpath] |
|
# -- --- --- --- --- --- |
|
set opt_ansi [dict get $opts -ansi] |
|
set opt_ansi_prompt [dict get $opts -ansi_prompt] |
|
set opt_ansi_warning [dict get $opts -ansi_warning] |
|
if {$opt_ansi eq "\uFFFF"} { |
|
set opt_ansi 1 |
|
} |
|
if {$opt_ansi} { |
|
if {$opt_ansi_prompt eq "\uFFFF"} { |
|
set ansiprompt [a+ green bold] |
|
} else { |
|
set ansiprompt [$opt_ansi_prompt] |
|
} |
|
if {$opt_ansi_warning eq "\uFFFF"} { |
|
set ansiwarn [a+ red bold] |
|
} else { |
|
set ansiwarn [$opt_ansi_warning] |
|
} |
|
set ansireset [a] |
|
} else { |
|
set ansiprompt "" |
|
set ansiwarn "" |
|
set ansireset "" |
|
} |
|
# -- --- --- --- --- --- |
|
|
|
set startdir $opt_parentfolder |
|
|
|
set fossil_prog [auto_execok fossil] |
|
if {$fossil_prog eq ""} { |
|
puts stderr "Fossil not found. Please install fossil" |
|
return |
|
} |
|
|
|
set config_db_path [fossil_get_configdb] |
|
|
|
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 {[llength $extrachoices]} { |
|
foreach tp $extrachoices { |
|
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 "${ansiwarn}CONFLICT - $projectname.fossil already exists in this folder${ansireset}" |
|
} 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 "${ansiprompt}Select the number of the folder to use to store the .fossil repository file${ansireset}" \n |
|
} else { |
|
append menu_message "${ansiwarn}--- NO suitable writable folders or locations found for .fossil file. Consider setting FOSSIL_HOME environment variable and check that folders are writable.--${ansireset}" \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 "${ansiwarn}<unavailable not writable> $readonly${ansireset}" \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) && !$opt_askpath} { |
|
set repo_folder_choice [lindex $choice_folders 0] |
|
set repository_folder [dict get $repo_folder_choice folder] |
|
} else { |
|
if {[llength $choice_folders] || $opt_askpath} { |
|
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 menuprompt "${ansiprompt}Enter $rangemsg to select location. (or N to abort)${ansireset}" |
|
if {$opt_askpath} { |
|
set askpathprompt "${ansiprompt}Enter the word: path followed by an absolute path to a folder if you would like to manually enter a folder${ansireset}" |
|
append menuprompt \n $askpathprompt |
|
} |
|
set answer [askuser $menuprompt] |
|
if {$opt_askpath && [string match "path*" [string tolower $answer]]} { |
|
set is_done 0 |
|
set repository_folder [string trim [string range $answer 4 end]] |
|
while {!$is_done} { |
|
|
|
if {![file isdirectory $repository_folder]} { |
|
puts stderr "${ansiwarn}Sorry - unable to find entered location '$repository_folder'${ansireset}" |
|
if {[file isdirectory [file dirname $repository_folder]]} { |
|
set answer [askuser "${ansiprompt}Do you want to create this folder? Type just the word mkdir to create it, or N for no${ansireset}"] |
|
if {[string equal mkdir [string tolower $answer]]} { |
|
if {[catch {file mkdir $repository_folder} errM]} { |
|
puts stderr "Failed to create folder $repository_folder. Error $errM" |
|
} |
|
} |
|
} else { |
|
puts stderr "${ansiwarn}Not offering to create directory because parent folder not found${ansireset}" |
|
} |
|
} |
|
|
|
if {![file isdirectory $repository_folder]} { |
|
set answer [askuser "${ansiprompt}Try again? (Y|N)${ansireset}"] |
|
if {[string match y* [string tolower $answer]]} { |
|
set answer [askuser $askpathprompt] |
|
if {[string match "path*" [string tolower $answer]]} { |
|
set repository_folder [string trim [string range $answer 4 end]] |
|
} else { |
|
puts stderr "Answer didn't begin with the word path" |
|
set is_done 1 |
|
} |
|
} else { |
|
set is_done 1 |
|
} |
|
} else { |
|
set is_done 1 |
|
} |
|
} |
|
if {$is_done && ![file isdirectory $repository_folder]} { |
|
puts stderr "Aborting" |
|
return |
|
} |
|
} else { |
|
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 "${ansiprompt}Hit enter to exit${ansireset}"] |
|
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 |
|
} |
|
} |
|
proc fossil_get_configdb {{path {}}} { |
|
#fossil info will *usually* give us the necessary config-db info whether in a project folder or not but.. |
|
#a) It's expensive to shell-out and call it |
|
#b) it won't give us a result if we are in a checkout folder which has had its repository moved |
|
#this fairly extensive mechanism is designed to find it even if the environment has some weird goings-on regarding the filesystem/environment variables |
|
#This is unlikely to be necessary in most scenarios, where the location is related to the user's home directory |
|
|
|
#attempt 1 - environment vars and well-known locations |
|
#This is first because it's faster - but hopefully it's aligned with how fossil does it |
|
|
|
if {"windows" eq $::tcl_platform(platform)} { |
|
foreach varname [list FOSSIL_HOME LOCALAPPDATA APPDATA USERPROFILES] { |
|
if {[info exists ::env($varname)]} { |
|
set testfile [file join $::env($varname) _fossil] |
|
if {[file exists $testfile]} { |
|
return $testfile |
|
} |
|
} |
|
} |
|
if {[info exists ::env(HOMEDRIVE)] && [info exists ::env(HOMEPATH)]} { |
|
set testfile $::env(HOMEDRIVE)$::env(HOMEPATH)\\_fossil" |
|
if {[file exists $testfile]} { |
|
return $testfile |
|
} |
|
} |
|
} else { |
|
foreach varname [list FOSSIL_HOME HOME ] { |
|
if {[info exists ::env($varname)]} { |
|
set testfile [file join $::env($varname) .fossil] |
|
if {[file exists $testfile]} { |
|
return $testfile |
|
} |
|
} |
|
} |
|
if {[info exists ::env(XDG_CONFIG_HOME)]} { |
|
set testfile [file join $::env(XDG_CONFIG_HOME) fossil.db] |
|
if {[file exists $testfile]} { |
|
return $testfile |
|
} |
|
set testfile [file join $::env(XDG_CONFIG_HOME) .config fossil.db] |
|
if {[file exists $testfile]} { |
|
return $testfile |
|
} |
|
} |
|
if {[info exists ::env(HOME)]} { |
|
set testfile [file join $::env(HOME) .config fossil.db] |
|
if {[file exists $testfile]} { |
|
return $testfile |
|
} |
|
} |
|
} |
|
|
|
|
|
set original_cwd [pwd] |
|
#attempt2 - let fossil do it for us - hopefully based on current folder |
|
if {$path eq {}} {set path [pwd]} |
|
set fossilcmd [auto_execok fossil] |
|
if {![llength $fossilcmd]} { |
|
set fossil_ok 0 |
|
} else { |
|
set fossil_ok 1 |
|
} |
|
try { |
|
while {$fossil_ok} { |
|
cd $path |
|
if {[catch {exec {*}$fossilcmd info} fossilinfo]} { |
|
#a detached repo above us can result in an error from fossil info |
|
set next [file dirname $path] |
|
} else { |
|
set matching_lines [punk::repo::grep {config-db:*} $fossilinfo] |
|
if {[llength $matching_lines] == 1} { |
|
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]} { |
|
return $config_db_path |
|
} |
|
} |
|
set next [file dirname $path] |
|
} |
|
|
|
if {$next eq $path || $next eq ""} { |
|
break |
|
} |
|
set path $next |
|
} |
|
} on error {errmsg options} { |
|
#puts "errmsg:$errmgs options:$options" |
|
} finally { |
|
cd $original_cwd |
|
} |
|
|
|
#attempt 3 - getting desperate.. find other repos, determine their checkouts and run fossil in them to get a result |
|
if {$fossil_ok} { |
|
#It should be extremely rare to need to resort to sqlite on the databases to find other potential repo paths |
|
#Conceivably only on some weird VFS or where some other filesystem strangeness is going on with our original path - or if the root volume itself is a broken fossil checkout |
|
#Examining the other repos gives us a chance at discovering some other filesystem/paths where things may not be broken |
|
if {![catch {package require sqlite3} errPackage]} { |
|
#use fossil all ls and sqlite |
|
if {[catch {exec {*}$fossilcmd all ls} repolines]} { |
|
error "fossil_get_configdb cannot find repositories" |
|
} else { |
|
set repolines [string map {\r\n \n} $repolines] |
|
set repolist [split $repolines \n] |
|
set dbcmd "fossil_get_configdb_tempdb" |
|
foreach repodb $repolist { |
|
catch {rename $dbcmd ""} |
|
if {[file exists $repodb]} { |
|
if {![catch {sqlite3 $dbcmd $repodb}]} { |
|
set ckoutrecords [$dbcmd eval {select name from config where name like 'ckout:%'}] |
|
catch {$dbcmd close} |
|
foreach ck $ckoutrecords { |
|
set ckfolder [string range $ck 6 end] |
|
#puts stdout "ckfolder $ckfolder" |
|
if {[file isdirectory $ckfolder]} { |
|
set result "" |
|
do_in_path $ckfolder { |
|
if {![catch {exec {*}$fossilcmd info} fossilinfo]} { |
|
set matching_lines [punk::repo::grep {config-db:*} $fossilinfo] |
|
if {[llength $matching_lines] == 1} { |
|
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]} { |
|
set result $config_db_path |
|
} |
|
} |
|
} |
|
} |
|
if {$result ne ""} { |
|
return $result |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
error "fossil_get_configdb exhausted search options" |
|
} |
|
#------------------------------------ |
|
|
|
#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 {\r\n \n} $data] |
|
return [lsearch -all -inline -glob [split $data \n] $pattern] |
|
} |
|
|
|
proc rgrep {pattern data} { |
|
set data [string map {\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) |
|
#review - will error on file join if lrange returns empty list ie if prefix longer than path |
|
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 "" fossil "" punk::repo::fossil_proxy |
|
interp alias "" FOSSIL "" punk::repo::establish_FOSSIL |
|
|
|
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 {} shellrun::runconsole git status -sb |
|
interp alias {} gr {} ::punk::repo::git_revision |
|
interp alias {} gl {} shellrun::runconsole git log --oneline --decorate ;#decorate so stdout consistent with what we see on console |
|
interp alias {} glast {} shellrun::runconsole git log -1 HEAD --stat |
|
interp alias {} gconf {} shellrun::runconsole git config --global -l |
|
|
|
} |
|
namespace eval punk::repo::lib { |
|
#----------------------------------------------------------------------------------- |
|
#strlen is important for testing issues with string representationa and shimmering. |
|
#This specific implementation with append (as at 2023-09) is designed to ensure the original str representation isn't changed |
|
#It may need to be reviewed with different Tcl versions in case the append empty string is 'optimised/tuned' in some way that affects the behaviour |
|
#The use of this function instead of string length can make a difference in certain circumstances with 'path' object representations |
|
proc strlen {str} { |
|
append str2 $str {} |
|
string length $str2 |
|
} |
|
#----------------------------------------------------------------------------------- |
|
|
|
} |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
if {![info exists ::punk::args::register::NAMESPACES]} { |
|
namespace eval ::punk::args::register { |
|
set ::punk::args::register::NAMESPACES [list] ;#use fully qualified so 8.6 doesn't find existing var in global namespace |
|
} |
|
} |
|
lappend ::punk::args::register::NAMESPACES ::punk::repo |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Ready |
|
package provide punk::repo [namespace eval punk::repo { |
|
variable version |
|
set version 0.1.1 |
|
}] |
|
return
|
|
|