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.
464 lines
24 KiB
464 lines
24 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. |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# (C) 2023 |
|
# |
|
# @@ Meta Begin |
|
# Application punk::mix::commandset::repo 999999.0a1.0 |
|
# Meta platform tcl |
|
# Meta license <unspecified> |
|
# @@ Meta End |
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Requirements |
|
##e.g package require frobz |
|
|
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
namespace eval punk::mix::commandset::repo { |
|
namespace export * |
|
|
|
variable PUNKARGS |
|
|
|
proc tickets {{project ""}} { |
|
#todo |
|
set result "" |
|
if {[string length $project]} { |
|
puts stderr "project status unimplemented" |
|
return |
|
} |
|
set active_dir [pwd] |
|
append result "Retrieving top 10 tickets only (for more, use fossil timeline -n <int> -t t)" \n |
|
append result [exec fossil timeline -n 10 -t t] |
|
|
|
return $result |
|
} |
|
|
|
lappend PUNKARGS [list { |
|
@id -id ::punk::mix::commandset::repo::fossilize |
|
@cmd -name punk::mix::commandset::repo::fossilize |
|
-summary\ |
|
"Initialise and check in a project to fossil (unimplemented)."\ |
|
-help\ |
|
"(unimplemented)" |
|
}] |
|
proc fossilize { args} { |
|
#check if project already managed by fossil.. initialise and check in if not. |
|
puts stderr "unimplemented" |
|
} |
|
|
|
lappend PUNKARGS [list { |
|
@id -id ::punk::mix::commandset::repo::unfossilize |
|
@cmd -name punk::mix::commandset::repo::unfossilize |
|
-summary\ |
|
"Remove/archive .fossil (unimplemented)."\ |
|
-help\ |
|
"(unimplemented)" |
|
}] |
|
proc unfossilize {projectname args} { |
|
#remove/archive .fossil |
|
puts stderr "unimplemented" |
|
} |
|
proc state {} { |
|
set result "" |
|
set repopaths [punk::repo::find_repos [pwd]] |
|
set repos [dict get $repopaths repos] |
|
if {![llength $repos]} { |
|
append result [a+ bold yellow][dict get $repopaths warnings][a] |
|
} else { |
|
append result [a+ bold yellow][dict get $repopaths warnings][a] |
|
lassign [lindex $repos 0] repopath repotypes |
|
if {"fossil" in $repotypes} { |
|
append result \n "Fossil repo based at $repopath" |
|
set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes fossil] |
|
append result \n [punk::repo::workingdir_state_summary $repostate] |
|
} |
|
if {"git" in $repotypes} { |
|
append result \n "Git repo based at $repopath" |
|
set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes git] |
|
append result \n [punk::repo::workingdir_state_summary $repostate] |
|
} |
|
} |
|
return $result |
|
} |
|
|
|
#punk::args |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::mix::commandset::repo::fossil-move-repository |
|
@cmd -name punk::mix::commandset::repo::fossil-move-repository |
|
-summary\ |
|
"Move a fossil repository database file."\ |
|
-help\ |
|
"Move the fossil repository file (usually named with .fossil extension). |
|
This is an interactive function which will prompt for answers on stdin |
|
before proceeding. |
|
The move can be done even if there are open checkouts and will maintain |
|
the link between checkout databases and the repository file. |
|
|
|
The call can be made from within a folder containing fossil databases, |
|
or from within one of the checkouts of the fossil database that is to |
|
be moved. |
|
" |
|
|
|
#todo? |
|
#@values -min 0 -max 1 |
|
#path |
|
}] |
|
proc fossil-move-repository {{path ""}} { |
|
#path unused for now - todo - allow calling with a specific target rather than relying on cwd? |
|
set searchbase [pwd] |
|
set projectinfo [punk::repo::find_repos $searchbase] |
|
set projectbase [dict get $projectinfo closest] |
|
set is_fossil [expr {"fossil" in [dict get $projectinfo closest_types]}] |
|
if {[catch { |
|
package require sqlite3 |
|
} errM]} { |
|
puts stderr "sqlite3 package failed to load" |
|
puts stderr "Try using 'fossil test-move-repository <targetpath>' from within an open checkout folder, or ensure that the Tcl sqlite3 package is available." |
|
return |
|
} |
|
set ansiprompt [a+ green bold] |
|
set ansiwarn [a+ red bold] |
|
set ansihighlight [a+ cyan bold] |
|
set ansireset [a] |
|
|
|
set in_checkout 0 |
|
set is_checkout_relink 0; #whether we are attempting to link a checkout that has lost its repo |
|
#we may also encounter a different kind of relink candidate - other checkouts of the same repo that we examine and find don't point back. |
|
if {$projectbase eq "" || !$is_fossil} { |
|
set repodbs [glob -dir $searchbase -type f -tail *.fossil] |
|
if {![llength $repodbs]} { |
|
puts stderr "Current directory does not seem to be directly below a fossil checkout, and no .fossil files found" |
|
puts stderr "Please move to a folder containing the .fossil repository database to move, or to a folder directly within a fossil checkout (and with no intermediate git/fossil repos)" |
|
return |
|
} |
|
set choice_files [list] |
|
set i 1 |
|
set menu_message "" |
|
append menu_message "${ansiprompt}Select the number of the fossil repo db to potentially move (confirmation will be requested before any action is taken)${ansireset}" \n |
|
foreach db $repodbs { |
|
sqlite3 dbinfo [file join $searchbase $db] |
|
set ckouts [dbinfo eval {select name from config where name like 'ckout:%'}] |
|
dbinfo close |
|
lappend choice_files [list index $i repofile $db checkouts [llength $ckouts]] |
|
append menu_message "$i $db checkouts: [llength $ckouts]" \n |
|
incr i |
|
} |
|
puts stdout $menu_message |
|
set max [llength $choice_files] |
|
if {$max == 1} { |
|
set rangemsg "the number 1" |
|
} else { |
|
set rangemsg "a number from 1 to $max" |
|
} |
|
set answer [punk::repo::askuser "${ansiprompt}Enter $rangemsg to select a .fossil repository database to show details and potentially move. (or N to abort)${ansireset}"] |
|
if {![string is integer -strict $answer]} { |
|
puts stderr "Aborting" |
|
return |
|
} |
|
|
|
set index [expr {int($answer) -1}] |
|
if {$index >= 0 && $index <= $max-1} { |
|
set repo_file_choice [lindex $choice_files $index] |
|
set repo_file [dict get $repo_file_choice repofile] |
|
set repo_file [file join $searchbase $repo_file] |
|
puts stdout "Selected fossil repo database file: $repo_file" |
|
} else { |
|
puts stderr " No menu number matched - aborting." |
|
return |
|
} |
|
} else { |
|
if {[file exists $projectbase/_FOSSIL_]} { |
|
set cdbfile [file join $projectbase/_FOSSIL_] |
|
} elseif {[file exists $projectbase/.fslckout]} { |
|
set cdbfile [file join $projectbase/.fslckout] |
|
} else { |
|
puts stderr "No checkout database (_FOSSIL_ or .fslckout) found in nearest repository folder $projectbase (looked upwards from $searchbase)" |
|
puts stderr "Unable to locate repository databases for potential move. Please move to a checkout folder or a folder containing .fossil repositories" |
|
puts stderr "If run from a location where repositories are found, fossil-move-repository will give you the option to select a repository or cancel the operation" |
|
return |
|
} |
|
set in_checkout 1 |
|
sqlite3 cdb $cdbfile |
|
set repo_file [cdb eval {select value from vvar where name='repository'}] |
|
cdb close |
|
if {[string length [string trim $repo_file]] && [file pathtype $repo_file] eq "relative"} { |
|
set repo_file [file join $projectbase $repo_file] |
|
} |
|
if {![string length [string trim $repo_file]] || ![file exists $repo_file]} { |
|
puts stderr "${ansiwarn}Checkout at $projectbase points to repository '$repo_file' - but it doesn't seem to exist${ansireset}" |
|
set answer [punk::repo::askuser "${ansiprompt}Do you want to link this to an existing repository file? (Y|N)${ansireset}"] |
|
if {[string match y* [string tolower $answer]]} { |
|
set is_checkout_relink 1 |
|
} else { |
|
puts stderr "Aborting - Unable to link this checkout dir to a repository database file" |
|
return |
|
} |
|
} |
|
} |
|
|
|
set pname [file rootname [file tail $repo_file]] |
|
set full_path_repo_file [file join $searchbase $repo_file] |
|
if {[file isfile $full_path_repo_file]} { |
|
sqlite3 dbinfo [file join $searchbase $repo_file] |
|
set ckouts [dbinfo eval {select name from config where name like 'ckout:%'}] |
|
dbinfo close |
|
if {![llength $ckouts]} { |
|
puts stdout "Repository db at [file join $searchbase $repo_file] appears to have no open checkouts" |
|
} else { |
|
puts stdout "Repository db at [file join $searchbase $repo_file] appears to have [llength $ckouts] open checkouts:" |
|
foreach ck $ckouts { |
|
puts stdout [string range $ck 6 end] |
|
} |
|
} |
|
} else { |
|
puts stderr "${ansiwarn}Missing repository db at $full_path_repo_file${ansireset}" |
|
} |
|
puts stdout "${ansihighlight}Report for all projects with repository file name $pname${ansireset}" |
|
puts stdout [punk::mix::commandset::project::collection::detail $pname] |
|
puts stdout [punk::mix::commandset::project::collection::work $pname -detail 1] |
|
|
|
#todo |
|
#ask user if they want to select a different pname |
|
set wantrenameprompt "${ansiprompt}Would you like to rename the .fossil file? (Y|N)${ansireset}" |
|
append wantrenameprompt \n "${ansiprompt}.eg change $pname.fossil to something else such as ${pname}_new.fossil${ansireset}" |
|
set answer [punk::repo::askuser $wantrenameprompt] |
|
set pname2 $pname |
|
if {[string match y* [string tolower $answer]]} { |
|
set dorenameprompt "${ansiprompt}Enter the new name and hit enter. (Just an alphanumeric name (possibly with dots/dashes/underscores) without .fossil and without any path)${ansireset}" |
|
set namechoice [punk::repo::askuser $dorenameprompt] |
|
if {[string length $namechoice]} { |
|
set permittedmap [list . "" - "" _ ""] |
|
if {[string is alnum -strict [string map $permittedmap $namechoice]]} { |
|
set pname2 $namechoice |
|
} else { |
|
puts stderr "Entered name was invalid. Must be numbers,letters,underscore,dot,dash" |
|
} |
|
} |
|
puts stdout "Continuing with name $pname2 - cancel at next prompt if this is incorrect" |
|
} |
|
|
|
set target_repodb_folder [punk::repo::fossil_get_repository_folder_for_project $pname2 -parentfolder $searchbase -askpath 1] |
|
#target_repodb_folder might be same as source folder - check for same file if name wasn't changed? |
|
if {![string length $target_repodb_folder]} { |
|
puts stderr "No usable repository database folder selected for $pname2.fossil file" |
|
return |
|
} |
|
|
|
set existing_target_repofile 0 |
|
if {[file exists $target_repodb_folder/$pname2.fossil]} { |
|
set existing_target_repofile 1 |
|
puts stdout "${ansiwarn}NOTICE: $target_repodb_folder/$pname2.fossil already exists${ansireset}" |
|
if {!$is_checkout_relink} { |
|
set finalquestion "${ansiprompt}Are you sure you want to switch the repository $repo_file for the open checkout(s) to the existing file $target_repodb_folder/$pname2.fossil? (Y|N)${ansireset}" |
|
} else { |
|
set finalquestion "${ansiprompt}Are you sure you want to attempt to linke the repository (previously linked with '$repo_file') for the open checkout(s) to the existing file $target_repodb_folder/$pname2.fossil? (Y|N)${ansireset}" |
|
} |
|
} else { |
|
if {!$is_checkout_relink} { |
|
set finalquestion "${ansiprompt}Proceed to move repository $repo_file to the new file $target_repodb_folder/$pname2.fossil? Y|N${ansireset}" |
|
} else { |
|
set finalquestion "${ansiprompt}Proceed to attempt link for missing repo db $repo_file to the new file $target_repodb_folder/$pname2.fossil? Y|N${ansireset}" |
|
} |
|
} |
|
set line "${ansiwarn}[string repeat - [string length $finalquestion]]${ansireset}" |
|
set finalprompt $line\n |
|
append finalprompt $finalquestion \n |
|
append finalprompt $line \n |
|
|
|
set answer [punk::repo::askuser $finalprompt] |
|
if {[string match y* [string tolower $answer]]} { |
|
if {!$existing_target_repofile && !$is_checkout_relink} { |
|
if {[catch { |
|
file copy $repo_file $target_repodb_folder/$pname2.fossil |
|
} errM]} { |
|
puts stderr "${ansiwarn}FAILED to copy $repo_file to $target_repodb_folder/$pname2.fossil - aborting${ansireset}" |
|
puts stderr "Error message was:\n $errM" |
|
return |
|
} |
|
if {$in_checkout} { |
|
#in_checkout means we can assume projectbase var exists |
|
#there may be other checkouts on the old repo |
|
#if so, we will remind the user of their existence |
|
if {[catch {exec fossil test-move-repository $target_repodb_folder/$pname2.fossil} errM]} { |
|
puts stderr "${ansiwarn}The fossil test-move-repository command appears to have failed${ansireset}" |
|
puts stderr "$errM" |
|
} else { |
|
|
|
sqlite3 oldrepo $repo_file |
|
set ckouts [oldrepo eval {select name from config where name like 'ckout:%'}] |
|
set pcode [oldrepo eval {select value from config where name = 'project-code'}] |
|
oldrepo close |
|
if {[string length $pcode] < 20} { |
|
puts stderr "WARNING: Failed to get project-code from repo db $repo_file" |
|
} |
|
set other_checkouts [list] |
|
set norm_projectbase [file normalize $projectbase] |
|
foreach ck $ckouts { |
|
set ckfolder [string trim [string range $ck 6 end]] |
|
if {![file isdirectory $ckfolder]} { |
|
#as the process was launched within a checkout - we won't bother user with reports of non-existant other checkouts |
|
continue |
|
} |
|
if {[file normalize $ckfolder] ne $norm_projectbase} { |
|
lappend other_checkouts $ckfolder |
|
} |
|
} |
|
if {[llength $other_checkouts]} { |
|
puts stderr "${ansiwarn}Other checkouts of $repo_file that may need consideration${ansireset}" |
|
foreach other $other_checkouts { |
|
puts stdout $other |
|
} |
|
} |
|
} |
|
} else { |
|
#we aren't in a checkout - moving a repo to a new db location and/or name so there's no reason to prefer one checkout over another.. presumably the user either wants to move them all - or be asked.. |
|
sqlite3 oldrepo $repo_file |
|
set ckouts [oldrepo eval {select name from config where name like 'ckout:%'}] |
|
oldrepo close |
|
if {[llength $ckouts] > 1} { |
|
puts stdout "There are [llength $ckouts] checkouts for the repository you are moving" |
|
puts stdout "You will be asked for each checkout if you want to adjust it to point to $target_repodb_folder/$pname2.folder" |
|
} |
|
set original_cwd [pwd] |
|
foreach ck $ckouts { |
|
set ckfolder [string trim [string range $ck 6 end]] |
|
if {![file isdirectory $ckfolder]} { |
|
puts stderr "old repo shows a checkout at $ckfolder - but it doesn't seem to exist. Ignoring" |
|
continue |
|
} |
|
cd $ckfolder |
|
puts stdout [exec fossil info] |
|
puts stdout [state] |
|
set answer [punk::repo::askuser "${ansiprompt}Do you want to point this checkout to $target_repodb_folder/$pname2.folder? (Y|N) Q to stop processing checkouts${ansireset}"] |
|
if {[string match q* [string tolower $answer]]} { |
|
puts stderr "User aborting loop" |
|
break |
|
} |
|
if {[string match y* [string tolower $answer]]} { |
|
if {[catch {exec fossil test-move-repository $target_repodb_folder/$pname2.fossil} moveresult]} { |
|
puts stderr "${ansiwarn}The fossil test-move-repository command appears to have failed${ansireset}" |
|
puts stderr "$moveresult" |
|
} else { |
|
puts stdout "OK - move performed with result:" |
|
puts stdout $moveresult |
|
} |
|
} |
|
} |
|
cd $original_cwd |
|
|
|
} |
|
} else { |
|
if {$is_checkout_relink} { |
|
#relinking a lost checkout to an existing repo.. we should probably check it's other checkouts and see if they point back |
|
if {[catch {exec fossil test-move-repository $target_repodb_folder/$pname2.fossil} errM]} { |
|
puts stderr "${ansiwarn}The fossil test-move-repository command appears to have failed${ansireset}" |
|
puts stderr "$errM" |
|
} |
|
} else { |
|
if {$in_checkout} { |
|
if {[catch {exec fossil test-move-repository $target_repodb_folder/$pname2.fossil} errM]} { |
|
puts stderr "${ansiwarn}The fossil test-move-repository command appears to have failed${ansireset}" |
|
puts stderr "$errM" |
|
} |
|
} else { |
|
#not in checkout - we're wanting what pointed to one repo to point to a different existing one - presumably for all checkouts |
|
sqlite3 newrepo $target_repodb_folder/$pname2.fossil |
|
set newpname [newrepo eval {select value from config where name = 'project-name'}] |
|
set newpcode [newrepo eval {select value from config where name = 'project-code'}] |
|
set newckouts [newrepo eval {select name from config where name like 'ckout:%'}] |
|
newrepo close |
|
|
|
sqlite3 oldrepo $repo_file |
|
set oldpname [oldrepo eval {select value from config where name = 'project-name'}] |
|
set oldpcode [oldrepo eval {select value from config where name = 'project-code'}] |
|
set oldckouts [oldrepo eval {select name from config where name like 'ckout:%'}] |
|
oldrepo close |
|
if {$newpname eq $oldpname} { |
|
set ansi_newpname [a+ green bold]$newpname[a] |
|
set ansi_oldpname [a+ green bold]$oldpname[a] |
|
} else { |
|
set ansi_newpname [a+ cyan bold]$newpname[a] |
|
set ansi_oldpname [a+ red bold]$oldpname[a] |
|
} |
|
if {$newpcode eq $oldpcode} { |
|
set ansi_newpcode [a+ green bold]$newpcode[a] |
|
set ansi_oldpcode [a+ green bold]$oldpcode[a] |
|
} else { |
|
set ansi_newpcode [a+ cyan bold]$newpcode[a] |
|
set ansi_oldpcode [a+ red bold]$oldpcode[a] |
|
} |
|
puts stdout "Target repository $target_repodb_folder/$pname2.fossil has project-name: $ansi_newpname and [llength $newckouts] existing checkouts" |
|
puts stdout "Target project code: $ansi_newpcode" |
|
puts stdout "Source repository $repo_file has project-name: $ansi_oldpname and [llength $oldckouts] existing checkouts" |
|
puts stdout "Source project code: $ansi_oldpcode" |
|
if {[llength $oldckouts] > 1} { |
|
puts stdout "You will be asked for each checkout if you want to adjust it to point to $target_repodb_folder/$pname2.folder" |
|
} |
|
set original_cwd [pwd] |
|
foreach ck $oldckouts { |
|
set ckfolder [string trim [string range $ck 6 end]] |
|
if {![file isdirectory $ckfolder]} { |
|
puts stderr "old repo shows a checkout at $ckfolder - but it doesn't seem to exist. Ignoring" |
|
continue |
|
} |
|
cd $ckfolder |
|
puts stdout [exec fossil info] |
|
puts stdout [state] |
|
set answer [punk::repo::askuser "${ansiprompt}Do you want to point this checkout to $target_repodb_folder/$pname2.folder? (Y|N) Q to stop processing checkouts${ansireset}"] |
|
if {[string match q* [string tolower $answer]]} { |
|
puts stderr "User aborting loop" |
|
break |
|
} |
|
if {[string match y* [string tolower $answer]]} { |
|
if {[catch {exec fossil test-move-repository $target_repodb_folder/$pname2.fossil} moveresult]} { |
|
puts stderr "${ansiwarn}The fossil test-move-repository command appears to have failed${ansireset}" |
|
puts stderr "$moveresult" |
|
} else { |
|
puts stdout "OK - move performed with result:" |
|
puts stdout $moveresult |
|
} |
|
} |
|
} |
|
cd $original_cwd |
|
|
|
} |
|
} |
|
} |
|
|
|
|
|
puts stdout "-done-" |
|
} else { |
|
puts stdout "-cancelled by user-" |
|
} |
|
|
|
} |
|
} |
|
|
|
|
|
|
|
|
|
namespace eval ::punk::args::register { |
|
#use fully qualified so 8.6 doesn't find existing var in global namespace |
|
lappend ::punk::args::register::NAMESPACES ::punk::mix::commandset::repo |
|
} |
|
|
|
|
|
|
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Ready |
|
package provide punk::mix::commandset::repo [namespace eval punk::mix::commandset::repo { |
|
variable version |
|
set version 999999.0a1.0 |
|
}] |
|
return
|
|
|