[24435] trunk/base/src/port1.0
source_changes at macosforge.org
source_changes at macosforge.org
Tue Apr 24 03:23:05 PDT 2007
Revision: 24435
http://trac.macosforge.org/projects/macports/changeset/24435
Author: eridius at macports.org
Date: 2007-04-24 03:23:05 -0700 (Tue, 24 Apr 2007)
Log Message:
-----------
Reimplement delete using fs-traverse - *much* smaller now.
Add test file for portutil, currently only tests delete
Modified Paths:
--------------
trunk/base/src/port1.0/Makefile
trunk/base/src/port1.0/portutil.tcl
Added Paths:
-----------
trunk/base/src/port1.0/tests/
trunk/base/src/port1.0/tests/portutil.tcl
Modified: trunk/base/src/port1.0/Makefile
===================================================================
--- trunk/base/src/port1.0/Makefile 2007-04-24 09:54:38 UTC (rev 24434)
+++ trunk/base/src/port1.0/Makefile 2007-04-24 10:23:05 UTC (rev 24435)
@@ -12,6 +12,8 @@
include ../../Mk/dports.subdir.mk
include ../../Mk/dports.autoconf.mk
+.PHONY: test
+
all::
clean::
@@ -25,3 +27,6 @@
$(INSTALL) -o ${DSTUSR} -g ${DSTGRP} -m 444 $$file ${INSTALLDIR}; \
done
$(SILENT) $(TCLSH) ../pkg_mkindex.tcl ${INSTALLDIR}
+
+test::
+ ${TCLSH} tests/portutil.tcl
Modified: trunk/base/src/port1.0/portutil.tcl
===================================================================
--- trunk/base/src/port1.0/portutil.tcl 2007-04-24 09:54:38 UTC (rev 24434)
+++ trunk/base/src/port1.0/portutil.tcl 2007-04-24 10:23:05 UTC (rev 24435)
@@ -711,30 +711,12 @@
# delete
# file delete -force by itself doesn't handle directories properly
-# on systems older than Tiger. However we can recurse this thing ourselves
+# on systems older than Tiger. Lets recurse using fs-traverse instead
proc delete {args} {
- foreach arg $args {
- ui_debug "delete: $arg"
- set stack [list $arg]
- while {[llength $stack] > 0} {
- set file [lindex $stack 0]
- if {[string equal [file type $file] directory]} {
- # 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]
- }
- }
+ ui_debug "delete: $args"
+ fs-traverse -depth file $args {
+ file delete -force -- $file
+ continue
}
}
Added: trunk/base/src/port1.0/tests/portutil.tcl
===================================================================
--- trunk/base/src/port1.0/tests/portutil.tcl (rev 0)
+++ trunk/base/src/port1.0/tests/portutil.tcl 2007-04-24 10:23:05 UTC (rev 24435)
@@ -0,0 +1,133 @@
+# Test file for Pextlib's fs-traverse
+# Requires r/w access to /tmp
+# MacPorts must be installed for this to work
+
+catch {source /Library/Tcl/darwinports1.0/darwinports_fastload.tcl}
+# load the current copy of portutil instead of the installed one
+source [file dirname [info script]]/../portutil.tcl
+package require darwinports
+
+# boilerplate necessary for using the macports infrastructure
+proc ui_isset {val} { return 0 }
+
+# no global options
+proc global_option_isset {val} { return 0 }
+
+# UI callback
+proc ui_prefix {priority} {
+ switch $priority {
+ debug {
+ return "DEBUG: "
+ }
+ error {
+ return "Error: "
+ }
+ warn {
+ return "Warning: "
+ }
+ default {
+ return ""
+ }
+ }
+}
+
+proc ui_channels {priority} {
+ switch $priority {
+ debug -
+ info {
+ return {}
+ }
+ msg {
+ return {stdout}
+ }
+ error {
+ return {stderr}
+ }
+ default {
+ return {stdout}
+ }
+ }
+}
+
+array set ui_options {}
+array set global_options {}
+array set global_variations {}
+dportinit ui_options global_options global_variations
+
+# end boilerplate
+
+namespace eval tests {
+
+proc test_delete {} {
+ set root "/tmp/macports-portutil-delete"
+ # use file delete -force to kill the test directory if it already exists
+ # yeah I realize this will fail on 10.3 if it already exists. oh well.
+ file delete -force $root
+ mtree $root {
+ a directory
+ a/a file
+ a/b file
+ a/c directory
+ a/c/a file
+ a/c/b {link ../b}
+ a/c/c {link ../../b}
+ a/c/d directory
+ a/c/d/a file
+ a/c/d/b directory
+ a/c/d/c file
+ a/d file
+ b directory
+ b/a file
+ b/b {link q}
+ b/c directory
+ b/c/a file
+ b/c/b file
+ b/d file
+ }
+
+ # test multiple args
+ delete $root/a $root/b
+
+ if {[file exists $root/a] || [file exists $root/b]} {
+ file delete -force $root
+ error "delete failed"
+ }
+ file delete -force $root
+}
+
+# Create a filesystem hierarchy based on the given specification
+# The mtree spec consists of name/type pairings, where type can be
+# one of directory, file or link. If type is link, it must be a
+# two-element list containing the path as the second element
+proc mtree {root spec} {
+ foreach {entry typelist} $spec {
+ set type [lindex $typelist 0]
+ set link [lindex $typelist 1]
+ set file [file join $root $entry]
+ switch $type {
+ directory {
+ file mkdir $file
+ }
+ file {
+ # touch
+ close [open $file w]
+ }
+ link {
+ # file link doesn't let you link to files that don't exist
+ # so lets farm out to /bin/ln
+ exec /bin/ln -s $link $file
+ }
+ default {
+ return -code error "Unknown file map type: $typelist"
+ }
+ }
+ }
+}
+
+# run all tests
+foreach proc [info procs test_*] {
+ $proc
+}
+
+# namespace eval tests
+}
Property changes on: trunk/base/src/port1.0/tests/portutil.tcl
___________________________________________________________________
Name: svn:keywords
+ Id
Name: svn:eol-style
+ native
-------------- next part --------------
An HTML attachment was scrubbed...
URL: http://lists.macosforge.org/pipermail/macports-changes/attachments/20070424/8f50fd6e/attachment.html
More information about the macports-changes
mailing list