Tcl Source Code

As for \fIpathPtr\fR, but used for the destination filename for a copy or
rename operation.
.AP int recursive in
Whether to remove subdirectories and their contents as well.
.AP "const char" *encodingName in
The encoding of the data stored in the
file identified by \fIpathPtr\fR and to be evaluated.
Can also be set to \fBTCL_ENCODING_UTF8_STRICT\fR,
\fBTCL_ENCODING_UTF8_REPLACE\fR or \fBTCL_ENCODING_UTF8_TCL8\fR,
which selects `utf-8` in combination with one of the 3 possible profiles.
.AP "const char" *pattern in
Only files or directories matching this pattern will be returned.
.AP Tcl_GlobTypeData *types in
Only files or directories matching the type descriptions contained in
this structure will be returned. This parameter may be NULL.
.AP Tcl_Interp *interp in
Interpreter to use either for results, evaluation, or reporting error

\fBTcl_FSListVolumes\fR calls each filesystem which has a non-NULL
.QW "list volumes"
function and asks them to return their list of root volumes. It
accumulates the return values in a list which is returned to the
caller (with a reference count of 0).
.PP
\fBTcl_FSEvalFileEx\fR reads the file given by \fIpathPtr\fR using
the encoding/profile identified by \fIencodingName\fR and evaluates
its contents as a Tcl script. It returns the same information as
\fBTcl_EvalObjEx\fR.
If \fIencodingName\fR is NULL, the utf-8 encoding and the
strict profile is used for reading the file contents.
If \fIencodingName\fR is set to \fBTCL_ENCODING_UTF8_STRICT\fR,
\fBTCL_ENCODING_UTF8_REPLACE\fR or \fBTCL_ENCODING_UTF8_TCL8\fR, the
profile is set to the given value, the encoding is utf-8.
If the file could not be read then a Tcl error is returned to describe
why the file could not be read.
The eofchar for files is
.QW \ex1A
(^Z) for all platforms.
If you require a
.QW ^Z

As argv, but type is always wchar_t.
.AP Tcl_AppInitProc *appInitProc in
Address of an application-specific initialization procedure.
The value for this argument is usually \fBTcl_AppInit\fR.
.AP Tcl_Obj *path in
Name of file to use as startup script, or NULL.
.AP "const char" *encoding in
Encoding of file to use as startup script, or NULL, or
\fBTCL_ENCODING_UTF8_STRICT\fR, \fBTCL_ENCODING_UTF8_REPLACE\fR
or \fBTCL_ENCODING_UTF8_TCL8\fR.
.AP "const char" **encodingPtr out
If non-NULL, location to write a copy of the (const char *)
pointing to the encoding name.
.AP Tcl_MainLoopProc *mainLoopProc in
Address of an application-specific event loop procedure.
.AP Tcl_Interp *interp in
Already created Tcl Interpreter.

\fBb\fR added as the second or third character in the value to
indicate that the opened channel should be configured as if with the
\fBfconfigure\fR \fB\-translation binary\fR option, making the channel suitable for
reading or writing of binary data.
.PP
In the second form, \fIaccess\fR consists of a list of any of the
following flags, most of which have the standard POSIX meanings.
If none of \fBRDONLY\fR, \fBWRONLY\fR or \fBRDWR\fR are specified,
\fBRDONLY\fR is the default.
.IP \fBRDONLY\fR
Open the file for reading only.
.IP \fBWRONLY\fR
Open the file for writing only.
.IP \fBRDWR\fR
Open the file for both reading and writing.
.IP \fBAPPEND\fR

.PP
A leading BOM (Byte order mark) contained in the file is ignored for
unicode encodings (utf-8, utf-16, ucs-2).
.PP
The \fB\-encoding\fR option is used to specify the encoding of
the data stored in \fIfileName\fR.  When the \fB\-encoding\fR option
is omitted, the utf-8 encoding is assumed.
.PP
The \fB\-profile\fR option is used to specify the profile. Can be
"tcl8", "replace" or "strict".
.SH EXAMPLE
.PP
Run the script in the file \fBfoo.tcl\fR and then the script in the
file \fBbar.tcl\fR:
.PP
.CS
\fBsource\fR foo.tcl

 * Reserve top byte for profile values (disjoint, not a mask). In case of
 * changes, ensure ENCODING_PROFILE_* macros in tclInt.h are modified if
 * necessary.
 */
