From 51396838f893d22181f0b41a266e055d170f52e7 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Wed, 15 Nov 2023 03:39:59 +1100 Subject: [PATCH] dir listing ./ (d/) multiple search support, x/ script running vs ./ --- src/bootsupport/modules/.punkcheck | 9 + src/bootsupport/modules/punk/repo-0.1.0.tm | 814 --------------------- src/bootsupport/modules/punk/repo-0.1.1.tm | 39 +- src/modules/punk-0.1.tm | 528 +++++++++---- src/modules/punk/ns-999999.0a1.0.tm | 1 + src/modules/punk/repo-999999.0a1.0.tm | 19 + src/modules/punk/winrun-999999.0a1.0.tm | 8 +- 7 files changed, 470 insertions(+), 948 deletions(-) create mode 100644 src/bootsupport/modules/.punkcheck delete mode 100644 src/bootsupport/modules/punk/repo-0.1.0.tm diff --git a/src/bootsupport/modules/.punkcheck b/src/bootsupport/modules/.punkcheck new file mode 100644 index 00000000..ba36a8e8 --- /dev/null +++ b/src/bootsupport/modules/.punkcheck @@ -0,0 +1,9 @@ +INSTALLER -tsiso 2023-10-05T01:17:29 -ts 1696429049063279 -name manual -keep_events 5 { + EVENT -tsiso 2023-10-05T01:17:29 -ts 1696429049063338 -type install -id 600bfdac-284e-488f-b8bb-62984640f12b -source ../../modules -target . -config {-glob repo-0.1.1.tm -antiglob_file_core {*.swp *999999.0a1.0* *-buildversion.txt .punkcheck} -antiglob_file {} -antiglob_dir_core {{#*} _aside .git .fossil*} -antiglob_dir {}} + EVENT -tsiso 2023-10-05T01:19:05 -ts 1696429145153107 -type install -id cb25e965-965f-4ebb-bd3d-cac901273bf0 -source ../../../modules -target . -config {-glob repo-0.1.1.tm -antiglob_file_core {*.swp *999999.0a1.0* *-buildversion.txt .punkcheck} -antiglob_file {} -antiglob_dir_core {{#*} _aside .git .fossil*} -antiglob_dir {}} +} +FILEINFO -target punk/repo-0.1.1.tm -keep_installrecords 2 -keep_skipped 1 -keep_installing 2 { + INSTALLRECORD -tsiso 2023-10-05T01:19:05 -ts 1696429145155747 -installer manual -eventid cb25e965-965f-4ebb-bd3d-cac901273bf0 -elapsed_us 16897 { + SOURCE -type file -path ../../../modules/punk/repo-0.1.1.tm -cksum eaf21ef8df7355cfe077b1da8aeca3b4a7a9d7f7 -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 10894 + } +} \ No newline at end of file diff --git a/src/bootsupport/modules/punk/repo-0.1.0.tm b/src/bootsupport/modules/punk/repo-0.1.0.tm deleted file mode 100644 index 29b9996e..00000000 --- a/src/bootsupport/modules/punk/repo-0.1.0.tm +++ /dev/null @@ -1,814 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix 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. -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#Copyright (c) 2023 Julian Noble -#Copyright (c) 2012-2018 Andreas Kupries -# - code from A.K's 'kettle' project used in this module -# -# @@ Meta Begin -# Application punk::repo 0.1.0 -# Meta platform tcl -# Meta license BSD -# @@ Meta End - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -##e.g package require frobz - - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# -# path/repo functions -# -if {$::tcl_platform(platform) eq "windows"} { - package require punk::winpath -} else { - catch {package require punk::winpath} -} -package require cksum ;#tcllib -package require fileutil; #tcllib - - -# -- --- --- --- --- --- --- --- --- --- --- -# For performance/efficiency reasons - use file functions on paths in preference to string operations -# e.g use file join -# branch to avoid unnecessary calls to 'pwd' or 'file normalize' - which can be surprisingly expensive operations (as at tcl 8.7 2023) -# pwd is only expensive if we treat it as a string instead of a list/path -# e.g -# > time {set x [pwd]} -# 5 microsoeconds.. no problem -# > time {set x [pwd]} -# 4 microsoeconds.. still no problem -# > string length $x -# 45 -# > time {set x [pwd]} -# 1372 microseconds per iteration ;#!! values above 0.5ms common.. and that's a potential problem in loops that trawl filesystem -# The same sorts of timings occur with file normalize -# also.. even if we build up a path with file join from a base value that has already been normalized - the subsequent normalize will be expensive -# -- --- --- --- --- --- --- --- --- --- --- - -namespace eval punk::repo { - variable tmpfile_counter 0 ;#additional tmpfile collision avoidance - - proc is_fossil {{path {}}} { - if {$path eq {}} { set path [pwd] } - return [expr {[find_fossil $path] ne {}}] - } - proc is_git {{path {}}} { - if {$path eq {}} { set path [pwd] } - return [expr {[find_git $path] ne {}}] - } - #tracked repo - but may not be a project - proc is_repo {{path {}}} { - if {$path eq {}} { set path [pwd] } - return [expr {[isfossil] || [is_git]}] - } - proc is_candidate {{path {}}} { - if {$path eq {}} { set path [pwd] } - return [expr {[find_candidate $path] ne {}}] - } - proc is_project {{path {}}} { - if {$path eq {}} { set path [pwd] } - return [expr {[find_project $path] ne {}}] - } - - - proc find_fossil {{path {}}} { - if {$path eq {}} { set path [pwd] } - scanup $path is_fossil_root - } - proc find_git {{path {}}} { - if {$path eq {}} { set path [pwd] } - scanup $path is_git_root - } - proc find_candidate {{path {}}} { - if {$path eq {}} { set path [pwd] } - scanup $path is_candidate_root - } - proc find_repo {{path {}}} { - if {$path eq {}} { set path [pwd] } - #find the closest (lowest in dirtree) repository - set f_root [find_fossil $path] - set g_root [find_git $path] - if {[string length $f_root]} { - if {[string length $g_root]} { - if {[path_a_below_b $f_root $g_root]} { - return $f_root - } else { - return $g_root - } - } else { - return $f_root - } - } else { - if {[string length $g_root]} { - return $g_root - } else { - return "" - } - } - } - proc find_project {{path {}}} { - if {$path eq {}} { set path [pwd] } - scanup $path is_project_root - } - - proc is_fossil_root {{path {}}} { - if {$path eq {}} { set path [pwd] } - #from kettle::path::is.fossil - foreach control { - _FOSSIL_ - .fslckout - .fos - } { - set control $path/$control - if {[file exists $control] && [file isfile $control]} {return 1} - } - return 0 - } - proc is_git_root {{path {}}} { - if {$path eq {}} { set path [pwd] } - set control [file join $path .git] - expr {[file exists $control] && [file isdirectory $control]} - } - proc is_repo_root {{path {}}} { - if {$path eq {}} { set path [pwd] } - expr {[is_fossil_root $path] || [is_git_root $path]} - } - #require a minimum of /src and /modules|lib|scriptapps|*.vfs - and that it's otherwise sensible - proc is_candidate_root {{path {}}} { - if {$path eq {}} { set path [pwd] } - if {[file pathtype $path] eq "relative"} { - if {$::tcl_platform(platform) eq "windows"} { - set normpath [punk::repo::norm [punk::winpath::winpath $path]] - } else { - set normpath [punk::repo::norm $path] - } - } else { - set normpath $path - } - set unwise_paths [list "/" "/usr/local" "/usr/local/bin" "/usr/local/lib" "c:/windows"] - if {[string tolower $normpath] in $unwise_paths} { - return 0 - } - if {[file pathtype [string trimright $normpath /]] eq "volumerelative"} { - #tcl 8.6/8.7 cd command doesn't preserve the windows "ProviderPath" (per drive current working directory) - return 0 - } - - #review - adjust to allow symlinks to folders? - foreach required { - src - } { - set req $path/$required - if {(![file exists $req]) || ([file type $req] ne "directory") } {return 0} - } - - set src_subs [glob -nocomplain -dir $path/src -types d -tail *] - if {"modules" in $src_subs || "lib" in $src_subs || "scriptapps" in $src_subs} { - return 1 - } - foreach sub $src_subs { - if {[string match *.vfs $sub]} { - return 1 - } - } - - #todo - breadth first search with depth limit (say depth 3?) for *.tm or *.tcl as another positive qualifier for this dir to be a project-root - #we probably don't want to deep search a src folder in case the user is accidentally in some other type of project's tree - #such a src tree could be very large, so if we don't find tcl indicators near the root it's a good bet this isn't a candidate - - return 0 - } - #keep this message in sync with the programmed requirements of is_candidate_root - #message is not titled - it is intended to be output along with more contextual information from the calling site. - proc is_candidate_root_requirements_msg {} { - set msg "" - append msg "./src directory must exist." \n - append msg "At least one of ./src/lib ./src/modules ./src/scriptapps or a ./src/.vfs folder should exist." \n - #append msg "Alternatively - the presence of any .tm or .tcl files within the top few levels of ./src will suffice." \n - return $msg - } - - proc is_project_root {path} { - #review - find a reliable simple mechanism. Noting we have projects based on different templates. - #Should there be a specific required 'project' file of some sort? - - #test for file/folder items indicating fossil or git workdir base - if {(![punk::repo::is_fossil_root $path]) && (![punk::repo::is_git_root $path])} { - return 0 - } - #exclude some known places we wouldn't want to put a project - if {![is_candidate_root $path]} { - return 0 - } - return 1 - } - - proc find_roots_and_warnings_dict {path} { - set start_dir $path - - #root is a 'project' if it it meets the candidate requrements and is under repo control - #therefore if project is in the closest_types list - candidate will always be there too - and at least one of git or fossil - set root_dict [list closest {} closest_types {} fossil {} git {} candidate {} project {} warnings {}] - set msg "" - - #we're only searching in a straight path up the tree looking for a few specific marker files/folder - set fosroot [punk::repo::find_fossil $start_dir] - dict set root_dict fossil $fosroot - set gitroot [punk::repo::find_git $start_dir] - dict set root_dict git $gitroot - set candroot [punk::repo::find_candidate $start_dir] - dict set root_dict candidate $candroot - - - if {[string length $fosroot]} { - if {([string length $candroot]) && ([string tolower $fosroot] ne [string tolower $candroot])} { - - #todo - only warn if this candidate is *within* the found repo root? - append msg "**" \n - append msg "** found folder with /src at or above starting folder - that isn't the fossil root" \n - append msg "** starting folder : $start_dir" \n - append msg "** unexpected : $candroot" \n - append msg "** fossil root : $fosroot ([punk::repo::path_relative $start_dir $fosroot])" \n - append msg "** reporting based on the fossil root found." - append msg "**" \n - - } - - } else { - if {[string length $gitroot]} { - - if {([string length $candroot]) && ([string tolower $gitroot] ne [string tolower $candroot])} { - - append msg "**" \n - append msg "** found folder with /src at or above current folder - that isn't the git root" \n - append msg "** starting folder : $start_dir" \n - append msg "** unexpected : $candroot ([punk::repo::path_relative $start_dir $candroot])" \n - append msg "** git root : $gitroot ([punk::repo::path_relative $start_dir $gitroot])" \n - append msg "** reporting based on the git root found." - append msg "**" \n - - } - } else { - - } - } - - if {(![string length [dict get $root_dict fossil]])} { - append msg "Not a punk fossil project" \n - } - #don't warn if not git - unless also not fossil - if {(![string length [dict get $root_dict fossil]]) && (![string length [dict get $root_dict git]])} { - append msg "No repository located at or above starting folder $start_dir" \n - if {![string length [dict get $root_dict candidate]]} { - append msg "No candidate project root found. " \n - append msg "Searched upwards from '$start_dir' expecting a folder with the following requirements: " \n - append msg [punk::repo::is_candidate_root_requirements_msg] \n - } else { - append msg "Candidate project root found at : $candidate" \n - append msg " - consider putting this folder under fossil control (and/or git)" \n - } - } - - - - set pathinfo [list];#exclude not found - foreach repotype [list fossil git candidate] { - set path [dict get $root_dict $repotype] - if {[string length $path]} { - set plen [llength [file split $path]] - lappend pathinfo [list $repotype $path $plen] - } - } - #these root are all inline towards root of drive - so anything of same length should be same path - shorter path must be above another - #we will check equal depth paths are equal strings and raise an error just in case there are problems with the coding for the various path functions used here - #longest path is 'closest' to start_dir - set longest_first [lsort -index 2 $pathinfo] - if {![llength $longest_first]} { - #no repos or candidate - we have already created msg above - } else { - dict set root_dict closest [lindex $longest_first 0 1] ;#the *path* of the closest to start_dir - now we need to find all the types of this len - #see if others same len - set longestlen [lindex $longest_first 0 2] - set equal_longest [lsearch -all -inline -index 2 $longest_first $longestlen] - set ctypes [list] - foreach pinfo $equal_longest { - lappend ctypes [lindex $pinfo 0] - } - dict set root_dict closest_types $ctypes - } - - if {[string length [set fosroot [dict get $root_dict fossil]]] && [string length [set gitroot [dict get $root_dict git]]]} { - if {$fosroot ne $gitroot} { - if {[path_a_above_b $fosroot $gitroot]} { - append msg "Found git repo nested within fossil repo - be careful" \n - append msg "** fos root : $fosroot ([punk::repo::path_relative $start_dir $fosroot])" \n - append msg " * git root : $gitroot ([punk::repo::path_relative $start_dir $gitroot])" \n - } else { - append msg "Found fossil repo nested within git repo - be careful" \n - append msg "** git root : $gitroot ([punk::repo::path_relative $start_dir $gitroot])" \n - append msg " * fos root : $fosroot ([punk::repo::path_relative $start_dir $fosroot])" \n - - } - } - } - - - dict set root_dict warnings $msg - #some quick sanity checks.. - set ctypes [dict get $root_dict closest_types] - if {"project" in $ctypes} { - if {"candidate" ni $ctypes} { - set errmsg "find_roots_and_warnings_dict logic error: have project but not also classified as candidate (coding error in punk::repo) - inform developer\n" - append errmsg " warnings gathered before error:\n $msg" - error $errmsg - } - if {("git" ni $ctypes) && ("fossil" ni $ctypes)} { - set errmsg "find_roots_and_warnings_dict logic error: have project but not also at least one of 'git', 'fossil' (coding error in punk::repo) - inform developer\n" - append errmsg " warnings gathered before error:\n $msg" - error $errmsg - } - } - set ctype_paths [list] - foreach ctype [dict get $root_dict closest_types] { - lappend ctype_paths [lindex [dict get $root_dict $ctype] 1] ;# type, path, len - } - set unique [lsort -unique $ctype_paths] - if {[llength $unique] > 1} { - # this may be a filesystem path representation issue? case? normalisation? - set errmsg "find_roots_and_warnings_dict logic error: different paths for closest folders found (error in punk::repo) - inform developer\n" - append errmsg " warnings gathered before error:\n $msg" - error $errmsg - } - - return $root_dict - } - - #------------------------------------ - #limit to exec so full punk shell not required in scripts - proc git_revision {{path {}}} { - if {$path eq {}} { set path [pwd] } - # ::kettle::path::revision.git - do_in_path $path { - try { - #git describe will error with 'No names found' if repo has no tags - #set v [::exec {*}[auto_execok git] describe] - set v [::exec {*}[auto_execok git] rev-parse HEAD] ;# consider 'git rev-parse --short HEAD' - } on error {e o} { - set v [lindex [split [dict get $o -errorinfo] \n] 0] - } - } - return [string trim $v] - } - proc git_remote {{path {{}}}} { - if {$path eq {}} { set path [pwd] } - do_in_path $path { - try { - #git describe will error with 'No names found' if repo has no tags - #set v [::exec {*}[auto_execok git] describe] - set v [::exec {*}[auto_execok git] -remote -v] ;# consider 'git rev-parse --short HEAD' - } on error {e o} { - set v [lindex [split [dict get $o -errorinfo] \n] 0] - } - } - return [string trim $v] - } - - proc fossil_revision {{path {}}} { - if {$path eq {}} { set path [pwd] } - # ::kettle::path::revision.fossil - set fossilcmd [auto_execok fossil] - if {[llength $fossilcmd]} { - do_in_path $path { - set info [::exec {*}$fossilcmd info] - } - return [lindex [grep {checkout:*} $info] 0 1] - } else { - return Unknown - } - } - - proc fossil_remote {{path {}}} { - if {$path eq {}} { set path [pwd] } - # ::kettle::path::revision.fossil - set fossilcmd [auto_execok fossil] - if {[llength $fossilcmd]} { - do_in_path $path { - set info [::exec {*}$fossilcmd remote ls] - } - return [string trim $v] - } else { - return Unknown - } - } - #------------------------------------ - - proc cksum_path_content {path args} { - dict set args -cksum_content 1 - dict set args -cksum_meta 0 - tailcall cksum_path $path {*}args - } - #for full cksum - using tar could reduce number of hashes to be made.. - #but as it stores metadata such as permission - we don't know if/how the archive will vary based on platform/filesystem - #-noperms only available on extraction - so that doesn't help - #Needs to operate on non-existant paths and return empty string in cksum field - proc cksum_path {path args} { - if {$path eq {}} { set path [pwd] } - if {[file pathtype $path] eq "relative"} { - set path [file normalize $path] - } - set base [file dirname $path] - set startdir [pwd] - - set defaults [list -cksum_content 1 -cksum_meta 1 -cksum_acls 0 -use_tar 1] - set opts [dict merge $defaults $args] - if {![file exists $path]} { - return [list cksum "" opts $opts] - } - - - - set opt_cksum_acls [dict get $opts -cksum_acls] - if {$opt_cksum_acls} { - puts stderr "cksum_path is not yet able to cksum ACLs" - return - } - set opt_cksum_meta [dict get $opts -cksum_meta] - if {$opt_cksum_meta} { - - } else { - if {[file type $path] ne "file"} { - puts stderr "cksum_path doesn't yet support a content-only cksum of a folder structure. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1" - return [list error unsupported opts $opts] - } - } - set opt_use_tar [dict get $opts -use_tar] - if {$opt_use_tar} { - package require tar ;#from tcllib - } else { - if {[file type $path] eq "directory"} { - puts stderr "cksum_path doesn't yet support -use_tar 0 for folders" - return [list error unsupported opts $opts] - } - } - - if {$path eq $base} { - #attempting to cksum at root/volume level of a filesystem.. extra work - #This needs fixing for general use.. not necessarily just for project repos - puts stderr "cksum_path doesn't yet support cksum of entire volume. (todo)" - return [list error unsupported opts $opts] - } - set cksum "" - if {$opt_use_tar} { - set target [file tail $path] - set tmplocation [tmpdir] - set archivename $tmplocation/[tmpfile].tar - - cd $base ;#cd is process-wide.. keep cd in effect for as small a scope as possible. (review for thread issues) - - #temp emission to stdout.. todo - repl telemetry channel - puts stdout "cksum_path: creating temporary tar archive at: $archivename .." - tar::create $archivename $target - puts stdout "cksum_path: calculating cksum for $target (size [file size $target])..." - set cksum [crc::cksum -format 0x%X -file $archivename] - puts stdout "cksum_path: cleaning up.. " - file delete -force $archivename - cd $startdir - - } else { - #todo - if {[file type $path] eq "file"} { - if {$opt_cksum_meta} { - return [list error unsupported opts $opts] - } else { - set cksum [crc::cksum -format 0x%X -file $path] - } - } else { - error "cksum_path unsupported $opts for path type [file type $path]" - } - } - set result [dict create] - dict set result cksum $cksum - dict set result opts $opts - return $result - } - #temporarily cd to workpath to run script - return to correct path even on failure - proc do_in_path {path script} { - #from ::kettle::path::in - set here [pwd] - try { - cd $path - uplevel 1 $script - } finally { - cd $here - } - } - proc scanup {path cmd} { - if {$path eq {}} { set path [pwd] } - #based on kettle::path::scanup - if {[file pathtype $path] eq "relative"} { - set path [file normalize $path] - } - while {1} { - # Found the proper directory, per the predicate. - if {[{*}$cmd $path]} { return $path } - - # Not found, walk to parent - set new [file dirname $path] - - # Stop when reaching the root. - if {$new eq $path} { return {} } - if {$new eq {}} { return {} } - - # Ok, truly walk up. - set path $new - } - return {} - } - #get content part of content/zip delimited by special \x1a (ctrl-z) char as used in tarjr and kettle::path::c/z - proc c/z {content} { - return [lindex [split $content \x1A] 0] - } - proc grep {pattern data} { - set data [string map [list \r\n \n] $data] - return [lsearch -all -inline -glob [split $data \n] $pattern] - } - - proc rgrep {pattern data} { - set data [string map [list \r\n \n] $data] - return [lsearch -all -inline -regexp [split $data \n] $pattern] - } - - proc tmpfile {{prefix tmp_}} { - #note risk of collision if pregenerating a list of tmpfile names - #we will maintain an icrementing id so the caller doesn't have to bear that in mind - variable tmpfile_counter - global tcl_platform - return .punkrepo_$prefix[pid]_[clock microseconds]_[incr tmpfile_counter]_[info hostname]_$tcl_platform(user) - } - - proc tmpdir {} { - # Taken from tcllib fileutil. - global tcl_platform env - - set attempdirs [list] - set problems {} - - foreach tmp {TMPDIR TEMP TMP} { - if { [info exists env($tmp)] } { - lappend attempdirs $env($tmp) - } else { - lappend problems "No environment variable $tmp" - } - } - - switch $tcl_platform(platform) { - windows { - lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP" - } - macintosh { - lappend attempdirs $env(TRASH_FOLDER) ;# a better place? - } - default { - lappend attempdirs \ - [file join / tmp] \ - [file join / var tmp] \ - [file join / usr tmp] - } - } - - lappend attempdirs [pwd] - - foreach tmp $attempdirs { - if { [file isdirectory $tmp] && - [file writable $tmp] } { - return [file normalize $tmp] - } elseif { ![file isdirectory $tmp] } { - lappend problems "Not a directory: $tmp" - } else { - lappend problems "Not writable: $tmp" - } - } - - # Fail if nothing worked. - return -code error "Unable to determine a proper directory for temporary files\n[join $problems \n]" - } - - #todo - review - proc ensure-cleanup {path} { - #::atexit [lambda {path} { - #file delete -force $path - #} [norm $path]] - - file delete -force $path - } - - proc path_relative {base dst} { - #see also kettle - # Modified copy of ::fileutil::relative (tcllib) - # Adapted to 8.5 ({*}). - # - # Taking two _directory_ paths, a base and a destination, computes the path - # of the destination relative to the base. - # - # Arguments: - # base The path to make the destination relative to. - # dst The destination path - # - # Results: - # The path of the destination, relative to the base. - - # Ensure that the link to directory 'dst' is properly done relative to - # the directory 'base'. - - if {[file pathtype $base] ne [file pathtype $dst]} { - return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)" - } - - set base [norm $base] - set dst [norm $dst] - - set save $dst - set base [file split $base] - set dst [file split $dst] - - while {[lindex $dst 0] eq [lindex $base 0]} { - set dst [lrange $dst 1 end] - set base [lrange $base 1 end] - if {![llength $dst]} {break} - } - - set dstlen [llength $dst] - set baselen [llength $base] - - if {($dstlen == 0) && ($baselen == 0)} { - # Cases: - # (a) base == dst - - set dst . - } else { - # Cases: - # (b) base is: base/sub = sub - # dst is: base = {} - - # (c) base is: base = {} - # dst is: base/sub = sub - - while {$baselen > 0} { - set dst [linsert $dst 0 ..] - incr baselen -1 - } - set dst [file join {*}$dst] - } - - return $dst - } - - #literate-programming style naming for some path tests - #Note the naming of the operator portion of a_op_b is consistent in that it is the higher side of the filesystem tree first. - #hence aboveorat vs atorbelow - #These names also sort in the logical order of higher to lower in the filesystem (when considering the root as 'higher' in the filesystem) - proc path_a_above_b {path_a path_b} { - #stripPath prefix path - return [expr {[fileutil::stripPath $path_a $path_b] ni [list . $path_b]}] - } - proc path_a_aboveorat_b {path_a path_b} { - return [expr {[fileutil::stripPath $path_a $path_b] ne $path_b}] - } - proc path_a_at_b {path_a path_b} { - return [expr {[fileutil::stripPath $path_a $path_b] eq "." }] - } - proc path_a_atorbelow_b {path_a path_b} { - return [expr {[fileutil::stripPath $path_b $path_a] ne $path_a}] - } - proc path_a_below_b {path_a path_b} { - return [expr {[fileutil::stripPath $path_b $path_a] ni [list . $path_a]}] - } - proc path_a_inlinewith_b {path_a path_b} { - return [expr {[path_a_aboveorat_b $path_a $path_b] || [path_a_below_b $path_a $path_b]}] - } - - #whether path is at and/or below one of the vfs mount points - #The design should facilitate nested vfs mountpoints - proc path_vfs_info {filepath} { - - } - - #file normalize is expensive so this is too - proc norm {path {platform env}} { - #kettle::path::norm - #see also wiki - #full path normalization - - set platform [string tolower $platform] - if {$platform eq "env"} { - set platform $::tcl_platform(platform) - } - if {$platform eq "windows"} { - return [file dirname [file normalize [punk::winpath::winpath $path]/__]] - } else { - return [file dirname [file normalize $path/__]] - } - } - - #This taken from kettle::path::strip - #It doesn't compare the prefix contents presumably for speed when used in kettle::path::scan - #renamed to better indicate its behaviour - - proc path_strip_prefixdepth {path prefix} { - return [file join \ - {*}[lrange \ - [file split [norm $path]] \ - [llength [file split [norm $prefix]]] \ - end]] - } - #MUCH faster version for absolute path prefix (pre-normalized) - proc path_strip_alreadynormalized_prefixdepth {path prefix} { - return [file join \ - {*}[lrange \ - [file split $path] \ - [llength [file split $prefix]] \ - end]] - } - - proc fcat {args} { - if {$::tcl_platform(platform) ne "windows"} { - return [fileutil::cat {*}$args] - } - - set knownopts [list -eofchar -translation -encoding --] - set last_opt 0 - for {set i 0} {$i < [llength $args]} {incr i} { - set ival [lindex $args $i] - #puts stdout "i:$i a: $ival known: [expr {$ival in $knownopts}]" - if {$ival eq "--"} { - set last_opt $i - break - } else { - if {$ival in $knownopts} { - #puts ">known at $i : [lindex $args $i]" - if {($i % 2) != 0} { - error "unexpected option at index $i. known options: $knownopts must come in -opt val pairs." - } - incr i - set last_opt $i - } else { - set last_opt [expr {$i - 1}] - break - } - } - } - set first_non_opt [expr {$last_opt + 1}] - - #puts stderr "first_non_opt: $first_non_opt" - set opts [lrange $args -1 $first_non_opt-1] - set paths [lrange $args $first_non_opt end] - if {![llength $paths]} { - error "Unable to find file in the supplied arguments: $args. Ensure options are all -opt val pairs and that file name(s) follow" - } - #puts stderr "opts: $opts paths: $paths" - set finalpaths [list] - foreach p $paths { - if {[punk::winpath::illegalname_test $p]} { - lappend finalpaths [punk::winpath::illegalname_fix $p] - } else { - lappend finalpaths $p - } - } - fileutil::cat {*}$opts {*}$finalpaths - } - - interp alias {} is_fossil {} ::punk::repo::is_fossil - interp alias {} is_fossil_root {} ::punk::repo::is_fossil_root - interp alias {} find_fossil {} ::punk::repo::find_fossil - interp alias {} fossil_revision {} ::punk::repo::fossil_revision - interp alias {} is_git {} ::punk::repo::is_git - interp alias {} is_git_root {} ::punk::repo::is_git_root - interp alias {} find_git {} ::punk::repo::find_git - interp alias {} git_revision {} ::punk::repo::git_revision - - - interp alias {} gs {} git status -sb - interp alias {} gr {} ::punk::repo::git_revision - interp alias {} gl {} git log --oneline --decorate ;#decorate so stdout consistent with what we see on console - interp alias {} glast {} git log -1 HEAD --stat - interp alias {} gconf {} git config --global -l - -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::repo [namespace eval punk::repo { - variable version - set version 0.1.0 -}] -return diff --git a/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/bootsupport/modules/punk/repo-0.1.1.tm index 0751cccd..bc218fca 100644 --- a/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -388,6 +388,8 @@ namespace eval punk::repo { #set checkrevision [fossil_revision $abspath] + dict set resultdict ahead "" + dict set resultdict behind "" foreach ln [split $fossilstate \n] { if {[string trim $ln] eq ""} {continue} @@ -439,6 +441,18 @@ namespace eval punk::repo { puts stderr "workingdir_state: git revision is (initial) - no file state to gather" break } + dict set resultdict ahead "" + dict set resultdict behind "" + set aheadbehind [lindex [grep {# branch.ab *} $gitstate] 0] + if {[llength $aheadbehind] > 0} { + lassign [lrange $aheadbehind 2 3] a b + if {$a > 0} { + dict set resultdict ahead [expr {abs($a)}] + } + if {$b < 0} { + dict set resultdict behind [expr {abs($b)}] + } + } #set checkrevision [git_revision $abspath] if {[catch {punk::mix::util::do_in_path $repodir [list exec {*}$git_cmd ls-tree -r $revision $abspath]} gitfiles]} { error "workingdir_state error: Unable to retrieve files for revision '$revision' using git. Errormsg: $gitfiles" @@ -519,7 +533,7 @@ namespace eval punk::repo { } package require overtype set defaults [dict create\ - -fields {unchanged changed new missing extra}\ + -fields {ahead behind unchanged changed new missing extra}\ ] set opts [dict merge $defaults $args] # -- --- --- --- --- --- --- --- --- --- @@ -532,6 +546,8 @@ namespace eval punk::repo { repodir repodir\ subpath subpath\ revision revision\ + ahead ahead\ + behind behind\ repotype repotype\ unchanged unchanged\ changed changed\ @@ -573,7 +589,7 @@ namespace eval punk::repo { } set filestates [dict values [dict get $repostate paths]] set path_count_fields [list unchanged changed new missing extra] - set state_fields [list repodir subpath repotype revision] + set state_fields [list ahead behind repodir subpath repotype revision] set dresult [dict create] foreach f $state_fields { dict set dresult $f [dict get $repostate $f] @@ -1143,6 +1159,25 @@ namespace eval punk::repo { [llength [file split $prefix]] \ end]] } + #fs agnostic - so file normalize must be done by caller + proc strip_if_prefix {prefix path args} { + set known_opts [list -nocase] + set opts [list] + foreach a $args { + lappend opts [tcl::prefix match -message "option" $known_opts $a] + } + if {"-nocase" in $opts} { + set lp [tcl::prefix longest [string tolower $path] [string tolower $prefix]] + } else { + set lp [tcl::prefix longest $path $prefix] + } + #return in original casing whether or not -nocase specified. -nocase only applies to the comparison + if {![llength $lp]} { + return $path + } else { + return [string range $path [string length $prefix] end] + } + } interp alias {} is_fossil {} ::punk::repo::is_fossil diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index ce85efc9..f3d7b1dd 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -5090,49 +5090,215 @@ namespace eval punk { } interp alias {} ~ {} punk::~ + #JMN + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values + #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. + #only supports -flag val pairs, not solo options + proc get_leading_opts_and_values {defaults rawargs} { + if {[set eopts [lsearch $rawargs "--"]] >= 0} { + set values [lrange $rawargs $eopts+1 end] + set arglist [lrange $rawargs 0 $eopts-1] + } else { + if {[lsearch $rawargs -*] >= 0} { + #to support option values with leading dash e.g -offset -1 , we can't just take the last flagindex + set i 0 + foreach {k v} $rawargs { + if {![string match -* $k]} { + break + } + incr i 2 + } + set arglist [lrange $rawargs 0 $i-1] + set values [lrange $rawargs $i end] + } else { + set values $rawargs ;#no -flags detected + set arglist [list] + } + } + set checked_args [dict create] + set caller [lindex [dict get [info frame -2] cmd] 0] ;#hopefully first word is a plain proc name if this function was called in the normal manner - directly from a proc + for {set i 0} {$i < [llength $arglist]} {incr i} { + #allow this to error out with message indicating expected flags + dict set checked_args [tcl::prefix match -message "$caller option" [dict keys $defaults] [lindex $arglist $i]] [lindex $arglist $i+1] + incr i ;#skip val + } + set opts [dict merge $defaults $checked_args] + + #maintain order of opts $opts values $values as caller may use lassign. + return [dict create opts $opts values $values] + } + + proc dirlist {{location ""}} { + set contents [dirfiles_dict $location] + return [dirfiles_dict_as_lines $contents -stripbase 1] + } + + #dirfiles dirfiles_dict always deliberately return absolute *unnormalized* path + #e.g when cwd is c:/repo/jn/shellspy dirfiles ../../ will return something like: + # c:/repo/jn/shellspy/../../blah + #dirfiles assumes we don't have glob chars in the filenames or paths - dirfiles_dict can be called directly with explicit -tailglob in the rare case that assumption doesn't hold + # dirfiles will test last segment (tail) of supplied searchspecs for fileness vs folderness (when no globchars present in tail) so that it can pass the appropriate flags downstream + proc dirfiles {args} { + set defaults [list\ + -stripbase 1\ + ] + lassign [dict values [get_leading_opts_and_values $defaults $args]] opts searchspecs ;#implicit merge of opts over defaults + + set opt_stripbase [dict get $opts -stripbase] + + #todo - support multiple - dirfiles_dict should merge results when same folder + set searchspec [lindex $searchspecs 0] + + set relativepath [expr {[file pathtype $searchspec] eq "relative"}] + set has_tailglobs [regexp {[?*]} [file tail $searchspec]] + + #dirfiles_dict would handle simple cases of globs within paths anyway - but we need to explicitly set tailglob here in all branches so that next level doesn't need to do file vs dir checks to determine user intent. + #(dir-listing vs file-info when no glob-chars present is inherently ambiguous so we test file vs dir to make an assumption - more explicit control via -tailglob can be done manually with dirfiles_dict) + if {$relativepath} { + set searchbase [pwd] + if {!$has_tailglobs} { + if {[file isdirectory [file join $searchbase $searchspec]]} { + set location [file join $searchbase $searchspec] + set tailglob * + } else { + set location [file dirname [file join $searchbase $searchspec]] + set tailglob [file tail $searchspec] ;#use exact match as a glob - will retrieve size,attributes etc. + } + } else { + #tailglobs exist - and we operate under assumption globchars aren't present in file/folder names - so no folderness/fileness check needed. + set location [file dirname [file join $searchbase $searchspec]] + set tailglob [file tail $searchspec] + } + } else { + #for absolute paths - searchbase AND location will change depending on globiness of tail and fileness vs folderness + if {!$has_tailglobs} { + if {[file isdirectory $searchspec]} { + set searchbase $searchspec + set location $searchspec + set tailglob * + } else { + set searchbase [file dirname $searchspec] + set location [file dirname $searchspec] + set tailglob [file tail $searchspec] ;#literal glob for single file - retrieves properties + } + } else { + set searchbase [file dirname $searchspec] + set location [file dirname $searchspec] + set tailglob [file tail $searchspec] + } + } + puts "-->location:$location" + set contents [dirfiles_dict -searchbase $searchbase -tailglob $tailglob $location] + return [dirfiles_dict_as_lines $contents {*}$opts] + } #todo - package as punk::navdir #todo - in thread #todo - streaming version - proc dirfiles_dict {{searchspec ""}} { - package require vfs - #we don't want to normalize.. - #for example if the user supplies ../ we want to see ../result - if {[file pathtype $searchspec] eq "relative"} { - set searchbase [pwd] - set listingfor [file join $searchbase $searchspec] - } else { - set searchbase "" - set listingfor $searchspec + #glob patterns in path prior to final segment should already be resolved before using dirfiles_dict - as the underlying filesystem mechanisms can't do nested globbing themselves. + #dirfiles_dict will assume the path up to the final segment is literal even if globchars are included therein. + #final segment globs will be recognised only if -tailglob is passed as empty string + #if -tailglob not supplied and last segment has globchars - presume searchspec parendir is the container and last segment is globbing within that. + #if -tailglob not supplied and last segment has no globchars - presume searchspec is a container(directory) and use glob * + #caller should use parentdir as location and set tailglob to search-pattern or exact match if location is intended to match a file rather than a directory + #examples: + # somewhere/files = search is effectively somewhere/files/* (location somewhere/files glob is *) + # somewhere/files/* = (as above) + # -tailglob * somewhere/files = (as above) + # + # -tailglob "" somewhere/files = search somewhere folder for exactly 'files' (location somewhere glob is files) + # -tailglob files somewhere = (as above) + # + # somewhere/f* = search somewhere folder for f* (location somewhere glob is f*) + # -tailglob f* somewhere = (as above) + # + # This somewhat clumsy API is so that simple searches can be made in a default sensible manner without requiring extra -tailglob argument for the common cases - with lack of trailing glob segment indicating a directory listing + # - but we need to distinguish somewhere/files as a search of that folder vs somewhere/files as a search for exactly 'files' within somewhere, hence the -tailglob option to fine-tune. + # - this also in theory allows file/directory names to contain glob chars - although this is probably unlikely and/or unwise and not likely to be usable on all platforms. + # + #if caller supplies a tailglob as empty string - presume the caller hasn't set location to parentdir - and that last element is the search pattern. + # -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied + proc dirfiles_dict {args} { + set defaults [dict create\ + -searchbase ""\ + -tailglob "\uFFFF"\ + ] + lassign [dict values [get_leading_opts_and_values $defaults $args]] opts searchspecs + + puts stderr "searchspecs: $searchspecs [llength $searchspecs]" + puts stdout "arglist: $opts" + + if {[llength $searchspecs] > 1} { + #review - spaced paths ? + error "dirfiles_dict: multiple listing not *yet* supported" } + set searchspec [lindex $searchspecs 0] + # -- --- --- --- --- --- --- + set opt_searchbase [dict get $opts -searchbase] + set opt_glob [dict get $opts -tailglob] + # -- --- --- --- --- --- --- - set ftail [file tail $listingfor] + #we don't want to normalize.. + #for example if the user supplies ../ we want to see ../result - if {[string first ? $ftail] >= 0 || [string first * $ftail] >=0} { - #has globchar (we only recognise as glob in tail) - set location [file dirname $listingfor] - set glob $ftail + set relativepath [expr {[file pathtype $searchspec] eq "relative"}] + set searchbase $opt_searchbase + if {$opt_glob eq ""} { + if {$relativepath} { + set location [file dirname [file join $searchbase $searchspec]] + } else { + set location [file dirname $searchspec] + } + #here tail is treated as a search-pattern within location whether or not it contains glob chars "?" or "*" + set glob [file tail $searchspec] } else { - set location $listingfor - set glob * + set tail [file tail $searchspec] + set tail_has_globs [regexp {[*?]} $tail] + + if {$opt_glob eq "\uFFFF"} { + if {$tail_has_globs} { + if {$relativepath} { + set location [file dirname [file join $searchbase $searchspec]] + } else { + set location [file dirname $searchspec] + } + set glob [file tail $searchspec] + } else { + #user didn't supply a glob within tail segment, nor did they specify a separate -tailglob - presume they want a directory listing + if {$relativepath} { + set location [file join $searchbase $searchspec] + } else { + set location $searchspec + } + set glob * + } + } else { + #-tailglob supplied separately - ignore any globiness in tail segment of searchspec and treat literally + if {$relativepath} { + set location [file join $searchbase $searchspec] + } else { + set location $searchspec + } + set glob $opt_glob + } } set in_vfs 0 - foreach mount [vfs::filesystem info] { - if {[punk::mix::base::lib::path_a_atorbelow_b $location $mount]} { - set in_vfs 1 - break + if {![catch {package require vfs} errM]} { + foreach mount [vfs::filesystem info] { + if {[punk::mix::base::lib::path_a_atorbelow_b $location $mount]} { + set in_vfs 1 + break + } } } + if {$in_vfs} { set listing [punk::du::lib::du_dirlisting_tclvfs $location -glob $glob -with_sizes f -with_times 1] } else { set listing [punk::du::dirlisting $location -glob $glob -with_sizes f -with_times 1] } - - - #set dirs [glob -nocomplain -directory $location -type d -tail $glob] set dirs [dict get $listing dirs] set files [dict get $listing files] set filesizes [dict get $listing filesizes] @@ -5210,12 +5376,11 @@ namespace eval punk { lappend nonportable $nm } } + set front_of_dict [dict create location $location searchbase $searchbase] + set listing [dict merge $front_of_dict $listing] - set updated [dict create dirs $dirs files $files filesizes $filesizes nonportable $nonportable flaggedhidden $flaggedhidden underlayfiles $underlayfiles underlayfilesizes $underlayfilesizes location $location searchbase $searchbase] - - + set updated [dict create dirs $dirs files $files filesizes $filesizes nonportable $nonportable flaggedhidden $flaggedhidden underlayfiles $underlayfiles underlayfilesizes $underlayfilesizes] return [dict merge $listing $updated] - #return [list dirs $dirs vfsmounts $vfsmounts files $files filesizes $filesizes underlayfiles $underlayfiles underlayfilesizes $underlayfilesizes nonportable $nonportable flaggedhidden $flaggedhidden flaggedsystem $flaggedsystem location $location searchbase $searchbase] } #todo - color key via repl-telemetry? help command? documentation? or add tag columns as done in namespace listing? @@ -5224,12 +5389,14 @@ namespace eval punk { -stripbase 0\ ] set known_opts [dict keys $defaults] - foreach k [dict keys $args] { - if {$k ni $known_opts} { - error "dirfiles_dict_as_lines unknown argument $k. Known options: $known_opts" - } - } - set opts [dict merge $defaults $args] + set testedargs [dict create] + foreach {k v} $args { + dict set testedargs [tcl::prefix match -message "dirfiles_dict_as_lines option" $known_opts $k] $v + #if {$k ni $known_opts} { + # error "dirfiles_dict_as_lines unknown argument $k. Known options: $known_opts" + #} + } + set opts [dict merge $defaults $testedargs] # -- --- --- --- --- --- --- --- --- --- --- --- set opt_stripbase [dict get $opts -stripbase] # -- --- --- --- --- --- --- --- --- --- --- --- @@ -5327,25 +5494,6 @@ namespace eval punk { return [list_as_lines $displaylist] } - proc dirlist {{location ""}} { - set contents [dirfiles_dict $location] - return [dirfiles_dict_as_lines $contents -stripbase 1] - } - - #dirfiles dirfiles_dict always deliberately return absolute *unnormalized* path - #e.g when cwd is c:/repo/jn/shellspy dirfiles ../../ will return something like: - # c:/repo/jn/shellspy/../../blah - proc dirfiles {{location ""} args} { - set defaults [list\ - -stripbase 0\ - ] - if {$location in [dict keys $defaults]} { - set args [list $location {*}$args] - set location "" - } - set contents [dirfiles_dict $location] - return [dirfiles_dict_as_lines $contents {*}$args] - } @@ -5525,7 +5673,102 @@ namespace eval punk { } } + #run a file + proc x/ {args} { + if {![llength $args]} { + set result [d/] + append result \n "x/ ?args?" + return $result + } + set curdir [pwd] + #todo - allow wish for those who want it.. but in punk we try to use tclsh or a kit and load Tk as a library + set scriptconfig [dict create\ + tcl [list exe tclsh extensions [list ".tcl" ".tm" ".tk" ".kit"]]\ + python [list exe python extensions [list ".py"]]\ + lua [list exe lua extensions [list ".lua"]]\ + perl [list exe perl extensions [list ".pl"]]\ + php [list exe php extensions [list ".php"]]\ + ] + set tcl_extensions [list ".tcl" ".tm" ".kit" ".tk"] ;#todo - load from config + set py_extensions [list ".py"] + set lua_extensions [list ".lua"] + set perl_extensions [list ".pl"] + + set script_extensions [list] + set extension_lookup [dict create] + dict for {lang langinfo} $scriptconfig { + set extensions [dict get $langinfo extensions] + lappend script_extensions {*}$extensions + foreach e $extensions { + dict set extension_lookup $e $lang ;#provide reverse lookup + } + } + + #some executables (e.g tcl) can use arguments prior to the script + #use first entry on commandline for which a file exists *and has a script extension - or is executable* as the script to run + #we can't always just assume that first existant file on commandline is the one being run, as it might be config file + #e.g php -c php.ini -f script.php + set scriptlang "" + set scriptfile "" + foreach a $args { + set ext [file extension $a] + if {$ext in $script_extensions && [file exists $a]} { + set scriptlang [dict get $extension_lookup $ext] + set scriptfile $a + break + } + } + puts "scriptlang: $scriptlang scriptfile:$scriptfile" + #todo - allow sh scripts with no extension ... look at shebang etc? + if {$scriptfile ne "" && $scriptlang ne ""} { + set path [path_to_absolute $scriptfile $curdir $::tcl_platform(platform)] + if {[file type $path] eq "file"} { + set ext [file extension $path] + set extlower [string tolower $ext] + if {$extlower in $tcl_extensions} { + set newargs [lrange $args 1 end] ;#todo - fix to allow script in position other than first + set ::argv0 $path + set ::argc [llength $newargs] + set ::argv $newargs + tailcall source $path + } elseif {$extlower in $py_extensions} { + set pycmd [auto_execok python] + tailcall {*}$pycmd {*}$args + } elseif {$extlower in $script_extensions} { + set exename [dict get $scriptconfig $scriptlang exe] + set cmd [auto_execok $exename] + tailcall {*}$cmd $args + } else { + set fd [open $path r] + set chunk [read $fd 4000]; close $fd + #consider any commented line near top of file containing 'tcl' as likely to be a tcl script of some sort and attempt to source it. + set toplines [split $chunk \n] + set tcl_indicator 0 + foreach ln $toplines { + set ln [string trim $ln] + if {[string match "#*tcl*" $ln]} { + set tcl_indicator 1 + break + } + } + if {$tcl_indicator} { + set newargs [lrange $args 1 end] ;#todo - fix to allow script in position other than first. + set ::argv0 $path + set ::argc [llength $newargs] + set ::argv $newargs + tailcall source $path + } + puts stderr "Cannot run [file extension $path] file directly ([file tail $path]) as tcl script. Ensure file has a known tcl extension ($tcl_extensions) or add a commented hint in the file such as #!/usr/bin/env tclsh" + return [pwd] + } + } + } else { + puts stderr "No script executable known for this" + } + + } + interp alias "" x/ "" punk::x/ #NOTE - as we expect to run other apps (e.g Tk) in the same process, but possibly different threads - we should be careful about use of cd which is per-process not per-thread. @@ -5543,6 +5786,7 @@ namespace eval punk { #While in most/normal cases the library will cd back to the remembered working directory after only a brief time - there seem to be many opportunities for issues #if the repl is used to launch/run a number of things in the one process proc d/ {args} { + #JMN set is_win [expr {"windows" eq $::tcl_platform(platform)}] set ::punk::last_run_display [list] @@ -5555,16 +5799,13 @@ namespace eval punk { if {![llength $args]} { #ls is too slow even over a fairly low-latency network #set out [runout -n ls -aFC] - set matchinfo [punk::dirfiles_dict] + set matchinfo [punk::dirfiles_dict -searchbase [pwd]] set dircount [llength [dict get $matchinfo dirs]] set filecount [llength [dict get $matchinfo files]] #set location [file normalize [dict get $matchinfo location]] set location [dict get $matchinfo location] - - - #result for glob is count of matches - use dirfiles etc for script access to results set result [list location $location dircount $dircount filecount $filecount] set filesizes [dict get $matchinfo filesizes] @@ -5574,105 +5815,133 @@ namespace eval punk { lappend result filebytes [format_number $filebytes] } if {$::repl::running} { - set out [punk::dirfiles_dict_as_lines $matchinfo -stripbase 1] + if {[llength [info commands ::repl::term::set_console_title]]} { + repl::term::set_console_title [lrange $result 1 end] ;#strip location key + } + set out [punk::dirfiles_dict_as_lines $matchinfo -stripbase 1] #puts stdout $out #puts stderr [a+ white]$out[a] set chunklist [list] lappend chunklist [list stdout "[a+ white light]$out[a]\n"] lappend chunklist [list result $result] set ::punk::last_run_display $chunklist - if {[llength [info commands ::repl::term::set_console_title]]} { - repl::term::set_console_title $location - } } return $result } else { - #set a1 [lindex $args 0] set atail [lassign $args a1] - if {$a1 in [list . .. "./" "../"]} { - if {$a1 in [list ".." "../"]} { - cd $a1 + if {[llength $args] == 1} { + set a1 [lindex $args 0] + if {$a1 in [list . .. "./" "../"]} { + if {$a1 in [list ".." "../"]} { + cd $a1 + } + tailcall punk::d/ + } + if {![regexp {[*?]} $a1]} { + if {[file type $a1] eq "directory"} { + cd $a1 + tailcall punk::d/ + } } - tailcall punk::d/ {*}$atail } - set curdir [pwd] - set path [path_to_absolute $a1 $curdir $::tcl_platform(platform)] - if {![llength $atail] && [regexp {[*?]} $path] } { - #no more segments and we have a globchar somewhere in the path - set matchinfo [punk::dirfiles_dict [file tail $path]] - set dircount [llength [dict get $matchinfo dirs]] - set filecount [llength [dict get $matchinfo files]] + #globchar somewhere in path - treated as literals except in final segment (for now. todo - make more like ns/ which accepts full path globbing with double ** etc.) + + set searchspec [lindex $args 0] + + set result "" + if {$::repl::running} { + set chunklist [list] + } + #only merge results if location matches previous (caller can deliberately intersperse bogus globs to force split if desired) + set last_location "" + set this_result [dict create] + foreach searchspec $args { + set path [path_to_absolute $searchspec $curdir $::tcl_platform(platform)] + set has_tailglob [expr {[regexp {[?*]} [file tail $path]]}] + #we have already done a 'cd' if only one unglobbed path was supplied - therefore any remaining non-glob tails must be tested for folderness vs fileness to see what they mean + #this may be slightly surprising if user tries to exactly match both a directory name and a file in that the dir will be listed - but is consistent enough. + #lower level dirfiles or dirfiles_dict can be used to more precisely craft searches. ( d/ will treat dir the same as dir/*) + if {$has_tailglob} { + set location [file dirname $path] + set glob [file tail $path] + } else { + if {[file isdirectory $path]} { + set location $path + set glob * + } else { + set location [file dirname $path] + set glob [file tail $path] ;#search for exact match file + } + } + + if {[file pathtype $searchspec] eq "absolute"} { + set matchinfo [punk::dirfiles_dict -searchbase "" -tailglob $glob $location] + } else { + set matchinfo [punk::dirfiles_dict -searchbase [pwd] -tailglob $glob $location] + } set location [file normalize [dict get $matchinfo location]] + if {$location ne $last_location} { + #emit previous result + if {[dict size $this_result]} { + dict set this_result filebytes [format_number [dict get $this_result filebytes]] + lappend chunklist [list result $this_result] + if {$result ne ""} { + append result \n + } + append result $this_result + } + set this_result [dict create] + set dircount 0 + set filecount 0 + } + incr dircount [llength [dict get $matchinfo dirs]] + incr filecount [llength [dict get $matchinfo files]] + #result for glob is count of matches - use dirfiles etc for script access to results - set result [list location $location dircount $dircount filecount $filecount] + dict set this_result location $location + dict set this_result dircount $dircount + dict set this_result filecount $filecount + set filesizes [dict get $matchinfo filesizes] if {[llength $filesizes]} { set filesizes [lsearch -all -inline -not $filesizes na] set filebytes [tcl::mathop::+ {*}$filesizes] - lappend result filebytes [format_number $filebytes] - } + dict incr this_result filebytes $filebytes + } else { + dict incr this_result filebytes 0 ;#ensure key exists! + } + dict lappend this_result pattern [dict get $matchinfo opts -glob] if {$::repl::running} { set out [punk::dirfiles_dict_as_lines $matchinfo -stripbase 1] - set chunklist [list] lappend chunklist [list stdout "[a+ white light]$out[a]\n"] - lappend chunklist [list result $result] - set ::punk::last_run_display $chunklist - - repl::term::set_console_title $location } - return $result - } - if {[file type $path] eq "file"} { - set tcl_extensions [list ".tcl" ".tm" ".kit" ".tk"] ;#todo - load from config - set py_extensions [list ".py"] - set ext [file extension $path] - set extlower [string tolower $ext] - if {$extlower in $tcl_extensions} { - set newargs $atail - set ::argv0 $path - set ::argc [llength $newargs] - set ::argv $newargs - tailcall source $path - } elseif {$extlower in $py_extensions} { - set newargs $atail - set pycmd [auto_execok python] - tailcall {*}$pycmd $path {*}$newargs - } else { - set fd [open $path r] - set chunk [read $fd 4000]; close $fd - #consider any commented line near top of file containing 'tcl' as likely to be a tcl script of some sort and attempt to source it. - set toplines [split $chunk \n] - set tcl_indicator 0 - foreach ln $toplines { - set ln [string trim $ln] - if {[string match "#*tcl*" $ln]} { - set tcl_indicator 1 - break - } - } - if {$tcl_indicator} { - set newargs $atail - set ::argv0 $path - set ::argc [llength $newargs] - set ::argv $newargs - tailcall source $path - } - puts stderr "Cannot run [file extension $path] file directly ([file tail $path]) as tcl script. Ensure file has a known tcl extension ($tcl_extensions) or add a commented hint in the file such as #!/usr/bin/env tclsh" - return [pwd] + + + set last_location $location + } + #process final result + if {[dict size $this_result]} { + dict set this_result filebytes [format_number [dict get $this_result filebytes]] + lappend chunklist [list result $this_result] + if {$result ne ""} { + append result \n } + append result $this_result } - if {[file type $path] eq "directory"} { - #don't cd to intermediate paths.. could be restricted - yet may have permissions on final path - cd $path - tailcall punk::d/ {*}$atail + + + + if {$::repl::running} { + set ::punk::last_run_display $chunklist } - error "Cannot access path $path" + + return $result } } proc dd/ {args} { @@ -5682,8 +5951,9 @@ namespace eval punk { } else { set path ../[file join {*}$args] } - cd $path - set matchinfo [punk::dirfiles_dict] + set normpath [file normalize $path] + cd $normpath + set matchinfo [punk::dirfiles_dict -searchbase $normpath $normpath] set dircount [llength [dict get $matchinfo dirs]] set filecount [llength [dict get $matchinfo files]] set location [file normalize [dict get $matchinfo location]] @@ -5703,7 +5973,9 @@ namespace eval punk { lappend chunklist [list stdout "[a+ white light]$out[a]\n"] lappend chunklist [list result $result] set ::punk::last_run_display $chunklist - repl::term::set_console_title $result + if {[llength [info commands ::repl::term::set_console_title]]} { + repl::term::set_console_title [lrange $result 1 end] ;#strip location key + } } return $result } diff --git a/src/modules/punk/ns-999999.0a1.0.tm b/src/modules/punk/ns-999999.0a1.0.tm index c3d0023c..72520606 100644 --- a/src/modules/punk/ns-999999.0a1.0.tm +++ b/src/modules/punk/ns-999999.0a1.0.tm @@ -1478,6 +1478,7 @@ namespace eval punk::ns { } } set runopts [lmap o $runopts {dict get $alias_dict $o}] + #todo - get these out of here. Should be supplied by caller. if {"-allowvars" in $runopts && "-disallowvars" in $runopts} { puts stderr "Warning - conflicting options -allowvars & -disallowvars specified: $arglist" } diff --git a/src/modules/punk/repo-999999.0a1.0.tm b/src/modules/punk/repo-999999.0a1.0.tm index d7cb773f..41e4f7bd 100644 --- a/src/modules/punk/repo-999999.0a1.0.tm +++ b/src/modules/punk/repo-999999.0a1.0.tm @@ -1159,6 +1159,25 @@ namespace eval punk::repo { [llength [file split $prefix]] \ end]] } + #fs agnostic - so file normalize must be done by caller + proc strip_if_prefix {prefix path args} { + set known_opts [list -nocase] + set opts [list] + foreach a $args { + lappend opts [tcl::prefix match -message "option" $known_opts $a] + } + if {"-nocase" in $opts} { + set lp [tcl::prefix longest [string tolower $path] [string tolower $prefix]] + } else { + set lp [tcl::prefix longest $path $prefix] + } + #return in original casing whether or not -nocase specified. -nocase only applies to the comparison + if {![llength $lp]} { + return $path + } else { + return [string range $path [string length $prefix] end] + } + } interp alias {} is_fossil {} ::punk::repo::is_fossil diff --git a/src/modules/punk/winrun-999999.0a1.0.tm b/src/modules/punk/winrun-999999.0a1.0.tm index 10a70ed1..0b201442 100644 --- a/src/modules/punk/winrun-999999.0a1.0.tm +++ b/src/modules/punk/winrun-999999.0a1.0.tm @@ -390,14 +390,14 @@ namespace eval punk::winrun { return $cmdline } - #This does what Sebres has implemented for Tcl's exec already - pass through that works for non builtins that are run via cmd.exe and require standard argv parsing + #This does essentially what Sebres has implemented for Tcl's exec already - pass through that works for non builtins that are run via cmd.exe and require standard argv parsing # - #tracked blocking of vars - after winquoting when in quotes,prefix % with (unslashed) quote - when outside quotes - prefix with ^ - #(always using unslashed quotes considered - seems more likely to cause prolems with the argv parsing) + #tracked blocking of vars. After winquoting, when in quotes;prefix % with (unslashed) quote. When outside quotes - prefix with ^ + #(always using unslashed quotes considered - seems more likely to cause problems with the argv parsing) # ! can't be blocked with carets ... always use quotes #other cmd specials - block only outside of quotes #existing carets? - #note that /v changes the way carets go through - we need twice as many ^ when /v in place e.g x^^^^y to get x^y vs x^^y to get x^y when /v not present - review - can we sensibly detect /v? + #note that cmd.exe's /v flag changes the way carets go through - we need twice as many ^ when /v in place e.g x^^^^y to get x^y vs x^^y to get x^y when /v not present - review - can we sensibly detect /v? #don't caret quotes. proc quote_cmdpassthru {args} { lassign [internal::get_run_opts $args] _r runopts _c cmdargs