#! /bin/env tclsh
package require lexec
package require control
namespace import ::control::assert
package require {ycl chan diagnostic}
namespace import [yclprefix]::chan::diagnostic
package require {ycl coro call}
namespace import [yclprefix]::coro::call::autocall
namespace import [yclprefix]::coro::call::body
namespace import [yclprefix]::coro::call::bye
namespace import [yclprefix]::coro::call::hi
namespace import [yclprefix]::coro::call::reply
package require {ycl iter async}
namespace import [yclprefix]::iter::async::cat
namespace import [yclprefix]::iter::async::list_
rename list_ listiter
rename cat asyncat
package require {ycl list}
namespace import [yclprefix]::list::assign
namespace import [yclprefix]::list::sl
namespace import [yclprefix]::list::iter
package require {ycl sugar}
namespace import [yclprefix]::sugar::lambda
namespace import [yclprefix]
if {[namespace tail [yclprefix]] ne {ycl}} {
rename [namespace tail [yclprefix]] ycl
}
package require fileutil
namespace import ::fileutil::fullnormalize
package require {ycl math rand}
namespace import [yclprefix]::math::rand::randprint_256
package require {ycl ns}
namespace import [yclprefix]::ns::object
namespace import [yclprefix]::ns::vars
package require {ycl proc}
namespace import [yclprefix]::proc::checkargs
namespace import [yclprefix]::proc::dproc
namespace import [yclprefix]::proc::alias
package require {ycl iter}
package require {ycl list}
interp alias {} [namespace current]::all {} [yclprefix] list all
namespace eval doc {}
namespace eval conf {}
variable doc {
These commands always set the system encoding to iso8859-1 in order to pass
filenames , because this is the only way to maintain sanity . The client
should do its own additional decoding if desired .
}
variable doc::build {
description {
Given a set of file descriptions, build a hierarchy of files on a
filesysem .
}
args {
at {
description {
The path on the filesystem to build the hierarchy at .
}
}
files {
description {
A coroutine that produces file information and delivers it via
{ycl coro call} .
}
}
lookup {
description {
$lookup argument for $build2
}
}
remove {
description {
$remove for build2
}
default {lindex 0}
}
}
}
proc build args {
checkargs [set doc::build] {*}$args
set count 0
while 1 {
set item [$files]
lassign $item target info
# target is assumed to be an absolute path (rooted at $at) with or
# without any initial "/" characters
set target [string trimleft $target /]
if {$remove} {
set target [file split $target[set target {}]]
set target [lrange $target[set target {}] $remove end]
set target [join $target /]
if {$target eq {}} {
# This archive build is finished
return $item
}
}
set cmd [list build2 at $at target $target files $files remove $remove \
lookup $lookup info $info]
set result [{*}$cmd]
if {[dict exists $result files]} {
set files [dict get $result files]
}
}
}
variable doc::build2 {
description {
}
args {
at {}
target {}
files {
description {$files argument for [build]}
}
info {
description {
the metadata for the file
}
}
lookup {
description {
Prefix for a command that , given the signature for a file ,
returns a path to a file containing its contents , or the empty
string .
}
}
remove {
description {
How many filename components to remove from a filename
}
}
content {
default {lindex {}}
}
}
}
proc build2 args {
checkargs [set doc::[namespace tail [lindex [info level 0] 0]]] {*}$args
set fulltarget $at/$target
set result {}
if {![dict exists $info t]} {
# This is a synthetic node . See [fileset node]
dict set info t d
}
switch [dict get $info t] {
directory - dir - d {
file mkdir $fulltarget
}
file - f {
set content [{*}$lookup [dict get $info sha256]]
if {$content eq {}} {
# Archive contents may be forthcoming . Try to build .
set dir [mktempdir]
assert {![string match /* $target]}
set dcount [expr {[llength [file split $target]]}]
incr remove $dcount
set item [build at $dir files $files lookup $lookup remove $remove]
if {[llength $item]} {
set files [asyncat [list [listiter [list $item]] next] $files]
}
dict set result files $files
if {![dict exists $info T]} {
error [list {no content found for file, and file is not an archive} $target]
}
set type [dict get $info T]
set taroptions [list --null -T -]
switch $type {
{application x-bzip2} - {application x-xz} - {application x-gzip} {
set compressflag [dict get {x-bzip2 j x-gzip z x-xz J} [
lindex $type 1]]
exec find $dir -maxdepth 1 -printf {%P\0} \
| tar -C $dir -c${compressflag}f $fulltarget {*}$taroptions 2>@stderr >@stdout
}
{application zip} {
set pwdsave [pwd]
try {
cd $dir
exec zip -r $fulltarget {*}[
listing -tyes +hidden -dir {} * .*]
} finally {
cd $pwdsave
}
}
default {
error [list {don't know how to build type} \
type $type for $at $target]
}
}
} else {
set dirname [file dirname $fulltarget]
if {![file exists $dirname]} {
file mkdir $dirname
}
file copy $content $fulltarget
}
}
l {
link $fulltarget [dict get $info l] type symbolic
}
default {
return -code error [list {unknown file type} [
dict get $info t]]
}
}
if {[file exists $fulltarget]} {
# Not a broken symlink . Proceed .
if {[dict exists $info m]} {
file mtime $fulltarget [dict get $info m]
}
if {[dict exists $info a]} {
file atime $fulltarget [dict get $info a]
}
set attributes {}
if {[dict exists $info u]} {
lappend attributes -owner [dict get $info u]
}
if {[dict exists $info g]} {
lappend attributes -group [dict get $info g]
}
if {[dict exists $info p]} {
lappend attributes -permissions [dict get $info p]
}
file attributes $fulltarget {*}$attributes
}
return $result
}
variable doc::contents {
description {
Wraps an [iter] in another {ycl coro call autocall} command that strips
off all information except the file name, and returns that wrapper
}
}
proc contents iter {
set name [namespace current]::contents_[info cmdcount]
coroutine $name\0 ::apply [list iter [body {
set args [hi]
if {[llength $args]} {
error [list {called with arguments}]
}
while 1 {
set res [{*}$iter]
set args [reply [lindex $res 0]]
if {[llength $args]} {
error [list {called with arguments}]
}
}
}] [namespace current]] $iter
autocall $name
}
variable doc::create {
description {
Atomically create a new directory.
}
}
proc create path {
exec mkdir $path
}
variable doc::dedup {
description {
remove duplicate files in a directory, being extremely careful to not
remove unduplicated data.
}
args {
duplicates {
description {
a {ycl coro call} routine that provides duplicate files,
delivering both the name of the duplicate and of what it
duplicates.
}
}
}
}
dproc dedup args {
checkargs $doc::dedup {*}$args
set dir [mktempdir]
try {
while 1 {
lassign [$duplicates] duplicate of
if {![file exists $of]} {
puts stderr [list {not deleting duplicate} $dupliate \
{because target doesn't exist} $of]
}
# Extra checks just to be safe
if {[link $duplicate] ne {}} {
puts stderr [list {not deleting symbolic link} $duplicate to $of]
continue
}
set tail [file tail $duplicate]
file stat $duplicate dupstat
file stat $of ofstat
if {$dupstat(ino) == $ofstat(ino)} {
puts stderr [list {not deleting same file} $duplicate as $of]
# Same file. Bail.
continue
}
file rename -force $duplicate $dir/$tail
if {[file exists $of]} {
file delete -force $dir/$tail
} else {
file rename -force $dir/$tail $duplicate
}
}
} finally {
set contents [glob -nocomplain -directory $dir *]
if {[llength $contents]} {
puts stderr [list {could not restore file} $dir/$tail \
{to original location} $duplicate]
} else {
file delete $dir
}
}
}
variable doc::deserialize {
description {
convert a representation of a filesystem tree to a real filesystem tree
}
args {
in {
description {
a path in which to create the directory tree
}
}
tree {
description {
a list of the form {directories files}. Each directory is a
list of the form {name hierarchy}, and each file is a list of
the form {name contents}
}
}
}
}
dproc deserialize args {
checkargs $doc::deserialize {*}$args
lassign $tree dirs files
foreach {file contents} $files {
set path [file join $in $file]
set chan [open $path w]
puts -nonewline $chan $contents
close $chan
}
foreach {dir tree} $dirs {
set in2 [file join $in $dir]
file mkdir $in2
deserialize tree $tree in $in2
}
}
variable doc::dislocate {
description {
rename a file to an automatically-chosen name, and return that name
}
}
proc dislocate name {
while {[catch {file rename $name $name.[set timestamp [clock format [
set ms [ clock microseconds]] -format %Y%m%d%H%M%S[
expr {$ms % 1000}]]]} cres copts]} {
lassign [dict get $copts -errorcode] posix eexist
#todo expannd this for other platforms
if {$posix ne {POSIX} || eexist ne {EEXIST}} {
return -options $copts $cres
}
}
return $name.$timestamp
}
variable doc::copynode {
description {
Copy a single file or directory node to an archive location,
faithfully reproducing all directories and symlinks to directories that
are necessary to keep the copied node valid. For directories, produces
just the directory, or symlink to the directory, not the contents of
the directory.
}
args {
source {
positional true
description {
An absolute path of a file or directory.
}
}
to {
positional true
description {
A directory in which to reproduce $source. Because symlinks in
the path to source may point to arbitrary locations, The full
path of $source is replicated in $to
}
}
}
}
proc copynode {source to} {
# Assume that $source exists, which means that any symbolic links in its path
# also exist.
set create {}
if {[file pathtype $source] ne {absolute}} {
error [list {not an absolute path} $source]
}
set target $to/[string trimleft $source /]
lappend tasks $source
set sourcedir [file dirname $source]
set targetdir $to$sourcedir
while {$sourcedir ne {/}} {
if {![file exists $targetdir]} {
set tasks [linsert $tasks[set tasks {}] 0 $sourcedir]
}
set sourcedir [file dirname $sourcedir]
set tagetdir $to$sourcedir
}
foreach source $tasks {
set target $to$source
if {[file type $source] eq {link}} {
set link [file link $source]
set pwd [pwd]
try {
cd [file dirname $source]
set link2 [file normalize $link]
copynode $link2 $to
} finally {
cd $pwd
}
if {[file pathtype $link] ne {relative}} {
set link $to$link
}
link $target $link type symbolic
} else {
if {[file isdirectory $source]} {
file mkdir $target
} else {
file copy $source $target
}
}
}
}
variable doc::demolish {
description {
Do everything possible (change permissions, etc.) to utterly destroy a
directory and all its contents recursively.
}
}
proc destroy name {
# No need to collect directory invasion information for a temporary directory
try {file delete -force $name} on ok {cres copts} {
return
} on error {} {
relay iter tmpfname {*}[contents $name invade true] {
# {to do} {add this functionality for Windows as well}
#puts [dict get [info frame 0] proc]
diagnostic info destroying $tmpfname
if {[file isdirectory $tmpfname]} {
set permissions u+rwx
} else {
set permissions u+rw
}
try {
file attributes $tmpfname -permissions $permissions
} on error {res opts} {
try {
file attributes $tmpfname -owner $::tcl_platform(user)
} on error {res opts} {
diagnostic info {could not change ownership of} $tmpfname
}
try {
file attributes $tmpfname -permissions $permissions
} on error {res opts} {
diagnostic info {could not change permission of} $tmpfname
#return -options $copts $res
}
}
}
try {file delete -force $name} on error {cres copts} {
return -options $copts $cres
}
}
}
proc noencoding script {
set encoding_save [encoding system]
encoding system iso8859-1
catch {uplevel 1 $script} cres copts
encoding system $encoding_save
set options [dict merge {-level 1} $copts]
dict incr options -level
return -options $options $cres
}
proc empty? {path} {
expr {[llength [list {*}[glob -nocomplain -directory $path *] {*}[
glob -nocomplain -directory $path -types hidden *]]] == 0}
}
proc followlink filename {
set pwd_save [pwd]
set res $filename
try {
while 1 {
if {[file type $res] eq $link} {
set link [file link $res]
cd [file dirname $res]
if {[file pathtype $link] ne {absolute}} {
set link [pwd]/$link
}
set res $link
} else break
}
} finally {
cd $pwd_save
}
return $res
}
variable doc::invade {
description {
To support walking a directory hierarchy, try everything possible as
the current user to modify ownership and permissions on the filesystem
such that the current user can both list $dir and access its contents
and, if $dir is a directory, to change attributes of files in the
directory.
A boolean value indicating whether permissions were changed .
The old ownership, if ownership was changed and the old ownership
could be obtained, or the empty string otherwise.
The old permissions , if permissions were changed and the old
permissions were available , or the empty string otherwise .
}
}
proc invade {dir args} {
# {{to do}} {Develop this functionality to work on Windows}
while {[llength $args]} {
set args [lassign $args[set args {}] key]
switch $key {
do {
set args [assign $args[set args {}] do]
}
default {
error [list {unknown key} $key]
}
}
}
if {[file readable $dir] && [file executable $dir] && [
file writable $dir]} {
return {} 0 {} {}
}
if {[file isdirectory $dir]} {
set newperms u+rwx
} else {
set newperms u+r
}
set parents {}
set changes {}
set permschanged 0
set ownerchanged 0
set parent [file dirname $dir]
while 1 {
set permissions [file attributes $parent -permissions]
if {($permissions & 0x700)} {
break
} else {
lassign [invade_newperms $parent u+rwx] accessible ownerchanged \
oldowner permschanged oldperms
if {$accessible} {
lappend changes [list $parent $oldowner $oldperms]
break
} else {
if {[file normalize $dirname] eq [file normalize $dir]} {
diagnostic warning {could not change permissions of parent of} $dir $cres
break
} else {
lappend parents $dir
}
}
set parent [file dirname $parent]
}
}
foreach parent [lreverse $parents] {
lassign [invade_newperms $parent u+rwx] accessible oldowner oldperms
lappend changes [list $parent $oldowner $oldperms]
}
lassign [invade_newperms $dir $newperms] accessible oldowner oldperms
if {[info exists do]} {
catch [list uplevel 1 $do] cres copts
if {$permschanged ne {}} {
catch {file attributes $dir -permissions $oldperms}
}
if {$ownerchanged ne {}} {
catch {file attributes $dir -owner $oldowner}
}
foreach permrecord [lreverse $changes] {
lassign $permrecord parent oldowner oldperms
if {$permschanged ne {}} {
catch {file attributes $dir -permissions $oldperms}
}
if {$ownerchanged ne {}} {
catch {file attributes $dir -owner $oldowner}
}
}
return -options $copts $cres
} else {
lappend changes [list [expr {[file readable $dir] && [file executable $dir] && [
file writable $dir]}] $oldowner $oldperms]
return $changes
}
}
proc invade_newperms {fname permissions} {
diagnostic debug [list {setting permissions of} $fname to $permissions]
try {set oldperms [file attributes $fname -permissions]} on error {
cres copts} {
diagnostic warning {could not capture permissions} $fname $cres
set oldperms {}
}
try {set oldowner [file attributes $fname -owner]} on error {cres copts} {
diagnostic warning {could not capture owner} $fname $cres
set oldowner {}
}
try {file attributes $fname -permissions $permissions} on ok {} {
set permschanged 1
} on error {cres copts} {
set permschanged 0
diagnostic warning {could not change permissions} $fname $cres
}
set ownerchanged 0
if {!$permschanged} {
if {![file owned $fname]} {
try {file attributes $fname -owner $::tcl_platform(user)} on ok {} {
set ownerchanged 1
} on error {cres copts} {
diagnostic warning {could not change owner} $fname $cres
set ownerchanged 0
}
}
try {file attributes $fname -permissions $permissions} on ok {} {
set permschanged 1
} on error {cres copts} {
set permschanged 0
diagnostic warning {could not change permissions} $fname $cres
}
}
return [list [expr {[file readable $fname] && [file executable $fname] && [
file writable $fname]}] $oldowner $oldperms]
}
variable doc::iter {
description {
produce an {ycl coro call} iterator of contents of a directory
in alphabetical order
each call to the routine yields a list containing
name of the item
type of the item
the result of [invade] for the item
}
args {
from {
description {
filesystem path to traverse, usually a directory. If it is a
path, the iterator will yield nothing
positional
}
validate {
[noencoding {file isdirectory $from}]
}
}
along {
description {
specifies depth-first or breadth-first
}
validate {
$along in {breadth depth}
}
default {
lindex breadth
}
}
invade {
description {
Fiddle with attributes as needed to get a directory listing.
}
default {lindex false}
}
prune {
description {
A command which invoked with each directory as an argument to
determine whether to prune the directory from the results.
}
default {
list apply [list path {
return 0
} [namespace current]]
}
}
symdirs {
description {
how to handle symbolic links to directories .
}
default {lindex prune}
validate {$symdirs in {prune follow}}
}
select {
description {
A command which is invoked with the name of each directory as
an argument, and which returns the desired contents of the
directory as a list where the first item is a list of
directories and the second item is a list of non-directories
}
default {
list apply [list pathname {
set saved [encoding system]
encoding system iso8859-1
try {
try {
set dirs [listing -types {d +hidden} \
-directory $pathname * .*]
} on ok {} {
set invaded {}
} on error {cres copts} {
upvar 1 invade invade
if {!$invade} {
return -options $copts $cres
}
set invaded [invade $pathname]
set dirs [listing -types {d +hidden} \
-directory $pathname * .*]
}
set files [lmap file [
listing -types +hidden -directory $pathname * .*] {
if {$file in $dirs} continue
lindex $file
}]
} finally {
encoding system $saved
}
return [list $dirs $files $invaded]
} [namespace current]]
}
}
tails {
description {
A boolean value that indicates whether to only produce the tail
of each filename, as described for [glob] .
}
default {lindex false}
}
types {
description {
A list of types to filter output by , as codumented for [listing]
}
default {lindex {d f}}
}
}
orderargs {
prune {
description {
If the last result was a directory , prune it .
}
default {[lindex 1]}
}
}
}
dproc iter {from args} {
checkargs $doc::iter {*}$args
set name [namespace current]::iter_[info cmdcount]
switch -- $along {
breadth {
coroutine $name\0 ::apply [list {
args from select types invade prune symdirs} [body {
iter_accept [hi]
set subdirs [list $from]
while {[llength $subdirs]} {
set subdirs [lassign $subdirs[set subdirs {}] from]
# {to do} {discard functionality goes here} The
# difference between discard and prune is that with
# prune, at least the directory to be pruned is still
# delivered as in the result set
if {0
} {
set from {}
continue
}
if {![noencoding {file exists $from}]} {
# $from must have been a symbolic link to a directory
# that has been deleted in the meantime.
continue
}
lassign [{*}$select $from] dirs files invaded
lappend subdirs {*}[lmap dir $dirs {
if {[iter_prune $dir]} {
continue
} else {
lindex $dir
}
}]
set res {}
if {{d} in $types} {
lappend res {*}$dirs
}
if {{f} in $types} {
lappend res {*}$files
}
# Contents are produced in alphabetical order, not grouped
# by type .
foreach item [lsort $res[set res {}]] {
iter_accept [reply [list $item dir {}]]
}
}
}] [namespace current]] $args $from $select $types $invade $prune $symdirs
}
depth {
coroutine $name\0 ::apply [list {
ns args from invade prune select symdirs types
} [body {
iter_accept [hi]
if {![iter_prune $from]} {
lassign [{*}$select $from] dirs files invaded
foreach dir $dirs {
if {![iter_prune $dir]} {
# Symbolic link to a directory may have become
# broken in the meantime .
if {[noencoding {file exists $dir}]} {
set coro [$ns iter $dir {*}$args]
while 1 {
set item [$coro next]
iter_accept [reply $item]
}
}
}
if {{d} in $types} {
iter_accept [reply [list $dir dir $invaded]]
}
}
}
foreach file $files {
iter_accept [reply [list $file file {}]]
}
}] [namespace current]] [namespace current] $args $from $invade \
$prune $select $symdirs $types
}
}
autocall $name
}
proc iter_accept cmd {
set response {}
while 1 {
switch $cmd {
next {
break
}
default {
error [list {unknown command} $cmd]
}
}
set cmd [reply {*}$response]
}
}
proc iter_prune dir {
upvar files invaded prune prune symdirs symdirs
expr {[{*}$prune $dir] || (
$symdirs eq {prune}
&& [noencoding {file isdirectory $dir}]
&& ![catch {noencoding {file readlink $dir}}])}
}
proc lexists name {
expr {![catch {file lstat $name info}]}
}
variable doc::link {
description {
Returns the target of the link or the empty string if the file is not
a link. If more than one argument is provided, the second argument is
the name of the file to point the link to. Additional arguments are
key/value pairs where keys listed below are valid
}
args {
as {
positional true
description {
The link to create .
}
}
to {
positional optional
description {
The target of the link .
}
}
type {
description {
"symbolic" or "hard". The default is "hard"
}
default {lindex hard}
process {
switch $type {
symbolic {
set symbolic -symbolic
}
default {
set symbolic {}
}
}
lindex $symbolic
}
}
overwrite {
description {
remove any existing link
}
default {lindex false}
process {expr {!!$overwrite}}
}
}
}
proc link {as args} {
if {[llength $args]} {
checkargs $doc::link {*}$args
# Use an external command because Tcl's [file link] refuses to create
# a link that points to a non-existing file.
#lexec::exec ln -${symbolic}$overwrite $to $as
if {$overwrite} {
if {[file exists $as]} {
if {[catch {file readlink $as}]} {
error [list {will not overwrite existing file}]
} else {
file delete -force $as
}
}
}
set pwd [pwd]
try {
set asdir [file dirname $as]
if {![file exists $asdir]} {
file mkdir $asdir
}
cd $asdir
if {![file exists $to]} {
if {![catch {file readlink $to} cres]} {
while 1 {
set tmpname $to.~[incr i]
if {![lexists $tmpname]} break
}
file rename -force $to $tmpname
}
# delete any broken symbolic link
file delete $to
set dummydata =jIPL-GyVqFxjx3G4HX9VedK+2+jmp20-zspJDCTFG
cd [file dirname $as]
foreach part [file split [file dirname $to]] {
lappend parts $part
if {![file exists $part]} {
file mkdir $part
cd $part
if {![info exists remove]} {
set remove [pwd]
}
} else {
cd $part
}
}
if {![info exists remove]} {
set remove $to
}
cd [file dirname $as]
if {![info exists remove]} {
set remove $to
}
set remove [file normalize $remove[set remove {}]]
set chan [open $to {WRONLY CREAT EXCL}]
puts -nonewline $chan $dummydata
close $chan
}
file link {*}$symbolic $as $to
if {[info exists remove]} {
# make sure it's a dummy file
set chan [open $to]
set dummydata2 [read $chan [string length $dummydata]]
close $chan
if {$dummydata ne $dummydata2} {
error [list {could not read back sentinel data} $remove]
}
file delete -force $remove
if {[info exists tmpname]} {
file rename $tmpname $to
}
}
} finally {
cd $pwd
}
}
if {[file type $as] ne {link}} {
return {}
}
file readlink $as
}
variable doc::listing {
description {
A drop-in replacement for [glob -nocomplain] whose results never
include a . or .. , and which provides an additional type specifier,
+hidden , that includes in the results any hidden files that would
otherwise match if they weren't hidden .
To maximizie compatibility , this command operates in iso8859-1 mode
when passing arguments to the system and when receiving the results
from the system .
On Unix systems , "-types hidden" misses files beginning with "." whose
file attributeds aren't readable, so to get a complete listing , the
caller should provide both "-types hidden" and a pattern that
explicitly matches "." . See also issue 391bc0fd2cdd5920.
Take care to handle the case when $dir is the empty string . Also ,
can't use -types because on *nix , when a directory is readable but not
executable , [glob] won't match on types , and returns an empty string
instead . Because -types hidden is also affected in this case ,
explicitly glob .* , until there's some resolution to 391bc0fd2cdd5920
.
}
}
proc listing args [string map [list @script@ [list [string map {
@glob@ {glob -nocomplain {*}$globargs -types $types -- {*}$args}
} {
set globargs {}
set types {}
set addhidden 0
while {[llength $args]} {
set args [lassign $args[set args {}] arg]
switch -glob $arg {
-types {
set args [lassign $args[set args {}] typespec]
foreach type $typespec {
if {$type eq {+hidden}} {
set addhidden 1
} else {
append types $type
}
}
}
-dir - -directory - path {
lappend globargs $arg
set args [lassign $args[set args {}] arg]
lappend globargs $arg
}
-join - -nocomplain - -tails {
lappend globargs $arg
}
-* {
error [list {unknown argument}]
}
-- {
break
}
default {
set args [list $arg {*}$args[set args {}]]
break
}
}
}
set res [noencoding {@glob@}]
if {$addhidden} {
lappend types hidden
lappend res {*}[@glob@]
}
set res [lmap item $res[set res {}] {
if {[file tail $item] in {. ..}} {
continue
}
lindex $item
}]
return [lsort -unique $res[set res {}]]
#performance-wise, the following two alternatives
#are sixes.
#set contents [lsearch -all -inline -not \
# $contents[set contents {}] */..]
#foreach item [lsort $contents[set contents {}]] {
# if {[file tail $item] ni {. ..}} {
# lappend contents $item
# }
#}
}]]] {
set savedargs $args
try @script@ on error {tres topts} {
set encoding_save [::encoding system]
noencoding @script@
}
}]
variable doc::lockdown {
}
proc lockdown name {
if {![file exists $name]} {
file mkdir $name
}
if {![file isdirectory $name]} {
return 0
}
file attributes $name -permissions 0700
set attributes [file attributes $fname]
if {[dict get $attributes -owner] eq $::tcl_platform(user)
&& !([dict get $attributes -permissions] & 077)
&& ([dict get $attributes -permissions] & 040000)} {
return 1
} else {
return 0
}
}
variable doc::manifest {
args {
chan {
description {
A channel to write the manifest to .
}
}
iter {
description {
A {ycl coro call} file iterator.
}
}
info {
description {
A command prefix to which is appended a path, and which returns
information about that file
}
default {list [namespace current] stat run}
}
}
}
proc manifest {chan iter args} {
checkargs [set doc::[namespace tail [lindex [info level 0] 0]]] {*}$args
set lastid -1
set seen {}
relay iter item $iter {
set dir [file dirname $item]
if {![info exists cwd] || $dir ne $cwd} {
set cwd $dir
if {[dict exists $seen $dir]} {
set dirid [dict get $seen $dir id]
} else {
set dirid [incr lastid]
}
}
}
}
variable doc::manifest_cli [sl {
args [sl {
dir {
description {
The directory to build a manifest of
}
}
sigcmd [
dict create default [sl {lindex [lambda fname {
lindex [exec sha256sum $fname] 0
}]}]
]
}]
}]
proc manifest_cli args {
set res {}
checkargs [set doc::[namespace tail [lindex [info level 0] 0]]] {*}$args
set iter [iter $dir]
while 1 {
set fname [$iter]
if {[namespace which $iter] eq {}} break
set split [lrange [file split $fname] 1 end]
if {[file isdirectory $fname]} {
dict set res {*}$split {}
} else {
set sig [{*}$sigcmd $fname]
dict set res {*}$split [list $sig]
}
}
return $res
}
variable doc::mktempdir {
description {
create a directory guaranteed to have just been created by this operation.
The user is responsible for deleting the temporary directory.
}
args {
in {
description {
path to create the tmpdir in
}
default {
set in [::fileutil::tempdir]
lindex $in
}
}
named {
description {
name of the temporary directory
}
default {
}
}
pattern {
description {
template for creating the directory
}
default {
}
}
tries {
description {
how many times to try making the directory before giving up
}
default {
set tries 1000
}
}
}
}
dproc mktempdir args {
#todo: also try to use mktemp -d
checkargs $doc::mktempdir {*}$args
set success 0
if {[auto_execok mkdir] ne {}} {
set mkdir mkdir
} else {
set mkdir {file mkdir}
}
for {} {$tries > 0} {incr tries -1} {
set fname [randprint_256]
set dirpath [file join $in $fname]
if {[file exists $dirpath]} {
continue
}
set status [catch {
exec {*}$mkdir $dirpath
set success 1
} cres copts]
if {$status} {
return -code $status -opts $copts $cres
}
break
}
return $dirpath
}
proc mkprivdir name {
#{to do} {a more portable implementation}
exec mkdir -m 1700 $name
}
proc popd {} {
vars dirs
if {[llength $dirs]} {
cd [lindex $dirs end]
set dirs [lrange $dirs[set dirs {}] 0 end-1]
}
}
proc pushd dir {
vars dirs
set pwd [pwd]
cd $dir
lappend dirs [pwd]
}
proc stat args {
package require {ycl dir stat}
tailcall [namespace current] stat {*}$args
}
variable doc::sync {
description {
synchronize the contents of two files.
}
args {
archive {
description {
Sets the following option values
permissions true
times true
}
default {
lindex true
}
process {
if {$archive} {
set permissions true
set times true
}
lindex $archive
}
}
backup {
description {
Backup any file that is overwritten and not identical .
}
default {
lindex true
}
}
files {
description {
iterator of files to sync
}
}
to {
description {
pathname to sync to
}
}
permissions {
description {
synchronize permisions
}
default {
lindex true
}
}
times {
description {
synchronize ctime, mtime, and atime .
}
default {
lindex true
}
}
delete {
description {
delete original
}
default {
lindex false
}
}
recurse {
description {
recurse when synchronizing a directory
}
default {
lindex false
}
}
}
}
proc sync args {
checkargs [set doc::[namespace tail [lindex [info level 0] 0]]] {*}$args
file stat $from fstat
if {[file isdirectory $from]} {
if {![file isdirectory] $to]} {
return -code error [list {not a directory} $to]
}
set iter [iter $from]
} else {
set iter [[yclprefix] iter list [list $from]]
}
[yclprefix] iter for pathname in $iter {
set same 1
file stat to tstat
if {[file exists $to]} {
foreach attribute {type size mtime} {
if {$from($attribute) ne $to($attribute)} {
set same 0
break
}
}
}
if {$same} {
continue
}
if {$delete && $process && $permissions} {
#Simply moving $from is an option
puts [list {simply rename $from $to}]
#file rename $from $to
continue
}
}
if {$delete && $times && $permissions} {
}
}
variable doc::trim {
description {
A {ycl coro call} wrapper that trims $path off files
}
}
proc trim {path prefix} {
set length [llength [file split $prefix]]
if {[string first $prefix $path] == 0} {
set path [file split $path]
file join {*}[lrange $path $length end]
} else {
error [list {value doesn't match prefix} $path $prefix]
}
}
proc tidyname name {
file join [file split $name]
}
if {[info exists argv0] && (
[file dirname [file normalize [info script]/...]] eq [
file dirname [file normalize $argv0/...]]
)} {
main
}