You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
365 lines
11 KiB
365 lines
11 KiB
# -*- tcl -*- |
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
|
# |
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# (C) 2023 |
|
# |
|
# @@ Meta Begin |
|
# Application punk::mix::util 999999.0a1.0 |
|
# Meta platform tcl |
|
# Meta license <unspecified> |
|
# @@ Meta End |
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Requirements |
|
##e.g package require frobz |
|
|
|
namespace eval punk::mix::util { |
|
variable has_winpath 0 |
|
} |
|
|
|
if {"windows" eq $::tcl_platform(platform)} { |
|
if {![catch {package require punk::winpath}]} { |
|
set punk::mix::util::has_winpath 1 |
|
} |
|
} |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
namespace eval punk::mix::util { |
|
variable tmpfile_counter 0 ;#additional tmpfile collision avoidance |
|
|
|
namespace export * |
|
|
|
#NOTE fileutil::cat seems to silently ignore options if passed at end instead of before file! |
|
proc fcat {args} { |
|
variable has_winpath |
|
|
|
|
|
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" |
|
|
|
#let's proceed, but warn the user if an apparent option is in paths |
|
foreach opt [list -encoding -eofchar -translation] { |
|
if {$opt in $paths} { |
|
puts stderr "fcat WARNING: apparent option $opt found after file argument(s) (expected them before filenames). Passing to fileutil::cat anyway - but for at least some versions, these options may be ignored. commandline 'fcat $args'" |
|
} |
|
} |
|
|
|
if {$::tcl_platform(platform) ne "windows"} { |
|
return [fileutil::cat {*}$args] |
|
} |
|
|
|
|
|
set finalpaths [list] |
|
foreach p $paths { |
|
if {$has_winpath && [punk::winpath::illegalname_test $p]} { |
|
lappend finalpaths [punk::winpath::illegalname_fix $p] |
|
} else { |
|
lappend finalpaths $p |
|
} |
|
} |
|
fileutil::cat {*}$opts {*}$finalpaths |
|
} |
|
|
|
#---------------------------------------- |
|
namespace eval internal { |
|
proc path_common_prefix_pop {varname} { |
|
upvar 1 $varname var |
|
set var [lassign $var head] |
|
return $head |
|
} |
|
} |
|
proc path_common_prefix {args} { |
|
set dirs $args |
|
set parts [file split [internal::path_common_prefix_pop dirs]] |
|
while {[llength $dirs]} { |
|
set r {} |
|
foreach cmp $parts elt [file split [internal::path_common_prefix_pop dirs]] { |
|
if {$cmp ne $elt} break |
|
lappend r $cmp |
|
} |
|
set parts $r |
|
} |
|
if {[llength $parts]} { |
|
return [file join {*}$parts] |
|
} else { |
|
return "" |
|
} |
|
} |
|
|
|
#retains case from first argument only - caseless comparison |
|
proc path_common_prefix_nocase {args} { |
|
set dirs $args |
|
set parts [file split [internal::path_common_prefix_pop dirs]] |
|
while {[llength $dirs]} { |
|
set r {} |
|
foreach cmp $parts elt [file split [internal::path_common_prefix_pop dirs]] { |
|
if {![string equal -nocase $cmp $elt]} break |
|
lappend r $cmp |
|
} |
|
set parts $r |
|
} |
|
if {[llength $parts]} { |
|
return [file join {*}$parts] |
|
} else { |
|
return "" |
|
} |
|
} |
|
#---------------------------------------- |
|
|
|
#namespace import ::punk::ns::nsimport_noclobber |
|
|
|
proc namespace_import_pattern_to_namespace_noclobber {pattern ns} { |
|
set source_ns [namespace qualifiers $pattern] |
|
if {![namespace exists $source_ns]} { |
|
error "namespace_import_pattern_to_namespace_noclobber error namespace $source_ns not found" |
|
} |
|
if {![string match ::* $ns]} { |
|
set nscaller [uplevel 1 {namespace current}] |
|
set ns [punk::nsjoin $nscaller $ns] |
|
} |
|
set a_export_patterns [namespace eval $source_ns {namespace export}] |
|
set a_commands [info commands $pattern] |
|
set a_tails [lmap v $a_commands {namespace tail $v}] |
|
set a_exported_tails [list] |
|
foreach pattern $a_export_patterns { |
|
set matches [lsearch -all -inline $a_tails $pattern] |
|
foreach m $matches { |
|
if {$m ni $a_exported_tails} { |
|
lappend a_exported_tails $m |
|
} |
|
} |
|
} |
|
set imported_commands [list] |
|
foreach e $a_exported_tails { |
|
set imported [namespace eval $ns [string map [list <func> $e <a> $source_ns] { |
|
set cmd "" |
|
if {![catch {namespace import <a>::<func>}]} { |
|
set cmd <func> |
|
} |
|
set cmd |
|
}]] |
|
if {[string length $imported]} { |
|
lappend imported_commands $imported |
|
} |
|
} |
|
return $imported_commands |
|
} |
|
|
|
proc askuser {question} { |
|
if {![catch {package require punk::lib}]} { |
|
return [punk::lib::askuser $question] ;#takes account of terminal mode raw vs line (if punk::console used) |
|
} |
|
puts stdout $question |
|
flush stdout |
|
set stdin_state [fconfigure stdin] |
|
fconfigure stdin -blocking 1 |
|
set answer [gets stdin] |
|
fconfigure stdin -blocking [dict get $stdin_state -blocking] |
|
return $answer |
|
} |
|
|
|
#review - can be surprising if caller unaware it uses try |
|
proc do_in_path {path script} { |
|
#from ::kettle::path::in |
|
set here [pwd] |
|
try { |
|
cd $path |
|
uplevel 1 $script |
|
} finally { |
|
cd $here |
|
} |
|
} |
|
|
|
proc foreach-file {path script_pathvariable script} { |
|
upvar 1 $script_pathvariable thepath |
|
|
|
set known {} |
|
lappend waiting $path |
|
while {[llength $waiting]} { |
|
set pending $waiting |
|
set waiting {} |
|
set at 0 |
|
while {$at < [llength $pending]} { |
|
set current [lindex $pending $at] |
|
incr at |
|
|
|
# Do not follow into parent. |
|
if {[string match *.. $current]} continue |
|
|
|
# Ignore what we have visited already. |
|
set c [file dirname [file normalize $current/___]] |
|
if {[dict exists $known $c]} continue |
|
dict set known $c . |
|
|
|
if {[file tail $c] eq ".git"} { |
|
continue |
|
} |
|
|
|
# Expand directories. |
|
if {[file isdirectory $c]} { |
|
lappend waiting {*}[lsort -unique [glob -directory $c * .*]] |
|
continue |
|
} |
|
|
|
# Handle files as per the user's will. |
|
set thepath $current |
|
switch -exact -- [catch { uplevel 1 $script } result] { |
|
0 - 4 { |
|
# ok, continue - nothing |
|
} |
|
2 { |
|
# return, abort, rethrow |
|
return -code return |
|
} |
|
3 { |
|
# break, abort |
|
return |
|
} |
|
1 - default { |
|
# error, any thing else - rethrow |
|
return -code error $result |
|
} |
|
} |
|
} |
|
} |
|
return |
|
} |
|
|
|
proc is_valid_tm_version {versionpart} { |
|
#Needs to be suitable for use with Tcl's 'package vcompare' |
|
if {![catch [list package vcompare $versionpart $versionpart]]} { |
|
return 1 |
|
} else { |
|
return 0 |
|
} |
|
} |
|
#Note that semver only has a small overlap with tcl tm versions. |
|
#todo - work out what overlap and whether it's even useful |
|
#see also TIP #439: Semantic Versioning (tcl 9??) |
|
proc semver {versionstring} { |
|
set re {^(0|[1-9]\d*)\.(0|[1-9]\d*)\.(0|[1-9]\d*)(?:-((?:0|[1-9]\d*|\d*[a-zA-Z-][0-9a-zA-Z-]*)(?:\.(?:0|[1-9]\d*|\d*[a-zA-Z-][0-9a-zA-Z-]*))*))?(?:\+([0-9a-zA-Z-]+(?:\.[0-9a-zA-Z-]+)*))?$} |
|
} |
|
#todo - semver conversion/validation for other systems? |
|
proc magic_tm_version {} { |
|
set magicbase 999999 ;#deliberately large so given load-preference when testing! |
|
#we split the literal to avoid the literal appearing here - reduce risk of accidentally converting to a release version |
|
return ${magicbase}.0a1.0 |
|
} |
|
|
|
|
|
|
|
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 .punkutil_$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 {TEMP TMP TMPDIR} { |
|
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]" |
|
} |
|
|
|
|
|
|
|
} |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Ready |
|
package provide punk::mix::util [namespace eval punk::mix::util { |
|
variable version |
|
set version 999999.0a1.0 |
|
}] |
|
return
|
|
|