#define TCL_ENCODING_PROFILE_STRICT   TCL_ENCODING_STOPONERROR
#define TCL_ENCODING_PROFILE_TCL8     0x01000000
#define TCL_ENCODING_PROFILE_REPLACE  0x02000000

#define TCL_ENCODING_UTF8_STRICT      ((const char *)-1)
#define TCL_ENCODING_UTF8_REPLACE     ((const char *)-2)
#define TCL_ENCODING_UTF8_TCL8        ((const char *)-3)

/*
 * The following definitions are the error codes returned by the conversion
 * routines:
 *
 * TCL_OK -			All characters were converted.
 * TCL_CONVERT_NOSPACE -	The output buffer would not have been large

    const char *encodingName = NULL;
    Tcl_Obj *fileName;
    int result;
    void **pkgFiles = NULL;
    void *names = NULL;

    if (objc < 2 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-encoding encoding|-profile profile? fileName");
	return TCL_ERROR;
    }

    fileName = objv[objc-1];

    if (objc == 4) {
	static const char *const options[] = {
	    "-encoding", "-profile", NULL
	};
	int index;

	if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], options,
		"option", TCL_EXACT, &index)) {
	    return TCL_ERROR;
	}
	if (index) {
	    int id;
	    result = TclEncodingProfileNameToId(interp, TclGetString(objv[2]), &id);
	    if (result != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (id == TCL_ENCODING_PROFILE_TCL8) {
		encodingName = TCL_ENCODING_UTF8_TCL8;
	    } else if (id == TCL_ENCODING_PROFILE_REPLACE) {
		encodingName = TCL_ENCODING_UTF8_REPLACE;
	    } else {
		encodingName = NULL;
	    }
	} else {
	encodingName = TclGetString(objv[2]);
	}
    } else if (objc == 3) {
	/* Handle undocumented -nopkg option. This should only be
	 * used by the internal ::tcl::Pkg::source utility function. */
	static const char *const nopkgoptions[] = {
	    "-nopkg", NULL
	};
	int index;

		flags |= (TCL_STDIN | TCL_STDOUT);
		break;
	    default:
		Tcl_Panic("Tcl_OpenCmd: invalid mode value");
		break;
	    }
	    chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags);
	    if (chan) {
		if (modeFlags & CHANNEL_RAW_MODE) {
		    Tcl_SetChannelOption(interp, chan, "-translation", "binary");
		} else if (ENCODING_PROFILE_GET(modeFlags) == TCL_ENCODING_PROFILE_TCL8) {
		    Tcl_SetChannelOption(interp, chan, "-profile", "tcl8");
		} else if (ENCODING_PROFILE_GET(modeFlags) == TCL_ENCODING_PROFILE_REPLACE) {
		    Tcl_SetChannelOption(interp, chan, "-profile", "replace");
		}
	    }
	}
	Tcl_Free((void *)cmdArgv);
    }
    if (chan == NULL) {
	return TCL_ERROR;
    }

 *
 *	Computes a POSIX mode mask for opening a file.
 *
 * Results:
 *	The mode to pass to "open", or -1 if an error occurs.
 *
 * Side effects:
 *	Sets *modeFlagsPtr to the expected profile. 0 is the default.
 *
 *	Adds 1 to *modeFlagsPtr to tell the caller to seek to EOF
 *	after opening the file.
 *
 *	Adds 2 to *modeFlagsPtr to tell the caller to configure the
 *	channel as a binary channel.
 *
 *	If there is an error and interp is not NULL, sets
 *	interpreter result to an error message.
 *
 * Special note:
 *	Based on a prototype implementation contributed by Mark Diekhans.
 *

