Tcl Source Code

Artifact Content
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to tclconference@googlegroups.com
or submit via the online form by Sep 9.

Artifact 5bc486b94efb7a8e3fdfa3de386150759d8f284d:

Attachment "file-tempname.patch" to ticket [999162ffff] added by techentin 2004-07-28 12:13:25.
Index: doc/file.n
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/file.n,v
retrieving revision 1.35
diff -c -r1.35 file.n
*** doc/file.n	2 Jun 2004 14:24:05 -0000	1.35
--- doc/file.n	28 Jul 2004 05:03:50 -0000
***************
*** 405,410 ****
--- 405,417 ----
  \fBfile tail a/b\fR, \fBfile tail a/b/\fR and \fBfile tail b\fR all
  return \fBb\fR.
  .TP
+ \fBfile tempname
+ .
+ Returns a string that is a valid filename, which does not exist.  
+ More specifically, it did not exist at some point in the past.
+ The filename is suitable for a temporary file.  Each call will
+ return a different, unique filename.
+ .TP
  \fBfile type \fIname\fR
  .
  Returns a string giving the type of file \fIname\fR, which will be one of
Index: generic/tclCmdAH.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCmdAH.c,v
retrieving revision 1.45
diff -c -r1.45 tclCmdAH.c
*** generic/tclCmdAH.c	13 May 2004 12:59:21 -0000	1.45
--- generic/tclCmdAH.c	28 Jul 2004 05:03:52 -0000
***************
*** 869,875 ****
  	"pathtype",	"readable",	"readlink",	"rename",
  	"rootname",	"separator",    "size",		"split",	
  	"stat",         "system", 
! 	"tail",		"type",		"volumes",	"writable",
  	(char *) NULL
      };
      enum options {
--- 869,876 ----
  	"pathtype",	"readable",	"readlink",	"rename",
  	"rootname",	"separator",    "size",		"split",	
  	"stat",         "system", 
! 	"tail",		"tempname",     "type",		"volumes",
! 	"writable",
  	(char *) NULL
      };
      enum options {
***************
*** 882,888 ****
  	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
      };
  
      if (objc < 2) {
--- 883,890 ----
  	FCMD_PATHTYPE,	FCMD_READABLE,	FCMD_READLINK,	FCMD_RENAME,
  	FCMD_ROOTNAME,	FCMD_SEPARATOR, FCMD_SIZE,	FCMD_SPLIT,	
  	FCMD_STAT,      FCMD_SYSTEM, 
! 	FCMD_TAIL,	FCMD_TEMPNAME,  FCMD_TYPE,	FCMD_VOLUMES,
! 	FCMD_WRITABLE
      };
  
      if (objc < 2) {
***************
*** 1425,1430 ****
--- 1427,1434 ----
  		return TCL_OK;
  	    }
  	}
