diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tcl.decls | 4 | ||||
| -rw-r--r-- | generic/tcl.h | 13 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 100 | ||||
| -rw-r--r-- | generic/tclIOUtil.c | 23 | ||||
| -rw-r--r-- | generic/tclTest.c | 5 |
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 \"", |