#endif
	} else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) {
	    if (mode & O_TRUNC) {
		goto accessFlagRepeated;
	    }
	    mode |= O_TRUNC;
	} else if ((c == 'B') && (strcmp(flag, "BINARY") == 0)) {
	    if (*modeFlagsPtr & (ENCODING_PROFILE_MASK|CHANNEL_RAW_MODE)) {
		goto invAccess;
	    }
	    *modeFlagsPtr |= CHANNEL_RAW_MODE;
	} else if ((c == 'T') && (strcmp(flag, "TCL8") == 0)) {
	    if (*modeFlagsPtr & (ENCODING_PROFILE_MASK|CHANNEL_RAW_MODE)) {
	    invAccess:
		if (interp != NULL) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
				"invalid access mode \"%s\": modes BINARY, "
				"REPLACE, STRICT, and TCL8 cannot be combined", flag));
		}
		goto invAccessMode;
	    }
	    *modeFlagsPtr |= TCL_ENCODING_PROFILE_TCL8;
	} else if ((c == 'S') && (strcmp(flag, "STRICT") == 0)) {
	    if (*modeFlagsPtr & (ENCODING_PROFILE_MASK|CHANNEL_RAW_MODE)) {
		goto invAccess;
	    }
	    *modeFlagsPtr |= TCL_ENCODING_PROFILE_STRICT;
	} else if ((c == 'R') && (strcmp(flag, "REPLACE") == 0)) {
	    if (*modeFlagsPtr & (ENCODING_PROFILE_MASK|CHANNEL_RAW_MODE)) {
		goto invAccess;
	    }
	    *modeFlagsPtr |= TCL_ENCODING_PROFILE_REPLACE;
	} else {
	    if (interp != NULL) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"invalid access mode \"%s\": must be APPEND, BINARY, "
			"CREAT, EXCL, NOCTTY, NONBLOCK, RDONLY, RDWR, "
			"REPLACE, STRICT, TCL8, TRUNC, or WRONLY", flag));
	    }
	    goto invAccessMode;
	}
    }

    Tcl_Free((void *)modeArgv);









    return mode;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSEvalFile, Tcl_FSEvalFileEx, TclNREvalFile --

int
Tcl_FSEvalFileEx(
    Tcl_Interp *interp,		/* Interpreter that evaluates the script. */
    Tcl_Obj *pathPtr,		/* Pathname of the file to process.
				 * Tilde-substitution is performed on this
				 * pathname. */
    const char *encodingName)	/* Either the name of an encoding or NULL to
				   use the utf-8 encoding. May also be TCL_ENCODING_UTF8_STRICT,
				   TCL_ENCODING_UTF8_REPLACE, or TCL_ENCODING_UTF8_TCL8,
				   for specifying the profile. */
{
    Tcl_Size length;
    int result = TCL_ERROR;
    Tcl_StatBuf statBuf;
    Tcl_Obj *oldScriptFile;
    Interp *iPtr;
    const char *string;

    Tcl_SetChannelOption(interp, chan, "-eofchar", "\x1A");

    /*
     * If the encoding is specified, set the channel to that encoding.
     * Otherwise use utf-8.  If the encoding is unknown report an error.
     */

    if (encodingName == NULL || encodingName == TCL_ENCODING_UTF8_STRICT) {
	goto utf8;
    } else if (encodingName == TCL_ENCODING_UTF8_REPLACE) {
	Tcl_SetChannelOption(interp, chan, "-profile", "replace");
	goto utf8;
    } else if (encodingName == TCL_ENCODING_UTF8_TCL8) {
	Tcl_SetChannelOption(interp, chan, "-profile", "tcl8");
    utf8:
	encodingName = "utf-8";
    }
    if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName)
	    != TCL_OK) {
	Tcl_CloseEx(interp,chan,0);
	return result;
    }

    Tcl_SetChannelOption(interp, chan, "-eofchar", "\x1A");

    /*
     * If the encoding is specified, set the channel to that encoding.
     * Otherwise use utf-8.  If the encoding is unknown report an error.
     */

    if (encodingName == NULL || encodingName == TCL_ENCODING_UTF8_STRICT) {
	goto utf8;
    } else if (encodingName == TCL_ENCODING_UTF8_REPLACE) {
	Tcl_SetChannelOption(interp, chan, "-profile", "replace");
	goto utf8;
    } else if (encodingName == TCL_ENCODING_UTF8_TCL8) {
	Tcl_SetChannelOption(interp, chan, "-profile", "tcl8");
    utf8:
	encodingName = "utf-8";
    }
    if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName)
	    != TCL_OK) {
	Tcl_CloseEx(interp, chan, 0);
	return TCL_ERROR;
    }

			TclGetString(pathPtr), Tcl_PosixError(interp)));
	    }
	    Tcl_CloseEx(NULL, retVal, 0);
	    return NULL;
	}
	if (modeFlags & CHANNEL_RAW_MODE) {
	    Tcl_SetChannelOption(interp, retVal, "-translation", "binary");
	} else if (ENCODING_PROFILE_GET(modeFlags) == TCL_ENCODING_PROFILE_TCL8) {
	    Tcl_SetChannelOption(interp, retVal, "-profile", "tcl8");
	} else if (ENCODING_PROFILE_GET(modeFlags) == TCL_ENCODING_PROFILE_REPLACE) {
	    Tcl_SetChannelOption(interp, retVal, "-profile", "replace");
	}
	return retVal;
    }

    /*
     * File doesn't belong to any filesystem that can open it.
     */

