summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authorvincentdarley <vincentdarley>2002-06-21 14:22:27 (GMT)
committervincentdarley <vincentdarley>2002-06-21 14:22:27 (GMT)
commitbb4e2d03bf05b0d16efdf08c97daf5c1f2b35c7b (patch)
tree4ef5a455a5af3008e1352fe5dce00df230fdef43 /generic
parente5f38332d33ee51ce394b1273c7c5cb30e3994d8 (diff)
downloadtcl-bb4e2d03bf05b0d16efdf08c97daf5c1f2b35c7b.zip
tcl-bb4e2d03bf05b0d16efdf08c97daf5c1f2b35c7b.tar.gz
tcl-bb4e2d03bf05b0d16efdf08c97daf5c1f2b35c7b.tar.bz2
tip99
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.decls4
-rw-r--r--generic/tcl.h13
-rw-r--r--generic/tclCmdAH.c100
-rw-r--r--generic/tclIOUtil.c23
-rw-r--r--generic/tclTest.c5
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 \"",