[24444] trunk/base
source_changes at macosforge.org
source_changes at macosforge.org
Tue Apr 24 05:47:08 PDT 2007
Revision: 24444
http://trac.macosforge.org/projects/macports/changeset/24444
Author: eridius at macports.org
Date: 2007-04-24 05:47:07 -0700 (Tue, 24 Apr 2007)
Log Message:
-----------
Implement new Pextlib command symlink which basically implements symlink(2).
Update ln in portutil to use this new symlink command.
Add full testing for ln, and for symlink.
Update ChangeLog appropriately
Modified Paths:
--------------
trunk/base/ChangeLog
trunk/base/src/pextlib1.0/Pextlib.c
trunk/base/src/port1.0/portutil.tcl
trunk/base/src/port1.0/tests/portutil.tcl
Added Paths:
-----------
trunk/base/src/pextlib1.0/tests/symlink.tcl
Modified: trunk/base/ChangeLog
===================================================================
--- trunk/base/ChangeLog 2007-04-24 12:40:23 UTC (rev 24443)
+++ trunk/base/ChangeLog 2007-04-24 12:47:07 UTC (rev 24444)
@@ -6,6 +6,11 @@
(unreleased):
+ - ln uses new symlink command so it can create symlinks that point to
+ files that don't actually exist (eridius r24444).
+
+ - New bare-bones Pextlib command `symlink source target` (ticket #11840, eridius r24444).
+
- delete reimplemented using fs-traverse (eridius r24435).
- fs-traverse now uses the fts(3) family of functions instead of readdir/opendir.
Modified: trunk/base/src/pextlib1.0/Pextlib.c
===================================================================
--- trunk/base/src/pextlib1.0/Pextlib.c 2007-04-24 12:40:23 UTC (rev 24443)
+++ trunk/base/src/pextlib1.0/Pextlib.c 2007-04-24 12:47:07 UTC (rev 24444)
@@ -1094,6 +1094,30 @@
return TCL_OK;
}
+/**
+ * symlink value target
+ * Create a symbolic link at target pointing to value
+ * See symlink(2) for possible errors
+ */
+int CreateSymlinkCmd(ClientData clientData UNUSED, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
+{
+ char *value, *target;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "value target");
+ return TCL_ERROR;
+ }
+
+ value = Tcl_GetString(objv[1]);
+ target = Tcl_GetString(objv[2]);
+
+ if (symlink(value, target) != 0) {
+ Tcl_SetResult(interp, (char *)Tcl_PosixError(interp), TCL_STATIC);
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
int Pextlib_Init(Tcl_Interp *interp)
{
if (Tcl_InitStubs(interp, "8.3", 0) == NULL)
@@ -1124,6 +1148,7 @@
Tcl_CreateObjCommand(interp, "mkchannelfromfd", MkChannelFromFdCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "pipe", PipeCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "curl", CurlCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "symlink", CreateSymlinkCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "readline", ReadlineCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "rl_history", RLHistoryCmd, NULL, NULL);
Added: trunk/base/src/pextlib1.0/tests/symlink.tcl
===================================================================
--- trunk/base/src/pextlib1.0/tests/symlink.tcl (rev 0)
+++ trunk/base/src/pextlib1.0/tests/symlink.tcl 2007-04-24 12:47:07 UTC (rev 24444)
@@ -0,0 +1,38 @@
+# Test file for Pextlib's symlink.
+# Requires r/w access to /tmp/
+# Syntax:
+# tclsh mkfifo.tcl <Pextlib name>
+
+proc main {pextlibname} {
+ load $pextlibname
+
+ set root "/tmp/macports-pextlib-symlink"
+
+ file delete -force $root
+
+ file mkdir $root
+
+ symlink foobar $root/test
+
+ if {[catch {file type $root/test}] || [file type $root/test] ne "link" || [file readlink $root/test] ne "foobar"} {
+ set message "symlink failed: "
+ if {[catch {file type $root/test}]} {
+ append message "symlink not created"
+ } elseif {[file type $root/test] ne "link"} {
+ append message "created [file type $root/test], not link"
+ } else {
+ append message "link to `[file readlink $root/test]', expected `foobar'"
+ }
+ file delete -force $root
+ error $message
+ }
+
+ if {![catch {symlink barfoo $root/test}]} {
+ file delete -force $root
+ error "symlink did not raise error when file already exists"
+ }
+
+ file delete -force $root
+}
+
+main $argv
Property changes on: trunk/base/src/pextlib1.0/tests/symlink.tcl
___________________________________________________________________
Name: svn:keywords
+ Id
Name: svn:eol-style
+ native
Modified: trunk/base/src/port1.0/portutil.tcl
===================================================================
--- trunk/base/src/port1.0/portutil.tcl 2007-04-24 12:40:23 UTC (rev 24443)
+++ trunk/base/src/port1.0/portutil.tcl 2007-04-24 12:47:07 UTC (rev 24444)
@@ -859,14 +859,18 @@
return -code error "ln: $file: Is a directory"
}
- if {[file isdirectory $target] && ![info exists options(h)]} {
+ if {[file isdirectory $target] && ([file type $target] ne "link" || ![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 {![catch {file type $linktarget}]} {
+ if {[info exists options(f)]} {
+ file delete $linktarget
+ } else {
+ return -code error "ln: $linktarget: File exists"
+ }
}
if {[llength $files] > 2} {
@@ -882,7 +886,7 @@
ui_msg "ln: $linktarget -> $file"
}
if {[info exists options(s)]} {
- file link -symbolic $linktarget $file
+ symlink $file $linktarget
} else {
file link -hard $linktarget $file
}
Modified: trunk/base/src/port1.0/tests/portutil.tcl
===================================================================
--- trunk/base/src/port1.0/tests/portutil.tcl 2007-04-24 12:40:23 UTC (rev 24443)
+++ trunk/base/src/port1.0/tests/portutil.tcl 2007-04-24 12:47:07 UTC (rev 24444)
@@ -63,36 +63,39 @@
# 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
+ try {
+ 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
+ }
- if {[file exists $root/a] || [file exists $root/b]} {
+ # test multiple args
+ delete $root/a $root/b
+
+ if {[file exists $root/a] || [file exists $root/b]} {
+ error "delete failed"
+ }
+ } finally {
file delete -force $root
- error "delete failed"
}
- file delete -force $root
}
proc test_touch {} {
@@ -126,6 +129,59 @@
}
}
+proc test_ln {} {
+ set root "/tmp/macports-portutil-ln"
+ file delete -force $root
+
+ file mkdir $root
+ try {
+ close [open $root/a w]
+ ln -s a $root/b
+ if {[catch {file type $root/b}] || [file type $root/b] ne "link"} {
+ set message "ln failed: "
+ if {[catch {file type $root/b}]} {
+ append message "symlink not created"
+ } elseif {[file type $root/b] ne "link"} {
+ append message "created [file type $root/b], expected link"
+ }
+ error $message
+ }
+
+ close [open $root/c w]
+ if {![catch {ln -s c $root/b}]} { error "ln failed" }
+
+ ln -s -f c $root/b
+ if {[catch {file type $root/b}] || [file type $root/b] ne "link"} { error "ln failed" }
+
+ file delete $root/b
+
+ ln $root/a $root/b
+ if {[catch {file type $root/b}] || [file type $root/b] ne "file"} { error "ln failed" }
+
+ file delete $root/b
+ file mkdir $root/dir
+ ln -s dir $root/b
+ ln -s a $root/b
+ if {[catch {file type $root/dir/a}] || [file type $root/dir/a] ne "link"} { error "ln failed" }
+ file delete $root/dir/a
+
+ ln -s -f -h a $root/b
+ if {[catch {file type $root/b}] || [file type $root/b] ne "link" || [file readlink $root/b] ne "a"} { error "ln failed" }
+
+ cd $root/dir
+ ln -s ../c
+ if {[catch {file type $root/dir/c}] || [file type $root/dir/c] ne "link"} { error "ln failed" }
+
+ ln -s foobar $root/d
+ if {[catch {file type $root/d}] || [file type $root/d] ne "link" || [file readlink $root/d] ne "foobar"} { error "ln failed" }
+
+ ln -s -f -h z $root/dir
+ if {[catch {file type $root/dir/z}] || [file type $root/dir/z] ne "link"} { error "ln failed" }
+ } finally {
+ 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
-------------- next part --------------
An HTML attachment was scrubbed...
URL: http://lists.macosforge.org/pipermail/macports-changes/attachments/20070424/b3c9c92c/attachment.html
More information about the macports-changes
mailing list