MODULE_SCOPE int	TclFSFileAttrIndex(Tcl_Obj *pathPtr,
			    const char *attributeName, int *indexPtr);
MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs(Tcl_Interp *interp,
			    const char *cmdName, Tcl_Namespace *nsPtr,
			    Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc,
			    void *clientData, Tcl_CmdDeleteProc *deleteProc);
MODULE_SCOPE int	TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,
			    const char *encoding);
MODULE_SCOPE int *	TclGetAsyncReadyPtr(void);
MODULE_SCOPE Tcl_Obj *	TclGetBgErrorHandler(Tcl_Interp *interp);
MODULE_SCOPE int	TclGetChannelFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Channel *chanPtr,
			    int *modePtr, int flags);
MODULE_SCOPE CmdFrame *	TclGetCmdFrameForProcedure(Proc *procPtr);
MODULE_SCOPE int	TclGetCompletionCodeFromObj(Tcl_Interp *interp,

 */

typedef struct {
    Tcl_Obj *path;		/* The filename of the script for *_Main()
				 * routines to [source] as a startup script,
				 * or NULL for none set, meaning enter
				 * interactive mode. */
    Tcl_Obj *encoding;		/* The encoding or profile of the startup script file. */
    Tcl_MainLoopProc *mainLoopProc;
				/* Any installed main loop handler. The main
				 * extension that installs these is Tk. */
} ThreadSpecificData;

/*
 * Structure definition for information used to keep the state of an

 *	None.
 *
 * Side effects:
 *
 *----------------------------------------------------------------------
 */

#define IS_ENCODING(encoding) ((encoding) && (((encoding) < TCL_ENCODING_UTF8_TCL8) \
	|| ((encoding) > TCL_ENCODING_UTF8_STRICT)))

void
Tcl_SetStartupScript(
    Tcl_Obj *path,		/* Filesystem path of startup script file */
    const char *encoding)	/* Encoding of the data in that file */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    Tcl_Obj *encodingObj;

    if (IS_ENCODING(encoding)) {
	encodingObj = Tcl_NewStringObj(encoding, -1);
	Tcl_IncrRefCount(encodingObj);
    } else {
	encodingObj = (Tcl_Obj *)encoding;
    }

    if (path != NULL) {
	Tcl_IncrRefCount(path);
    }
    if (tsdPtr->path != NULL) {
	Tcl_DecrRefCount(tsdPtr->path);
    }
    tsdPtr->path = path;

    if (IS_ENCODING((const char *)tsdPtr->encoding)) {
	Tcl_DecrRefCount(tsdPtr->encoding);
    }
    tsdPtr->encoding = encodingObj;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetStartupScript --
 *
 *	Gets the path and encoding of the startup script to be evaluated by
 *	Tcl_Main.
 *
 * Results:
 *	The path of the startup script; NULL if none has been set.
 *
 * Side effects:
 *	If encodingPtr is not NULL, stores a (const char *) in it pointing
 *	to the encoding name or profile registered for the startup script.
 *	Tcl retains ownership of the string, and may free it. Caller
 *	should make a copy for long-term use.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_GetStartupScript(
    const char **encodingPtr)	/* When not NULL or TCL_ENCODING_UTF8_????,
				 * points to storage for the (const char *) that points to
				 * the registered encoding name for the startup script. */

