[22007] trunk/base/src/port1.0/portutil.tcl
Jordan K. Hubbard
jkh at brierdr.com
Wed Feb 14 00:23:08 PST 2007
While most of these helper functions seem pretty sane, I can't help
but think that the delete function really ought to be written in C
for speed and correctness (following the pseudo code example at
http://docs.info.apple.com/article.html?artnum=107884). The Tcl
function I see below is not going to be particularly fast on either
broad or deep hierarchies of files, and mass deletions of stuff in
cleanup procedures is fairly common place. I think the other
functions are low-overhead enough that Tcl is a fine implementation
language, but not delete.
- Jordan
On Feb 13, 2007, at 7:09 PM, source_changes at macosforge.org wrote:
> Revision
> 22007
> Author
> eridius at macports.org
> Date
> 2007-02-13 19:09:46 -0800 (Tue, 13 Feb 2007)
> Log Message
>
> Reimplement delete so it no longer uses system "/bin/rm -rf ..."
> This also fixes the case of filenames with spaces in them being
> incorrectly parsed - That was EXTREMELY dangerous
> Add new touch command - usage similar to BSD touch
> Add new copy and move commands - basically aliases for file copy/
> rename
> Add new ln command - usage similar to BSD ln
> These should be documented somewhere
> Modified Paths
>
> trunk/base/src/port1.0/portutil.tcl
> Diff
>
> Modified: trunk/base/src/port1.0/portutil.tcl (22006 => 22007)
>
> --- trunk/base/src/port1.0/portutil.tcl 2007-02-13 22:54:21 UTC
> (rev 22006)
> +++ trunk/base/src/port1.0/portutil.tcl 2007-02-14 03:09:46 UTC
> (rev 22007)
> @@ -443,7 +443,7 @@
> proc ldelete {list value} {
> set ix [lsearch -exact $list $value]
> if {$ix >= 0} {
> - return [lreplace $list $ix $ix]
> + return [lreplace $list $ix $ix]
> }
> return $list
> }
> @@ -511,14 +511,204 @@
> }
>
> # delete
> -# fast (and more reliable than 'file delete') file- and directory-
> remove routine
> +# file delete -force by itself doesn't handle directories properly
> +# on systems older than Tiger. However we can recurse this thing
> ourselves
> proc delete {args} {
> - foreach arg $args {
> - ui_debug "delete: $arg"
> - system "/bin/rm -rf $arg"
> - }
> + foreach arg $args {
> + ui_debug "delete: $arg"
> + set stack [list $arg]
> + while {[llength $stack] > 0} {
> + set file [lindex $stack 0]
> + if {[file isdirectory $file]} {
> + # it's a directory
> + set children [glob -nocomplain -directory $file
> {{*,.*}}]
> + set children [ldelete [ldelete $children $file/.]
> $file/..]
> + if {[llength $children] > 0} {
> + set stack [concat $children $stack]
> + } else {
> + # directory is empty
> + file delete -force -- $file
> + set stack [lrange $stack 1 end]
> + }
> + } else {
> + # it's not a directory - kill it now
> + file delete -force -- $file
> + set stack [lrange $stack 1 end]
> + }
> + }
> + }
> }
>
> +# touch
> +# mimics the BSD touch command
> +proc touch {args} {
> + while {[string match -* [lindex $args 0]]} {
> + set arg [string range [lindex $args 0] 1 end]
> + set args [lrange $args 1 end]
> + switch -- $arg {
> + a -
> + c -
> + m {set options($arg) yes}
> + r -
> + t {
> + set narg [lindex $args 0]
> + set args [lrange $args 1 end]
> + if {[string length $narg] == 0} {
> + return -code error "touch: option requires an
> argument -- $arg"
> + }
> + set options($arg) $narg
> + set options(rt) $arg ;# later option overrides
> earlier
> + }
> + - break
> + default {return -code error "touch: illegal option --
> $arg"}
> + }
> + }
> +
> + # parse the r/t options
> + if {[info exists options(rt)]} {
> + if {[string equal $options(rt) r]} {
> + # -r
> + # get atime/mtime from the file
> + if {[file exists $options(r)]} {
> + set atime [file atime $options(r)]
> + set mtime [file mtime $options(r)]
> + } else {
> + return -code error "touch: $options(r): No such
> file or directory"
> + }
> + } else {
> + # -t
> + # parse the time specification
> + # turn it into a CCyymmdd hhmmss
> + set timespec {^(?:(\d\d)?(\d\d))?(\d\d)(\d\d)(\d\d)(\d
> \d)(?:\.(\d\d))?$}
> + if {[regexp $timespec $options(t) {} CC YY MM DD hh mm
> SS]} {
> + if {[string length $YY] == 0} {
> + set year [clock format [clock seconds] -format
> %Y]
> + } elseif {[string length $CC] == 0} {
> + if {$YY >= 69 && $YY <= 99} {
> + set year 19$YY
> + } else {
> + set year 20$YY
> + }
> + } else {
> + set year $CC$YY
> + }
> + if {[string length $SS] == 0} {
> + set SS 00
> + }
> + set atime [clock scan "$year$MM$DD $hh$mm$SS"]
> + set mtime $atime
> + } else {
> + return -code error \
> + {touch: out of range or illegal time
> specification: [[CC]YY]MMDDhhmm[.SS]}
> + }
> + }
> + } else {
> + set atime [clock seconds]
> + set mtime [clock seconds]
> + }
> +
> + # do we have any files to process?
> + if {[llength $args] == 0} {
> + # print usage
> + ui_msg {usage: touch [-a] [-c] [-m] [-r file] [-t [[CC]YY]
> MMDDhhmm[.SS]] file ...}
> + return
> + }
> +
> + foreach file $args {
> + if {![file exists $file]} {
> + if {[info exists options(c)]} {
> + continue
> + } else {
> + close [open $file w]
> + }
> + }
> +
> + if {[info exists options(a)] || ![info exists options(m)]} {
> + file atime $file $atime
> + }
> + if {[info exists options(m)] || ![info exists options(a)]} {
> + file mtime $file $mtime
> + }
> + }
> + return
> +}
> +
> +# copy
> +proc copy {args} {
> + exec file copy $args
> +}
> +
> +# move
> +proc move {args} {
> + exec file rename $args
> +}
> +
> +# ln
> +# Mimics the BSD ln implementation
> +# ln [-f] [-h] [-s] [-v] source_file [target_file]
> +# ln [-f] [-h] [-s] [-v] source_file ... target_dir
> +proc ln {args} {
> + while {[string match -* [lindex $args 0]]} {
> + set arg [string range [lindex $args 0] 1 end]
> + set args [lrange $args 1 end]
> + switch -- $arg {
> + f -
> + h -
> + s -
> + v {set options($arg) yes}
> + - break
> + default {return -code error "ln: illegal option -- $arg"}
> + }
> + }
> +
> + if {[llength $args] == 0} {
> + ui_msg {usage: ln [-f] [-h] [-s] [-v] source_file
> [target_file]}
> + ui_msg { ln [-f] [-h] [-s] [-v] file ... directory}
> + return
> + } elseif {[llength $args] == 1} {
> + set files $args
> + set target ./
> + } else {
> + set files [lrange $args 0 [expr [llength $args] - 2]]
> + set target [lindex $args end]
> + }
> +
> + foreach file $files {
> + if {[file isdirectory $file] && ![info exists options(s)]} {
> + return -code error "ln: $file: Is a directory"
> + }
> +
> + if {[file isdirectory $target] && ![info exists options
> (h)]} {
> + set linktarget [file join $target [file tail $file]]
> + } else {
> + set linktarget $target
> + }
> +
> + if {[file exists $linktarget] && ![info exists options(f)]} {
> + return -code error "ln: $linktarget: File exists"
> + }
> +
> + if {[llength $files] > 2} {
> + if {![file exists $linktarget]} {
> + return -code error "ln: $linktarget: No such file
> or directory"
> + } elseif {![file isdirectory $target]} {
> + # this error isn't striclty what BSD ln gives, but
> I think it's more useful
> + return -code error "ln: $target: Not a directory"
> + }
> + }
> +
> + if {[info exists options(v)]} {
> + ui_msg "ln: $linktarget -> $file"
> + }
> + if {[info exists options(s)]} {
> + file link -symbolic $linktarget $file
> + } else {
> + file link -hard $linktarget $file
> + }
> + }
> + return
> +}
> +
> # filefindbypath
> # Provides searching of the standard path for included files
> proc filefindbypath {fname} {
> _______________________________________________
> macports-changes mailing list
> macports-changes at lists.macosforge.org
> http://lists.macosforge.org/mailman/listinfo/macports-changes
-------------- next part --------------
An HTML attachment was scrubbed...
URL: http://lists.macosforge.org/pipermail/macports-dev/attachments/20070214/55510f7e/attachment.html
More information about the macports-dev
mailing list