# -*- tcl -*- # Maintenance Instruction: leave the 999999.xxx.x as is and use 'deck make' or src/make.tcl to update from -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 # @@ 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 projects. #[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] } namespace eval argdoc { set layout_dict [punk::cap::call_handler punk.templates get_itemdict_projectlayouts] variable LAYOUTNAMES [dict keys $layout_dict] } punk::args::define { @id -id ::punk::mix::commandset::project::new @cmd -name "punk::mix::commandset::project::new" -help\ "" @leaders -min 1 -max 1 project -type string -help\ "Project name or path. If just a name is given ... (todo)" @opts -type -default plain -empty -default 0 -type boolean -force -default 0 -type boolean -update -default 0 -type boolean -confirm -default 1 -type boolean -layout -default "punk.project" -choices {${$::punk::mix::commandset::project::argdoc::LAYOUTNAMES}} } 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_layout [dict get $opts -layout] set opt_update [dict get $opts -update] # -- --- --- --- --- --- --- --- --- --- --- --- --- 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 } } # -- --- --- --- --- --- --- --- --- --- --- --- --- #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} { set warnmsg "mix new WARNING: -update 1 was supplied. Will copy layout $layout_path using -update option to add missing items" if {$opt_confirm} { puts stderr $warnmsg set msg "Do you want to proceed to possibly overwrite some existing files in $projectdir? Y|N" set answer [util::askuser $msg] 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 prompt." return } } puts stderr $warnmsg } 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 -createempty 1 -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 -createempty 1 -overwrite installedsourcechanged-targets -antiglob_paths $antipaths -antiglob_dir $antiglob_dir] } puts stdout [punkcheck::summarize_install_resultdict $resultdict] if {[file exists $layout_path/src/doc]} { puts stdout "copying layout src/doc files (if target missing)" set resultdict [punkcheck::install $layout_path/src/doc $projectdir/src/doc -createdir 1 -punkcheck_folder $projectdir -installer project.new -overwrite SYNCED-TARGETS] puts stdout [punkcheck::summarize_install_resultdict $resultdict] } else { puts stdout "no src/doc in source template - update not required" } #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] if {[file exists $layout_path/.fossil-custom]} { 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 -createempty 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] puts stdout [punkcheck::summarize_install_resultdict $resultdict] } else { puts stdout "no .fossil-custom in source template - update not required" } if {[file exists $layout_path/.fossil-settings]} { 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 -createempty 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] puts stdout [punkcheck::summarize_install_resultdict $resultdict] } else { puts stdout "no .fossil-settings in source template - update not required" } #scan all files in template # #TODO - deck command to substitute templates? set templateinfo_list [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 $templateinfo_list]} { puts stdout "Filling template file placeholders with the following tag map:" foreach {placeholder value} $tagmap { puts stdout " $placeholder -> $value" } } foreach templateinfo $templateinfo_list { lassign $templateinfo templatefullpath template_tagnames_found set templatetail [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] set fpath [file join $projectdir $templatetail] foreach t $template_tagnames_found { if {"%$t%" ni [dict keys $tagmap]} { puts stderr "warning: No substitution available for tag: %$t% in $fpath" } } 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" } } ::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: projects.detail #[list_begin definitions] namespace export * namespace path [namespace parent] punk::args::define { @id -id ::punk::mix::commandset::project::collection::_default @cmd -name "punk::mix::commandset::project::collection::_default"\ -summary\ "List projects under fossil managment."\ -help\ "List projects under fossil management, showing fossil db location and number of checkouts" @values -min 0 -max -1 glob -type string -multiple 1 -default * } #e.g imported as 'projects' proc _default {args} { set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::_default] set globlist [dict get $argd values glob] #*** !doctools #[call [fun _default] [arg glob...]] #[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 projects package require overtype set db_projects [lib::get_projects {*}$globlist] 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]] } punk::args::define { @id -id ::punk::mix::commandset::project::collection::work @cmd -name punk::mix::commandset::project::collection::work\ -summary\ "List projects with checkout directories."\ -help\ "Get project info by opening the central fossil config-db to determine fossil database files for each project, and the known checkout folders. If -detail is true, a second operation gathers file state information for each checkout folder." @leaders -min 0 -max 0 -cd -type none -help\ "If this flag is provided, after lsting, prompt the user to enter the row number of the checkout to 'cd' into, or an option to cancel. If there is only one project with only a single checkout, the cd operation will occur without prompting unless -prompt was also supplied." -prompt -type none -help\ "If there is only one checkout in the result, cause a prompt to be raised instead of automatically peforming the cd operation. Has no effect if -cd was not supplied, or if -cd is supplied and there are multiple checkouts, in which case user is always prompted." -detail -type boolean -default 0 -help\ "Include file state information for each checkout in the resulting table. This includes information such as which files are changed, unchanged,new,missing or extra and can take a little more time to gather as it must examine the filesystem for each checkout folder. Note that although the default is false - if only a single project matches the glob pattern(s) then file state will be gathered for each of its checkouts. Use an explicit -detail 0 if this is not desired." @values -min 0 -max -1 glob -type string -multiple 1 -default * -optional 1 -help\ "glob patterns used to search for project. The glob is applied against the names of the fossil repository database files - not the project-name, which is not available in the central fossil config-db. Case insensitive." } proc work {args} { set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] lassign [dict values $argd] leaders opts values received package require sqlite3 set globlist [dict get $values glob] set db_projects [lib::get_projects {*}$globlist] #list of lists of the form: #{fosdb fname workdirlist} if {[llength $db_projects] == 0} { puts stderr "::punk::mix::commandset::project::work No Repo DB name matches found for '$globlist'" return "" } # -- --- --- --- --- --- --- set opt_cd [dict exists $received -cd] # -- --- --- --- --- --- --- set opt_detail [dict get $opts -detail] if {[dict exists $received -detail] && !$opt_detail} { set opt_detail_explicit_zero 1 } else { set opt_detail_explicit_zero 0 } set opt_prompt [dict exists $received -prompt] # -- --- --- --- --- --- --- 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 && !$opt_prompt} { 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 } punk::args::define { @id -id ::punk::mix::commandset::project::collection::cd @cmd -name punk::mix::commandset::project::collection::cd\ -summary\ "List projects with checkout directories and prompt for which checkout to cd to."\ -help\ "List projects with checkout directories and prompt for which checkout to cd to." @leaders -min 0 -max 0 }\ [punk::args::resolved_def -types opts ::punk::mix::commandset::project::collection::work -detail]\ { -prompt -type none -help\ "Prompt even when result contains only one checkout location as a possible cd target. User will always be prompted if result contains more than one checkout." @values -min 0 -max -1 }\ [punk::args::resolved_def -types values ::punk::mix::commandset::project::collection::work glob] proc cd {args} { set argd [punk::args::parse $args withid ::punk::mix::commandset::project::collection::work] work -cd {*}$args } #*** !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 %] } punk::args::define { @id -id ::punk::mix::commandset::project::lib::get_projects @cmd -name punk::mix::commandset::project::lib::get_projects\ -summary\ "Return a 3-element list of projects referred to by central fossil config-db."\ -help\ "Get project info only by opening the central fossil config-db. Each member of the returned list is a 3-element list of: The shortname is simply the name based on the root name of the fossil database, it is not necessarily the project-name by which the project is referred to in the fossil checkout databases." @values -min 0 -max -1 glob -type string -multiple 1 -default * -optional 1 -help\ "case insensitive glob for the name of the fossil database." } proc get_projects {args} { set argd [punk::args::parse $args withid ::punk::mix::commandset::project::lib::get_projects] set globlist [dict get $argd values glob] 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 #list of repositories of the form repo: #eg repo:C:/Users/someone/.fossils/tcl.fossil #the command: # fossil all ignore /repo.fossil #will remove the {repo:/repo.fossil 1} record from global_config #but it leaves {ckout: /repo.fossil} records, even if such checkouts are closed #when the folder itself at is removed - then commands such as 'fossil all ls -c' automatically remove the corresponding ckout: record. 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;}] #list of entries like "ckout:C:/buildtcl/2024zig/tcl90/" 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 -nocase -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