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.
1040 lines
50 KiB
1040 lines
50 KiB
# -*- tcl -*- |
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'deck 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::project 0.1.0 |
|
# Meta platform tcl |
|
# Meta license <unspecified> |
|
# @@ Meta End |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# doctools header |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
#*** !doctools |
|
#[manpage_begin punkshell_module_punk::mix::commandset::project 0 0.1.0] |
|
#[copyright "2023"] |
|
#[titledesc {dec commandset - project}] [comment {-- Name section and table of contents description --}] |
|
#[moddesc {deck CLI commandset - project}] [comment {-- Description at end of page heading --}] |
|
#[require punk::mix::commandset::project] |
|
#[description] |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[section Overview] |
|
#[para] overview of punk::mix::commandset::project |
|
#[para]Import into an ensemble namespace similarly to the way it is done with punk::mix::cli e.g |
|
#[example { |
|
# namespace eval myproject::cli { |
|
# namespace export * |
|
# namespace ensemble create |
|
# package require punk::overlay |
|
# |
|
# package require punk::mix::commandset::project |
|
# punk::overlay::import_commandset project . ::punk::mix::commandset::project |
|
# punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection |
|
# } |
|
#}] |
|
#[para] Where the . in the above example is the prefix/command separator |
|
#[para]The prefix ('project' in the above example) can be any string desired to disambiguate commands imported from other commandsets. |
|
#[para]The above results in the availability of the ensemble command: ::myproject::cli project.new, which is implemented in ::punk::mix::commandset::project::new |
|
#[para]Similarly, procs under ::punk::mix::commandset::project::collection will be available as subcommands of the ensemble as <ensemblecommand> projects.<procname> |
|
#[para] |
|
#[subsection Concepts] |
|
#[para] see punk::overlay |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Requirements |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[subsection dependencies] |
|
#[para] packages used by punk::mix::commandset::project |
|
#[list_begin itemized] |
|
|
|
package require Tcl 8.6- |
|
#*** !doctools |
|
#[item] [package {Tcl 8.6-}] |
|
#[item] [package punk::ns] |
|
#[item] [package sqlite3] (binary) |
|
#[item] [package overtype] |
|
#[item] [package textutil] (tcllib) |
|
|
|
|
|
# #package require frobz |
|
# #*** !doctools |
|
# #[item] [package {frobz}] |
|
|
|
#*** !doctools |
|
#[list_end] |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[section API] |
|
|
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
namespace eval punk::mix::commandset::project { |
|
namespace export * |
|
#*** !doctools |
|
#[subsection {Namespace punk::mix::commandset::project}] |
|
#[para] core commandset functions for punk::mix::commandset::project |
|
#[list_begin definitions] |
|
|
|
proc _default {} { |
|
package require punk::ns |
|
set dispatched_to [lindex [info level 2] 0] ;#e.g ::punk::mix::cli::project |
|
set dispatch_tail [punk::ns::nstail $dispatched_to] |
|
set dispatch_ensemble [punk::ns::nsprefix $dispatched_to] ;#e.g ::punk::mix::cli |
|
set sibling_commands [namespace eval $dispatch_ensemble {namespace export}] |
|
#todo - get separator? |
|
set sep "." |
|
set result [list] |
|
foreach sib $sibling_commands { |
|
if {[string match ${dispatch_tail}${sep}* $sib]} { |
|
lappend result $sib |
|
} |
|
} |
|
return [lsort $result] |
|
} |
|
|
|
|
|
|
|
|
|
proc new {newprojectpath_or_name args} { |
|
#*** !doctools |
|
# [call [fun new] [arg newprojectpath_or_name] [opt args]] |
|
#new project structure - may be dedicated to one module, or contain many. |
|
#create minimal folder structure only by specifying in args: -modules {} |
|
if {[file pathtype $newprojectpath_or_name] eq "absolute"} { |
|
set projectfullpath [file normalize $newprojectpath_or_name] |
|
set projectname [file tail $projectfullpath] |
|
set projectparentdir [file dirname $newprojectpath_or_name] |
|
} else { |
|
set projectfullpath [file join [pwd] $newprojectpath_or_name] |
|
set projectname [file tail $projectfullpath] |
|
set projectparentdir [file dirname $projectfullpath] |
|
} |
|
if {[file type $projectparentdir] ne "directory"} { |
|
error "punk::mix::cli::new error: unable to determine containing folder for '$newprojectpath_or_name'" |
|
} |
|
|
|
punk::mix::cli::lib::validate_projectname $projectname -errorprefix "punk mix project.new" |
|
|
|
|
|
set defaults [list\ |
|
-type plain\ |
|
-empty 0\ |
|
-force 0\ |
|
-update 0\ |
|
-confirm 1\ |
|
-modules \uFFFF\ |
|
-layout punk.project |
|
] ;#todo |
|
set known_opts [dict keys $defaults] |
|
foreach {k v} $args { |
|
if {$k ni $known_opts} { |
|
error "project.new error: option '$k' not known. Known options: $known_opts" |
|
} |
|
} |
|
set opts [dict merge $defaults $args] |
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
|
set opt_type [dict get $opts -type] |
|
if {$opt_type ni [punk::mix::cli::lib::module_types]} { |
|
error "deck new error - unknown type '$opt_type' known types: [punk::mix::cli::lib::module_types]" |
|
} |
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- |
|
set opt_force [dict get $opts -force] |
|
set opt_confirm [string tolower [dict get $opts -confirm]] |
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- |
|
set opt_modules [dict get $opts -modules] |
|
if {[llength $opt_modules] == 1 && [lindex $opt_modules 0] eq "\uFFFF"} { |
|
#if not specified - add a single module matching project name |
|
if {$opt_force || $opt_update} { |
|
#generally undesirable to add default project module during an update. |
|
#user can use dev module.new manually or supply module name in -modules |
|
set opt_modules [list] |
|
} else { |
|
set opt_modules [list [string tolower $projectname]] ;#default modules to lowercase as is the modern (tip 590) recommendation for Tcl |
|
} |
|
} |
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- |
|
set opt_layout [dict get $opts -layout] |
|
set opt_update [dict get $opts -update] |
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- |
|
|
|
|
|
#todo - install support binaries on a per-project basis in a way that doesn't impact machine (e.g not added to path) - cache in user config dir if possible, supply mechanism to clear cache |
|
# |
|
set fossil_prog [auto_execok fossil] |
|
if {![string length $fossil_prog]} { |
|
puts stderr "The fossil program was not found. A fossil executable is required to use most deck features." |
|
if {[string length [set scoop_prog [auto_execok scoop]]]} { |
|
#restrict to windows? |
|
set answer [util::askuser "scoop detected. Would you like deck to install fossil now using scoop? Y|N"] |
|
if {[string tolower $answer] ne "y"} { |
|
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." |
|
return |
|
} |
|
#we don't assume 'unknown' is configured to run shell commands |
|
if {[string length [package provide shellrun]]} { |
|
set exitinfo [run {*}$scoop_prog install fossil] |
|
#scoop tends to return successful exitcode (0) even when packages not found etc. - so exitinfo not much use. |
|
puts stdout "scoop install fossil ran with result: $exitinfo" |
|
} else { |
|
puts stdout "Please wait while scoop runs - there may be a slight delay and then scoop output will be shown. (use punk shellrun package for )" |
|
set result [exec {*}$scoop_prog install fossil] |
|
puts stdout $result |
|
} |
|
catch {::auto_reset} ;#can be missing (unsure under what circumstances - but I've seen it raise error 'invalid command name "auto_reset"') |
|
if {![string length [auto_execok fossil]]} { |
|
puts stderr "Fossil still not detected. If it was successfully installed, try restarting your punk/tcl shell." |
|
return |
|
} |
|
#todo - ask user if they want to configure fosssil first.. |
|
set answer [util::askuser "Fossil command now appears to be available. You may wish to answer N to exit and customize it - but default config may be ok. Type the word 'continue' to proceed with default configuration."] |
|
if {[string tolower $answer] ne "continue"} { |
|
return |
|
} |
|
|
|
} else { |
|
puts stdout "See: https://fossil-scm.org/home/uv/download.html" |
|
if {"windows" eq $::tcl_platform(platform)} { |
|
puts stdout "Consider using a package manager such as scoop: https://scoop.sh" |
|
puts stdout "(Then: scoop install fossil)" |
|
} |
|
return |
|
} |
|
} |
|
set startdir [pwd] |
|
if {[set in_project [punk::repo::find_project $startdir]] ne ""} { |
|
# use this project as source of templates |
|
puts stdout "-------------------------------------------" |
|
puts stdout "Currently in a project directory '$in_project'" |
|
puts stdout "This project will be searched for templates" |
|
puts stdout "-------------------------------------------" |
|
} |
|
|
|
|
|
package require punk::cap |
|
if {[punk::cap::capability_has_handler punk.templates]} { |
|
set layout_dict [punk::cap::call_handler punk.templates get_itemdict_projectlayouts] |
|
} else { |
|
put stderr "commandset::project::new WARNING - no handler available for the 'punk.templates' capability - template providers will be unable to provide layout locations" |
|
return |
|
} |
|
if {[dict exists $layout_dict $opt_layout]} { |
|
set layout_name $opt_layout |
|
set layout_info [dict get $layout_dict $layout_name] |
|
set layout_path [dict get $layout_info path] |
|
set layout_sourceinfo [dict get $layout_info sourceinfo] |
|
} else { |
|
puts stderr "commandset::project::new - no exact match for specified layout-name $opt_layout found" |
|
puts stderr "layout names found: [dict keys $layout_dict]" |
|
return |
|
|
|
#todo - pick highest version layout that matches opt_layout if version not specified but multiple exist |
|
|
|
#set layout_name ... |
|
#set layout_info .. |
|
#set layout_path ... |
|
} |
|
|
|
|
|
|
|
#todo - detect whether inside cwd-project or inside a different project |
|
set projectdir $projectparentdir/$projectname |
|
if {[set target_in_project [punk::repo::find_project $projectparentdir]] ne ""} { |
|
puts stderr "Target location for new project is already within a project: $target_in_project" |
|
error "Nested projects not yet supported aborting" |
|
} |
|
|
|
|
|
|
|
if {[punk::repo::is_git $projectparentdir]} { |
|
puts stderr "mix new WARNING: target project location is within a git repo based at [punk::repo::find_git $projectparentdir]" |
|
puts stderr "The new project will create a fossil repository (which you are free to ignore - but but will be used to confirm project base)" |
|
puts stderr "If you intend to use both git and fossil in the same project space - you should research and understand the details and any possible interactions/issues" |
|
set answer [util::askuser "Do you want to proceed to create a project based at: $projectdir? Y|N"] |
|
if {[string tolower $answer] ne "y"} { |
|
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." |
|
return |
|
} |
|
} |
|
set is_nested_fossil 0 ;#default assumption |
|
if {[punk::repo::is_fossil $projectparentdir]} { |
|
puts stderr "mix new WARNING: target project location is within an open fossil repo based at [punk::repo::find_fossil $projectparentdir] NESTED fossil repository" |
|
if {$opt_confirm ni [list 0 no false]} { |
|
puts stderr "If you proceed - the new project's fossil repo will be created using the --nested flag" |
|
set answer [util::askuser "Do you want to proceed to create a NESTED project based at: $projectdir? Y|N"] |
|
if {[string tolower $answer] ne "y"} { |
|
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." |
|
return |
|
} |
|
set is_nested_fossil 1 |
|
} |
|
} |
|
|
|
|
|
set project_dir_exists [file exists $projectdir] |
|
if {$project_dir_exists && !($opt_force || $opt_update)} { |
|
puts stderr "Unable to create new project at $projectdir - file/folder already exists use -update 1 to fill in missing items from template use -force 1 to overwrite from template" |
|
return |
|
} elseif {$project_dir_exists && $opt_force} { |
|
puts stderr "mix new WARNING: -force 1 was supplied. Will copy layout $layout_path using -force option to overwrite from template" |
|
if {$opt_confirm ni [list 0 no false]} { |
|
set answer [util::askuser "Do you want to proceed to possibly overwrite existing files in $projectdir? Y|N"] |
|
if {[string tolower $answer] ne "y"} { |
|
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." |
|
return |
|
} |
|
} |
|
} elseif {$project_dir_exists && $opt_update} { |
|
puts stderr "mix new WARNING: -update 1 was supplied. Will copy layout $layout_path using -update option to add missing items" |
|
} |
|
|
|
set fossil_repo_file "" |
|
set is_fossil_root 0 |
|
if {$project_dir_exists && [punk::repo::is_fossil_root $projectdir]} { |
|
set is_fossil_root 1 |
|
set fossil_repo_file [punk::repo::fossil_get_repository_file $projectdir] |
|
if {$fossil_repo_file ne ""} { |
|
set repodb_folder [file dirname $fossil_repo_file] |
|
} |
|
} |
|
|
|
if {$fossil_repo_file eq ""} { |
|
set repodb_folder [punk::repo::fossil_get_repository_folder_for_project $projectname -parentfolder $startdir] |
|
if {![string length $repodb_folder]} { |
|
puts stderr "No usable repository database folder selected for $projectname.fossil file" |
|
return |
|
} |
|
} |
|
if {[file exists $repodb_folder/$projectname.fossil]} { |
|
puts stdout "NOTICE: $repodb_folder/$projectname.fossil already exists" |
|
if {!($opt_force || $opt_update)} { |
|
puts stderr "-force 1 or -update 1 not specified - aborting" |
|
return |
|
} |
|
#review |
|
set fossil_repo_file $repodb_folder/$projectname.fossil |
|
} |
|
|
|
if {$fossil_repo_file eq ""} { |
|
puts stdout "Initialising fossil repo: $repodb_folder/$projectname.fossil" |
|
set fossilinit [runx -n {*}$fossil_prog init $repodb_folder/$projectname.fossil -project-name $projectname] |
|
if {[dict get $fossilinit exitcode] != 0} { |
|
puts stderr "fossil init failed:" |
|
puts stderr [dict get $fossilinit stderr] |
|
return |
|
} else { |
|
puts stdout "fossil init result:" |
|
puts stdout [dict get $fossilinit stdout] |
|
} |
|
} |
|
|
|
# |
|
|
|
|
|
|
|
file mkdir $projectdir |
|
|
|
puts stdout ">>> about to call punkcheck::install $layout_path $projectdir" |
|
set resultdict [dict create] |
|
set antipaths [list\ |
|
src/doc/*\ |
|
src/doc/include/*\ |
|
src/PROJECT_LAYOUTS_*\ |
|
] |
|
|
|
#set antiglob_dir [list\ |
|
# _ignore_*\ |
|
#] |
|
set antiglob_dir [list\ |
|
] |
|
|
|
#default antiglob_dir_core will stop .fossil* from being updated - which is generally desirable as these are likely to be customized |
|
if {$opt_force} { |
|
puts stdout "copying layout files - with force applied - overwrite all-targets" |
|
set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -overwrite ALL-TARGETS -antiglob_paths $antipaths -antiglob_dir $antiglob_dir] |
|
} else { |
|
puts stdout "copying layout files - (if source file changed)" |
|
set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -overwrite installedsourcechanged-targets -antiglob_paths $antipaths -antiglob_dir $antiglob_dir] |
|
} |
|
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
|
|
|
puts stdout "copying layout src/doc files (if target missing)" |
|
set resultdict [punkcheck::install $layout_path/src/doc $projectdir/src/doc -punkcheck_folder $projectdir -installer project.new -overwrite SYNCED-TARGETS] |
|
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
|
|
|
#target folders .fossil-custom and .fossil-settings may not exist. use -createdir 1 to ensure existence. |
|
#In this case we need to override the default dir antiglob - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized. |
|
## default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"] |
|
set override_antiglob_dir_core [list #* _aside .git] |
|
puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)" |
|
set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] |
|
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
|
|
|
puts stdout "copying layout src/.fossil-settings files (if target missing or uncustomised)" |
|
set resultdict [punkcheck::install $layout_path/.fossil-settings $projectdir/.fossil-settings -createdir 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] |
|
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
|
|
|
#scan all files in template |
|
# |
|
#TODO - deck command to substitute templates? |
|
set templatefiles [punk::mix::commandset::layout::lib::layout_scan_for_template_files $opt_layout] |
|
set stripprefix [file normalize $layout_path] |
|
|
|
set tagmap [list [lib::template_tag project] $projectname] |
|
if {[llength $templatefiles]} { |
|
puts stdout "Filling template file placeholders with the following tag map:" |
|
foreach {placeholder value} $tagmap { |
|
puts stdout " $placeholder -> $value" |
|
} |
|
} |
|
foreach templatefullpath $templatefiles { |
|
set templatetail [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] |
|
|
|
set fpath [file join $projectdir $templatetail] |
|
if {[file exists $fpath]} { |
|
set fd [open $fpath r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd |
|
set data2 [string map $tagmap $data] |
|
if {$data2 ne $data} { |
|
puts stdout "updated template file: $fpath" |
|
set fdout [open $fpath w]; fconfigure $fdout -translation binary; puts -nonewline $fdout $data2; close $fdout |
|
} |
|
} else { |
|
puts stderr "warning: Missing template file $fpath" |
|
} |
|
} |
|
#todo - tag substitutions in src/doc tree |
|
|
|
::cd $projectdir |
|
|
|
if {[file exists $projectdir/src/modules]} { |
|
foreach m $opt_modules { |
|
#check if mod-ver.tm file or #modpod-mod-ver folder exist |
|
set tmfile $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm |
|
set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::magic_tm_version]/$m-[punk::mix::util::magic_tm_version].tm |
|
|
|
set has_tm [file exists $tmfile] |
|
set has_pod [file exists $podfile] |
|
#puts stderr "=====> has_tm: $has_tm has_pod: $has_pod" |
|
if {!$has_tm && !$has_pod} { |
|
#todo - option for -module_template - and check existence at top? or change opt_modules to be a list of dicts with configuration info -template -type etc |
|
punk::mix::commandset::module::new -project $projectname -type $opt_type $m |
|
} else { |
|
#we should rarely if ever want to force any src/modules to be overwritten |
|
if {$opt_force} { |
|
if {$has_pod} { |
|
set answer [util::askuser "OVERWRITE the src/modules file $podfile ?? (generally not desirable) Y|N"] |
|
set overwrite_type zip |
|
} else { |
|
set answer [util::askuser "OVERWRITE the src/modules file $tmfile ?? (generally not desirable) Y|N"] |
|
set overwrite_type $opt_type |
|
} |
|
if {[string tolower $answer] eq "y"} { |
|
#REVIEW - all pods zip - for now |
|
punk::mix::commandset::module::new -project $projectname -type $overwrite_type -force 1 $m |
|
} |
|
} |
|
} |
|
} |
|
} else { |
|
puts stderr "project.new WARNING template hasn't created src/modules - skipping creation of new module(s) for project" |
|
} |
|
|
|
#generate www/man/md output in 'embedded' folder which should be checked into repo for online documentation |
|
if {[file exists $projectdir/src]} { |
|
::cd $projectdir/src |
|
#---------- |
|
set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] |
|
$installer set_source_target $projectdir/src/doc $projectdir/src/embedded |
|
set event [$installer start_event {-install_step kettledoc}] |
|
$event targetset_init VIRTUAL kettle_build_doc ;#VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated |
|
$event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source |
|
#---------- |
|
if {\ |
|
[llength [dict get [$event targetset_source_changes] changed]]\ |
|
} { |
|
$event targetset_started |
|
# -- --- --- --- --- --- |
|
puts stdout "BUILDING DOCS at src/embedded from src/doc" |
|
if {[catch { |
|
|
|
punk::mix::cli::lib::kettle_call lib doc |
|
#Kettle doc |
|
|
|
} errM]} { |
|
$event targetset_end FAILED -note "kettle_build_doc failed: $errM" |
|
} else { |
|
$event targetset_end OK |
|
} |
|
# -- --- --- --- --- --- |
|
} else { |
|
puts stderr "No change detected in src/doc" |
|
$event targetset_end SKIPPED |
|
} |
|
$event end |
|
$event destroy |
|
$installer destroy |
|
} |
|
|
|
::cd $projectdir |
|
|
|
if {![punk::repo::is_fossil_root $projectdir]} { |
|
set first_fossil 1 |
|
#-k = keep. (only modify the manifest file(s)) |
|
if {$is_nested_fossil} { |
|
set fossilopen [runx -n {*}$fossil_prog open --nested $repodb_folder/$projectname.fossil -k --workdir $projectdir] |
|
} else { |
|
set fossilopen [runx -n {*}$fossil_prog open $repodb_folder/$projectname.fossil -k --workdir $projectdir] |
|
} |
|
if {[file exists $projectdir/_FOSSIL_] && ![file exists $projectdir/.fslckout]} { |
|
file rename $projectdir/_FOSSIL_ $projectdir/.fslckout |
|
} |
|
if {[dict get $fossilopen exitcode] != 0} { |
|
puts stderr "fossil open in project workdir '$projectdir' FAILED:" |
|
puts stderr [dict get $fossilopen stderr] |
|
return |
|
} else { |
|
puts stdout "fossil open in project workdir '$projectdir' OK:" |
|
puts stdout [dict get $fossilopen stdout] |
|
} |
|
} else { |
|
set first_fossil 0 |
|
} |
|
set fossiladd [runx -n {*}$fossil_prog add --dotfiles $projectdir] |
|
if {[dict get $fossiladd exitcode] != 0} { |
|
puts stderr "fossil add workfiles in workdir '$projectdir' FAILED:" |
|
puts stderr [dict get $fossiladd stderr] |
|
return |
|
} else { |
|
puts stdout "fossil add workfiles in workdir '$projectdir' OK:" |
|
puts stdout [dict get $fossiladd stdout] |
|
} |
|
if {$first_fossil} { |
|
#fossil commit may prompt user for input.. runx runout etc will pause with no prompts |
|
util::do_in_path $projectdir { |
|
set fossilcommit [run -n {*}$fossil_prog commit -m "initial project commit"] |
|
} |
|
if {[dict get $fossilcommit exitcode] != 0} { |
|
puts stderr "fossil commit in workdir '$projectdir' FAILED" |
|
return |
|
} else { |
|
puts stdout "fossil commit in workdir '$projectdir' OK" |
|
} |
|
} |
|
|
|
puts stdout "-done- project:$projectname projectdir: $projectdir" |
|
} |
|
|
|
#*** !doctools |
|
#[list_end] [comment {--- end definitions namespace punk::mix::commandset::project ---}] |
|
|
|
namespace eval collection { |
|
#*** !doctools |
|
#[subsection {Namespace punk::mix::commandset::project::collection}] |
|
#[para] commandset functions for operating with multiple projects. |
|
#[para] It would usually be imported with the prefix "projects" and separator "." to result in commands such as: <ensemblecommand> projects.detail |
|
#[list_begin definitions] |
|
namespace export * |
|
namespace path [namespace parent] |
|
|
|
#e.g imported as 'projects' |
|
proc _default {{glob {}} args} { |
|
#*** !doctools |
|
#[call [fun _default] [arg glob] [opt {option value...}]] |
|
#[para]List projects under fossil management, showing fossil db location and number of checkouts |
|
#[para]The glob argument is optional unless option/value pairs are also supplied, in which case * should be explicitly supplied |
|
#[para]glob restricts output based on the name of the fossil db file e.g s* for all projects beginning with s |
|
#[para]The _default function is made available in the ensemble by the name of the prefix used when importing the commandset. |
|
#[para]e.g |
|
#[para] punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection |
|
#[para]Will result in the command being available as <ensemblecommand> projects |
|
package require overtype |
|
set db_projects [lib::get_projects $glob] |
|
set col1items [lsearch -all -inline -index 0 -subindices $db_projects *] |
|
set col2items [lsearch -all -inline -index 1 -subindices $db_projects *] |
|
set checkouts [lsearch -all -inline -index 2 -subindices $db_projects *] |
|
set col3items [lmap v $checkouts {llength $v}] |
|
|
|
set title1 "Fossil Repo DB" |
|
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1items] {punk::strlen $v}]] |
|
set col1 [string repeat " " $widest1] |
|
set title2 "File Name" |
|
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {punk::strlen $v}]] |
|
set col2 [string repeat " " $widest2] |
|
set title3 "Checkouts" |
|
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {string length $v}]] |
|
set col3 [string repeat " " $widest3] |
|
set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3}] |
|
|
|
|
|
append msg "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]" \n |
|
append msg [string repeat "=" $tablewidth] \n |
|
foreach p $col1items n $col2items c $col3items { |
|
append msg "[overtype::left $col1 $p] [overtype::left $col2 $n] [overtype::right $col3 $c]" \n |
|
} |
|
return $msg |
|
#return [list_as_lines [lib::get_projects $glob]] |
|
} |
|
proc detail {{glob {}} args} { |
|
package require overtype |
|
package require textutil |
|
set defaults [dict create\ |
|
-description 0\ |
|
] |
|
set opts [dict merge $defaults $args] |
|
# -- --- --- --- --- --- --- |
|
set opt_description [dict get $opts -description] |
|
# -- --- --- --- --- --- --- |
|
|
|
|
|
set db_projects [lib::get_projects $glob] |
|
set col1_dbfiles [lsearch -all -inline -index 0 -subindices $db_projects *] |
|
set col2items [lsearch -all -inline -index 1 -subindices $db_projects *] |
|
set checkouts [lsearch -all -inline -index 2 -subindices $db_projects *] |
|
set col3items [lmap v $checkouts {llength $v}] |
|
|
|
set col4_pnames [list] |
|
set col5_pcodes [list] |
|
set col6_dupids [list] |
|
set col7_pdescs [list] |
|
set codes [dict create] |
|
set file_idx 0 |
|
foreach dbfile $col1_dbfiles { |
|
set project_name "" |
|
set project_code "" |
|
set project_desc "" |
|
set db_error "" |
|
if {[file exists $dbfile]} { |
|
if {[catch { |
|
sqlite3 dbp $dbfile |
|
dbp eval {select name,value from config where name like 'project-%';} r { |
|
if {$r(name) eq "project-name"} { |
|
set project_name $r(value) |
|
} elseif {$r(name) eq "project-code"} { |
|
set project_code $r(value) |
|
} elseif {$r(name) eq "project-description"} { |
|
set project_desc $r(value) |
|
} |
|
} |
|
} errM]} { |
|
set db_error $errM |
|
} |
|
catch {dbp close} |
|
} else { |
|
set db_error "fossil file $dbfile missing" |
|
} |
|
lappend col4_pnames $project_name |
|
lappend col5_pcodes $project_code |
|
dict lappend codes $project_code $dbfile |
|
lappend col7_pdescs $project_desc |
|
if {$db_error ne ""} { |
|
lset col1_dbfiles $file_idx "[a+ web-red]$dbfile[a]" |
|
} |
|
incr file_idx |
|
} |
|
|
|
set setid 1 |
|
set codeset [dict create] |
|
dict for {code dbs} $codes { |
|
if {[llength $dbs]>1} { |
|
dict set codeset $code setid $setid |
|
dict set codeset $code count [llength $dbs] |
|
dict set codeset $code seen 0 |
|
incr setid |
|
} |
|
} |
|
set dupid 1 |
|
foreach pc $col5_pcodes { |
|
if {[dict exists $codeset $pc]} { |
|
set seen [dict get $codeset $pc seen] |
|
set this_seen [expr {$seen + 1}] |
|
dict set codeset $pc seen $this_seen |
|
lappend col6_dupids "[dict get $codeset $pc setid].${this_seen}/[dict get $codeset $pc count]" |
|
} else { |
|
lappend col6_dupids "" |
|
} |
|
} |
|
|
|
set title1 "Fossil Repo DB" |
|
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1_dbfiles] {punk::strlen $v}]] |
|
set col1 [string repeat " " $widest1] |
|
set title2 "File Name" |
|
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {punk::strlen $v}]] |
|
set col2 [string repeat " " $widest2] |
|
set title3 "Checkouts" |
|
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {string length $v}]] |
|
set col3 [string repeat " " $widest3] |
|
set title4 "Project Name" |
|
set widest4 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col4_pnames] {string length $v}]] |
|
set col4 [string repeat " " $widest4] |
|
set title5 "Project Code" |
|
set widest5 [tcl::mathfunc::max {*}[lmap v [concat [list $title5] $col5_pcodes] {string length $v}]] |
|
set col5 [string repeat " " $widest5] |
|
set title6 "Dup" |
|
set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col6_dupids] {string length $v}]] |
|
set col6 [string repeat " " $widest6] |
|
set title7 "Description" |
|
#set widest7 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col7_pdescs] {string length $v}]] |
|
set widest7 35 |
|
set col7 [string repeat " " $widest7] |
|
|
|
|
|
set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3 +1 + $widest4 + 1 + $widest5 + 1 + $widest6}] |
|
|
|
append msg "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]\ |
|
[overtype::left $col4 $title4] [overtype::left $col5 $title5] [overtype::left $col6 $title6]" |
|
if {!$opt_description} { |
|
append msg \n |
|
} else { |
|
append msg "[overtype::left $col7 $title7]" \n |
|
set tablewidth [expr {$tablewidth + 1 + $widest7}] |
|
} |
|
|
|
append msg [string repeat "=" $tablewidth] \n |
|
foreach p $col1_dbfiles n $col2items c $col3items pn $col4_pnames pc $col5_pcodes dup $col6_dupids desc $col7_pdescs { |
|
set desclines [split [textutil::adjust $desc -length $widest7] \n] |
|
set desc1 [lindex $desclines 0] |
|
append msg "[overtype::left $col1 $p] [overtype::left $col2 $n] [overtype::right $col3 $c]\ |
|
[overtype::left $col4 $pn] [overtype::left $col5 $pc] [overtype::left $col6 $dup]" |
|
if {!$opt_description} { |
|
append msg \n |
|
} else { |
|
append msg " [overtype::left $col7 $desc1]" \n |
|
foreach dline [lrange $desclines 1 end] { |
|
append msg "$col1 $col2 $col3 $col4 $col5 $col6 [overtype::left $col7 $dline]" \n |
|
} |
|
} |
|
} |
|
return $msg |
|
#return [list_as_lines [lib::get_projects $glob]] |
|
} |
|
proc cd {{glob {}} args} { |
|
dict set args -cd 1 |
|
work $glob {*}$args |
|
} |
|
proc work {{glob {}} args} { |
|
package require sqlite3 |
|
set db_projects [lib::get_projects $glob] |
|
if {[llength $db_projects] == 0} { |
|
puts stderr "::punk::mix::commandset::project::work No Repo DB name matches found for '$glob'" |
|
return "" |
|
} |
|
#list of lists of the form: |
|
#{fosdb fname workdirlist} |
|
set defaults [dict create\ |
|
-cd 0\ |
|
-detail "\uFFFF"\ |
|
] |
|
set opts [dict merge $defaults $args] |
|
# -- --- --- --- --- --- --- |
|
set opt_cd [dict get $opts -cd] |
|
# -- --- --- --- --- --- --- |
|
set opt_detail [dict get $opts -detail] |
|
set opt_detail_explicit_zero 1 ;#default assumption only |
|
if {$opt_detail eq "\uFFFF"} { |
|
set opt_detail_explicit_zero 0 |
|
set opt_detail 0; #default |
|
} |
|
# -- --- --- --- --- --- --- |
|
set workdir_dict [dict create] |
|
set all_workdirs [list] |
|
foreach pinfo $db_projects { |
|
lassign $pinfo fosdb name workdirs |
|
foreach wdir $workdirs { |
|
dict set workdir_dict $wdir $pinfo |
|
lappend all_workdirs $wdir |
|
} |
|
} |
|
set col_rowids [list] |
|
set workdirs [lsort -index 0 $all_workdirs] |
|
set col_dupids [list] |
|
set col_fnames [list] |
|
set col_pnames [list] |
|
set col_pcodes [list] |
|
set col_dupids [list] |
|
|
|
set fosdb_count [dict create] |
|
set fosdb_dupset [dict create] |
|
set fosdb_cache [dict create] |
|
set dupset 0 |
|
set rowid 1 |
|
foreach wd $workdirs { |
|
set wdinfo [dict get $workdir_dict $wd] |
|
lassign $wdinfo fosdb nm siblingworkdirs |
|
dict incr fosdb_count $fosdb |
|
set dbcount [dict get $fosdb_count $fosdb] |
|
if {[llength $siblingworkdirs] > 1} { |
|
if {![dict exists $fosdb_dupset $fosdb]} { |
|
#first time this multi-checkout fosdb seen |
|
dict set fosdb_dupset $fosdb [incr dupset] |
|
} |
|
set dupid "[dict get $fosdb_dupset $fosdb].$dbcount/[llength $siblingworkdirs]" |
|
} else { |
|
set dupid "" |
|
} |
|
if {$dbcount == 1} { |
|
set pname "" |
|
set pcode "" |
|
if {[file exists $fosdb]} { |
|
if {[catch { |
|
sqlite3 fdb $fosdb |
|
set pname [lindex [fdb eval {select value from config where name = 'project-name'}] 0] |
|
set pcode [lindex [fdb eval {select value from config where name = 'project-code'}] 0] |
|
fdb close |
|
dict set fosdb_cache $fosdb [list name $pname code $pcode] |
|
} errM]} { |
|
puts stderr "!!! problem with fossil db: $fosdb when examining workdir $wd" |
|
puts stderr "!!! error: $errM" |
|
} |
|
} else { |
|
puts stderr "!!! missing fossil db $fosdb" |
|
} |
|
} else { |
|
set info [dict get $fosdb_cache $fosdb] |
|
lassign $info _name pname _code pcode |
|
} |
|
lappend col_rowids $rowid |
|
lappend col_fnames $nm |
|
lappend col_dupids $dupid |
|
lappend col_pnames $pname |
|
lappend col_pcodes [string range $pcode 0 9] |
|
incr rowid |
|
} |
|
|
|
set col_states [list] |
|
set state_title "" |
|
#if only one set of fossil checkouts in the resultset and opt_detail is 0 and not explicit - retrieve workingdir state for each co |
|
if {([llength [dict keys $fosdb_cache]] == 1)} { |
|
if {!$opt_detail_explicit_zero} { |
|
set opt_detail 1 |
|
} |
|
puts stderr "Result is from a single repo db [dict keys $fosdb_cache]" |
|
} |
|
if {$opt_detail} { |
|
if {!$opt_detail_explicit_zero} { |
|
set detailmsg "Use -detail 0 to omit file state" |
|
} else { |
|
set detailmsg "" |
|
} |
|
puts stderr "Gathering file state for [llength $workdirs] checkout folder(s). $detailmsg" |
|
set c_rev [list] |
|
set c_rev_iso [list] |
|
set c_unchanged [list] |
|
set c_changed [list] |
|
set c_new [list] |
|
set c_missing [list] |
|
set c_extra [list] |
|
foreach wd $workdirs { |
|
set wd_state [punk::repo::workingdir_state $wd] |
|
set state_dict [punk::repo::workingdir_state_summary_dict $wd_state] |
|
lappend c_rev [string range [dict get $state_dict revision] 0 9] |
|
lappend c_rev_iso [dict get $state_dict revision_iso8601] |
|
lappend c_unchanged [dict get $state_dict unchanged] |
|
lappend c_changed [dict get $state_dict changed] |
|
lappend c_new [dict get $state_dict new] |
|
lappend c_missing [dict get $state_dict missing] |
|
lappend c_extra [dict get $state_dict extra] |
|
puts -nonewline stderr "." |
|
} |
|
puts -nonewline stderr \n |
|
set t0 "Revision" |
|
set w0 [tcl::mathfunc::max {*}[lmap v [concat [list $t0] $c_rev] {string length $v}]] |
|
set c0 [string repeat " " $w0] |
|
set t0b "Revision iso8601" |
|
set w0b [tcl::mathfunc::max {*}[lmap v [concat [list $t0] $c_rev_iso] {string length $v}]] |
|
set c0b [string repeat " " $w0b] |
|
set t1 "Unch" |
|
set w1 [tcl::mathfunc::max {*}[lmap v [concat [list $t1] $c_unchanged] {string length $v}]] |
|
set c1 [string repeat " " $w1] |
|
set t2 "Chgd" |
|
set w2 [tcl::mathfunc::max {*}[lmap v [concat [list $t2] $c_changed] {string length $v}]] |
|
set c2 [string repeat " " $w2] |
|
set t3 "New" |
|
set w3 [tcl::mathfunc::max {*}[lmap v [concat [list $t3] $c_new] {string length $v}]] |
|
set c3 [string repeat " " $w3] |
|
set t4 "Miss" |
|
set w4 [tcl::mathfunc::max {*}[lmap v [concat [list $t4] $c_missing] {string length $v}]] |
|
set c4 [string repeat " " $w4] |
|
set t5 "Extr" |
|
set w5 [tcl::mathfunc::max {*}[lmap v [concat [list $t5] $c_extra] {string length $v}]] |
|
set c5 [string repeat " " $w5] |
|
|
|
set state_title "[overtype::left $c0 $t0] [overtype::left $c0b $t0b] [overtype::right $c1 $t1] [overtype::right $c2 $t2] [overtype::right $c3 $t3] [overtype::right $c4 $t4] [overtype::right $c5 $t5]" |
|
foreach r $c_rev iso $c_rev_iso u $c_unchanged c $c_changed n $c_new m $c_missing e $c_extra { |
|
lappend col_states "[overtype::left $c0 $r] [overtype::left $c0b $iso] [overtype::right $c1 $u] [overtype::right $c2 $c] [overtype::right $c3 $n] [overtype::right $c4 $m] [overtype::right $c5 $e]" |
|
} |
|
} |
|
|
|
set msg "" |
|
if {$opt_cd} { |
|
set title0 "CD" |
|
} else { |
|
set title0 "" |
|
} |
|
set widest0 [tcl::mathfunc::max {*}[lmap v [concat [list $title0] $col_rowids] {punk::strlen $v}]] |
|
set col0 [string repeat " " $widest0] |
|
set title1 "Checkout dir" |
|
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $workdirs] {punk::strlen $v}]] |
|
set col1 [string repeat " " $widest1] |
|
set title2 "Repo DB name" |
|
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col_fnames] {string length $v}]] |
|
set col2 [string repeat " " $widest2] |
|
set title3 "CO dup" |
|
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col_dupids] {string length $v}]] |
|
set col3 [string repeat " " $widest3] |
|
set title4 "Project Name" |
|
set widest4 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col_pnames] {string length $v}]] |
|
set col4 [string repeat " " $widest4] |
|
set title5 "Project Code" |
|
set widest5 [tcl::mathfunc::max {*}[lmap v [concat [list $title5] $col_pcodes] {string length $v}]] |
|
set col5 [string repeat " " $widest5] |
|
|
|
set tablewidth [expr {$widest0 + 1 + $widest1 + 1 + $widest2 + 1 + $widest3 +1 + $widest4 + 1 + $widest5}] |
|
append msg "[overtype::right $col0 $title0] [overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3] [overtype::left $col4 $title4] [overtype::left $col5 $title5]" |
|
|
|
if {[llength $col_states]} { |
|
set title6 $state_title |
|
set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col_states] {string length $v}]] |
|
set col6 [string repeat " " $widest6] |
|
incr tablewidth [expr {$widest6 + 1}] |
|
append msg " [overtype::left $col6 $title6]" \n |
|
} else { |
|
append msg \n |
|
} |
|
append msg [string repeat "=" $tablewidth] \n |
|
|
|
if {[llength $col_states]} { |
|
foreach row $col_rowids wd $workdirs db $col_fnames dup $col_dupids pname $col_pnames pcode $col_pcodes s $col_states { |
|
if {![file exists $wd]} { |
|
set row [punk::ansi::a+ strike red]$row[a] |
|
set wd [punk::ansi::a+ red]$wd[a] |
|
} |
|
append msg "[overtype::right $col0 $row] [overtype::left $col1 $wd] [overtype::left $col2 $db] [overtype::right $col3 $dup] [overtype::left $col4 $pname] [overtype::left $col5 $pcode] [overtype::left $col6 $s]" \n |
|
} |
|
} else { |
|
foreach row $col_rowids wd $workdirs db $col_fnames dup $col_dupids pname $col_pnames pcode $col_pcodes { |
|
if {![file exists $wd]} { |
|
set row [punk::ansi::a+ strike red]$row[a] |
|
set wd [punk::ansi::a+ red]$wd[a] |
|
} |
|
append msg "[overtype::right $col0 $row] [overtype::left $col1 $wd] [overtype::left $col2 $db] [overtype::right $col3 $dup] [overtype::left $col4 $pname] [overtype::left $col5 $pcode]" \n |
|
} |
|
} |
|
set numrows [llength $col_rowids] |
|
if {$opt_cd && $numrows >= 1} { |
|
puts stdout $msg |
|
if {$numrows == 1} { |
|
set workingdir [lindex $workdirs 0] |
|
puts stdout "1 result. Changing dir to $workingdir" |
|
if {[file exists $workingdir]} { |
|
::cd $workingdir |
|
return $workingdir |
|
} else { |
|
puts stderr "path $workingdir doesn't appear to exist" |
|
return [pwd] |
|
} |
|
} else { |
|
set answer [util::askuser "Change directory to working folder - select a number from 1 to [llength $col_rowids] or any other key to cancel."] |
|
if {[string trim $answer] in $col_rowids} { |
|
set index [expr {$answer - 1}] |
|
set workingdir [lindex $workdirs $index] |
|
::cd $workingdir |
|
puts stdout [deck stat] |
|
return $workingdir |
|
} |
|
} |
|
} |
|
return $msg |
|
} |
|
#*** !doctools |
|
#[list_end] [comment {-- end collection namespace definitions --}] |
|
} |
|
|
|
namespace eval lib { |
|
proc template_tag {tagname} { |
|
#todo - support different tagwrappers - it shouldn't be so likely to collide with common code idioms etc. |
|
#we need to detect presence of tags intended for punk::mix system |
|
#consider using punk::cap to enable multiple template-substitution providers with their own set of tagnames and/or tag wrappers, where substitution providers are all run |
|
return [string cat % $tagname %] |
|
} |
|
#get project info only by opening the central confg-db |
|
#(will not have proper project-name etc) |
|
proc get_projects {{globlist {}} args} { |
|
if {![llength $globlist]} { |
|
set globlist [list *] |
|
} |
|
set fossil_prog [auto_execok fossil] |
|
|
|
set configdb [punk::repo::fossil_get_configdb] |
|
|
|
package require sqlite3 |
|
::sqlite3 fosconf $configdb |
|
#set testresult [fosconf eval {select name,value from global_config;}] |
|
#puts stderr $testresult |
|
set project_repos [fosconf eval {select name from global_config where name like 'repo:%';}] |
|
set paths_and_names [list] |
|
foreach pr $project_repos { |
|
set path [string trim [string range $pr 5 end]] |
|
set nm [file rootname [file tail $path]] |
|
set ckouts [fosconf eval {select name from global_config where value = $path;}] |
|
set checkout_paths [list] |
|
#strip "ckout:" |
|
foreach ck $ckouts { |
|
lappend checkout_paths [string trim [string range $ck 6 end]] |
|
} |
|
lappend paths_and_names [list $path $nm $checkout_paths] |
|
} |
|
set filtered_list [list] |
|
foreach glob $globlist { |
|
set matches [lsearch -all -inline -index 1 $paths_and_names $glob] |
|
foreach m $matches { |
|
if {$m ni $filtered_list} { |
|
lappend filtered_list $m |
|
} |
|
} |
|
} |
|
set projects [lsort -index 1 $filtered_list] |
|
return $projects |
|
} |
|
|
|
} |
|
|
|
|
|
|
|
|
|
|
|
} |
|
|
|
|
|
#*** !doctools |
|
#[manpage_end] |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Ready |
|
package provide punk::mix::commandset::project [namespace eval punk::mix::commandset::project { |
|
variable version |
|
set version 0.1.0 |
|
}] |
|
return
|
|
|