{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (encodingPtr != NULL) {
	if (IS_ENCODING((const char *)tsdPtr->encoding)) {
	    *encodingPtr = Tcl_GetString(tsdPtr->encoding);
	} else {
	    *encodingPtr = (const char *)tsdPtr->encoding;
	}
    }
    return tsdPtr->path;
}

/*----------------------------------------------------------------------
 *

	/* mind argc is being adjusted as we proceed */
	if ((argc >= 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
		&& ('-' != argv[3][0])) {
	    Tcl_Obj *value = NewNativeObj(argv[2]);
	    Tcl_SetStartupScript(NewNativeObj(argv[3]),
		    Tcl_GetString(value));
	    Tcl_DecrRefCount(value);
	    argc -= 3;
	    i += 3;
	} else if ((argc >= 3) && (0 == _tcscmp(TEXT("-profile"), argv[1]))
		&& ('-' != argv[3][0])) {
	    if (0 == _tcscmp(TEXT("tcl8"), argv[2])) {
		Tcl_SetStartupScript(NewNativeObj(argv[3]), TCL_ENCODING_UTF8_TCL8);
	    } else if (0 == _tcscmp(TEXT("replace"), argv[2])) {
		Tcl_SetStartupScript(NewNativeObj(argv[3]), TCL_ENCODING_UTF8_REPLACE);
	    } else {
		Tcl_SetStartupScript(NewNativeObj(argv[3]), NULL);
	    }
	    argc -= 3;
	    i += 3;
	} else if ((argc >= 1) && ('-' != argv[1][0])) {
	    Tcl_SetStartupScript(NewNativeObj(argv[1]), NULL);
	    argc--;
	    i++;
	}

} "1 unmatched open brace in list
unmatched open brace in list
    while processing open access modes \"FOO {BAR BAZ\"
    invoked from within
\"open \$path(test3) \"FOO \\{BAR BAZ\"\""
test iocmd-12.7 {POSIX open access modes: errors} {
  list [catch {open $path(test3) {FOO BAR BAZ}} msg] $msg
} {1 {invalid access mode "FOO": must be APPEND, BINARY, CREAT, EXCL, NOCTTY, NONBLOCK, RDONLY, RDWR, REPLACE, STRICT, TCL8, TRUNC, or WRONLY}}
test iocmd-12.8 {POSIX open access modes: errors} {
    list [catch {open $path(test3) {BINARY STRICT}} msg] $msg
} {1 {invalid access mode "STRICT": modes BINARY, REPLACE, STRICT, and TCL8 cannot be combined}}
close [open $path(test3) w]
test iocmd-12.9 {POSIX open access modes: BINARY} {
    list [catch {open $path(test1) {RDWR WRONLY}} msg] $msg
} {1 {invalid access mode "WRONLY": modes RDONLY, RDWR, and WRONLY cannot be combined}}
test iocmd-12.10 {POSIX open access modes: BINARY} {
    set f [open $path(test1) {WRONLY BINARY TRUNC}]
    puts $f a
    puts $f b
    puts -nonewline $f c	;# contents are now 5 bytes: a\nb\nc
    close $f
    set f [open $path(test1) r]

    set result
} H
test iocmd-12.12 {POSIX open access modes: errors} {
  list [catch {open $path(test3) {RDWR WRONLY}} msg] $msg
} {1 {invalid access mode "WRONLY": modes RDONLY, RDWR, and WRONLY cannot be combined}}
test iocmd-12.13 {POSIX open access modes: errors} {
  list [catch {open $path(test3) {BINARY BINARY}} msg] $msg
} {1 {invalid access mode "BINARY": modes BINARY, REPLACE, STRICT, and TCL8 cannot be combined}}
test iocmd-12.14 {POSIX open access modes: errors} {
  list [catch {open $path(test3) {TRUNC TRUNC}} msg] $msg
} {1 {access mode "TRUNC" repeated}}

test iocmd-13.1 {errors in open command} {
    list [catch {open} msg] $msg
} {1 {wrong # args: should be "open fileName ?access? ?permissions?"}}
test iocmd-13.2 {errors in open command} {
    list [catch {open a b c d} msg] $msg
} {1 {wrong # args: should be "open fileName ?access? ?permissions?"}}