diff options
| -rw-r--r-- | ChangeLog | 9 | ||||
| -rw-r--r-- | doc/file.n | 19 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 159 | ||||
| -rw-r--r-- | generic/tclInt.h | 5 | ||||
| -rw-r--r-- | tests/cmdAH.test | 53 | ||||
| -rw-r--r-- | unix/configure.in | 33 | ||||
| -rw-r--r-- | unix/tclUnixFCmd.c | 123 | ||||
| -rw-r--r-- | win/tclWinPipe.c | 122 |
8 files changed, 459 insertions, 64 deletions
@@ -1,5 +1,14 @@ 2008-11-29 Donal K. Fellows <dkf@users.sf.net> + TIP #210 IMPLEMENTATION + + * generic/tclCmdAH.c (FileTempfileCmd): + * unix/tclUnixFCmd.c (TclpOpenTemporaryFile, DefaultTempDir): + * win/tclWinPipe.c (TclpOpenTemporaryFile): + * doc/file.n, tests/cmdAH.test: Implementation of [file tempfile]. I + do not claim that this is a brilliant implementation, especially on + Windows, but it covers the main points. + * generic/tclThreadStorage.c: General revisions to make code clearer and more like the style used in the rest of the core. Includes adding more comments and explanation of what is going on. Reduce the amount @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: file.n,v 1.55 2008/10/15 10:43:37 dkf Exp $ +'\" RCS: @(#) $Id: file.n,v 1.56 2008/11/29 18:17:19 dkf Exp $ '\" .so man.macros .TH file n 8.3 Tcl "Tcl Built-In Commands" @@ -435,6 +435,19 @@ If \fIname\fR contains no separators then returns \fIname\fR. So, \fBfile tail a/b\fR, \fBfile tail a/b/\fR and \fBfile tail b\fR all return \fBb\fR. .TP +\fBfile tempfile\fR ?\fInameVar\fR? ?\fItemplate\fR? +'\" TIP #210 +.VS 8.6 +Creates a temporary file and returns a read-write channel opened on that file. +If the \fInameVar\fR is given, it specifies a variable that the name of the +temporary file will be written into; if absent, Tcl will attempt to arrange +for the temporary file to be deleted once it is no longer required. If the +\fItemplate\fR is present, it specifies parts of the template of the filename +to use when creating it (such as the directory, base-name or extension) though +some platforms may ignore some or all of these parts and use a built-in +default instead. +.VE 8.6 +.TP \fBfile type \fIname\fR . Returns a string giving the type of file \fIname\fR, which will be one of @@ -519,3 +532,7 @@ filename(n), open(n), close(n), eof(n), gets(n), tell(n), seek(n), fblocked(n), flush(n) .SH KEYWORDS attributes, copy files, delete files, directory, file, move files, name, rename files, stat +'\" Local Variables: +'\" mode: nroff +'\" fill-column: 78 +'\" End: diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index df24e16..19ef57e 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -10,7 +10,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.109 2008/10/26 18:34:04 dkf Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.110 2008/11/29 18:17:20 dkf Exp $ */ #include "tclInt.h" @@ -45,6 +45,8 @@ static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr, static int EncodingDirsObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int FileTempfileCmd(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static inline int ForeachAssignments(Tcl_Interp *interp, struct ForeachState *statePtr); static inline void ForeachCleanup(Tcl_Interp *interp, @@ -893,8 +895,8 @@ Tcl_FileObjCmd( "normalize", "owned", "pathtype", "readable", "readlink", "rename", "rootname", "separator", "size", "split", - "stat", "system", - "tail", "type", "volumes", "writable", + "stat", "system", "tail", "tempfile", + "type", "volumes", "writable", NULL }; enum options { @@ -906,8 +908,8 @@ Tcl_FileObjCmd( FCMD_NORMALIZE, FCMD_OWNED, FCMD_PATHTYPE, FCMD_READABLE, FCMD_READLINK, FCMD_RENAME, FCMD_ROOTNAME, FCMD_SEPARATOR, FCMD_SIZE, FCMD_SPLIT, - FCMD_STAT, FCMD_SYSTEM, - FCMD_TAIL, FCMD_TYPE, FCMD_VOLUMES, FCMD_WRITABLE + FCMD_STAT, FCMD_SYSTEM, FCMD_TAIL, FCMD_TEMPFILE, + FCMD_TYPE, FCMD_VOLUMES, FCMD_WRITABLE }; if (objc < 2) { @@ -1414,6 +1416,8 @@ Tcl_FileObjCmd( Tcl_DecrRefCount(dirPtr); return TCL_OK; } + case FCMD_TEMPFILE: + return FileTempfileCmd(interp, objc, objv); case FCMD_VOLUMES: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); @@ -1635,6 +1639,151 @@ GetTypeFromMode( } /* + *--------------------------------------------------------------------------- + * + * FileTempfileCmd + * + * This function implements the "tempfile" subcommand of the "file" + * command. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Creates a temporary file. Opens a channel to that file and puts the + * name of that channel in the result. *Might* register suitable exit + * handlers to ensure that the temporary file gets deleted. Might write + * to a variable, so reentrancy is a potential issue. + * + *--------------------------------------------------------------------------- + */ + +static int +FileTempfileCmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *nameVarObj = NULL; /* Variable to store the name of the temporary + * file in. */ + Tcl_Obj *nameObj = NULL; /* Object that will contain the filename. */ + Tcl_Channel chan; /* The channel opened (RDWR) on the temporary + * file, or NULL if there's an error. */ + Tcl_Obj *tempDirObj = NULL, *tempBaseObj = NULL, *tempExtObj = NULL; + /* Pieces of template. Each piece is NULL if + * it is omitted. The platform temporary file + * engine might ignore some pieces. */ + + if (objc < 2 || objc > 4) { + Tcl_WrongNumArgs(interp, 2, objv, "?nameVar? ?template?"); + return TCL_ERROR; + } + + if (objc > 2) { + nameVarObj = objv[2]; + TclNewObj(nameObj); + } + if (objc > 3) { + int length; + const char *string = TclGetStringFromObj(objv[3], &length); + + /* + * Treat an empty string as if it wasn't there. + */ + + if (length == 0) { + goto makeTemporary; + } + + /* + * The template only gives a directory if there is a directory + * separator in it. + */ + + if (strchr(string, '/') != NULL + || (tclPlatform == TCL_PLATFORM_WINDOWS + && strchr(string, '\\') != NULL)) { + tempDirObj = TclPathPart(interp, objv[3], TCL_PATH_DIRNAME); + } + + /* + * The template only gives the filename if the last character isn't a + * directory separator. + */ + + if (string[length-1] != '/' && (tclPlatform != TCL_PLATFORM_WINDOWS + || string[length-1] != '\\')) { + Tcl_Obj *tailObj = TclPathPart(interp, objv[3], TCL_PATH_TAIL); + + tempBaseObj = TclPathPart(interp, tailObj, TCL_PATH_ROOT); + tempExtObj = TclPathPart(interp, tailObj, TCL_PATH_EXTENSION); + TclDecrRefCount(tailObj); + } + } + + /* + * Convert empty parts of the template into unspecified parts. + */ + + if (tempDirObj && !TclGetString(tempDirObj)[0]) { + TclDecrRefCount(tempDirObj); + tempDirObj = NULL; + } + if (tempBaseObj && !TclGetString(tempBaseObj)[0]) { + TclDecrRefCount(tempBaseObj); + tempBaseObj = NULL; + } + if (tempExtObj && !TclGetString(tempExtObj)[0]) { + TclDecrRefCount(tempExtObj); + tempExtObj = NULL; + } + + /* + * Create and open the temporary file. + */ + + makeTemporary: + chan = TclpOpenTemporaryFile(tempDirObj,tempBaseObj,tempExtObj, nameObj); + + /* + * If we created pieces of template, get rid of them now. + */ + + if (tempDirObj) { + TclDecrRefCount(tempDirObj); + } + if (tempBaseObj) { + TclDecrRefCount(tempBaseObj); + } + if (tempExtObj) { + TclDecrRefCount(tempExtObj); + } + + /* + * Deal with results. + */ + + if (chan == NULL) { + if (nameVarObj) { + TclDecrRefCount(nameObj); + } + Tcl_AppendResult(interp, "can't create temporary file: ", + Tcl_PosixError(interp), NULL); + return TCL_ERROR; + } + Tcl_RegisterChannel(interp, chan); + if (nameVarObj != NULL) { + if (Tcl_ObjSetVar2(interp, nameVarObj, NULL, nameObj, + TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_UnregisterChannel(interp, chan); + return TCL_ERROR; + } + } + Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); + return TCL_OK; +} + +/* *---------------------------------------------------------------------- * * Tcl_ForObjCmd -- diff --git a/generic/tclInt.h b/generic/tclInt.h index 027e93e..85c8c00 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.406 2008/11/13 22:34:33 nijtmans Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.407 2008/11/29 18:17:20 dkf Exp $ */ #ifndef _TCLINT @@ -2783,6 +2783,9 @@ MODULE_SCOPE Tcl_FSDupInternalRepProc TclNativeDupInternalRep; MODULE_SCOPE Tcl_Obj * TclpObjLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkType); MODULE_SCOPE int TclpObjChdir(Tcl_Obj *pathPtr); +MODULE_SCOPE Tcl_Channel TclpOpenTemporaryFile(Tcl_Obj *dirObj, + Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, + Tcl_Obj *resultingNameObj); MODULE_SCOPE Tcl_Obj * TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_PathPart portion); MODULE_SCOPE void TclpPanic(const char *format, ...); diff --git a/tests/cmdAH.test b/tests/cmdAH.test index cca533f..b5408dd 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: cmdAH.test,v 1.63 2008/09/24 19:31:29 dgp Exp $ +# RCS: @(#) $Id: cmdAH.test,v 1.64 2008/11/29 18:17:19 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -201,7 +201,7 @@ test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { } -result {wrong # args: should be "file option ?arg ...?"} test cmdAH-5.2 {Tcl_FileObjCmd} -returnCodes error -body { file x -} -result {bad option "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable} +} -result {bad option "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable} test cmdAH-5.3 {Tcl_FileObjCmd} -returnCodes error -body { file exists } -result {wrong # args: should be "file exists name"} @@ -1445,7 +1445,7 @@ test cmdAH-29.5 {Tcl_FileObjCmd: type} { test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file gorp x -} -result {bad option "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable} +} -result {bad option "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable} test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file ex x } -match glob -result {ambiguous option "ex": must be *} @@ -1530,6 +1530,53 @@ test cmdAH-31.13 {Tcl_FileObjCmd: channels in other interp} { safeInterp eval [list file channels] } {stdout} +# Temp files (TIP#210) +test cmdAH-32.1 {file tempfile - usage} -returnCodes error -body { + file tempfile a b c +} -result {wrong # args: should be "file tempfile ?nameVar? ?template?"} +test cmdAH-32.2 {file tempfile - returns a read/write channel} -body { + set f [file tempfile] + puts $f ok + seek $f 0 + gets $f +} -cleanup { + catch {close $f} +} -result ok +test cmdAH-32.3 {file tempfile - makes filenames} -setup { + catch {unset name} +} -body { + set result [info exists name] + set f [file tempfile name] + lappend result [info exists name] [file exists $name] + close $f + lappend result [file exists $name] +} -cleanup { + catch {close $f} + catch {file delete $name} +} -result {0 1 1 1} +# We try to obey the template on Unix, but don't (currently) bother on Win +test cmdAH-32.4 {file tempfile - templates} -constraints unix -body { + close [file tempfile name foo] + expr {[string match foo* [file tail $name]] ? "ok" : "foo produced $name"} +} -cleanup { + catch {file delete $name} +} -result ok +test cmdAH-32.5 {file tempfile - templates} -constraints unix -body { + set template [file join $dirfile foo] + close [file tempfile name $template] + expr {[string match $template* $name] ? "ok" : "$template produced $name"} +} -cleanup { + catch {file delete $name} +} -result ok +test cmdAH-32.6 {file tempfile - templates} -constraints unix -body { + set template [file join $dirfile foo] + close [file tempfile name $template.bar] + expr {[string match $template*.bar $name] ? "ok" : + "$template.bar produced $name"} +} -cleanup { + catch {file delete $name} +} -result ok + # This shouldn't work, but just in case a test above failed... catch {close $newFileId} diff --git a/unix/configure.in b/unix/configure.in index 61153a5..e5dc12b 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -3,7 +3,7 @@ dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run during Tcl installation dnl to configure the system for the local environment. # -# RCS: @(#) $Id: configure.in,v 1.189 2008/10/14 20:08:21 dgp Exp $ +# RCS: @(#) $Id: configure.in,v 1.190 2008/11/29 18:17:19 dkf Exp $ AC_INIT([tcl],[8.6]) AC_PREREQ(2.59) @@ -244,24 +244,24 @@ fi SC_TIME_HANDLER #-------------------------------------------------------------------- -# Some systems (e.g., IRIX 4.0.5) lack the st_blksize field -# in struct stat. But we might be able to use fstatfs instead. +# Some systems (e.g., IRIX 4.0.5) lack the st_blksize field in struct +# stat. But we might be able to use fstatfs instead. #-------------------------------------------------------------------- AC_STRUCT_ST_BLKSIZE AC_CHECK_FUNC(fstatfs, , [AC_DEFINE(NO_FSTATFS, 1, [Do we have fstatfs()?])]) #-------------------------------------------------------------------- -# Some system have no memcmp or it does not work with 8 bit -# data, this checks it and add memcmp.o to LIBOBJS if needed +# Some system have no memcmp or it does not work with 8 bit data, this +# checks it and add memcmp.o to LIBOBJS if needed #-------------------------------------------------------------------- AC_FUNC_MEMCMP #-------------------------------------------------------------------- -# Some system like SunOS 4 and other BSD like systems -# have no memmove (we assume they have bcopy instead). -# {The replacement define is in compat/string.h} +# Some system like SunOS 4 and other BSD like systems have no memmove +# (we assume they have bcopy instead). {The replacement define is in +# compat/string.h} #-------------------------------------------------------------------- AC_CHECK_FUNC(memmove, , [ @@ -269,8 +269,8 @@ AC_CHECK_FUNC(memmove, , [ AC_DEFINE(NO_STRING_H, 1, [Do we have <string.h>?]) ]) #-------------------------------------------------------------------- -# On some systems strstr is broken: it returns a pointer even -# even if the original string is empty. +# On some systems strstr is broken: it returns a pointer even even if +# the original string is empty. #-------------------------------------------------------------------- SC_TCL_CHECK_BROKEN_FUNC(strstr, [ @@ -486,10 +486,10 @@ fi SC_ENABLE_LANGINFO #-------------------------------------------------------------------- -# Check for support of chflags function +# Check for support of chflags and mkstemps functions #-------------------------------------------------------------------- -AC_CHECK_FUNCS(chflags) +AC_CHECK_FUNCS(chflags mkstemps) #-------------------------------------------------------------------- # Check for support of isnan() function or macro @@ -552,7 +552,7 @@ else fi #-------------------------------------------------------------------- -# Check for support of fts functions (readdir replacement) +# Check for support of fts functions (readdir replacement) #-------------------------------------------------------------------- AC_CACHE_CHECK([for fts], tcl_cv_api_fts, [ @@ -570,10 +570,9 @@ if test $tcl_cv_api_fts = yes; then fi #-------------------------------------------------------------------- -# The statements below check for systems where POSIX-style -# non-blocking I/O (O_NONBLOCK) doesn't work or is unimplemented. -# On these systems (mostly older ones), use the old BSD-style -# FIONBIO approach instead. +# The statements below check for systems where POSIX-style non-blocking +# I/O (O_NONBLOCK) doesn't work or is unimplemented. On these systems +# (mostly older ones), use the old BSD-style FIONBIO approach instead. #-------------------------------------------------------------------- SC_BLOCKING_STYLE diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index 868e98e..442c6d6 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixFCmd.c,v 1.69 2008/10/26 12:45:04 dkf Exp $ + * RCS: @(#) $Id: tclUnixFCmd.c,v 1.70 2008/11/29 18:17:19 dkf Exp $ * * Portions of this code were derived from NetBSD source code which has the * following copyright notice: @@ -181,6 +181,7 @@ const TclFileAttrProcs tclpFileAttrProcs[] = { static int CopyFileAtts(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); +static const char * DefaultTempDir(void); static int DoCopyFile(const char *srcPtr, const char *dstPtr, const Tcl_StatBuf *statBufPtr); static int DoCreateDirectory(const char *pathPtr); @@ -2090,6 +2091,126 @@ TclpObjNormalizePath( return nextCheckpoint; } +/* + *---------------------------------------------------------------------- + * + * TclpOpenTemporaryFile -- + * + * Creates a temporary file, possibly based on the supplied bits and + * pieces of template supplied in the first three arguments. If the + * fourth argument is non-NULL, it contains a Tcl_Obj to store the name + * of the temporary file in (and it is caller's responsibility to clean + * up). If the fourth argument is NULL, try to arrange for the temporary + * file to go away once it is no longer needed. + * + * Results: + * A read-write Tcl Channel open on the file. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +TclpOpenTemporaryFile( + Tcl_Obj *dirObj, + Tcl_Obj *basenameObj, + Tcl_Obj *extensionObj, + Tcl_Obj *resultingNameObj) +{ + Tcl_Channel chan; + Tcl_DString template, tmp; + const char *string; + int len, fd; + + if (dirObj) { + string = Tcl_GetStringFromObj(dirObj, &len); + Tcl_UtfToExternalDString(NULL, string, len, &template); + } else { + Tcl_DStringInit(&template); + Tcl_DStringAppend(&template, DefaultTempDir(), -1); /* INTL: native */ + } + + Tcl_DStringAppend(&template, "/", -1); + + if (basenameObj) { + string = Tcl_GetStringFromObj(basenameObj, &len); + Tcl_UtfToExternalDString(NULL, string, len, &tmp); + Tcl_DStringAppend(&template, Tcl_DStringValue(&tmp), -1); + Tcl_DStringFree(&tmp); + } else { + Tcl_DStringAppend(&template, "tcl", -1); + } + + Tcl_DStringAppend(&template, "_XXXXXX", -1); + +#ifdef HAVE_MKSTEMPS + if (extensionObj) { + string = Tcl_GetStringFromObj(extensionObj, &len); + Tcl_UtfToExternalDString(NULL, string, len, &tmp); + Tcl_DStringAppend(&template, Tcl_DStringValue(&tmp), -1); + fd = mkstemps(Tcl_DStringValue(&template), Tcl_DStringLength(&tmp)); + Tcl_DStringFree(&tmp); + } else +#endif + { + fd = mkstemp(Tcl_DStringValue(&template)); + } + + if (fd == -1) { + return NULL; + } + chan = Tcl_MakeFileChannel(INT2PTR(fd), TCL_READABLE|TCL_WRITABLE); + if (resultingNameObj) { + Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&template), + Tcl_DStringLength(&template), &tmp); + Tcl_SetStringObj(resultingNameObj, Tcl_DStringValue(&tmp), + Tcl_DStringLength(&tmp)); + Tcl_DStringFree(&tmp); + } else { + /* + * Try to delete the file immediately since we're not reporting the + * name to anyone. Note that we're *not* handling any errors from + * this! + */ + + unlink(Tcl_DStringValue(&template)); + errno = 0; + } + Tcl_DStringFree(&template); + + return chan; +} + +/* + * Helper that does *part* of what tempnam() does. + */ + +static const char * +DefaultTempDir(void) +{ + const char *dir; + struct stat buf; + + dir = getenv("TMPDIR"); + if (dir && dir[0] && stat(dir, &buf) == 0 && S_ISDIR(buf.st_mode) + && access(dir, W_OK)) { + return dir; + } + +#ifdef P_tmpdir + dir = P_tmpdir; + if (stat(dir, &buf) == 0 && S_ISDIR(buf.st_mode) && access(dir, W_OK)) { + return dir; + } +#endif + + /* + * Assume that "/tmp" is always an existing writable directory; we've no + * recovery mechanism if it isn't. + */ + + return "/tmp"; +} + #if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) /* *---------------------------------------------------------------------- diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index db484db..ad9e6d8 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinPipe.c,v 1.67 2008/10/26 18:43:27 dkf Exp $ + * RCS: @(#) $Id: tclWinPipe.c,v 1.68 2008/11/29 18:17:20 dkf Exp $ */ #include "tclWinInt.h" @@ -1573,6 +1573,7 @@ BuildCommandLine( } else { int count; Tcl_UniChar ch; + for (start = arg; *start != '\0'; start += count) { count = Tcl_UtfToUniChar(start, &ch); if (Tcl_UniCharIsSpace(ch)) { /* INTL: ISO space. */ @@ -1673,18 +1674,18 @@ TclpCreateCommandChannel( infoPtr->writeBuf = 0; infoPtr->writeBufLen = 0; infoPtr->writeError = 0; - infoPtr->channel = (Tcl_Channel) NULL; + infoPtr->channel = NULL; /* * Use one of the fds associated with the channel as the channel id. */ if (readFile) { - channelId = (int) ((WinFile*)readFile)->handle; + channelId = (int) ((WinFile *) readFile)->handle; } else if (writeFile) { - channelId = (int) ((WinFile*)writeFile)->handle; + channelId = (int) ((WinFile *) writeFile)->handle; } else if (errorFile) { - channelId = (int) ((WinFile*)errorFile)->handle; + channelId = (int) ((WinFile *) errorFile)->handle; } else { channelId = 0; } @@ -1731,7 +1732,7 @@ TclpCreateCommandChannel( wsprintfA(channelName, "file%lx", infoPtr); infoPtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName, - (ClientData) infoPtr, infoPtr->validMask); + infoPtr, infoPtr->validMask); /* * Pipes have AUTO translation mode on Windows and ^Z eof char, which @@ -1739,10 +1740,8 @@ TclpCreateCommandChannel( * Windows programs that expect a ^Z at EOF. */ - Tcl_SetChannelOption((Tcl_Interp *) NULL, infoPtr->channel, - "-translation", "auto"); - Tcl_SetChannelOption((Tcl_Interp *) NULL, infoPtr->channel, - "-eofchar", "\032 {}"); + Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto"); + Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}"); return infoPtr->channel; } @@ -1754,22 +1753,18 @@ TclpCreateCommandChannel( * System dependent interface to create a pipe for the [chan pipe] * command. Stolen from TclX. * - * Parameters: - * o interp - Errors returned in result. - * o rchan, wchan - Returned read and write side. - * o flags - Reserved for future use. * Results: - * TCL_OK or TCL_ERROR. + * TCL_OK or TCL_ERROR. * *---------------------------------------------------------------------- */ + int -Tcl_CreatePipe ( - Tcl_Interp *interp, - Tcl_Channel *rchan, - Tcl_Channel *wchan, - int flags - ) +Tcl_CreatePipe( + Tcl_Interp *interp, /* Errors returned in result.*/ + Tcl_Channel *rchan, /* Where to return the read side. */ + Tcl_Channel *wchan, /* Where to return the write side. */ + int flags) /* Reserved for future use. */ { HANDLE readHandle, writeHandle; SECURITY_ATTRIBUTES sec; @@ -1778,24 +1773,21 @@ Tcl_CreatePipe ( sec.lpSecurityDescriptor = NULL; sec.bInheritHandle = FALSE; - if (!CreatePipe (&readHandle, &writeHandle, &sec, 0)) { - TclWinConvertError (GetLastError ()); - Tcl_AppendResult (interp, "pipe creation failed: ", - Tcl_PosixError (interp), (char *) NULL); - return TCL_ERROR; + if (!CreatePipe(&readHandle, &writeHandle, &sec, 0)) { + TclWinConvertError(GetLastError()); + Tcl_AppendResult(interp, "pipe creation failed: ", + Tcl_PosixError(interp), NULL); + return TCL_ERROR; } - - *rchan = Tcl_MakeFileChannel ((ClientData) readHandle, - TCL_READABLE); - Tcl_RegisterChannel (interp, *rchan); - *wchan = Tcl_MakeFileChannel ((ClientData) writeHandle, - TCL_WRITABLE); - Tcl_RegisterChannel (interp, *wchan); + *rchan = Tcl_MakeFileChannel((ClientData) readHandle, TCL_READABLE); + Tcl_RegisterChannel(interp, *rchan); + + *wchan = Tcl_MakeFileChannel((ClientData) writeHandle, TCL_WRITABLE); + Tcl_RegisterChannel(interp, *wchan); return TCL_OK; } - /* *---------------------------------------------------------------------- @@ -2100,9 +2092,8 @@ PipeClose2Proc( */ if (pipePtr->errorFile) { - WinFile *filePtr; + WinFile *filePtr = (WinFile *) pipePtr->errorFile; - filePtr = (WinFile*)pipePtr->errorFile; errChan = Tcl_MakeFileChannel((ClientData) filePtr->handle, TCL_READABLE); ckfree((char *) filePtr); @@ -3159,6 +3150,65 @@ PipeThreadActionProc( } /* + *---------------------------------------------------------------------- + * + * TclpOpenTemporaryFile -- + * + * Creates a temporary file, possibly based on the supplied bits and + * pieces of template supplied in the first three arguments. If the + * fourth argument is non-NULL, it contains a Tcl_Obj to store the name + * of the temporary file in (and it is caller's responsibility to clean + * up). If the fourth argument is NULL, try to arrange for the temporary + * file to go away once it is no longer needed. + * + * Results: + * A read-write Tcl Channel open on the file. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +TclpOpenTemporaryFile( + Tcl_Obj *dirObj, + Tcl_Obj *basenameObj, + Tcl_Obj *extensionObj, + Tcl_Obj *resultingNameObj) +{ + WCHAR name[MAX_PATH]; + HANDLE handle; + DWORD flags = FILE_ATTRIBUTE_TEMPORARY; + + if (!resultingNameObj) { + flags |= FILE_FLAG_DELETE_ON_CLOSE; + } + + do { + if (TempFileName(name) == 0) { + TclWinConvertError(GetLastError()); + return NULL; + } + + handle = tclWinProcs->createFileProc((TCHAR *) name, + GENERIC_READ|GENERIC_WRITE, 0, NULL, CREATE_NEW, flags, NULL); + } while (handle == INVALID_HANDLE_VALUE + && GetLastError() == ERROR_FILE_EXISTS); + if (handle == INVALID_HANDLE_VALUE) { + TclWinConvertError(GetLastError()); + return NULL; + } + + if (resultingNameObj) { + Tcl_Obj *tmpObj = TclpNativeToNormalized(name); + + Tcl_AppendObjToObj(resultingNameObj, tmpObj); + TclDecrRefCount(tmpObj); + } + + return Tcl_MakeFileChannel((ClientData) handle, + TCL_READABLE|TCL_WRITABLE); +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 |