+ 	case FCMD_TEMPNAME:
+ 	    return TclFileTempnameCmd(interp, objc, objv);
  	case FCMD_TYPE: {
  	    Tcl_StatBuf buf;
  
Index: generic/tclFCmd.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclFCmd.c,v
retrieving revision 1.26
diff -c -r1.26 tclFCmd.c
*** generic/tclFCmd.c	6 Apr 2004 22:25:51 -0000	1.26
--- generic/tclFCmd.c	28 Jul 2004 05:03:53 -0000
***************
*** 417,422 ****
--- 417,454 ----
  /*
   *---------------------------------------------------------------------------
   *
+  * TclFileTempnameCmd
+  *
+  *	This procedure implements the "tempname" subcommand of the "file"
+  *	command.  
+  *
+  * Results:
+  *	Returns a temporary file name.
+  *
+  * Side effects:
+  *	None.
+  *
+  *---------------------------------------------------------------------------
+  */
+ 
+ int
+ TclFileTempnameCmd(interp, objc, objv)
+     Tcl_Interp *interp;		/* Used for error reporting */
+     int objc;			/* Number of arguments. */
+     Tcl_Obj *CONST objv[];	/* Argument strings passed to Tcl_FileCmd. */
+ {
+   char filename[FILENAME_MAX];
+   if (objc != 2) {
+     Tcl_WrongNumArgs(interp, 2, objv, NULL);
+     return TCL_ERROR;
+   }
+   Tcl_SetResult(interp, tmpnam(filename), NULL);
+   return TCL_OK;
+ }
+ 
+ /*
+  *---------------------------------------------------------------------------
+  *
   * CopyRenameOneFile
   *
   *	Copies or renames specified source file or directory hierarchy
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.170
diff -c -r1.170 tclInt.h
*** generic/tclInt.h	21 Jul 2004 01:45:44 -0000	1.170
--- generic/tclInt.h	28 Jul 2004 05:03:57 -0000
***************
*** 1731,1736 ****
--- 1731,1738 ----
  			    int objc, Tcl_Obj *CONST objv[])) ;
  EXTERN int		TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp *interp,
  			    int objc, Tcl_Obj *CONST objv[])) ;
+ EXTERN int		TclFileTempnameCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ 			    int objc, Tcl_Obj *CONST objv[]));
  EXTERN void		TclFinalizeAllocSubsystem _ANSI_ARGS_((void));
  EXTERN void		TclFinalizeCompExecEnv _ANSI_ARGS_((void));
  EXTERN void		TclFinalizeCompilation _ANSI_ARGS_((void));
Index: tests/cmdAH.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/cmdAH.test,v
retrieving revision 1.43
diff -c -r1.43 cmdAH.test
*** tests/cmdAH.test	23 Jun 2004 15:46:45 -0000	1.43
--- tests/cmdAH.test	28 Jul 2004 05:03:58 -0000
***************
*** 184,190 ****
  } {1 {wrong # args: should be "file option ?arg ...?"}}
  test cmdAH-5.2 {Tcl_FileObjCmd} {
      list [catch {file x} msg] $msg
! } {1 {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}}
  test cmdAH-5.3 {Tcl_FileObjCmd} {
      list [catch {file exists} msg] $msg
  } {1 {wrong # args: should be "file exists name"}}
--- 184,190 ----
  } {1 {wrong # args: should be "file option ?arg ...?"}}
  test cmdAH-5.2 {Tcl_FileObjCmd} {
      list [catch {file x} msg] $msg
! } {1 {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, tempname, type, volumes, or writable}}
  test cmdAH-5.3 {Tcl_FileObjCmd} {
      list [catch {file exists} msg] $msg
  } {1 {wrong # args: should be "file exists name"}}
***************
*** 1412,1436 ****
  
  test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} {
      list [catch {file gorp x} msg] $msg
! } {1 {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}}
  test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} {
      list [catch {file ex x} msg] $msg
! } {1 {ambiguous option "ex": 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}}
  test cmdAH-30.3 {Tcl_FileObjCmd: error conditions} {
      list [catch {file is x} msg] $msg
! } {1 {ambiguous option "is": 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}}
  test cmdAH-30.4 {Tcl_FileObjCmd: error conditions} {
      list [catch {file z x} msg] $msg
! } {1 {bad option "z": 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}}
  test cmdAH-30.5 {Tcl_FileObjCmd: error conditions} {
      list [catch {file read x} msg] $msg
! } {1 {ambiguous option "read": 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}}
  test cmdAH-30.6 {Tcl_FileObjCmd: error conditions} {
      list [catch {file s x} msg] $msg
! } {1 {ambiguous option "s": 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}}
  test cmdAH-30.7 {Tcl_FileObjCmd: error conditions} {
      list [catch {file t x} msg] $msg
! } {1 {ambiguous option "t": 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}}
  test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} {
      list [catch {file dirname ~woohgy} msg] $msg
  } {1 {user "woohgy" doesn't exist}}
--- 1412,1436 ----
  
  test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} {
      list [catch {file gorp x} msg] $msg
! } {1 {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, tempname, type, volumes, or writable}}
  test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} {
      list [catch {file ex x} msg] $msg
! } {1 {ambiguous option "ex": 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, tempname, type, volumes, or writable}}
  test cmdAH-30.3 {Tcl_FileObjCmd: error conditions} {
      list [catch {file is x} msg] $msg
! } {1 {ambiguous option "is": 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, tempname, type, volumes, or writable}}
  test cmdAH-30.4 {Tcl_FileObjCmd: error conditions} {
      list [catch {file z x} msg] $msg
! } {1 {bad option "z": 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, tempname, type, volumes, or writable}}
  test cmdAH-30.5 {Tcl_FileObjCmd: error conditions} {
      list [catch {file read x} msg] $msg
! } {1 {ambiguous option "read": 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, tempname, type, volumes, or writable}}
  test cmdAH-30.6 {Tcl_FileObjCmd: error conditions} {
      list [catch {file s x} msg] $msg
! } {1 {ambiguous option "s": 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, tempname, type, volumes, or writable}}
  test cmdAH-30.7 {Tcl_FileObjCmd: error conditions} {
      list [catch {file t x} msg] $msg
! } {1 {ambiguous option "t": 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, tempname, type, volumes, or writable}}
  test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} {
      list [catch {file dirname ~woohgy} msg] $msg
  } {1 {user "woohgy" doesn't exist}}
Index: tests/fCmd.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/fCmd.test,v
retrieving revision 1.41
diff -c -r1.41 fCmd.test
*** tests/fCmd.test	23 Jun 2004 15:36:56 -0000	1.41
--- tests/fCmd.test	28 Jul 2004 05:04:01 -0000
***************
*** 2429,2434 ****
--- 2429,2451 ----
      catch {set res [open [file join ~a_totally_bogus_user_id/foo bar]]}
  } 1
  
+ test fCmd-30.1 {TclFileTempfileCmd: returns non-existing filename} {} {
+     set fname [file tempname]
+     set length [expr {[string length $fname] > 0}]
+     set exists [file exists $fname]
+     list $length $exists
+ } {1 0}
+ test fCmd-30.2 {TclFileTempfileCmd: too many args} {} {
+     list [catch {file tempname tf1} msg] $msg
+ } {1 {wrong # args: should be "file tempname"}}
+ test fCmd-30.3 {TclFileTempfileCmd: unique name on each call} {} {
+     set tf1 [file tempname]
+     set tf2 [file tempname]
+     expr {$tf1 eq $tf2}
+ } {0}
+ 
+ 
+ 
  cd [temporaryDirectory]
  file delete -force abc.link
  file delete -force d1/d2