tip99

5 files changed, 125 insertions, 20 deletions

diff --git a/generic/tcl.decls b/generic/tcl.decls
index ef74bdb..69ebc9c 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -11,7 +11,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 # 
-# RCS: @(#) $Id: tcl.decls,v 1.89 2002/06/13 09:39:59 vincentdarley Exp $
+# RCS: @(#) $Id: tcl.decls,v 1.90 2002/06/21 14:22:28 vincentdarley Exp $
 
 library tcl
 
@@ -1577,7 +1577,7 @@ declare 445 generic {
 	    Tcl_Obj *pathPtr, CONST char *pattern, Tcl_GlobTypeData *types)
 }
 declare 446 generic {
-    Tcl_Obj * Tcl_FSLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkType)
+    Tcl_Obj * Tcl_FSLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkAction)
 }
 declare 447 generic {
     int Tcl_FSRemoveDirectory(Tcl_Obj *pathPtr,
diff --git a/generic/tcl.h b/generic/tcl.h
index 0405cb4..f74f18a 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -13,7 +13,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tcl.h,v 1.128 2002/06/18 00:12:44 davygrvy Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.129 2002/06/21 14:22:28 vincentdarley Exp $
  */
 
 #ifndef _TCL
@@ -1840,6 +1840,17 @@ typedef struct Tcl_Filesystem {
 			     */
 } Tcl_Filesystem;
 
+/*
+ * The following definitions are used as values for the 'linkAction' flag
+ * to Tcl_FSLink, or the linkProc of any filesystem.  Any combination
+ * of flags can be given.  For link creation, the linkProc should create
+ * a link which matches any of the types given.
+ * 
+ * TCL_CREATE_SYMBOLIC_LINK:  Create a symbolic or soft link.
+ * TCL_CREATE_HARD_LINK:      Create a hard link.
+ */
+#define TCL_CREATE_SYMBOLIC_LINK   0x01
+#define TCL_CREATE_HARD_LINK       0x02
 
 /*
  * The following structure represents the Notifier functions that
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 4cf7eb1..bc6b655 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCmdAH.c,v 1.25 2002/06/13 09:40:00 vincentdarley Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.26 2002/06/21 14:22:28 vincentdarley Exp $
  */
 
 #include "tclInt.h"
@@ -791,8 +791,8 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
 	"atime",	"attributes",	"channels",	"copy",
 	"delete",
 	"dirname",	"executable",	"exists",	"extension",
-	"isdirectory",	"isfile",	"join",		"lstat",
-	"mtime",	"mkdir",	"nativename",	
+	"isdirectory",	"isfile",	"join",		"link",
+	"lstat",        "mtime",	"mkdir",	"nativename",	
 	"normalize",    "owned",
 	"pathtype",	"readable",	"readlink",	"rename",
 	"rootname",	"separator",    "size",		"split",	
@@ -804,8 +804,8 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
 	FILE_ATIME,	FILE_ATTRIBUTES, FILE_CHANNELS,	FILE_COPY,
 	FILE_DELETE,
 	FILE_DIRNAME,	FILE_EXECUTABLE, FILE_EXISTS,	FILE_EXTENSION,
-	FILE_ISDIRECTORY, FILE_ISFILE,	FILE_JOIN,	FILE_LSTAT,
-	FILE_MTIME,	FILE_MKDIR,	FILE_NATIVENAME, 
+	FILE_ISDIRECTORY, FILE_ISFILE,	FILE_JOIN,	FILE_LINK, 
+	FILE_LSTAT,     FILE_MTIME,	FILE_MKDIR,	FILE_NATIVENAME, 
 	FILE_NORMALIZE, FILE_OWNED,
 	FILE_PATHTYPE,	FILE_READABLE,	FILE_READLINK,	FILE_RENAME,
 	FILE_ROOTNAME,	FILE_SEPARATOR, FILE_SIZE,	FILE_SPLIT,	
@@ -955,6 +955,96 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
 	    Tcl_SetObjResult(interp, resObj);
 	    return TCL_OK;
 	}
+	case FILE_LINK: {
+	    Tcl_Obj *contents;
+	    int index;
+	    
+	    if (objc < 3 || objc > 5) {
+		Tcl_WrongNumArgs(interp, 2, objv, 
+				 "?-linktype? source ?target?");
+		return TCL_ERROR;
+	    }
+	    
+	    /* Index of the 'source' argument */
+	    if (objc == 5) {
+		index = 3;
+	    } else {
+		index = 2;
+	    }
+	    
+	    if (objc > 3) {
+		int linkAction;
+		if (objc == 5) {
+		    /* We have a '-linktype' argument */
+		    static CONST char *linkTypes[] = {
+			"-symbolic", "-hard", NULL
+		    };
+		    if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes, 
+				     "switch", 0, &linkAction) != TCL_OK) {
+			return TCL_ERROR;
+		    }
+		    if (linkAction == 0) {
+		        linkAction = TCL_CREATE_SYMBOLIC_LINK;
+		    } else {
+			linkAction = TCL_CREATE_HARD_LINK;
+		    }
+		} else {
+		    linkAction = TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK;
+		}
+		if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
+		    return TCL_ERROR;
+		}
+		/* Create link from source to target */
+		contents = Tcl_FSLink(objv[index], objv[index+1], linkAction);
+		if (contents == NULL) {
+		    /* 
+		     * We handle two common error cases specially, and
+		     * for all other errors, we use the standard posix
+		     * error message.
+		     */
+		    if (errno == EEXIST) {
+			Tcl_AppendResult(interp, "could not create new link \"", 
+				Tcl_GetString(objv[index]), 
+				"\": that path already exists", (char *) NULL);
+		    } else if (errno == ENOENT) {
+			Tcl_AppendResult(interp, "could not create new link \"", 
+				Tcl_GetString(objv[index]), 
+				"\" since target \"", 
+				Tcl_GetString(objv[index+1]), 
+				"\" doesn't exist", 
+				(char *) NULL);
+		    } else {
+			Tcl_AppendResult(interp, "could not create new link \"", 
+				Tcl_GetString(objv[index]), "\" pointing to \"", 
+				Tcl_GetString(objv[index+1]), "\": ", 
+				Tcl_PosixError(interp), (char *) NULL);
+		    }
+		    return TCL_ERROR;
+		}
+	    } else {
+		if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
+		    return TCL_ERROR;
+		}
+		/* Read link */
+		contents = Tcl_FSLink(objv[index], NULL, 0);
+		if (contents == NULL) {
+		    Tcl_AppendResult(interp, "could not read link \"", 
+			    Tcl_GetString(objv[index]), "\": ", 
+			    Tcl_PosixError(interp), (char *) NULL);
+		    return TCL_ERROR;
+		}
+	    }
+	    Tcl_SetObjResult(interp, contents);
+	    if (objc == 3) {
+		/* 
+		 * If we are reading a link, we need to free this
+		 * result refCount.  If we are creating a link, this
+		 * will just be objv[index+1], and so we don't own it.
+		 */
+		Tcl_DecrRefCount(contents);
+	    }
+	    return TCL_OK;
+	}
     	case FILE_LSTAT: {
 	    char *varName;
 	    Tcl_StatBuf buf;
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index 2bf584c..041f5b8 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -17,7 +17,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclIOUtil.c,v 1.49 2002/06/13 09:40:00 vincentdarley Exp $
+ * RCS: @(#) $Id: tclIOUtil.c,v 1.50 2002/06/21 14:22:28 vincentdarley Exp $
  */
 
 #include "tclInt.h"
@@ -2690,34 +2690,37 @@ FSUnloadTempFile(clientData)
  *      the caller, which should call Tcl_DecrRefCount when the result
  *      is no longer needed.
  *      
- *      If toPtr is non-NULL, then the result is toPtr if the link
+ *      If toPtr is non-NULL, then the result is toPtr if the link action
  *      was successful, or NULL if not.  In this case the result has no
- *      additional reference count, and need not be freed.
+ *      additional reference count, and need not be freed.  The actual
+ *      action to perform is given by the 'linkAction' flags, which is
+ *      an or'd combination of:
+ *      
+ *        TCL_CREATE_SYMBOLIC_LINK
+ *        TCL_CREATE_HARD_LINK
  *      
  *      Note that most filesystems will not support linking across
  *      to different filesystems, so this function will usually
  *      fail unless toPtr is in the same FS as pathPtr.
  *      
- *      Note: currently no Tcl filesystems support the 'link' action,
- *      so we actually always return an error for that call.
- *
  * Side effects:
- *	See readlink() documentation.
+ *	See readlink() documentation.  A new filesystem link 
+ *	object may appear
  *
  *---------------------------------------------------------------------------
  */
 
 Tcl_Obj *
-Tcl_FSLink(pathPtr, toPtr, linkType)
+Tcl_FSLink(pathPtr, toPtr, linkAction)
     Tcl_Obj *pathPtr;		/* Path of file to readlink or link */
     Tcl_Obj *toPtr;		/* NULL or path to be linked to */
-    int linkType;               /* Type of link to create */
+    int linkAction;             /* Action to perform */
 {
     Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
     if (fsPtr != NULL) {
 	Tcl_FSLinkProc *proc = fsPtr->linkProc;
 	if (proc != NULL) {
-	    return (*proc)(pathPtr, toPtr, linkType);
+	    return (*proc)(pathPtr, toPtr, linkAction);
 	}
     }
     /*
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 1b45e81..14e8ce7 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -13,7 +13,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclTest.c,v 1.50 2002/06/13 09:40:00 vincentdarley Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.51 2002/06/21 14:22:28 vincentdarley Exp $
  */
 
 #define TCL_TEST
@@ -2007,7 +2007,8 @@ TestfilelinkCmd(clientData, interp, objc, objv)
     
     if (objc == 3) {
 	/* Create link from source to target */
-	contents = Tcl_FSLink(objv[1], objv[2], 0);
+	contents = Tcl_FSLink(objv[1], objv[2], 
+			TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK);
 	if (contents == NULL) {
 	    Tcl_AppendResult(interp, "could not create link from \"", 
 		    Tcl_GetString(objv[1]), "\" to \"",