Symaptic: os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclFileName.c@bde4ae8d615e (annotated)

sl@0	1	/*
sl@0	2	* tclFileName.c --
sl@0	3	*
sl@0	4	* This file contains routines for converting file names betwen
sl@0	5	* native and network form.
sl@0	6	*
sl@0	7	* Copyright (c) 1995-1998 Sun Microsystems, Inc.
sl@0	8	* Copyright (c) 1998-1999 by Scriptics Corporation.
sl@0	9	* Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
sl@0	10	*
sl@0	11	* See the file "license.terms" for information on usage and redistribution
sl@0	12	* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0	13	*
sl@0	14	* RCS: @(#) $Id: tclFileName.c,v 1.40.2.15 2006/10/03 18:20:33 dgp Exp $
sl@0	15	*/
sl@0	16
sl@0	17	#include "tclInt.h"
sl@0	18	#include "tclPort.h"
sl@0	19	#include "tclRegexp.h"
sl@0	20	#if defined(__SYMBIAN32__) && defined(__WINSCW__)
sl@0	21	#include "tclSymbianGlobals.h"
sl@0	22	#define dataKey getdataKey(2)
sl@0	23	#endif
sl@0	24
sl@0	25	/*
sl@0	26	* This define is used to activate Tcl's interpretation of Unix-style
sl@0	27	* paths (containing forward slashes, '.' and '..') on MacOS. A
sl@0	28	* side-effect of this is that some paths become ambiguous.
sl@0	29	*/
sl@0	30	#define MAC_UNDERSTANDS_UNIX_PATHS
sl@0	31
sl@0	32	#ifdef MAC_UNDERSTANDS_UNIX_PATHS
sl@0	33	/*
sl@0	34	* The following regular expression matches the root portion of a Macintosh
sl@0	35	* absolute path. It will match degenerate Unix-style paths, tilde paths,
sl@0	36	* Unix-style paths, and Mac paths. The various subexpressions in this
sl@0	37	* can be summarised as follows: ^(/..\|~user/unix\|~user:mac\|/unix\|mac:dir).
sl@0	38	* The subexpression indices which match the root portions, are as follows:
sl@0	39	*
sl@0	40	* degenerate unix-style: 2
sl@0	41	* unix-tilde: 5
sl@0	42	* mac-tilde: 7
sl@0	43	* unix-style: 9 (or 10 to cut off the irrelevant header).
sl@0	44	* mac: 12
sl@0	45	*
sl@0	46	*/
sl@0	47
sl@0	48	#define MAC_ROOT_PATTERN "^((/+([.][.]?/+)([.][.]?)?)\|(~[^:/])(/[^:])?\|(~[^:])(:.)?\|/+([.][.]?/+)([^:/]+)(/[^:])?\|([^:]+):.)$"
sl@0	49
sl@0	50	/*
sl@0	51	* The following variables are used to hold precompiled regular expressions
sl@0	52	* for use in filename matching.
sl@0	53	*/
sl@0	54
sl@0	55	typedef struct ThreadSpecificData {
sl@0	56	int initialized;
sl@0	57	Tcl_Obj *macRootPatternPtr;
sl@0	58	} ThreadSpecificData;
sl@0	59
sl@0	60	static void FileNameCleanup _ANSI_ARGS_((ClientData clientData));
sl@0	61	static void FileNameInit _ANSI_ARGS_((void));
sl@0	62
sl@0	63	#endif
sl@0	64
sl@0	65	#if !defined(__SYMBIAN32__) \|\| !defined(__WINSCW__)
sl@0	66	static Tcl_ThreadDataKey dataKey;
sl@0	67
sl@0	68	/*
sl@0	69	* The following variable is set in the TclPlatformInit call to one
sl@0	70	* of: TCL_PLATFORM_UNIX, TCL_PLATFORM_MAC, or TCL_PLATFORM_WINDOWS.
sl@0	71	*/
sl@0	72
sl@0	73	TclPlatformType tclPlatform = TCL_PLATFORM_UNIX;
sl@0	74	#endif
sl@0	75	/*
sl@0	76	* Prototypes for local procedures defined in this file:
sl@0	77	*/
sl@0	78
sl@0	79	static CONST char * DoTildeSubst _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	80	CONST char user, Tcl_DString resultPtr));
sl@0	81	static CONST char * ExtractWinRoot _ANSI_ARGS_((CONST char *path,
sl@0	82	Tcl_DString *resultPtr, int offset,
sl@0	83	Tcl_PathType *typePtr));
sl@0	84	static int SkipToChar _ANSI_ARGS_((char **stringPtr,
sl@0	85	char *match));
sl@0	86	static Tcl_Obj* SplitMacPath _ANSI_ARGS_((CONST char *path));
sl@0	87	static Tcl_Obj* SplitWinPath _ANSI_ARGS_((CONST char *path));
sl@0	88	static Tcl_Obj* SplitUnixPath _ANSI_ARGS_((CONST char *path));
sl@0	89	#ifdef MAC_UNDERSTANDS_UNIX_PATHS
sl@0	90
sl@0	91	/*
sl@0	92	*----------------------------------------------------------------------
sl@0	93	*
sl@0	94	* FileNameInit --
sl@0	95	*
sl@0	96	* This procedure initializes the patterns used by this module.
sl@0	97	*
sl@0	98	* Results:
sl@0	99	* None.
sl@0	100	*
sl@0	101	* Side effects:
sl@0	102	* Compiles the regular expressions.
sl@0	103	*
sl@0	104	*----------------------------------------------------------------------
sl@0	105	*/
sl@0	106
sl@0	107	static void
sl@0	108	FileNameInit()
sl@0	109	{
sl@0	110	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
sl@0	111	if (!tsdPtr->initialized) {
sl@0	112	tsdPtr->initialized = 1;
sl@0	113	tsdPtr->macRootPatternPtr = Tcl_NewStringObj(MAC_ROOT_PATTERN, -1);
sl@0	114	Tcl_CreateThreadExitHandler(FileNameCleanup, NULL);
sl@0	115	}
sl@0	116	}
sl@0	117
sl@0	118	/*
sl@0	119	*----------------------------------------------------------------------
sl@0	120	*
sl@0	121	* FileNameCleanup --
sl@0	122	*
sl@0	123	* This procedure is a Tcl_ExitProc used to clean up the static
sl@0	124	* data structures used in this file.
sl@0	125	*
sl@0	126	* Results:
sl@0	127	* None.
sl@0	128	*
sl@0	129	* Side effects:
sl@0	130	* Deallocates storage used by the procedures in this file.
sl@0	131	*
sl@0	132	*----------------------------------------------------------------------
sl@0	133	*/
sl@0	134
sl@0	135	static void
sl@0	136	FileNameCleanup(clientData)
sl@0	137	ClientData clientData; /* Not used. */
sl@0	138	{
sl@0	139	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
sl@0	140	Tcl_DecrRefCount(tsdPtr->macRootPatternPtr);
sl@0	141	tsdPtr->initialized = 0;
sl@0	142	}
sl@0	143	#endif
sl@0	144
sl@0	145	/*
sl@0	146	*----------------------------------------------------------------------
sl@0	147	*
sl@0	148	* ExtractWinRoot --
sl@0	149	*
sl@0	150	* Matches the root portion of a Windows path and appends it
sl@0	151	* to the specified Tcl_DString.
sl@0	152	*
sl@0	153	* Results:
sl@0	154	* Returns the position in the path immediately after the root
sl@0	155	* including any trailing slashes.
sl@0	156	* Appends a cleaned up version of the root to the Tcl_DString
sl@0	157	* at the specified offest.
sl@0	158	*
sl@0	159	* Side effects:
sl@0	160	* Modifies the specified Tcl_DString.
sl@0	161	*
sl@0	162	*----------------------------------------------------------------------
sl@0	163	*/
sl@0	164
sl@0	165	static CONST char *
sl@0	166	ExtractWinRoot(path, resultPtr, offset, typePtr)
sl@0	167	CONST char path; / Path to parse. */
sl@0	168	Tcl_DString resultPtr; / Buffer to hold result. */
sl@0	169	int offset; /* Offset in buffer where result should be
sl@0	170	* stored. */
sl@0	171	Tcl_PathType typePtr; / Where to store pathType result */
sl@0	172	{
sl@0	173	if (path[0] == '/' \|\| path[0] == '\\') {
sl@0	174	/* Might be a UNC or Vol-Relative path */
sl@0	175	CONST char host, share, *tail;
sl@0	176	int hlen, slen;
sl@0	177	if (path[1] != '/' && path[1] != '\\') {
sl@0	178	Tcl_DStringSetLength(resultPtr, offset);
sl@0	179	*typePtr = TCL_PATH_VOLUME_RELATIVE;
sl@0	180	Tcl_DStringAppend(resultPtr, "/", 1);
sl@0	181	return &path[1];
sl@0	182	}
sl@0	183	host = &path[2];
sl@0	184
sl@0	185	/* Skip separators */
sl@0	186	while (host[0] == '/' \|\| host[0] == '\\') host++;
sl@0	187
sl@0	188	for (hlen = 0; host[hlen];hlen++) {
sl@0	189	if (host[hlen] == '/' \|\| host[hlen] == '\\')
sl@0	190	break;
sl@0	191	}
sl@0	192	if (host[hlen] == 0 \|\| host[hlen+1] == 0) {
sl@0	193	/*
sl@0	194	* The path given is simply of the form
sl@0	195	* '/foo', '//foo', '/////foo' or the same
sl@0	196	* with backslashes. If there is exactly
sl@0	197	* one leading '/' the path is volume relative
sl@0	198	* (see filename man page). If there are more
sl@0	199	* than one, we are simply assuming they
sl@0	200	* are superfluous and we trim them away.
sl@0	201	* (An alternative interpretation would
sl@0	202	* be that it is a host name, but we have
sl@0	203	* been documented that that is not the case).
sl@0	204	*/
sl@0	205	*typePtr = TCL_PATH_VOLUME_RELATIVE;
sl@0	206	Tcl_DStringAppend(resultPtr, "/", 1);
sl@0	207	return &path[2];
sl@0	208	}
sl@0	209	Tcl_DStringSetLength(resultPtr, offset);
sl@0	210	share = &host[hlen];
sl@0	211
sl@0	212	/* Skip separators */
sl@0	213	while (share[0] == '/' \|\| share[0] == '\\') share++;
sl@0	214
sl@0	215	for (slen = 0; share[slen];slen++) {
sl@0	216	if (share[slen] == '/' \|\| share[slen] == '\\')
sl@0	217	break;
sl@0	218	}
sl@0	219	Tcl_DStringAppend(resultPtr, "//", 2);
sl@0	220	Tcl_DStringAppend(resultPtr, host, hlen);
sl@0	221	Tcl_DStringAppend(resultPtr, "/", 1);
sl@0	222	Tcl_DStringAppend(resultPtr, share, slen);
sl@0	223
sl@0	224	tail = &share[slen];
sl@0	225
sl@0	226	/* Skip separators */
sl@0	227	while (tail[0] == '/' \|\| tail[0] == '\\') tail++;
sl@0	228
sl@0	229	*typePtr = TCL_PATH_ABSOLUTE;
sl@0	230	return tail;
sl@0	231	} else if (*path && path[1] == ':') {
sl@0	232	/* Might be a drive sep */
sl@0	233	Tcl_DStringSetLength(resultPtr, offset);
sl@0	234
sl@0	235	if (path[2] != '/' && path[2] != '\\') {
sl@0	236	*typePtr = TCL_PATH_VOLUME_RELATIVE;
sl@0	237	Tcl_DStringAppend(resultPtr, path, 2);
sl@0	238	return &path[2];
sl@0	239	} else {
sl@0	240	char tail = (char)&path[3];
sl@0	241
sl@0	242	/* Skip separators */
sl@0	243	while (*tail && (tail[0] == '/' \|\| tail[0] == '\\')) tail++;
sl@0	244
sl@0	245	*typePtr = TCL_PATH_ABSOLUTE;
sl@0	246	Tcl_DStringAppend(resultPtr, path, 2);
sl@0	247	Tcl_DStringAppend(resultPtr, "/", 1);
sl@0	248
sl@0	249	return tail;
sl@0	250	}
sl@0	251	} else {
sl@0	252	int abs = 0;
sl@0	253	if ((path[0] == 'c' \|\| path[0] == 'C')
sl@0	254	&& (path[1] == 'o' \|\| path[1] == 'O')) {
sl@0	255	if ((path[2] == 'm' \|\| path[2] == 'M')
sl@0	256	&& path[3] >= '1' && path[3] <= '4') {
sl@0	257	/* May have match for 'com[1-4]:?', which is a serial port */
sl@0	258	if (path[4] == '\0') {
sl@0	259	abs = 4;
sl@0	260	} else if (path [4] == ':' && path[5] == '\0') {
sl@0	261	abs = 5;
sl@0	262	}
sl@0	263	} else if ((path[2] == 'n' \|\| path[2] == 'N') && path[3] == '\0') {
sl@0	264	/* Have match for 'con' */
sl@0	265	abs = 3;
sl@0	266	}
sl@0	267	} else if ((path[0] == 'l' \|\| path[0] == 'L')
sl@0	268	&& (path[1] == 'p' \|\| path[1] == 'P')
sl@0	269	&& (path[2] == 't' \|\| path[2] == 'T')) {
sl@0	270	if (path[3] >= '1' && path[3] <= '3') {
sl@0	271	/* May have match for 'lpt[1-3]:?' */
sl@0	272	if (path[4] == '\0') {
sl@0	273	abs = 4;
sl@0	274	} else if (path [4] == ':' && path[5] == '\0') {
sl@0	275	abs = 5;
sl@0	276	}
sl@0	277	}
sl@0	278	} else if ((path[0] == 'p' \|\| path[0] == 'P')
sl@0	279	&& (path[1] == 'r' \|\| path[1] == 'R')
sl@0	280	&& (path[2] == 'n' \|\| path[2] == 'N')
sl@0	281	&& path[3] == '\0') {
sl@0	282	/* Have match for 'prn' */
sl@0	283	abs = 3;
sl@0	284	} else if ((path[0] == 'n' \|\| path[0] == 'N')
sl@0	285	&& (path[1] == 'u' \|\| path[1] == 'U')
sl@0	286	&& (path[2] == 'l' \|\| path[2] == 'L')
sl@0	287	&& path[3] == '\0') {
sl@0	288	/* Have match for 'nul' */
sl@0	289	abs = 3;
sl@0	290	} else if ((path[0] == 'a' \|\| path[0] == 'A')
sl@0	291	&& (path[1] == 'u' \|\| path[1] == 'U')
sl@0	292	&& (path[2] == 'x' \|\| path[2] == 'X')
sl@0	293	&& path[3] == '\0') {
sl@0	294	/* Have match for 'aux' */
sl@0	295	abs = 3;
sl@0	296	}
sl@0	297	if (abs != 0) {
sl@0	298	*typePtr = TCL_PATH_ABSOLUTE;
sl@0	299	Tcl_DStringSetLength(resultPtr, offset);
sl@0	300	Tcl_DStringAppend(resultPtr, path, abs);
sl@0	301	return path + abs;
sl@0	302	}
sl@0	303	}
sl@0	304	/* Anything else is treated as relative */
sl@0	305	*typePtr = TCL_PATH_RELATIVE;
sl@0	306	return path;
sl@0	307	}
sl@0	308
sl@0	309	/*
sl@0	310	*----------------------------------------------------------------------
sl@0	311	*
sl@0	312	* Tcl_GetPathType --
sl@0	313	*
sl@0	314	* Determines whether a given path is relative to the current
sl@0	315	* directory, relative to the current volume, or absolute.
sl@0	316	*
sl@0	317	* The objectified Tcl_FSGetPathType should be used in
sl@0	318	* preference to this function (as you can see below, this
sl@0	319	* is just a wrapper around that other function).
sl@0	320	*
sl@0	321	* Results:
sl@0	322	* Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
sl@0	323	* TCL_PATH_VOLUME_RELATIVE.
sl@0	324	*
sl@0	325	* Side effects:
sl@0	326	* None.
sl@0	327	*
sl@0	328	*----------------------------------------------------------------------
sl@0	329	*/
sl@0	330
sl@0	331	EXPORT_C Tcl_PathType
sl@0	332	Tcl_GetPathType(path)
sl@0	333	CONST char *path;
sl@0	334	{
sl@0	335	Tcl_PathType type;
sl@0	336	Tcl_Obj *tempObj = Tcl_NewStringObj(path,-1);
sl@0	337	Tcl_IncrRefCount(tempObj);
sl@0	338	type = Tcl_FSGetPathType(tempObj);
sl@0	339	Tcl_DecrRefCount(tempObj);
sl@0	340	return type;
sl@0	341	}
sl@0	342
sl@0	343	/*
sl@0	344	*----------------------------------------------------------------------
sl@0	345	*
sl@0	346	* TclpGetNativePathType --
sl@0	347	*
sl@0	348	* Determines whether a given path is relative to the current
sl@0	349	* directory, relative to the current volume, or absolute, but
sl@0	350	* ONLY FOR THE NATIVE FILESYSTEM. This function is called from
sl@0	351	* tclIOUtil.c (but needs to be here due to its dependence on
sl@0	352	* static variables/functions in this file). The exported
sl@0	353	* function Tcl_FSGetPathType should be used by extensions.
sl@0	354	*
sl@0	355	* Results:
sl@0	356	* Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
sl@0	357	* TCL_PATH_VOLUME_RELATIVE.
sl@0	358	*
sl@0	359	* Side effects:
sl@0	360	* None.
sl@0	361	*
sl@0	362	*----------------------------------------------------------------------
sl@0	363	*/
sl@0	364
sl@0	365	Tcl_PathType
sl@0	366	TclpGetNativePathType(pathObjPtr, driveNameLengthPtr, driveNameRef)
sl@0	367	Tcl_Obj *pathObjPtr;
sl@0	368	int *driveNameLengthPtr;
sl@0	369	Tcl_Obj **driveNameRef;
sl@0	370	{
sl@0	371	Tcl_PathType type = TCL_PATH_ABSOLUTE;
sl@0	372	int pathLen;
sl@0	373	char *path = Tcl_GetStringFromObj(pathObjPtr, &pathLen);
sl@0	374
sl@0	375	if (path[0] == '~') {
sl@0	376	/*
sl@0	377	* This case is common to all platforms.
sl@0	378	* Paths that begin with ~ are absolute.
sl@0	379	*/
sl@0	380	if (driveNameLengthPtr != NULL) {
sl@0	381	char *end = path + 1;
sl@0	382	while ((end != '\0') && (end != '/')) {
sl@0	383	end++;
sl@0	384	}
sl@0	385	*driveNameLengthPtr = end - path;
sl@0	386	}
sl@0	387	} else {
sl@0	388	switch (tclPlatform) {
sl@0	389	case TCL_PLATFORM_UNIX: {
sl@0	390	char *origPath = path;
sl@0	391
sl@0	392	/*
sl@0	393	* Paths that begin with / are absolute.
sl@0	394	*/
sl@0	395
sl@0	396	#ifdef __QNX__
sl@0	397	/*
sl@0	398	* Check for QNX //<node id> prefix
sl@0	399	*/
sl@0	400	if (*path && (pathLen > 3) && (path[0] == '/')
sl@0	401	&& (path[1] == '/') && isdigit(UCHAR(path[2]))) {
sl@0	402	path += 3;
sl@0	403	while (isdigit(UCHAR(*path))) {
sl@0	404	++path;
sl@0	405	}
sl@0	406	}
sl@0	407	#endif
sl@0	408	if (path[0] == '/') {
sl@0	409	if (driveNameLengthPtr != NULL) {
sl@0	410	/*
sl@0	411	* We need this addition in case the QNX code
sl@0	412	* was used
sl@0	413	*/
sl@0	414	*driveNameLengthPtr = (1 + path - origPath);
sl@0	415	}
sl@0	416	} else {
sl@0	417	type = TCL_PATH_RELATIVE;
sl@0	418	}
sl@0	419	break;
sl@0	420	}
sl@0	421	case TCL_PLATFORM_MAC:
sl@0	422	if (path[0] == ':') {
sl@0	423	type = TCL_PATH_RELATIVE;
sl@0	424	} else {
sl@0	425	#ifdef MAC_UNDERSTANDS_UNIX_PATHS
sl@0	426	ThreadSpecificData *tsdPtr;
sl@0	427	Tcl_RegExp re;
sl@0	428
sl@0	429	tsdPtr = TCL_TSD_INIT(&dataKey);
sl@0	430
sl@0	431	/*
sl@0	432	* Since we have eliminated the easy cases, use the
sl@0	433	* root pattern to look for the other types.
sl@0	434	*/
sl@0	435
sl@0	436	FileNameInit();
sl@0	437	re = Tcl_GetRegExpFromObj(NULL, tsdPtr->macRootPatternPtr,
sl@0	438	REG_ADVANCED);
sl@0	439
sl@0	440	if (!Tcl_RegExpExec(NULL, re, path, path)) {
sl@0	441	type = TCL_PATH_RELATIVE;
sl@0	442	} else {
sl@0	443	CONST char root, end;
sl@0	444	Tcl_RegExpRange(re, 2, &root, &end);
sl@0	445	if (root != NULL) {
sl@0	446	type = TCL_PATH_RELATIVE;
sl@0	447	} else {
sl@0	448	if (driveNameLengthPtr != NULL) {
sl@0	449	Tcl_RegExpRange(re, 0, &root, &end);
sl@0	450	*driveNameLengthPtr = end - root;
sl@0	451	}
sl@0	452	if (driveNameRef != NULL) {
sl@0	453	if (*root == '/') {
sl@0	454	char *c;
sl@0	455	int gotColon = 0;
sl@0	456	*driveNameRef = Tcl_NewStringObj(root + 1,
sl@0	457	end - root -1);
sl@0	458	c = Tcl_GetString(*driveNameRef);
sl@0	459	while (*c != '\0') {
sl@0	460	if (*c == '/') {
sl@0	461	gotColon++;
sl@0	462	*c = ':';
sl@0	463	}
sl@0	464	c++;
sl@0	465	}
sl@0	466	/*
sl@0	467	* If there is no colon, we have just a
sl@0	468	* volume name so we must add a colon so
sl@0	469	* it is an absolute path.
sl@0	470	*/
sl@0	471	if (gotColon == 0) {
sl@0	472	Tcl_AppendToObj(*driveNameRef, ":", 1);
sl@0	473	} else if ((gotColon > 1) &&
sl@0	474	(*(c-1) == ':')) {
sl@0	475	/* We have an extra colon */
sl@0	476	Tcl_SetObjLength(*driveNameRef,
sl@0	477	c - Tcl_GetString(*driveNameRef) - 1);
sl@0	478	}
sl@0	479	}
sl@0	480	}
sl@0	481	}
sl@0	482	}
sl@0	483	#else
sl@0	484	if (path[0] == '~') {
sl@0	485	} else if (path[0] == ':') {
sl@0	486	type = TCL_PATH_RELATIVE;
sl@0	487	} else {
sl@0	488	char *colonPos = strchr(path,':');
sl@0	489	if (colonPos == NULL) {
sl@0	490	type = TCL_PATH_RELATIVE;
sl@0	491	} else {
sl@0	492	}
sl@0	493	}
sl@0	494	if (type == TCL_PATH_ABSOLUTE) {
sl@0	495	if (driveNameLengthPtr != NULL) {
sl@0	496	*driveNameLengthPtr = strlen(path);
sl@0	497	}
sl@0	498	}
sl@0	499	#endif
sl@0	500	}
sl@0	501	break;
sl@0	502
sl@0	503	case TCL_PLATFORM_WINDOWS: {
sl@0	504	Tcl_DString ds;
sl@0	505	CONST char *rootEnd;
sl@0	506
sl@0	507	Tcl_DStringInit(&ds);
sl@0	508	rootEnd = ExtractWinRoot(path, &ds, 0, &type);
sl@0	509	if ((rootEnd != path) && (driveNameLengthPtr != NULL)) {
sl@0	510	*driveNameLengthPtr = rootEnd - path;
sl@0	511	if (driveNameRef != NULL) {
sl@0	512	*driveNameRef = Tcl_NewStringObj(Tcl_DStringValue(&ds),
sl@0	513	Tcl_DStringLength(&ds));
sl@0	514	Tcl_IncrRefCount(*driveNameRef);
sl@0	515	}
sl@0	516	}
sl@0	517	Tcl_DStringFree(&ds);
sl@0	518	break;
sl@0	519	}
sl@0	520	}
sl@0	521	}
sl@0	522	return type;
sl@0	523	}
sl@0	524
sl@0	525	/*
sl@0	526	*---------------------------------------------------------------------------
sl@0	527	*
sl@0	528	* TclpNativeSplitPath --
sl@0	529	*
sl@0	530	* This function takes the given Tcl_Obj, which should be a valid
sl@0	531	* path, and returns a Tcl List object containing each segment
sl@0	532	* of that path as an element.
sl@0	533	*
sl@0	534	* Note this function currently calls the older Split(Plat)Path
sl@0	535	* functions, which require more memory allocation than is
sl@0	536	* desirable.
sl@0	537	*
sl@0	538	* Results:
sl@0	539	* Returns list object with refCount of zero. If the passed in
sl@0	540	* lenPtr is non-NULL, we use it to return the number of elements
sl@0	541	* in the returned list.
sl@0	542	*
sl@0	543	* Side effects:
sl@0	544	* None.
sl@0	545	*
sl@0	546	*---------------------------------------------------------------------------
sl@0	547	*/
sl@0	548
sl@0	549	Tcl_Obj*
sl@0	550	TclpNativeSplitPath(pathPtr, lenPtr)
sl@0	551	Tcl_Obj pathPtr; / Path to split. */
sl@0	552	int lenPtr; / int to store number of path elements. */
sl@0	553	{
sl@0	554	Tcl_Obj resultPtr = NULL; / Needed only to prevent gcc warnings. */
sl@0	555
sl@0	556	/*
sl@0	557	* Perform platform specific splitting.
sl@0	558	*/
sl@0	559
sl@0	560	switch (tclPlatform) {
sl@0	561	case TCL_PLATFORM_UNIX:
sl@0	562	resultPtr = SplitUnixPath(Tcl_GetString(pathPtr));
sl@0	563	break;
sl@0	564
sl@0	565	case TCL_PLATFORM_WINDOWS:
sl@0	566	resultPtr = SplitWinPath(Tcl_GetString(pathPtr));
sl@0	567	break;
sl@0	568
sl@0	569	case TCL_PLATFORM_MAC:
sl@0	570	resultPtr = SplitMacPath(Tcl_GetString(pathPtr));
sl@0	571	break;
sl@0	572	}
sl@0	573
sl@0	574	/*
sl@0	575	* Compute the number of elements in the result.
sl@0	576	*/
sl@0	577
sl@0	578	if (lenPtr != NULL) {
sl@0	579	Tcl_ListObjLength(NULL, resultPtr, lenPtr);
sl@0	580	}
sl@0	581	return resultPtr;
sl@0	582	}
sl@0	583
sl@0	584	/*
sl@0	585	*----------------------------------------------------------------------
sl@0	586	*
sl@0	587	* Tcl_SplitPath --
sl@0	588	*
sl@0	589	* Split a path into a list of path components. The first element
sl@0	590	* of the list will have the same path type as the original path.
sl@0	591	*
sl@0	592	* Results:
sl@0	593	* Returns a standard Tcl result. The interpreter result contains
sl@0	594	* a list of path components.
sl@0	595	* *argvPtr will be filled in with the address of an array
sl@0	596	* whose elements point to the elements of path, in order.
sl@0	597	* *argcPtr will get filled in with the number of valid elements
sl@0	598	* in the array. A single block of memory is dynamically allocated
sl@0	599	* to hold both the argv array and a copy of the path elements.
sl@0	600	* The caller must eventually free this memory by calling ckfree()
sl@0	601	* on argvPtr. Note: argvPtr and *argcPtr are only modified
sl@0	602	* if the procedure returns normally.
sl@0	603	*
sl@0	604	* Side effects:
sl@0	605	* Allocates memory.
sl@0	606	*
sl@0	607	*----------------------------------------------------------------------
sl@0	608	*/
sl@0	609
sl@0	610	EXPORT_C void
sl@0	611	Tcl_SplitPath(path, argcPtr, argvPtr)
sl@0	612	CONST char path; / Pointer to string containing a path. */
sl@0	613	int argcPtr; / Pointer to location to fill in with
sl@0	614	* the number of elements in the path. */
sl@0	615	CONST char **argvPtr; / Pointer to place to store pointer to array
sl@0	616	* of pointers to path elements. */
sl@0	617	{
sl@0	618	Tcl_Obj resultPtr = NULL; / Needed only to prevent gcc warnings. */
sl@0	619	Tcl_Obj tmpPtr, eltPtr;
sl@0	620	int i, size, len;
sl@0	621	char p, str;
sl@0	622
sl@0	623	/*
sl@0	624	* Perform the splitting, using objectified, vfs-aware code.
sl@0	625	*/
sl@0	626
sl@0	627	tmpPtr = Tcl_NewStringObj(path, -1);
sl@0	628	Tcl_IncrRefCount(tmpPtr);
sl@0	629	resultPtr = Tcl_FSSplitPath(tmpPtr, argcPtr);
sl@0	630	Tcl_DecrRefCount(tmpPtr);
sl@0	631
sl@0	632	/* Calculate space required for the result */
sl@0	633
sl@0	634	size = 1;
sl@0	635	for (i = 0; i < *argcPtr; i++) {
sl@0	636	Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
sl@0	637	Tcl_GetStringFromObj(eltPtr, &len);
sl@0	638	size += len + 1;
sl@0	639	}
sl@0	640
sl@0	641	/*
sl@0	642	* Allocate a buffer large enough to hold the contents of all of
sl@0	643	* the list plus the argv pointers and the terminating NULL pointer.
sl@0	644	*/
sl@0	645
sl@0	646	argvPtr = (CONST char *) ckalloc((unsigned)
sl@0	647	((((argcPtr) + 1) sizeof(char *)) + size));
sl@0	648
sl@0	649	/*
sl@0	650	* Position p after the last argv pointer and copy the contents of
sl@0	651	* the list in, piece by piece.
sl@0	652	*/
sl@0	653
sl@0	654	p = (char ) &(argvPtr)[(*argcPtr) + 1];
sl@0	655	for (i = 0; i < *argcPtr; i++) {
sl@0	656	Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
sl@0	657	str = Tcl_GetStringFromObj(eltPtr, &len);
sl@0	658	memcpy((VOID ) p, (VOID ) str, (size_t) len+1);
sl@0	659	p += len+1;
sl@0	660	}
sl@0	661
sl@0	662	/*
sl@0	663	* Now set up the argv pointers.
sl@0	664	*/
sl@0	665
sl@0	666	p = (char ) &(argvPtr)[(*argcPtr) + 1];
sl@0	667
sl@0	668	for (i = 0; i < *argcPtr; i++) {
sl@0	669	(*argvPtr)[i] = p;
sl@0	670	while ((*p++) != '\0') {}
sl@0	671	}
sl@0	672	(*argvPtr)[i] = NULL;
sl@0	673
sl@0	674	/*
sl@0	675	* Free the result ptr given to us by Tcl_FSSplitPath
sl@0	676	*/
sl@0	677
sl@0	678	Tcl_DecrRefCount(resultPtr);
sl@0	679	}
sl@0	680
sl@0	681	/*
sl@0	682	*----------------------------------------------------------------------
sl@0	683	*
sl@0	684	* SplitUnixPath --
sl@0	685	*
sl@0	686	* This routine is used by Tcl_(FS)SplitPath to handle splitting
sl@0	687	* Unix paths.
sl@0	688	*
sl@0	689	* Results:
sl@0	690	* Returns a newly allocated Tcl list object.
sl@0	691	*
sl@0	692	* Side effects:
sl@0	693	* None.
sl@0	694	*
sl@0	695	*----------------------------------------------------------------------
sl@0	696	*/
sl@0	697
sl@0	698	static Tcl_Obj*
sl@0	699	SplitUnixPath(path)
sl@0	700	CONST char path; / Pointer to string containing a path. */
sl@0	701	{
sl@0	702	int length;
sl@0	703	CONST char p, elementStart;
sl@0	704	Tcl_Obj *result = Tcl_NewObj();
sl@0	705
sl@0	706	/*
sl@0	707	* Deal with the root directory as a special case.
sl@0	708	*/
sl@0	709
sl@0	710	#ifdef __QNX__
sl@0	711	/*
sl@0	712	* Check for QNX //<node id> prefix
sl@0	713	*/
sl@0	714	if ((path[0] == '/') && (path[1] == '/')
sl@0	715	&& isdigit(UCHAR(path[2]))) { /* INTL: digit */
sl@0	716	path += 3;
sl@0	717	while (isdigit(UCHAR(path))) { / INTL: digit */
sl@0	718	++path;
sl@0	719	}
sl@0	720	}
sl@0	721	#endif
sl@0	722
sl@0	723	if (path[0] == '/') {
sl@0	724	Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj("/",1));
sl@0	725	p = path+1;
sl@0	726	} else {
sl@0	727	p = path;
sl@0	728	}
sl@0	729
sl@0	730	/*
sl@0	731	* Split on slashes. Embedded elements that start with tilde will be
sl@0	732	* prefixed with "./" so they are not affected by tilde substitution.
sl@0	733	*/
sl@0	734
sl@0	735	for (;;) {
sl@0	736	elementStart = p;
sl@0	737	while ((p != '\0') && (p != '/')) {
sl@0	738	p++;
sl@0	739	}
sl@0	740	length = p - elementStart;
sl@0	741	if (length > 0) {
sl@0	742	Tcl_Obj *nextElt;
sl@0	743	if ((elementStart[0] == '~') && (elementStart != path)) {
sl@0	744	nextElt = Tcl_NewStringObj("./",2);
sl@0	745	Tcl_AppendToObj(nextElt, elementStart, length);
sl@0	746	} else {
sl@0	747	nextElt = Tcl_NewStringObj(elementStart, length);
sl@0	748	}
sl@0	749	Tcl_ListObjAppendElement(NULL, result, nextElt);
sl@0	750	}
sl@0	751	if (*p++ == '\0') {
sl@0	752	break;
sl@0	753	}
sl@0	754	}
sl@0	755	return result;
sl@0	756	}
sl@0	757
sl@0	758
sl@0	759	/*
sl@0	760	*----------------------------------------------------------------------
sl@0	761	*
sl@0	762	* SplitWinPath --
sl@0	763	*
sl@0	764	* This routine is used by Tcl_(FS)SplitPath to handle splitting
sl@0	765	* Windows paths.
sl@0	766	*
sl@0	767	* Results:
sl@0	768	* Returns a newly allocated Tcl list object.
sl@0	769	*
sl@0	770	* Side effects:
sl@0	771	* None.
sl@0	772	*
sl@0	773	*----------------------------------------------------------------------
sl@0	774	*/
sl@0	775
sl@0	776	static Tcl_Obj*
sl@0	777	SplitWinPath(path)
sl@0	778	CONST char path; / Pointer to string containing a path. */
sl@0	779	{
sl@0	780	int length;
sl@0	781	CONST char p, elementStart;
sl@0	782	Tcl_PathType type = TCL_PATH_ABSOLUTE;
sl@0	783	Tcl_DString buf;
sl@0	784	Tcl_Obj *result = Tcl_NewObj();
sl@0	785	Tcl_DStringInit(&buf);
sl@0	786
sl@0	787	p = ExtractWinRoot(path, &buf, 0, &type);
sl@0	788
sl@0	789	/*
sl@0	790	* Terminate the root portion, if we matched something.
sl@0	791	*/
sl@0	792
sl@0	793	if (p != path) {
sl@0	794	Tcl_ListObjAppendElement(NULL, result,
sl@0	795	Tcl_NewStringObj(Tcl_DStringValue(&buf),
sl@0	796	Tcl_DStringLength(&buf)));
sl@0	797	}
sl@0	798	Tcl_DStringFree(&buf);
sl@0	799
sl@0	800	/*
sl@0	801	* Split on slashes. Embedded elements that start with tilde
sl@0	802	* or a drive letter will be prefixed with "./" so they are not
sl@0	803	* affected by tilde substitution.
sl@0	804	*/
sl@0	805
sl@0	806	do {
sl@0	807	elementStart = p;
sl@0	808	while ((p != '\0') && (p != '/') && (*p != '\\')) {
sl@0	809	p++;
sl@0	810	}
sl@0	811	length = p - elementStart;
sl@0	812	if (length > 0) {
sl@0	813	Tcl_Obj *nextElt;
sl@0	814	if ((elementStart != path)
sl@0	815	&& ((elementStart[0] == '~')
sl@0	816	\|\| (isalpha(UCHAR(elementStart[0]))
sl@0	817	&& elementStart[1] == ':'))) {
sl@0	818	nextElt = Tcl_NewStringObj("./",2);
sl@0	819	Tcl_AppendToObj(nextElt, elementStart, length);
sl@0	820	} else {
sl@0	821	nextElt = Tcl_NewStringObj(elementStart, length);
sl@0	822	}
sl@0	823	Tcl_ListObjAppendElement(NULL, result, nextElt);
sl@0	824	}
sl@0	825	} while (*p++ != '\0');
sl@0	826
sl@0	827	return result;
sl@0	828	}
sl@0	829
sl@0	830	/*
sl@0	831	*----------------------------------------------------------------------
sl@0	832	*
sl@0	833	* SplitMacPath --
sl@0	834	*
sl@0	835	* This routine is used by Tcl_(FS)SplitPath to handle splitting
sl@0	836	* Macintosh paths.
sl@0	837	*
sl@0	838	* Results:
sl@0	839	* Returns a newly allocated Tcl list object.
sl@0	840	*
sl@0	841	* Side effects:
sl@0	842	* None.
sl@0	843	*
sl@0	844	*----------------------------------------------------------------------
sl@0	845	*/
sl@0	846
sl@0	847	static Tcl_Obj*
sl@0	848	SplitMacPath(path)
sl@0	849	CONST char path; / Pointer to string containing a path. */
sl@0	850	{
sl@0	851	int isMac = 0; /* 1 if is Mac-style, 0 if Unix-style path. */
sl@0	852	int length;
sl@0	853	CONST char p, elementStart;
sl@0	854	Tcl_Obj *result;
sl@0	855	#ifdef MAC_UNDERSTANDS_UNIX_PATHS
sl@0	856	Tcl_RegExp re;
sl@0	857	int i;
sl@0	858	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
sl@0	859	#endif
sl@0	860
sl@0	861	result = Tcl_NewObj();
sl@0	862
sl@0	863	#ifdef MAC_UNDERSTANDS_UNIX_PATHS
sl@0	864	/*
sl@0	865	* Initialize the path name parser for Macintosh path names.
sl@0	866	*/
sl@0	867
sl@0	868	FileNameInit();
sl@0	869
sl@0	870	/*
sl@0	871	* Match the root portion of a Mac path name.
sl@0	872	*/
sl@0	873
sl@0	874	i = 0; /* Needed only to prevent gcc warnings. */
sl@0	875
sl@0	876	re = Tcl_GetRegExpFromObj(NULL, tsdPtr->macRootPatternPtr, REG_ADVANCED);
sl@0	877
sl@0	878	if (Tcl_RegExpExec(NULL, re, path, path) == 1) {
sl@0	879	CONST char start, end;
sl@0	880	Tcl_Obj *nextElt;
sl@0	881
sl@0	882	/*
sl@0	883	* Treat degenerate absolute paths like / and /../.. as
sl@0	884	* Mac relative file names for lack of anything else to do.
sl@0	885	*/
sl@0	886
sl@0	887	Tcl_RegExpRange(re, 2, &start, &end);
sl@0	888	if (start) {
sl@0	889	Tcl_Obj *elt = Tcl_NewStringObj(":", 1);
sl@0	890	Tcl_RegExpRange(re, 0, &start, &end);
sl@0	891	Tcl_AppendToObj(elt, path, end - start);
sl@0	892	Tcl_ListObjAppendElement(NULL, result, elt);
sl@0	893	return result;
sl@0	894	}
sl@0	895
sl@0	896	Tcl_RegExpRange(re, 5, &start, &end);
sl@0	897	if (start) {
sl@0	898	/*
sl@0	899	* Unix-style tilde prefixed paths.
sl@0	900	*/
sl@0	901
sl@0	902	isMac = 0;
sl@0	903	i = 5;
sl@0	904	} else {
sl@0	905	Tcl_RegExpRange(re, 7, &start, &end);
sl@0	906	if (start) {
sl@0	907	/*
sl@0	908	* Mac-style tilde prefixed paths.
sl@0	909	*/
sl@0	910
sl@0	911	isMac = 1;
sl@0	912	i = 7;
sl@0	913	} else {
sl@0	914	Tcl_RegExpRange(re, 10, &start, &end);
sl@0	915	if (start) {
sl@0	916	/*
sl@0	917	* Normal Unix style paths.
sl@0	918	*/
sl@0	919
sl@0	920	isMac = 0;
sl@0	921	i = 10;
sl@0	922	} else {
sl@0	923	Tcl_RegExpRange(re, 12, &start, &end);
sl@0	924	if (start) {
sl@0	925	/*
sl@0	926	* Normal Mac style paths.
sl@0	927	*/
sl@0	928
sl@0	929	isMac = 1;
sl@0	930	i = 12;
sl@0	931	}
sl@0	932	}
sl@0	933	}
sl@0	934	}
sl@0	935	Tcl_RegExpRange(re, i, &start, &end);
sl@0	936	length = end - start;
sl@0	937
sl@0	938	/*
sl@0	939	* Append the element and terminate it with a :
sl@0	940	*/
sl@0	941
sl@0	942	nextElt = Tcl_NewStringObj(start, length);
sl@0	943	Tcl_AppendToObj(nextElt, ":", 1);
sl@0	944	Tcl_ListObjAppendElement(NULL, result, nextElt);
sl@0	945	p = end;
sl@0	946	} else {
sl@0	947	isMac = (strchr(path, ':') != NULL);
sl@0	948	p = path;
sl@0	949	}
sl@0	950	#else
sl@0	951	if ((path[0] != ':') && (path[0] == '~' \|\| (strchr(path,':') != NULL))) {
sl@0	952	CONST char *end;
sl@0	953	Tcl_Obj *nextElt;
sl@0	954
sl@0	955	isMac = 1;
sl@0	956
sl@0	957	end = strchr(path,':');
sl@0	958	if (end == NULL) {
sl@0	959	length = strlen(path);
sl@0	960	} else {
sl@0	961	length = end - path;
sl@0	962	}
sl@0	963
sl@0	964	/*
sl@0	965	* Append the element and terminate it with a :
sl@0	966	*/
sl@0	967
sl@0	968	nextElt = Tcl_NewStringObj(path, length);
sl@0	969	Tcl_AppendToObj(nextElt, ":", 1);
sl@0	970	Tcl_ListObjAppendElement(NULL, result, nextElt);
sl@0	971	p = path + length;
sl@0	972	} else {
sl@0	973	isMac = (strchr(path, ':') != NULL);
sl@0	974	isMac = 1;
sl@0	975	p = path;
sl@0	976	}
sl@0	977	#endif
sl@0	978
sl@0	979	if (isMac) {
sl@0	980
sl@0	981	/*
sl@0	982	* p is pointing at the first colon in the path. There
sl@0	983	* will always be one, since this is a Mac-style path.
sl@0	984	* (This is no longer true if MAC_UNDERSTANDS_UNIX_PATHS
sl@0	985	* is false, so we must check whether 'p' points to the
sl@0	986	* end of the string.)
sl@0	987	*/
sl@0	988	elementStart = p;
sl@0	989	if (*p == ':') {
sl@0	990	p++;
sl@0	991	}
sl@0	992
sl@0	993	while ((p = strchr(p, ':')) != NULL) {
sl@0	994	length = p - elementStart;
sl@0	995	if (length == 1) {
sl@0	996	while (*p == ':') {
sl@0	997	Tcl_ListObjAppendElement(NULL, result,
sl@0	998	Tcl_NewStringObj("::", 2));
sl@0	999	elementStart = p++;
sl@0	1000	}
sl@0	1001	} else {
sl@0	1002	/*
sl@0	1003	* If this is a simple component, drop the leading colon.
sl@0	1004	*/
sl@0	1005
sl@0	1006	if ((elementStart[1] != '~')
sl@0	1007	&& (strchr(elementStart+1, '/') == NULL)) {
sl@0	1008	elementStart++;
sl@0	1009	length--;
sl@0	1010	}
sl@0	1011	Tcl_ListObjAppendElement(NULL, result,
sl@0	1012	Tcl_NewStringObj(elementStart, length));
sl@0	1013	elementStart = p++;
sl@0	1014	}
sl@0	1015	}
sl@0	1016	if (elementStart[0] != ':') {
sl@0	1017	if (elementStart[0] != '\0') {
sl@0	1018	Tcl_ListObjAppendElement(NULL, result,
sl@0	1019	Tcl_NewStringObj(elementStart, -1));
sl@0	1020	}
sl@0	1021	} else {
sl@0	1022	if (elementStart[1] != '\0' \|\| elementStart == path) {
sl@0	1023	if ((elementStart[1] != '~') && (elementStart[1] != '\0')
sl@0	1024	&& (strchr(elementStart+1, '/') == NULL)) {
sl@0	1025	elementStart++;
sl@0	1026	}
sl@0	1027	Tcl_ListObjAppendElement(NULL, result,
sl@0	1028	Tcl_NewStringObj(elementStart, -1));
sl@0	1029	}
sl@0	1030	}
sl@0	1031	} else {
sl@0	1032
sl@0	1033	/*
sl@0	1034	* Split on slashes, suppress extra /'s, and convert .. to ::.
sl@0	1035	*/
sl@0	1036
sl@0	1037	for (;;) {
sl@0	1038	elementStart = p;
sl@0	1039	while ((p != '\0') && (p != '/')) {
sl@0	1040	p++;
sl@0	1041	}
sl@0	1042	length = p - elementStart;
sl@0	1043	if (length > 0) {
sl@0	1044	if ((length == 1) && (elementStart[0] == '.')) {
sl@0	1045	Tcl_ListObjAppendElement(NULL, result,
sl@0	1046	Tcl_NewStringObj(":", 1));
sl@0	1047	} else if ((length == 2) && (elementStart[0] == '.')
sl@0	1048	&& (elementStart[1] == '.')) {
sl@0	1049	Tcl_ListObjAppendElement(NULL, result,
sl@0	1050	Tcl_NewStringObj("::", 2));
sl@0	1051	} else {
sl@0	1052	Tcl_Obj *nextElt;
sl@0	1053	if (*elementStart == '~') {
sl@0	1054	nextElt = Tcl_NewStringObj(":",1);
sl@0	1055	Tcl_AppendToObj(nextElt, elementStart, length);
sl@0	1056	} else {
sl@0	1057	nextElt = Tcl_NewStringObj(elementStart, length);
sl@0	1058	}
sl@0	1059	Tcl_ListObjAppendElement(NULL, result, nextElt);
sl@0	1060	}
sl@0	1061	}
sl@0	1062	if (*p++ == '\0') {
sl@0	1063	break;
sl@0	1064	}
sl@0	1065	}
sl@0	1066	}
sl@0	1067	return result;
sl@0	1068	}
sl@0	1069
sl@0	1070	/*
sl@0	1071	*---------------------------------------------------------------------------
sl@0	1072	*
sl@0	1073	* Tcl_FSJoinToPath --
sl@0	1074	*
sl@0	1075	* This function takes the given object, which should usually be a
sl@0	1076	* valid path or NULL, and joins onto it the array of paths
sl@0	1077	* segments given.
sl@0	1078	*
sl@0	1079	* Results:
sl@0	1080	* Returns object with refCount of zero
sl@0	1081	*
sl@0	1082	* Side effects:
sl@0	1083	* None.
sl@0	1084	*
sl@0	1085	*---------------------------------------------------------------------------
sl@0	1086	*/
sl@0	1087
sl@0	1088	EXPORT_C Tcl_Obj*
sl@0	1089	Tcl_FSJoinToPath(basePtr, objc, objv)
sl@0	1090	Tcl_Obj *basePtr;
sl@0	1091	int objc;
sl@0	1092	Tcl_Obj *CONST objv[];
sl@0	1093	{
sl@0	1094	int i;
sl@0	1095	Tcl_Obj lobj, ret;
sl@0	1096
sl@0	1097	if (basePtr == NULL) {
sl@0	1098	lobj = Tcl_NewListObj(0, NULL);
sl@0	1099	} else {
sl@0	1100	lobj = Tcl_NewListObj(1, &basePtr);
sl@0	1101	}
sl@0	1102
sl@0	1103	for (i = 0; i<objc;i++) {
sl@0	1104	Tcl_ListObjAppendElement(NULL, lobj, objv[i]);
sl@0	1105	}
sl@0	1106	ret = Tcl_FSJoinPath(lobj, -1);
sl@0	1107	Tcl_DecrRefCount(lobj);
sl@0	1108	return ret;
sl@0	1109	}
sl@0	1110
sl@0	1111	/*
sl@0	1112	*---------------------------------------------------------------------------
sl@0	1113	*
sl@0	1114	* TclpNativeJoinPath --
sl@0	1115	*
sl@0	1116	* 'prefix' is absolute, 'joining' is relative to prefix.
sl@0	1117	*
sl@0	1118	* Results:
sl@0	1119	* modifies prefix
sl@0	1120	*
sl@0	1121	* Side effects:
sl@0	1122	* None.
sl@0	1123	*
sl@0	1124	*---------------------------------------------------------------------------
sl@0	1125	*/
sl@0	1126
sl@0	1127	void
sl@0	1128	TclpNativeJoinPath(prefix, joining)
sl@0	1129	Tcl_Obj *prefix;
sl@0	1130	char* joining;
sl@0	1131	{
sl@0	1132	int length, needsSep;
sl@0	1133	char dest, p, *start;
sl@0	1134
sl@0	1135	start = Tcl_GetStringFromObj(prefix, &length);
sl@0	1136
sl@0	1137	/*
sl@0	1138	* Remove the ./ from tilde prefixed elements, and drive-letter
sl@0	1139	* prefixed elements on Windows, unless it is the first component.
sl@0	1140	*/
sl@0	1141
sl@0	1142	p = joining;
sl@0	1143
sl@0	1144	if (length != 0) {
sl@0	1145	if ((p[0] == '.') && (p[1] == '/')
sl@0	1146	&& ((p[2] == '~')
sl@0	1147	\|\| ((tclPlatform == TCL_PLATFORM_WINDOWS)
sl@0	1148	&& isalpha(UCHAR(p[2]))
sl@0	1149	&& (p[3] == ':')))) {
sl@0	1150	p += 2;
sl@0	1151	}
sl@0	1152	}
sl@0	1153	if (*p == '\0') {
sl@0	1154	return;
sl@0	1155	}
sl@0	1156
sl@0	1157	switch (tclPlatform) {
sl@0	1158	case TCL_PLATFORM_UNIX:
sl@0	1159	/*
sl@0	1160	* Append a separator if needed.
sl@0	1161	*/
sl@0	1162
sl@0	1163	if (length > 0 && (start[length-1] != '/')) {
sl@0	1164	Tcl_AppendToObj(prefix, "/", 1);
sl@0	1165	length++;
sl@0	1166	}
sl@0	1167	needsSep = 0;
sl@0	1168
sl@0	1169	/*
sl@0	1170	* Append the element, eliminating duplicate and trailing
sl@0	1171	* slashes.
sl@0	1172	*/
sl@0	1173
sl@0	1174	Tcl_SetObjLength(prefix, length + (int) strlen(p));
sl@0	1175
sl@0	1176	dest = Tcl_GetString(prefix) + length;
sl@0	1177	for (; *p != '\0'; p++) {
sl@0	1178	if (*p == '/') {
sl@0	1179	while (p[1] == '/') {
sl@0	1180	p++;
sl@0	1181	}
sl@0	1182	if (p[1] != '\0') {
sl@0	1183	if (needsSep) {
sl@0	1184	*dest++ = '/';
sl@0	1185	}
sl@0	1186	}
sl@0	1187	} else {
sl@0	1188	dest++ = p;
sl@0	1189	needsSep = 1;
sl@0	1190	}
sl@0	1191	}
sl@0	1192	length = dest - Tcl_GetString(prefix);
sl@0	1193	Tcl_SetObjLength(prefix, length);
sl@0	1194	break;
sl@0	1195
sl@0	1196	case TCL_PLATFORM_WINDOWS:
sl@0	1197	/*
sl@0	1198	* Check to see if we need to append a separator.
sl@0	1199	*/
sl@0	1200
sl@0	1201	if ((length > 0) &&
sl@0	1202	(start[length-1] != '/') && (start[length-1] != ':')) {
sl@0	1203	Tcl_AppendToObj(prefix, "/", 1);
sl@0	1204	length++;
sl@0	1205	}
sl@0	1206	needsSep = 0;
sl@0	1207
sl@0	1208	/*
sl@0	1209	* Append the element, eliminating duplicate and
sl@0	1210	* trailing slashes.
sl@0	1211	*/
sl@0	1212
sl@0	1213	Tcl_SetObjLength(prefix, length + (int) strlen(p));
sl@0	1214	dest = Tcl_GetString(prefix) + length;
sl@0	1215	for (; *p != '\0'; p++) {
sl@0	1216	if ((p == '/') \|\| (p == '\\')) {
sl@0	1217	while ((p[1] == '/') \|\| (p[1] == '\\')) {
sl@0	1218	p++;
sl@0	1219	}
sl@0	1220	if ((p[1] != '\0') && needsSep) {
sl@0	1221	*dest++ = '/';
sl@0	1222	}
sl@0	1223	} else {
sl@0	1224	dest++ = p;
sl@0	1225	needsSep = 1;
sl@0	1226	}
sl@0	1227	}
sl@0	1228	length = dest - Tcl_GetString(prefix);
sl@0	1229	Tcl_SetObjLength(prefix, length);
sl@0	1230	break;
sl@0	1231
sl@0	1232	case TCL_PLATFORM_MAC: {
sl@0	1233	int newLength;
sl@0	1234
sl@0	1235	/*
sl@0	1236	* Sort out separators. We basically add the object we've
sl@0	1237	* been given, but we have to make sure that there is
sl@0	1238	* exactly one separator inbetween (unless the object we're
sl@0	1239	* adding contains multiple contiguous colons, all of which
sl@0	1240	* we must add). Also if an object is just ':' we don't
sl@0	1241	* bother to add it unless it's the very first element.
sl@0	1242	*/
sl@0	1243
sl@0	1244	#ifdef MAC_UNDERSTANDS_UNIX_PATHS
sl@0	1245	int adjustedPath = 0;
sl@0	1246	if ((strchr(p, ':') == NULL) && (strchr(p, '/') != NULL)) {
sl@0	1247	char *start = p;
sl@0	1248	adjustedPath = 1;
sl@0	1249	while (*start != '\0') {
sl@0	1250	if (*start == '/') {
sl@0	1251	*start = ':';
sl@0	1252	}
sl@0	1253	start++;
sl@0	1254	}
sl@0	1255	}
sl@0	1256	#endif
sl@0	1257	if (length > 0) {
sl@0	1258	if ((p[0] == ':') && (p[1] == '\0')) {
sl@0	1259	return;
sl@0	1260	}
sl@0	1261	if (start[length-1] != ':') {
sl@0	1262	if (p != '\0' && p != ':') {
sl@0	1263	Tcl_AppendToObj(prefix, ":", 1);
sl@0	1264	length++;
sl@0	1265	}
sl@0	1266	} else if (*p == ':') {
sl@0	1267	p++;
sl@0	1268	}
sl@0	1269	} else {
sl@0	1270	if (p != '\0' && p != ':') {
sl@0	1271	Tcl_AppendToObj(prefix, ":", 1);
sl@0	1272	length++;
sl@0	1273	}
sl@0	1274	}
sl@0	1275
sl@0	1276	/*
sl@0	1277	* Append the element
sl@0	1278	*/
sl@0	1279
sl@0	1280	newLength = strlen(p);
sl@0	1281	/*
sl@0	1282	* It may not be good to just do 'Tcl_AppendToObj(prefix,
sl@0	1283	* p, newLength)' because the object may contain duplicate
sl@0	1284	* colons which we want to get rid of.
sl@0	1285	*/
sl@0	1286	Tcl_AppendToObj(prefix, p, newLength);
sl@0	1287
sl@0	1288	/* Remove spurious trailing single ':' */
sl@0	1289	dest = Tcl_GetString(prefix) + length + newLength;
sl@0	1290	if (*(dest-1) == ':') {
sl@0	1291	if (dest-1 > Tcl_GetString(prefix)) {
sl@0	1292	if (*(dest-2) != ':') {
sl@0	1293	Tcl_SetObjLength(prefix, length + newLength -1);
sl@0	1294	}
sl@0	1295	}
sl@0	1296	}
sl@0	1297	#ifdef MAC_UNDERSTANDS_UNIX_PATHS
sl@0	1298	/* Revert the path to what it was */
sl@0	1299	if (adjustedPath) {
sl@0	1300	char *start = joining;
sl@0	1301	while (*start != '\0') {
sl@0	1302	if (*start == ':') {
sl@0	1303	*start = '/';
sl@0	1304	}
sl@0	1305	start++;
sl@0	1306	}
sl@0	1307	}
sl@0	1308	#endif
sl@0	1309	break;
sl@0	1310	}
sl@0	1311	}
sl@0	1312	return;
sl@0	1313	}
sl@0	1314
sl@0	1315	/*
sl@0	1316	*----------------------------------------------------------------------
sl@0	1317	*
sl@0	1318	* Tcl_JoinPath --
sl@0	1319	*
sl@0	1320	* Combine a list of paths in a platform specific manner. The
sl@0	1321	* function 'Tcl_FSJoinPath' should be used in preference where
sl@0	1322	* possible.
sl@0	1323	*
sl@0	1324	* Results:
sl@0	1325	* Appends the joined path to the end of the specified
sl@0	1326	* Tcl_DString returning a pointer to the resulting string. Note
sl@0	1327	* that the Tcl_DString must already be initialized.
sl@0	1328	*
sl@0	1329	* Side effects:
sl@0	1330	* Modifies the Tcl_DString.
sl@0	1331	*
sl@0	1332	*----------------------------------------------------------------------
sl@0	1333	*/
sl@0	1334
sl@0	1335	EXPORT_C char *
sl@0	1336	Tcl_JoinPath(argc, argv, resultPtr)
sl@0	1337	int argc;
sl@0	1338	CONST char * CONST *argv;
sl@0	1339	Tcl_DString resultPtr; / Pointer to previously initialized DString */
sl@0	1340	{
sl@0	1341	int i, len;
sl@0	1342	Tcl_Obj *listObj = Tcl_NewObj();
sl@0	1343	Tcl_Obj *resultObj;
sl@0	1344	char *resultStr;
sl@0	1345
sl@0	1346	/* Build the list of paths */
sl@0	1347	for (i = 0; i < argc; i++) {
sl@0	1348	Tcl_ListObjAppendElement(NULL, listObj,
sl@0	1349	Tcl_NewStringObj(argv[i], -1));
sl@0	1350	}
sl@0	1351
sl@0	1352	/* Ask the objectified code to join the paths */
sl@0	1353	Tcl_IncrRefCount(listObj);
sl@0	1354	resultObj = Tcl_FSJoinPath(listObj, argc);
sl@0	1355	Tcl_IncrRefCount(resultObj);
sl@0	1356	Tcl_DecrRefCount(listObj);
sl@0	1357
sl@0	1358	/* Store the result */
sl@0	1359	resultStr = Tcl_GetStringFromObj(resultObj, &len);
sl@0	1360	Tcl_DStringAppend(resultPtr, resultStr, len);
sl@0	1361	Tcl_DecrRefCount(resultObj);
sl@0	1362
sl@0	1363	/* Return a pointer to the result */
sl@0	1364	return Tcl_DStringValue(resultPtr);
sl@0	1365	}
sl@0	1366
sl@0	1367	/*
sl@0	1368	*---------------------------------------------------------------------------
sl@0	1369	*
sl@0	1370	* Tcl_TranslateFileName --
sl@0	1371	*
sl@0	1372	* Converts a file name into a form usable by the native system
sl@0	1373	* interfaces. If the name starts with a tilde, it will produce a
sl@0	1374	* name where the tilde and following characters have been replaced
sl@0	1375	* by the home directory location for the named user.
sl@0	1376	*
sl@0	1377	* Results:
sl@0	1378	* The return value is a pointer to a string containing the name
sl@0	1379	* after tilde substitution. If there was no tilde substitution,
sl@0	1380	* the return value is a pointer to a copy of the original string.
sl@0	1381	* If there was an error in processing the name, then an error
sl@0	1382	* message is left in the interp's result (if interp was not NULL)
sl@0	1383	* and the return value is NULL. Space for the return value is
sl@0	1384	* allocated in bufferPtr; the caller must call Tcl_DStringFree()
sl@0	1385	* to free the space if the return value was not NULL.
sl@0	1386	*
sl@0	1387	* Side effects:
sl@0	1388	* None.
sl@0	1389	*
sl@0	1390	*----------------------------------------------------------------------
sl@0	1391	*/
sl@0	1392
sl@0	1393	EXPORT_C char *
sl@0	1394	Tcl_TranslateFileName(interp, name, bufferPtr)
sl@0	1395	Tcl_Interp interp; / Interpreter in which to store error
sl@0	1396	* message (if necessary). */
sl@0	1397	CONST char name; / File name, which may begin with "~" (to
sl@0	1398	* indicate current user's home directory) or
sl@0	1399	* "~<user>" (to indicate any user's home
sl@0	1400	* directory). */
sl@0	1401	Tcl_DString bufferPtr; / Uninitialized or free DString filled
sl@0	1402	* with name after tilde substitution. */
sl@0	1403	{
sl@0	1404	Tcl_Obj *path = Tcl_NewStringObj(name, -1);
sl@0	1405	Tcl_Obj *transPtr;
sl@0	1406
sl@0	1407	Tcl_IncrRefCount(path);
sl@0	1408	transPtr = Tcl_FSGetTranslatedPath(interp, path);
sl@0	1409	if (transPtr == NULL) {
sl@0	1410	Tcl_DecrRefCount(path);
sl@0	1411	return NULL;
sl@0	1412	}
sl@0	1413
sl@0	1414	Tcl_DStringInit(bufferPtr);
sl@0	1415	Tcl_DStringAppend(bufferPtr, Tcl_GetString(transPtr), -1);
sl@0	1416	Tcl_DecrRefCount(path);
sl@0	1417	Tcl_DecrRefCount(transPtr);
sl@0	1418
sl@0	1419	/*
sl@0	1420	* Convert forward slashes to backslashes in Windows paths because
sl@0	1421	* some system interfaces don't accept forward slashes.
sl@0	1422	*/
sl@0	1423
sl@0	1424	if (tclPlatform == TCL_PLATFORM_WINDOWS) {
sl@0	1425	register char *p;
sl@0	1426	for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
sl@0	1427	if (*p == '/') {
sl@0	1428	*p = '\\';
sl@0	1429	}
sl@0	1430	}
sl@0	1431	}
sl@0	1432	return Tcl_DStringValue(bufferPtr);
sl@0	1433	}
sl@0	1434
sl@0	1435	/*
sl@0	1436	*----------------------------------------------------------------------
sl@0	1437	*
sl@0	1438	* TclGetExtension --
sl@0	1439	*
sl@0	1440	* This function returns a pointer to the beginning of the
sl@0	1441	* extension part of a file name.
sl@0	1442	*
sl@0	1443	* Results:
sl@0	1444	* Returns a pointer into name which indicates where the extension
sl@0	1445	* starts. If there is no extension, returns NULL.
sl@0	1446	*
sl@0	1447	* Side effects:
sl@0	1448	* None.
sl@0	1449	*
sl@0	1450	*----------------------------------------------------------------------
sl@0	1451	*/
sl@0	1452
sl@0	1453	char *
sl@0	1454	TclGetExtension(name)
sl@0	1455	char name; / File name to parse. */
sl@0	1456	{
sl@0	1457	char p, lastSep;
sl@0	1458
sl@0	1459	/*
sl@0	1460	* First find the last directory separator.
sl@0	1461	*/
sl@0	1462
sl@0	1463	lastSep = NULL; /* Needed only to prevent gcc warnings. */
sl@0	1464	switch (tclPlatform) {
sl@0	1465	case TCL_PLATFORM_UNIX:
sl@0	1466	lastSep = strrchr(name, '/');
sl@0	1467	break;
sl@0	1468
sl@0	1469	case TCL_PLATFORM_MAC:
sl@0	1470	#ifdef MAC_UNDERSTANDS_UNIX_PATHS
sl@0	1471	if (strchr(name, ':') == NULL) {
sl@0	1472	lastSep = strrchr(name, '/');
sl@0	1473	} else {
sl@0	1474	lastSep = strrchr(name, ':');
sl@0	1475	}
sl@0	1476	#else
sl@0	1477	lastSep = strrchr(name, ':');
sl@0	1478	#endif
sl@0	1479	break;
sl@0	1480
sl@0	1481	case TCL_PLATFORM_WINDOWS:
sl@0	1482	lastSep = NULL;
sl@0	1483	for (p = name; *p != '\0'; p++) {
sl@0	1484	if (strchr("/\\:", *p) != NULL) {
sl@0	1485	lastSep = p;
sl@0	1486	}
sl@0	1487	}
sl@0	1488	break;
sl@0	1489	}
sl@0	1490	p = strrchr(name, '.');
sl@0	1491	if ((p != NULL) && (lastSep != NULL) && (lastSep > p)) {
sl@0	1492	p = NULL;
sl@0	1493	}
sl@0	1494
sl@0	1495	/*
sl@0	1496	* In earlier versions, we used to back up to the first period in a series
sl@0	1497	* so that "foo..o" would be split into "foo" and "..o". This is a
sl@0	1498	* confusing and usually incorrect behavior, so now we split at the last
sl@0	1499	* period in the name.
sl@0	1500	*/
sl@0	1501
sl@0	1502	return p;
sl@0	1503	}
sl@0	1504
sl@0	1505	/*
sl@0	1506	*----------------------------------------------------------------------
sl@0	1507	*
sl@0	1508	* DoTildeSubst --
sl@0	1509	*
sl@0	1510	* Given a string following a tilde, this routine returns the
sl@0	1511	* corresponding home directory.
sl@0	1512	*
sl@0	1513	* Results:
sl@0	1514	* The result is a pointer to a static string containing the home
sl@0	1515	* directory in native format. If there was an error in processing
sl@0	1516	* the substitution, then an error message is left in the interp's
sl@0	1517	* result and the return value is NULL. On success, the results
sl@0	1518	* are appended to resultPtr, and the contents of resultPtr are
sl@0	1519	* returned.
sl@0	1520	*
sl@0	1521	* Side effects:
sl@0	1522	* Information may be left in resultPtr.
sl@0	1523	*
sl@0	1524	*----------------------------------------------------------------------
sl@0	1525	*/
sl@0	1526
sl@0	1527	static CONST char *
sl@0	1528	DoTildeSubst(interp, user, resultPtr)
sl@0	1529	Tcl_Interp interp; / Interpreter in which to store error
sl@0	1530	* message (if necessary). */
sl@0	1531	CONST char user; / Name of user whose home directory should be
sl@0	1532	* substituted, or "" for current user. */
sl@0	1533	Tcl_DString resultPtr; / Initialized DString filled with name
sl@0	1534	* after tilde substitution. */
sl@0	1535	{
sl@0	1536	CONST char *dir;
sl@0	1537
sl@0	1538	if (*user == '\0') {
sl@0	1539	Tcl_DString dirString;
sl@0	1540
sl@0	1541	dir = TclGetEnv("HOME", &dirString);
sl@0	1542	if (dir == NULL) {
sl@0	1543	if (interp) {
sl@0	1544	Tcl_ResetResult(interp);
sl@0	1545	Tcl_AppendResult(interp, "couldn't find HOME environment ",
sl@0	1546	"variable to expand path", (char *) NULL);
sl@0	1547	}
sl@0	1548	return NULL;
sl@0	1549	}
sl@0	1550	Tcl_JoinPath(1, &dir, resultPtr);
sl@0	1551	Tcl_DStringFree(&dirString);
sl@0	1552	} else {
sl@0	1553	if (TclpGetUserHome(user, resultPtr) == NULL) {
sl@0	1554	if (interp) {
sl@0	1555	Tcl_ResetResult(interp);
sl@0	1556	Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist",
sl@0	1557	(char *) NULL);
sl@0	1558	}
sl@0	1559	return NULL;
sl@0	1560	}
sl@0	1561	}
sl@0	1562	return Tcl_DStringValue(resultPtr);
sl@0	1563	}
sl@0	1564
sl@0	1565	/*
sl@0	1566	*----------------------------------------------------------------------
sl@0	1567	*
sl@0	1568	* Tcl_GlobObjCmd --
sl@0	1569	*
sl@0	1570	* This procedure is invoked to process the "glob" Tcl command.
sl@0	1571	* See the user documentation for details on what it does.
sl@0	1572	*
sl@0	1573	* Results:
sl@0	1574	* A standard Tcl result.
sl@0	1575	*
sl@0	1576	* Side effects:
sl@0	1577	* See the user documentation.
sl@0	1578	*
sl@0	1579	*----------------------------------------------------------------------
sl@0	1580	*/
sl@0	1581
sl@0	1582	/* ARGSUSED */
sl@0	1583	int
sl@0	1584	Tcl_GlobObjCmd(dummy, interp, objc, objv)
sl@0	1585	ClientData dummy; /* Not used. */
sl@0	1586	Tcl_Interp interp; / Current interpreter. */
sl@0	1587	int objc; /* Number of arguments. */
sl@0	1588	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	1589	{
sl@0	1590	int index, i, globFlags, length, join, dir, result;
sl@0	1591	char string, separators;
sl@0	1592	Tcl_Obj typePtr, resultPtr, *look;
sl@0	1593	Tcl_Obj *pathOrDir = NULL;
sl@0	1594	Tcl_DString prefix;
sl@0	1595	static CONST char *options[] = {
sl@0	1596	"-directory", "-join", "-nocomplain", "-path", "-tails",
sl@0	1597	"-types", "--", NULL
sl@0	1598	};
sl@0	1599	enum options {
sl@0	1600	GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TAILS,
sl@0	1601	GLOB_TYPE, GLOB_LAST
sl@0	1602	};
sl@0	1603	enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1};
sl@0	1604	Tcl_GlobTypeData *globTypes = NULL;
sl@0	1605
sl@0	1606	globFlags = 0;
sl@0	1607	join = 0;
sl@0	1608	dir = PATH_NONE;
sl@0	1609	typePtr = NULL;
sl@0	1610	for (i = 1; i < objc; i++) {
sl@0	1611	if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index)
sl@0	1612	!= TCL_OK) {
sl@0	1613	string = Tcl_GetStringFromObj(objv[i], &length);
sl@0	1614	if (string[0] == '-') {
sl@0	1615	/*
sl@0	1616	* It looks like the command contains an option so signal
sl@0	1617	* an error
sl@0	1618	*/
sl@0	1619	return TCL_ERROR;
sl@0	1620	} else {
sl@0	1621	/*
sl@0	1622	* This clearly isn't an option; assume it's the first
sl@0	1623	* glob pattern. We must clear the error
sl@0	1624	*/
sl@0	1625	Tcl_ResetResult(interp);
sl@0	1626	break;
sl@0	1627	}
sl@0	1628	}
sl@0	1629	switch (index) {
sl@0	1630	case GLOB_NOCOMPLAIN: /* -nocomplain */
sl@0	1631	globFlags \|= TCL_GLOBMODE_NO_COMPLAIN;
sl@0	1632	break;
sl@0	1633	case GLOB_DIR: /* -dir */
sl@0	1634	if (i == (objc-1)) {
sl@0	1635	Tcl_SetObjResult(interp, Tcl_NewStringObj(
sl@0	1636	"missing argument to \"-directory\"", -1));
sl@0	1637	return TCL_ERROR;
sl@0	1638	}
sl@0	1639	if (dir != PATH_NONE) {
sl@0	1640	Tcl_SetObjResult(interp, Tcl_NewStringObj(
sl@0	1641	"\"-directory\" cannot be used with \"-path\"",
sl@0	1642	-1));
sl@0	1643	return TCL_ERROR;
sl@0	1644	}
sl@0	1645	dir = PATH_DIR;
sl@0	1646	globFlags \|= TCL_GLOBMODE_DIR;
sl@0	1647	pathOrDir = objv[i+1];
sl@0	1648	i++;
sl@0	1649	break;
sl@0	1650	case GLOB_JOIN: /* -join */
sl@0	1651	join = 1;
sl@0	1652	break;
sl@0	1653	case GLOB_TAILS: /* -tails */
sl@0	1654	globFlags \|= TCL_GLOBMODE_TAILS;
sl@0	1655	break;
sl@0	1656	case GLOB_PATH: /* -path */
sl@0	1657	if (i == (objc-1)) {
sl@0	1658	Tcl_SetObjResult(interp, Tcl_NewStringObj(
sl@0	1659	"missing argument to \"-path\"", -1));
sl@0	1660	return TCL_ERROR;
sl@0	1661	}
sl@0	1662	if (dir != PATH_NONE) {
sl@0	1663	Tcl_SetObjResult(interp, Tcl_NewStringObj(
sl@0	1664	"\"-path\" cannot be used with \"-directory\"",
sl@0	1665	-1));
sl@0	1666	return TCL_ERROR;
sl@0	1667	}
sl@0	1668	dir = PATH_GENERAL;
sl@0	1669	pathOrDir = objv[i+1];
sl@0	1670	i++;
sl@0	1671	break;
sl@0	1672	case GLOB_TYPE: /* -types */
sl@0	1673	if (i == (objc-1)) {
sl@0	1674	Tcl_SetObjResult(interp, Tcl_NewStringObj(
sl@0	1675	"missing argument to \"-types\"", -1));
sl@0	1676	return TCL_ERROR;
sl@0	1677	}
sl@0	1678	typePtr = objv[i+1];
sl@0	1679	if (Tcl_ListObjLength(interp, typePtr, &length) != TCL_OK) {
sl@0	1680	return TCL_ERROR;
sl@0	1681	}
sl@0	1682	i++;
sl@0	1683	break;
sl@0	1684	case GLOB_LAST: /* -- */
sl@0	1685	i++;
sl@0	1686	goto endOfForLoop;
sl@0	1687	}
sl@0	1688	}
sl@0	1689	endOfForLoop:
sl@0	1690	if (objc - i < 1) {
sl@0	1691	Tcl_WrongNumArgs(interp, 1, objv, "?switches? name ?name ...?");
sl@0	1692	return TCL_ERROR;
sl@0	1693	}
sl@0	1694	if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) {
sl@0	1695	Tcl_SetObjResult(interp, Tcl_NewStringObj(
sl@0	1696	"\"-tails\" must be used with either \"-directory\" or \"-path\"",
sl@0	1697	-1));
sl@0	1698	return TCL_ERROR;
sl@0	1699	}
sl@0	1700
sl@0	1701	separators = NULL; /* lint. */
sl@0	1702	switch (tclPlatform) {
sl@0	1703	case TCL_PLATFORM_UNIX:
sl@0	1704	separators = "/";
sl@0	1705	break;
sl@0	1706	case TCL_PLATFORM_WINDOWS:
sl@0	1707	separators = "/\\:";
sl@0	1708	break;
sl@0	1709	case TCL_PLATFORM_MAC:
sl@0	1710	separators = ":";
sl@0	1711	break;
sl@0	1712	}
sl@0	1713	if (dir == PATH_GENERAL) {
sl@0	1714	int pathlength;
sl@0	1715	char *last;
sl@0	1716	char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength);
sl@0	1717
sl@0	1718	/*
sl@0	1719	* Find the last path separator in the path
sl@0	1720	*/
sl@0	1721	last = first + pathlength;
sl@0	1722	for (; last != first; last--) {
sl@0	1723	if (strchr(separators, *(last-1)) != NULL) {
sl@0	1724	break;
sl@0	1725	}
sl@0	1726	}
sl@0	1727	if (last == first + pathlength) {
sl@0	1728	/* It's really a directory */
sl@0	1729	dir = PATH_DIR;
sl@0	1730	} else {
sl@0	1731	Tcl_DString pref;
sl@0	1732	char search, find;
sl@0	1733	Tcl_DStringInit(&pref);
sl@0	1734	if (last == first) {
sl@0	1735	/* The whole thing is a prefix */
sl@0	1736	Tcl_DStringAppend(&pref, first, -1);
sl@0	1737	pathOrDir = NULL;
sl@0	1738	} else {
sl@0	1739	/* Have to split off the end */
sl@0	1740	Tcl_DStringAppend(&pref, last, first+pathlength-last);
sl@0	1741	pathOrDir = Tcl_NewStringObj(first, last-first-1);
sl@0	1742	/*
sl@0	1743	* We must ensure that we haven't cut off too much,
sl@0	1744	* and turned a valid path like '/' or 'C:/' into
sl@0	1745	* an incorrect path like '' or 'C:'. The way we
sl@0	1746	* do this is to add a separator if there are none
sl@0	1747	* presently in the prefix.
sl@0	1748	*/
sl@0	1749	if (strpbrk(Tcl_GetString(pathOrDir), "\\/") == NULL) {
sl@0	1750	Tcl_AppendToObj(pathOrDir, last-1, 1);
sl@0	1751	}
sl@0	1752	}
sl@0	1753	/* Need to quote 'prefix' */
sl@0	1754	Tcl_DStringInit(&prefix);
sl@0	1755	search = Tcl_DStringValue(&pref);
sl@0	1756	while ((find = (strpbrk(search, "\\[]*?{}"))) != NULL) {
sl@0	1757	Tcl_DStringAppend(&prefix, search, find-search);
sl@0	1758	Tcl_DStringAppend(&prefix, "\\", 1);
sl@0	1759	Tcl_DStringAppend(&prefix, find, 1);
sl@0	1760	search = find+1;
sl@0	1761	if (*search == '\0') {
sl@0	1762	break;
sl@0	1763	}
sl@0	1764	}
sl@0	1765	if (*search != '\0') {
sl@0	1766	Tcl_DStringAppend(&prefix, search, -1);
sl@0	1767	}
sl@0	1768	Tcl_DStringFree(&pref);
sl@0	1769	}
sl@0	1770	}
sl@0	1771
sl@0	1772	if (pathOrDir != NULL) {
sl@0	1773	Tcl_IncrRefCount(pathOrDir);
sl@0	1774	}
sl@0	1775
sl@0	1776	if (typePtr != NULL) {
sl@0	1777	/*
sl@0	1778	* The rest of the possible type arguments (except 'd') are
sl@0	1779	* platform specific. We don't complain when they are used
sl@0	1780	* on an incompatible platform.
sl@0	1781	*/
sl@0	1782	Tcl_ListObjLength(interp, typePtr, &length);
sl@0	1783	globTypes = (Tcl_GlobTypeData*) ckalloc(sizeof(Tcl_GlobTypeData));
sl@0	1784	globTypes->type = 0;
sl@0	1785	globTypes->perm = 0;
sl@0	1786	globTypes->macType = NULL;
sl@0	1787	globTypes->macCreator = NULL;
sl@0	1788	while(--length >= 0) {
sl@0	1789	int len;
sl@0	1790	char *str;
sl@0	1791	Tcl_ListObjIndex(interp, typePtr, length, &look);
sl@0	1792	str = Tcl_GetStringFromObj(look, &len);
sl@0	1793	if (strcmp("readonly", str) == 0) {
sl@0	1794	globTypes->perm \|= TCL_GLOB_PERM_RONLY;
sl@0	1795	} else if (strcmp("hidden", str) == 0) {
sl@0	1796	globTypes->perm \|= TCL_GLOB_PERM_HIDDEN;
sl@0	1797	} else if (len == 1) {
sl@0	1798	switch (str[0]) {
sl@0	1799	case 'r':
sl@0	1800	globTypes->perm \|= TCL_GLOB_PERM_R;
sl@0	1801	break;
sl@0	1802	case 'w':
sl@0	1803	globTypes->perm \|= TCL_GLOB_PERM_W;
sl@0	1804	break;
sl@0	1805	case 'x':
sl@0	1806	globTypes->perm \|= TCL_GLOB_PERM_X;
sl@0	1807	break;
sl@0	1808	case 'b':
sl@0	1809	globTypes->type \|= TCL_GLOB_TYPE_BLOCK;
sl@0	1810	break;
sl@0	1811	case 'c':
sl@0	1812	globTypes->type \|= TCL_GLOB_TYPE_CHAR;
sl@0	1813	break;
sl@0	1814	case 'd':
sl@0	1815	globTypes->type \|= TCL_GLOB_TYPE_DIR;
sl@0	1816	break;
sl@0	1817	case 'p':
sl@0	1818	globTypes->type \|= TCL_GLOB_TYPE_PIPE;
sl@0	1819	break;
sl@0	1820	case 'f':
sl@0	1821	globTypes->type \|= TCL_GLOB_TYPE_FILE;
sl@0	1822	break;
sl@0	1823	case 'l':
sl@0	1824	globTypes->type \|= TCL_GLOB_TYPE_LINK;
sl@0	1825	break;
sl@0	1826	case 's':
sl@0	1827	globTypes->type \|= TCL_GLOB_TYPE_SOCK;
sl@0	1828	break;
sl@0	1829	default:
sl@0	1830	goto badTypesArg;
sl@0	1831	}
sl@0	1832	} else if (len == 4) {
sl@0	1833	/* This is assumed to be a MacOS file type */
sl@0	1834	if (globTypes->macType != NULL) {
sl@0	1835	goto badMacTypesArg;
sl@0	1836	}
sl@0	1837	globTypes->macType = look;
sl@0	1838	Tcl_IncrRefCount(look);
sl@0	1839	} else {
sl@0	1840	Tcl_Obj* item;
sl@0	1841	if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) &&
sl@0	1842	(len == 3)) {
sl@0	1843	Tcl_ListObjIndex(interp, look, 0, &item);
sl@0	1844	if (!strcmp("macintosh", Tcl_GetString(item))) {
sl@0	1845	Tcl_ListObjIndex(interp, look, 1, &item);
sl@0	1846	if (!strcmp("type", Tcl_GetString(item))) {
sl@0	1847	Tcl_ListObjIndex(interp, look, 2, &item);
sl@0	1848	if (globTypes->macType != NULL) {
sl@0	1849	goto badMacTypesArg;
sl@0	1850	}
sl@0	1851	globTypes->macType = item;
sl@0	1852	Tcl_IncrRefCount(item);
sl@0	1853	continue;
sl@0	1854	} else if (!strcmp("creator", Tcl_GetString(item))) {
sl@0	1855	Tcl_ListObjIndex(interp, look, 2, &item);
sl@0	1856	if (globTypes->macCreator != NULL) {
sl@0	1857	goto badMacTypesArg;
sl@0	1858	}
sl@0	1859	globTypes->macCreator = item;
sl@0	1860	Tcl_IncrRefCount(item);
sl@0	1861	continue;
sl@0	1862	}
sl@0	1863	}
sl@0	1864	}
sl@0	1865	/*
sl@0	1866	* Error cases. We reset
sl@0	1867	* the 'join' flag to zero, since we haven't yet
sl@0	1868	* made use of it.
sl@0	1869	*/
sl@0	1870	badTypesArg:
sl@0	1871	resultPtr = Tcl_GetObjResult(interp);
sl@0	1872	Tcl_AppendToObj(resultPtr, "bad argument to \"-types\": ", -1);
sl@0	1873	Tcl_AppendObjToObj(resultPtr, look);
sl@0	1874	result = TCL_ERROR;
sl@0	1875	join = 0;
sl@0	1876	goto endOfGlob;
sl@0	1877	badMacTypesArg:
sl@0	1878	Tcl_SetObjResult(interp, Tcl_NewStringObj(
sl@0	1879	"only one MacOS type or creator argument"
sl@0	1880	" to \"-types\" allowed", -1));
sl@0	1881	result = TCL_ERROR;
sl@0	1882	join = 0;
sl@0	1883	goto endOfGlob;
sl@0	1884	}
sl@0	1885	}
sl@0	1886	}
sl@0	1887
sl@0	1888	/*
sl@0	1889	* Now we perform the actual glob below. This may involve joining
sl@0	1890	* together the pattern arguments, dealing with particular file types
sl@0	1891	* etc. We use a 'goto' to ensure we free any memory allocated along
sl@0	1892	* the way.
sl@0	1893	*/
sl@0	1894	objc -= i;
sl@0	1895	objv += i;
sl@0	1896	result = TCL_OK;
sl@0	1897	if (join) {
sl@0	1898	if (dir != PATH_GENERAL) {
sl@0	1899	Tcl_DStringInit(&prefix);
sl@0	1900	}
sl@0	1901	for (i = 0; i < objc; i++) {
sl@0	1902	string = Tcl_GetStringFromObj(objv[i], &length);
sl@0	1903	Tcl_DStringAppend(&prefix, string, length);
sl@0	1904	if (i != objc -1) {
sl@0	1905	Tcl_DStringAppend(&prefix, separators, 1);
sl@0	1906	}
sl@0	1907	}
sl@0	1908	if (TclGlob(interp, Tcl_DStringValue(&prefix), pathOrDir,
sl@0	1909	globFlags, globTypes) != TCL_OK) {
sl@0	1910	result = TCL_ERROR;
sl@0	1911	goto endOfGlob;
sl@0	1912	}
sl@0	1913	} else {
sl@0	1914	if (dir == PATH_GENERAL) {
sl@0	1915	Tcl_DString str;
sl@0	1916	for (i = 0; i < objc; i++) {
sl@0	1917	Tcl_DStringInit(&str);
sl@0	1918	if (dir == PATH_GENERAL) {
sl@0	1919	Tcl_DStringAppend(&str, Tcl_DStringValue(&prefix),
sl@0	1920	Tcl_DStringLength(&prefix));
sl@0	1921	}
sl@0	1922	string = Tcl_GetStringFromObj(objv[i], &length);
sl@0	1923	Tcl_DStringAppend(&str, string, length);
sl@0	1924	if (TclGlob(interp, Tcl_DStringValue(&str), pathOrDir,
sl@0	1925	globFlags, globTypes) != TCL_OK) {
sl@0	1926	result = TCL_ERROR;
sl@0	1927	Tcl_DStringFree(&str);
sl@0	1928	goto endOfGlob;
sl@0	1929	}
sl@0	1930	}
sl@0	1931	Tcl_DStringFree(&str);
sl@0	1932	} else {
sl@0	1933	for (i = 0; i < objc; i++) {
sl@0	1934	string = Tcl_GetString(objv[i]);
sl@0	1935	if (TclGlob(interp, string, pathOrDir,
sl@0	1936	globFlags, globTypes) != TCL_OK) {
sl@0	1937	result = TCL_ERROR;
sl@0	1938	goto endOfGlob;
sl@0	1939	}
sl@0	1940	}
sl@0	1941	}
sl@0	1942	}
sl@0	1943	if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) {
sl@0	1944	if (Tcl_ListObjLength(interp, Tcl_GetObjResult(interp),
sl@0	1945	&length) != TCL_OK) {
sl@0	1946	/* This should never happen. Maybe we should be more dramatic */
sl@0	1947	result = TCL_ERROR;
sl@0	1948	goto endOfGlob;
sl@0	1949	}
sl@0	1950	if (length == 0) {
sl@0	1951	Tcl_AppendResult(interp, "no files matched glob pattern",
sl@0	1952	(join \|\| (objc == 1)) ? " \"" : "s \"", (char *) NULL);
sl@0	1953	if (join) {
sl@0	1954	Tcl_AppendResult(interp, Tcl_DStringValue(&prefix),
sl@0	1955	(char *) NULL);
sl@0	1956	} else {
sl@0	1957	char *sep = "";
sl@0	1958	for (i = 0; i < objc; i++) {
sl@0	1959	string = Tcl_GetString(objv[i]);
sl@0	1960	Tcl_AppendResult(interp, sep, string, (char *) NULL);
sl@0	1961	sep = " ";
sl@0	1962	}
sl@0	1963	}
sl@0	1964	Tcl_AppendResult(interp, "\"", (char *) NULL);
sl@0	1965	result = TCL_ERROR;
sl@0	1966	}
sl@0	1967	}
sl@0	1968	endOfGlob:
sl@0	1969	if (join \|\| (dir == PATH_GENERAL)) {
sl@0	1970	Tcl_DStringFree(&prefix);
sl@0	1971	}
sl@0	1972	if (pathOrDir != NULL) {
sl@0	1973	Tcl_DecrRefCount(pathOrDir);
sl@0	1974	}
sl@0	1975	if (globTypes != NULL) {
sl@0	1976	if (globTypes->macType != NULL) {
sl@0	1977	Tcl_DecrRefCount(globTypes->macType);
sl@0	1978	}
sl@0	1979	if (globTypes->macCreator != NULL) {
sl@0	1980	Tcl_DecrRefCount(globTypes->macCreator);
sl@0	1981	}
sl@0	1982	ckfree((char *) globTypes);
sl@0	1983	}
sl@0	1984	return result;
sl@0	1985	}
sl@0	1986
sl@0	1987	/*
sl@0	1988	*----------------------------------------------------------------------
sl@0	1989	*
sl@0	1990	* TclGlob --
sl@0	1991	*
sl@0	1992	* This procedure prepares arguments for the TclDoGlob call.
sl@0	1993	* It sets the separator string based on the platform, performs
sl@0	1994	* tilde substitution, and calls TclDoGlob.
sl@0	1995	*
sl@0	1996	* The interpreter's result, on entry to this function, must
sl@0	1997	* be a valid Tcl list (e.g. it could be empty), since we will
sl@0	1998	* lappend any new results to that list. If it is not a valid
sl@0	1999	* list, this function will fail to do anything very meaningful.
sl@0	2000	*
sl@0	2001	* Results:
sl@0	2002	* The return value is a standard Tcl result indicating whether
sl@0	2003	* an error occurred in globbing. After a normal return the
sl@0	2004	* result in interp (set by TclDoGlob) holds all of the file names
sl@0	2005	* given by the pattern and unquotedPrefix arguments. After an
sl@0	2006	* error the result in interp will hold an error message, unless
sl@0	2007	* the 'TCL_GLOBMODE_NO_COMPLAIN' flag was given, in which case
sl@0	2008	* an error results in a TCL_OK return leaving the interpreter's
sl@0	2009	* result unmodified.
sl@0	2010	*
sl@0	2011	* Side effects:
sl@0	2012	* The 'pattern' is written to.
sl@0	2013	*
sl@0	2014	*----------------------------------------------------------------------
sl@0	2015	*/
sl@0	2016
sl@0	2017	/* ARGSUSED */
sl@0	2018	int
sl@0	2019	TclGlob(interp, pattern, unquotedPrefix, globFlags, types)
sl@0	2020	Tcl_Interp interp; / Interpreter for returning error message
sl@0	2021	* or appending list of matching file names. */
sl@0	2022	char pattern; / Glob pattern to match. Must not refer
sl@0	2023	* to a static string. */
sl@0	2024	Tcl_Obj unquotedPrefix; / Prefix to glob pattern, if non-null, which
sl@0	2025	* is considered literally. */
sl@0	2026	int globFlags; /* Stores or'ed combination of flags */
sl@0	2027	Tcl_GlobTypeData types; / Struct containing acceptable types.
sl@0	2028	* May be NULL. */
sl@0	2029	{
sl@0	2030	char *separators;
sl@0	2031	CONST char *head;
sl@0	2032	char tail, start;
sl@0	2033	char c;
sl@0	2034	int result, prefixLen;
sl@0	2035	Tcl_DString buffer;
sl@0	2036	Tcl_Obj *oldResult;
sl@0	2037
sl@0	2038	separators = NULL; /* lint. */
sl@0	2039	switch (tclPlatform) {
sl@0	2040	case TCL_PLATFORM_UNIX:
sl@0	2041	separators = "/";
sl@0	2042	break;
sl@0	2043	case TCL_PLATFORM_WINDOWS:
sl@0	2044	separators = "/\\:";
sl@0	2045	break;
sl@0	2046	case TCL_PLATFORM_MAC:
sl@0	2047	#ifdef MAC_UNDERSTANDS_UNIX_PATHS
sl@0	2048	if (unquotedPrefix == NULL) {
sl@0	2049	separators = (strchr(pattern, ':') == NULL) ? "/" : ":";
sl@0	2050	} else {
sl@0	2051	separators = ":";
sl@0	2052	}
sl@0	2053	#else
sl@0	2054	separators = ":";
sl@0	2055	#endif
sl@0	2056	break;
sl@0	2057	}
sl@0	2058
sl@0	2059	Tcl_DStringInit(&buffer);
sl@0	2060	if (unquotedPrefix != NULL) {
sl@0	2061	start = Tcl_GetString(unquotedPrefix);
sl@0	2062	} else {
sl@0	2063	start = pattern;
sl@0	2064	}
sl@0	2065
sl@0	2066	/*
sl@0	2067	* Perform tilde substitution, if needed.
sl@0	2068	*/
sl@0	2069
sl@0	2070	if (start[0] == '~') {
sl@0	2071
sl@0	2072	/*
sl@0	2073	* Find the first path separator after the tilde.
sl@0	2074	*/
sl@0	2075	for (tail = start; *tail != '\0'; tail++) {
sl@0	2076	if (*tail == '\\') {
sl@0	2077	if (strchr(separators, tail[1]) != NULL) {
sl@0	2078	break;
sl@0	2079	}
sl@0	2080	} else if (strchr(separators, *tail) != NULL) {
sl@0	2081	break;
sl@0	2082	}
sl@0	2083	}
sl@0	2084
sl@0	2085	/*
sl@0	2086	* Determine the home directory for the specified user.
sl@0	2087	*/
sl@0	2088
sl@0	2089	c = *tail;
sl@0	2090	*tail = '\0';
sl@0	2091	if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
sl@0	2092	/*
sl@0	2093	* We will ignore any error message here, and we
sl@0	2094	* don't want to mess up the interpreter's result.
sl@0	2095	*/
sl@0	2096	head = DoTildeSubst(NULL, start+1, &buffer);
sl@0	2097	} else {
sl@0	2098	head = DoTildeSubst(interp, start+1, &buffer);
sl@0	2099	}
sl@0	2100	*tail = c;
sl@0	2101	if (head == NULL) {
sl@0	2102	if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
sl@0	2103	return TCL_OK;
sl@0	2104	} else {
sl@0	2105	return TCL_ERROR;
sl@0	2106	}
sl@0	2107	}
sl@0	2108	if (head != Tcl_DStringValue(&buffer)) {
sl@0	2109	Tcl_DStringAppend(&buffer, head, -1);
sl@0	2110	}
sl@0	2111	if (unquotedPrefix != NULL) {
sl@0	2112	Tcl_DStringAppend(&buffer, tail, -1);
sl@0	2113	tail = pattern;
sl@0	2114	}
sl@0	2115	} else {
sl@0	2116	tail = pattern;
sl@0	2117	if (unquotedPrefix != NULL) {
sl@0	2118	Tcl_DStringAppend(&buffer,Tcl_GetString(unquotedPrefix),-1);
sl@0	2119	}
sl@0	2120	}
sl@0	2121
sl@0	2122	/*
sl@0	2123	* We want to remember the length of the current prefix,
sl@0	2124	* in case we are using TCL_GLOBMODE_TAILS. Also if we
sl@0	2125	* are using TCL_GLOBMODE_DIR, we must make sure the
sl@0	2126	* prefix ends in a directory separator.
sl@0	2127	*/
sl@0	2128	prefixLen = Tcl_DStringLength(&buffer);
sl@0	2129
sl@0	2130	if (prefixLen > 0) {
sl@0	2131	c = Tcl_DStringValue(&buffer)[prefixLen-1];
sl@0	2132	if (strchr(separators, c) == NULL) {
sl@0	2133	/*
sl@0	2134	* If the prefix is a directory, make sure it ends in a
sl@0	2135	* directory separator.
sl@0	2136	*/
sl@0	2137	if (globFlags & TCL_GLOBMODE_DIR) {
sl@0	2138	Tcl_DStringAppend(&buffer,separators,1);
sl@0	2139	/* Try to borrow that separator from the tail */
sl@0	2140	if (tail == separators) {
sl@0	2141	tail++;
sl@0	2142	}
sl@0	2143	}
sl@0	2144	prefixLen++;
sl@0	2145	}
sl@0	2146	}
sl@0	2147
sl@0	2148	/*
sl@0	2149	* We need to get the old result, in case it is over-written
sl@0	2150	* below when we still need it.
sl@0	2151	*/
sl@0	2152	oldResult = Tcl_GetObjResult(interp);
sl@0	2153	Tcl_IncrRefCount(oldResult);
sl@0	2154	Tcl_ResetResult(interp);
sl@0	2155
sl@0	2156	result = TclDoGlob(interp, separators, &buffer, tail, types);
sl@0	2157
sl@0	2158	if (result != TCL_OK) {
sl@0	2159	if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
sl@0	2160	/* Put back the old result and reset the return code */
sl@0	2161	Tcl_SetObjResult(interp, oldResult);
sl@0	2162	result = TCL_OK;
sl@0	2163	}
sl@0	2164	} else {
sl@0	2165	/*
sl@0	2166	* Now we must concatenate the 'oldResult' and the current
sl@0	2167	* result, and then place that into the interpreter.
sl@0	2168	*
sl@0	2169	* If we only want the tails, we must strip off the prefix now.
sl@0	2170	* It may seem more efficient to pass the tails flag down into
sl@0	2171	* TclDoGlob, Tcl_FSMatchInDirectory, but those functions are
sl@0	2172	* continually adjusting the prefix as the various pieces of
sl@0	2173	* the pattern are assimilated, so that would add a lot of
sl@0	2174	* complexity to the code. This way is a little slower (when
sl@0	2175	* the -tails flag is given), but much simpler to code.
sl@0	2176	*/
sl@0	2177	int objc, i;
sl@0	2178	Tcl_Obj **objv;
sl@0	2179
sl@0	2180	/* Ensure sole ownership */
sl@0	2181	if (Tcl_IsShared(oldResult)) {
sl@0	2182	Tcl_DecrRefCount(oldResult);
sl@0	2183	oldResult = Tcl_DuplicateObj(oldResult);
sl@0	2184	Tcl_IncrRefCount(oldResult);
sl@0	2185	}
sl@0	2186
sl@0	2187	Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp),
sl@0	2188	&objc, &objv);
sl@0	2189	#ifdef MAC_TCL
sl@0	2190	/* adjust prefixLen if TclDoGlob prepended a ':' */
sl@0	2191	if ((prefixLen > 0) && (objc > 0)
sl@0	2192	&& (Tcl_DStringValue(&buffer)[0] != ':')) {
sl@0	2193	char *str = Tcl_GetStringFromObj(objv[0],NULL);
sl@0	2194	if (str[0] == ':') {
sl@0	2195	prefixLen++;
sl@0	2196	}
sl@0	2197	}
sl@0	2198	#endif
sl@0	2199	for (i = 0; i< objc; i++) {
sl@0	2200	Tcl_Obj* elt;
sl@0	2201	if (globFlags & TCL_GLOBMODE_TAILS) {
sl@0	2202	int len;
sl@0	2203	char *oldStr = Tcl_GetStringFromObj(objv[i],&len);
sl@0	2204	if (len == prefixLen) {
sl@0	2205	if ((pattern[0] == '\0')
sl@0	2206	\|\| (strchr(separators, pattern[0]) == NULL)) {
sl@0	2207	elt = Tcl_NewStringObj(".",1);
sl@0	2208	} else {
sl@0	2209	elt = Tcl_NewStringObj("/",1);
sl@0	2210	}
sl@0	2211	} else {
sl@0	2212	elt = Tcl_NewStringObj(oldStr + prefixLen,
sl@0	2213	len - prefixLen);
sl@0	2214	}
sl@0	2215	} else {
sl@0	2216	elt = objv[i];
sl@0	2217	}
sl@0	2218	/* Assumption that 'oldResult' is a valid list */
sl@0	2219	Tcl_ListObjAppendElement(interp, oldResult, elt);
sl@0	2220	}
sl@0	2221	Tcl_SetObjResult(interp, oldResult);
sl@0	2222	}
sl@0	2223	/*
sl@0	2224	* Release our temporary copy. All code paths above must
sl@0	2225	* end here so we free our reference.
sl@0	2226	*/
sl@0	2227	Tcl_DecrRefCount(oldResult);
sl@0	2228	Tcl_DStringFree(&buffer);
sl@0	2229	return result;
sl@0	2230	}
sl@0	2231
sl@0	2232	/*
sl@0	2233	*----------------------------------------------------------------------
sl@0	2234	*
sl@0	2235	* SkipToChar --
sl@0	2236	*
sl@0	2237	* This function traverses a glob pattern looking for the next
sl@0	2238	* unquoted occurance of the specified character at the same braces
sl@0	2239	* nesting level.
sl@0	2240	*
sl@0	2241	* Results:
sl@0	2242	* Updates stringPtr to point to the matching character, or to
sl@0	2243	* the end of the string if nothing matched. The return value
sl@0	2244	* is 1 if a match was found at the top level, otherwise it is 0.
sl@0	2245	*
sl@0	2246	* Side effects:
sl@0	2247	* None.
sl@0	2248	*
sl@0	2249	*----------------------------------------------------------------------
sl@0	2250	*/
sl@0	2251
sl@0	2252	static int
sl@0	2253	SkipToChar(stringPtr, match)
sl@0	2254	char *stringPtr; / Pointer string to check. */
sl@0	2255	char match; / Pointer to character to find. */
sl@0	2256	{
sl@0	2257	int quoted, level;
sl@0	2258	register char *p;
sl@0	2259
sl@0	2260	quoted = 0;
sl@0	2261	level = 0;
sl@0	2262
sl@0	2263	for (p = stringPtr; p != '\0'; p++) {
sl@0	2264	if (quoted) {
sl@0	2265	quoted = 0;
sl@0	2266	continue;
sl@0	2267	}
sl@0	2268	if ((level == 0) && (p == match)) {
sl@0	2269	*stringPtr = p;
sl@0	2270	return 1;
sl@0	2271	}
sl@0	2272	if (*p == '{') {
sl@0	2273	level++;
sl@0	2274	} else if (*p == '}') {
sl@0	2275	level--;
sl@0	2276	} else if (*p == '\\') {
sl@0	2277	quoted = 1;
sl@0	2278	}
sl@0	2279	}
sl@0	2280	*stringPtr = p;
sl@0	2281	return 0;
sl@0	2282	}
sl@0	2283
sl@0	2284	/*
sl@0	2285	*----------------------------------------------------------------------
sl@0	2286	*
sl@0	2287	* TclDoGlob --
sl@0	2288	*
sl@0	2289	* This recursive procedure forms the heart of the globbing
sl@0	2290	* code. It performs a depth-first traversal of the tree
sl@0	2291	* given by the path name to be globbed. The directory and
sl@0	2292	* remainder are assumed to be native format paths. The prefix
sl@0	2293	* contained in 'headPtr' is not used as a glob pattern, simply
sl@0	2294	* as a path specifier, so it can contain unquoted glob-sensitive
sl@0	2295	* characters (if the directories to which it points contain
sl@0	2296	* such strange characters).
sl@0	2297	*
sl@0	2298	* Results:
sl@0	2299	* The return value is a standard Tcl result indicating whether
sl@0	2300	* an error occurred in globbing. After a normal return the
sl@0	2301	* result in interp will be set to hold all of the file names
sl@0	2302	* given by the dir and rem arguments. After an error the
sl@0	2303	* result in interp will hold an error message.
sl@0	2304	*
sl@0	2305	* Side effects:
sl@0	2306	* None.
sl@0	2307	*
sl@0	2308	*----------------------------------------------------------------------
sl@0	2309	*/
sl@0	2310
sl@0	2311	int
sl@0	2312	TclDoGlob(interp, separators, headPtr, tail, types)
sl@0	2313	Tcl_Interp interp; / Interpreter to use for error reporting
sl@0	2314	* (e.g. unmatched brace). */
sl@0	2315	char separators; / String containing separator characters
sl@0	2316	* that should be used to identify globbing
sl@0	2317	* boundaries. */
sl@0	2318	Tcl_DString headPtr; / Completely expanded prefix. */
sl@0	2319	char tail; / The unexpanded remainder of the path.
sl@0	2320	* Must not be a pointer to a static string. */
sl@0	2321	Tcl_GlobTypeData types; / List object containing list of acceptable
sl@0	2322	* types. May be NULL. */
sl@0	2323	{
sl@0	2324	int baseLength, quoted, count;
sl@0	2325	int result = TCL_OK;
sl@0	2326	char name, p, openBrace, closeBrace, *firstSpecialChar, savedChar;
sl@0	2327	char lastChar = 0;
sl@0	2328
sl@0	2329	int length = Tcl_DStringLength(headPtr);
sl@0	2330
sl@0	2331	if (length > 0) {
sl@0	2332	lastChar = Tcl_DStringValue(headPtr)[length-1];
sl@0	2333	}
sl@0	2334
sl@0	2335	/*
sl@0	2336	* Consume any leading directory separators, leaving tail pointing
sl@0	2337	* just past the last initial separator.
sl@0	2338	*/
sl@0	2339
sl@0	2340	count = 0;
sl@0	2341	name = tail;
sl@0	2342	for (; *tail != '\0'; tail++) {
sl@0	2343	if (*tail == '\\') {
sl@0	2344	/*
sl@0	2345	* If the first character is escaped, either we have a directory
sl@0	2346	* separator, or we have any other character. In the latter case
sl@0	2347	* the rest of tail is a pattern, and we must break from the loop.
sl@0	2348	* This is particularly important on Windows where '\' is both
sl@0	2349	* the escaping character and a directory separator.
sl@0	2350	*/
sl@0	2351	if (strchr(separators, tail[1]) != NULL) {
sl@0	2352	tail++;
sl@0	2353	} else {
sl@0	2354	break;
sl@0	2355	}
sl@0	2356	} else if (strchr(separators, *tail) == NULL) {
sl@0	2357	break;
sl@0	2358	}
sl@0	2359	if (tclPlatform != TCL_PLATFORM_MAC) {
sl@0	2360	if (*tail == '\\') {
sl@0	2361	Tcl_DStringAppend(headPtr, separators, 1);
sl@0	2362	} else {
sl@0	2363	Tcl_DStringAppend(headPtr, tail, 1);
sl@0	2364	}
sl@0	2365	}
sl@0	2366	count++;
sl@0	2367	}
sl@0	2368
sl@0	2369	/*
sl@0	2370	* Deal with path separators. On the Mac, we have to watch out
sl@0	2371	* for multiple separators, since they are special in Mac-style
sl@0	2372	* paths.
sl@0	2373	*/
sl@0	2374
sl@0	2375	switch (tclPlatform) {
sl@0	2376	case TCL_PLATFORM_MAC:
sl@0	2377	#ifdef MAC_UNDERSTANDS_UNIX_PATHS
sl@0	2378	if (*separators == '/') {
sl@0	2379	if (((length == 0) && (count == 0))
sl@0	2380	\|\| ((length > 0) && (lastChar != ':'))) {
sl@0	2381	Tcl_DStringAppend(headPtr, ":", 1);
sl@0	2382	}
sl@0	2383	} else {
sl@0	2384	#endif
sl@0	2385	if (count == 0) {
sl@0	2386	if ((length > 0) && (lastChar != ':')) {
sl@0	2387	Tcl_DStringAppend(headPtr, ":", 1);
sl@0	2388	}
sl@0	2389	} else {
sl@0	2390	if (lastChar == ':') {
sl@0	2391	count--;
sl@0	2392	}
sl@0	2393	while (count-- > 0) {
sl@0	2394	Tcl_DStringAppend(headPtr, ":", 1);
sl@0	2395	}
sl@0	2396	}
sl@0	2397	#ifdef MAC_UNDERSTANDS_UNIX_PATHS
sl@0	2398	}
sl@0	2399	#endif
sl@0	2400	break;
sl@0	2401	case TCL_PLATFORM_WINDOWS:
sl@0	2402	/*
sl@0	2403	* If this is a drive relative path, add the colon and the
sl@0	2404	* trailing slash if needed. Otherwise add the slash if
sl@0	2405	* this is the first absolute element, or a later relative
sl@0	2406	* element. Add an extra slash if this is a UNC path.
sl@0	2407
sl@0	2408	if (*name == ':') {
sl@0	2409	Tcl_DStringAppend(headPtr, ":", 1);
sl@0	2410	if (count > 1) {
sl@0	2411	Tcl_DStringAppend(headPtr, "/", 1);
sl@0	2412	}
sl@0	2413	} else if ((*tail != '\0')
sl@0	2414	&& (((length > 0)
sl@0	2415	&& (strchr(separators, lastChar) == NULL))
sl@0	2416	\|\| ((length == 0) && (count > 0)))) {
sl@0	2417	Tcl_DStringAppend(headPtr, "/", 1);
sl@0	2418	if ((length == 0) && (count > 1)) {
sl@0	2419	Tcl_DStringAppend(headPtr, "/", 1);
sl@0	2420	}
sl@0	2421	}
sl@0	2422	*/
sl@0	2423
sl@0	2424	break;
sl@0	2425	case TCL_PLATFORM_UNIX: {
sl@0	2426	/*
sl@0	2427	* Add a separator if this is the first absolute element, or
sl@0	2428	* a later relative element.
sl@0	2429
sl@0	2430	if ((*tail != '\0')
sl@0	2431	&& (((length > 0)
sl@0	2432	&& (strchr(separators, lastChar) == NULL))
sl@0	2433	\|\| ((length == 0) && (count > 0)))) {
sl@0	2434	Tcl_DStringAppend(headPtr, "/", 1);
sl@0	2435	}
sl@0	2436	*/
sl@0	2437	break;
sl@0	2438	}
sl@0	2439	}
sl@0	2440
sl@0	2441	/*
sl@0	2442	* Look for the first matching pair of braces or the first
sl@0	2443	* directory separator that is not inside a pair of braces.
sl@0	2444	*/
sl@0	2445
sl@0	2446	openBrace = closeBrace = NULL;
sl@0	2447	quoted = 0;
sl@0	2448	for (p = tail; *p != '\0'; p++) {
sl@0	2449	if (quoted) {
sl@0	2450	quoted = 0;
sl@0	2451	} else if (*p == '\\') {
sl@0	2452	quoted = 1;
sl@0	2453	if (strchr(separators, p[1]) != NULL) {
sl@0	2454	break; /* Quoted directory separator. */
sl@0	2455	}
sl@0	2456	} else if (strchr(separators, *p) != NULL) {
sl@0	2457	break; /* Unquoted directory separator. */
sl@0	2458	} else if (*p == '{') {
sl@0	2459	openBrace = p;
sl@0	2460	p++;
sl@0	2461	if (SkipToChar(&p, "}")) {
sl@0	2462	closeBrace = p; /* Balanced braces. */
sl@0	2463	break;
sl@0	2464	}
sl@0	2465	Tcl_SetResult(interp, "unmatched open-brace in file name",
sl@0	2466	TCL_STATIC);
sl@0	2467	return TCL_ERROR;
sl@0	2468	} else if (*p == '}') {
sl@0	2469	Tcl_SetResult(interp, "unmatched close-brace in file name",
sl@0	2470	TCL_STATIC);
sl@0	2471	return TCL_ERROR;
sl@0	2472	}
sl@0	2473	}
sl@0	2474
sl@0	2475	/*
sl@0	2476	* Substitute the alternate patterns from the braces and recurse.
sl@0	2477	*/
sl@0	2478
sl@0	2479	if (openBrace != NULL) {
sl@0	2480	char *element;
sl@0	2481	Tcl_DString newName;
sl@0	2482	Tcl_DStringInit(&newName);
sl@0	2483
sl@0	2484	/*
sl@0	2485	* For each element within in the outermost pair of braces,
sl@0	2486	* append the element and the remainder to the fixed portion
sl@0	2487	* before the first brace and recursively call TclDoGlob.
sl@0	2488	*/
sl@0	2489
sl@0	2490	Tcl_DStringAppend(&newName, tail, openBrace-tail);
sl@0	2491	baseLength = Tcl_DStringLength(&newName);
sl@0	2492	length = Tcl_DStringLength(headPtr);
sl@0	2493	*closeBrace = '\0';
sl@0	2494	for (p = openBrace; p != closeBrace; ) {
sl@0	2495	p++;
sl@0	2496	element = p;
sl@0	2497	SkipToChar(&p, ",");
sl@0	2498	Tcl_DStringSetLength(headPtr, length);
sl@0	2499	Tcl_DStringSetLength(&newName, baseLength);
sl@0	2500	Tcl_DStringAppend(&newName, element, p-element);
sl@0	2501	Tcl_DStringAppend(&newName, closeBrace+1, -1);
sl@0	2502	result = TclDoGlob(interp, separators, headPtr,
sl@0	2503	Tcl_DStringValue(&newName), types);
sl@0	2504	if (result != TCL_OK) {
sl@0	2505	break;
sl@0	2506	}
sl@0	2507	}
sl@0	2508	*closeBrace = '}';
sl@0	2509	Tcl_DStringFree(&newName);
sl@0	2510	return result;
sl@0	2511	}
sl@0	2512
sl@0	2513	/*
sl@0	2514	* At this point, there are no more brace substitutions to perform on
sl@0	2515	* this path component. The variable p is pointing at a quoted or
sl@0	2516	* unquoted directory separator or the end of the string. So we need
sl@0	2517	* to check for special globbing characters in the current pattern.
sl@0	2518	* We avoid modifying tail if p is pointing at the end of the string.
sl@0	2519	*/
sl@0	2520
sl@0	2521	if (*p != '\0') {
sl@0	2522
sl@0	2523	/*
sl@0	2524	* Note that we are modifying the string in place. This won't work
sl@0	2525	* if the string is a static.
sl@0	2526	*/
sl@0	2527
sl@0	2528	savedChar = *p;
sl@0	2529	*p = '\0';
sl@0	2530	firstSpecialChar = strpbrk(tail, "*[]?\\");
sl@0	2531	*p = savedChar;
sl@0	2532	} else {
sl@0	2533	firstSpecialChar = strpbrk(tail, "*[]?\\");
sl@0	2534	}
sl@0	2535
sl@0	2536	if (firstSpecialChar != NULL) {
sl@0	2537	int ret;
sl@0	2538	Tcl_Obj *head = Tcl_NewStringObj(Tcl_DStringValue(headPtr),-1);
sl@0	2539	Tcl_IncrRefCount(head);
sl@0	2540	/*
sl@0	2541	* Look for matching files in the given directory. The
sl@0	2542	* implementation of this function is platform specific. For
sl@0	2543	* each file that matches, it will add the match onto the
sl@0	2544	* resultPtr given.
sl@0	2545	*/
sl@0	2546	if (*p == '\0') {
sl@0	2547	ret = Tcl_FSMatchInDirectory(interp, Tcl_GetObjResult(interp),
sl@0	2548	head, tail, types);
sl@0	2549	} else {
sl@0	2550	/*
sl@0	2551	* We do the recursion ourselves. This makes implementing
sl@0	2552	* Tcl_FSMatchInDirectory for each filesystem much easier.
sl@0	2553	*/
sl@0	2554	Tcl_GlobTypeData dirOnly = { TCL_GLOB_TYPE_DIR, 0, NULL, NULL };
sl@0	2555	char save = *p;
sl@0	2556	Tcl_Obj *resultPtr;
sl@0	2557
sl@0	2558	resultPtr = Tcl_NewListObj(0, NULL);
sl@0	2559	Tcl_IncrRefCount(resultPtr);
sl@0	2560	*p = '\0';
sl@0	2561	ret = Tcl_FSMatchInDirectory(interp, resultPtr,
sl@0	2562	head, tail, &dirOnly);
sl@0	2563	*p = save;
sl@0	2564	if (ret == TCL_OK) {
sl@0	2565	int resLength;
sl@0	2566	ret = Tcl_ListObjLength(interp, resultPtr, &resLength);
sl@0	2567	if (ret == TCL_OK) {
sl@0	2568	int i;
sl@0	2569	for (i =0; i< resLength; i++) {
sl@0	2570	Tcl_Obj *elt;
sl@0	2571	Tcl_DString ds;
sl@0	2572	Tcl_ListObjIndex(interp, resultPtr, i, &elt);
sl@0	2573	Tcl_DStringInit(&ds);
sl@0	2574	Tcl_DStringAppend(&ds, Tcl_GetString(elt), -1);
sl@0	2575	if(tclPlatform == TCL_PLATFORM_MAC) {
sl@0	2576	Tcl_DStringAppend(&ds, ":",1);
sl@0	2577	} else {
sl@0	2578	Tcl_DStringAppend(&ds, "/",1);
sl@0	2579	}
sl@0	2580	ret = TclDoGlob(interp, separators, &ds, p+1, types);
sl@0	2581	Tcl_DStringFree(&ds);
sl@0	2582	if (ret != TCL_OK) {
sl@0	2583	break;
sl@0	2584	}
sl@0	2585	}
sl@0	2586	}
sl@0	2587	}
sl@0	2588	Tcl_DecrRefCount(resultPtr);
sl@0	2589	}
sl@0	2590	Tcl_DecrRefCount(head);
sl@0	2591	return ret;
sl@0	2592	}
sl@0	2593	Tcl_DStringAppend(headPtr, tail, p-tail);
sl@0	2594	if (*p != '\0') {
sl@0	2595	return TclDoGlob(interp, separators, headPtr, p, types);
sl@0	2596	} else {
sl@0	2597	/*
sl@0	2598	* This is the code path reached by a command like 'glob foo'.
sl@0	2599	*
sl@0	2600	* There are no more wildcards in the pattern and no more
sl@0	2601	* unprocessed characters in the tail, so now we can construct
sl@0	2602	* the path, and pass it to Tcl_FSMatchInDirectory with an
sl@0	2603	* empty pattern to verify the existence of the file and check
sl@0	2604	* it is of the correct type (if a 'types' flag it given -- if
sl@0	2605	* no such flag was given, we could just use 'Tcl_FSLStat', but
sl@0	2606	* for simplicity we keep to a common approach).
sl@0	2607	*/
sl@0	2608
sl@0	2609	Tcl_Obj *nameObj;
sl@0	2610
sl@0	2611	switch (tclPlatform) {
sl@0	2612	case TCL_PLATFORM_MAC: {
sl@0	2613	if (strchr(Tcl_DStringValue(headPtr), ':') == NULL) {
sl@0	2614	Tcl_DStringAppend(headPtr, ":", 1);
sl@0	2615	}
sl@0	2616	break;
sl@0	2617	}
sl@0	2618	case TCL_PLATFORM_WINDOWS: {
sl@0	2619	if (Tcl_DStringLength(headPtr) == 0) {
sl@0	2620	if (((*name == '\\') && (name[1] == '/' \|\| name[1] == '\\'))
sl@0	2621	\|\| (*name == '/')) {
sl@0	2622	Tcl_DStringAppend(headPtr, "/", 1);
sl@0	2623	} else {
sl@0	2624	Tcl_DStringAppend(headPtr, ".", 1);
sl@0	2625	}
sl@0	2626	}
sl@0	2627	#if defined(__CYGWIN__) && defined(__WIN32__)
sl@0	2628	{
sl@0	2629	extern int cygwin_conv_to_win32_path
sl@0	2630	_ANSI_ARGS_((CONST char , char ));
sl@0	2631	char winbuf[MAX_PATH+1];
sl@0	2632
sl@0	2633	cygwin_conv_to_win32_path(Tcl_DStringValue(headPtr), winbuf);
sl@0	2634	Tcl_DStringFree(headPtr);
sl@0	2635	Tcl_DStringAppend(headPtr, winbuf, -1);
sl@0	2636	}
sl@0	2637	#endif /* __CYGWIN__ && __WIN32__ */
sl@0	2638	/*
sl@0	2639	* Convert to forward slashes. This is required to pass
sl@0	2640	* some Tcl tests. We should probably remove the conversions
sl@0	2641	* here and in tclWinFile.c, since they aren't needed since
sl@0	2642	* the dropping of support for Win32s.
sl@0	2643	*/
sl@0	2644	for (p = Tcl_DStringValue(headPtr); *p != '\0'; p++) {
sl@0	2645	if (*p == '\\') {
sl@0	2646	*p = '/';
sl@0	2647	}
sl@0	2648	}
sl@0	2649	break;
sl@0	2650	}
sl@0	2651	case TCL_PLATFORM_UNIX: {
sl@0	2652	if (Tcl_DStringLength(headPtr) == 0) {
sl@0	2653	if ((name == '\\' && name[1] == '/') \|\| (name == '/')) {
sl@0	2654	Tcl_DStringAppend(headPtr, "/", 1);
sl@0	2655	} else {
sl@0	2656	Tcl_DStringAppend(headPtr, ".", 1);
sl@0	2657	}
sl@0	2658	}
sl@0	2659	break;
sl@0	2660	}
sl@0	2661	}
sl@0	2662	/* Common for all platforms */
sl@0	2663	name = Tcl_DStringValue(headPtr);
sl@0	2664	nameObj = Tcl_NewStringObj(name, Tcl_DStringLength(headPtr));
sl@0	2665
sl@0	2666	Tcl_IncrRefCount(nameObj);
sl@0	2667	Tcl_FSMatchInDirectory(interp, Tcl_GetObjResult(interp), nameObj,
sl@0	2668	NULL, types);
sl@0	2669	Tcl_DecrRefCount(nameObj);
sl@0	2670	return TCL_OK;
sl@0	2671	}
sl@0	2672	}
sl@0	2673
sl@0	2674
sl@0	2675	/*
sl@0	2676	*---------------------------------------------------------------------------
sl@0	2677	*
sl@0	2678	* TclFileDirname
sl@0	2679	*
sl@0	2680	* This procedure calculates the directory above a given
sl@0	2681	* path: basically 'file dirname'. It is used both by
sl@0	2682	* the 'dirname' subcommand of file and by code in tclIOUtil.c.
sl@0	2683	*
sl@0	2684	* Results:
sl@0	2685	* NULL if an error occurred, otherwise a Tcl_Obj owned by
sl@0	2686	* the caller (i.e. most likely with refCount 1).
sl@0	2687	*
sl@0	2688	* Side effects:
sl@0	2689	* None.
sl@0	2690	*
sl@0	2691	*---------------------------------------------------------------------------
sl@0	2692	*/
sl@0	2693
sl@0	2694	Tcl_Obj*
sl@0	2695	TclFileDirname(interp, pathPtr)
sl@0	2696	Tcl_Interp interp; / Used for error reporting */
sl@0	2697	Tcl_Obj pathPtr; / Path to take dirname of */
sl@0	2698	{
sl@0	2699	int splitElements;
sl@0	2700	Tcl_Obj *splitPtr;
sl@0	2701	Tcl_Obj *splitResultPtr = NULL;
sl@0	2702
sl@0	2703	/*
sl@0	2704	* The behaviour we want here is slightly different to
sl@0	2705	* the standard Tcl_FSSplitPath in the handling of home
sl@0	2706	* directories; Tcl_FSSplitPath preserves the "~" while
sl@0	2707	* this code computes the actual full path name, if we
sl@0	2708	* had just a single component.
sl@0	2709	*/
sl@0	2710	splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements);
sl@0	2711	if ((splitElements == 1) && (Tcl_GetString(pathPtr)[0] == '~')) {
sl@0	2712	Tcl_DecrRefCount(splitPtr);
sl@0	2713	splitPtr = Tcl_FSGetNormalizedPath(interp, pathPtr);
sl@0	2714	if (splitPtr == NULL) {
sl@0	2715	return NULL;
sl@0	2716	}
sl@0	2717	splitPtr = Tcl_FSSplitPath(splitPtr, &splitElements);
sl@0	2718	}
sl@0	2719
sl@0	2720	/*
sl@0	2721	* Return all but the last component. If there is only one
sl@0	2722	* component, return it if the path was non-relative, otherwise
sl@0	2723	* return the current directory.
sl@0	2724	*/
sl@0	2725
sl@0	2726	if (splitElements > 1) {
sl@0	2727	splitResultPtr = Tcl_FSJoinPath(splitPtr, splitElements - 1);
sl@0	2728	} else if (splitElements == 0 \|\|
sl@0	2729	(Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE)) {
sl@0	2730	splitResultPtr = Tcl_NewStringObj(
sl@0	2731	((tclPlatform == TCL_PLATFORM_MAC) ? ":" : "."), 1);
sl@0	2732	} else {
sl@0	2733	Tcl_ListObjIndex(NULL, splitPtr, 0, &splitResultPtr);
sl@0	2734	}
sl@0	2735	Tcl_IncrRefCount(splitResultPtr);
sl@0	2736	Tcl_DecrRefCount(splitPtr);
sl@0	2737	return splitResultPtr;
sl@0	2738	}
sl@0	2739
sl@0	2740	/*
sl@0	2741	*---------------------------------------------------------------------------
sl@0	2742	*
sl@0	2743	* Tcl_AllocStatBuf
sl@0	2744	*
sl@0	2745	* This procedure allocates a Tcl_StatBuf on the heap. It exists
sl@0	2746	* so that extensions may be used unchanged on systems where
sl@0	2747	* largefile support is optional.
sl@0	2748	*
sl@0	2749	* Results:
sl@0	2750	* A pointer to a Tcl_StatBuf which may be deallocated by being
sl@0	2751	* passed to ckfree().
sl@0	2752	*
sl@0	2753	* Side effects:
sl@0	2754	* None.
sl@0	2755	*
sl@0	2756	*---------------------------------------------------------------------------
sl@0	2757	*/
sl@0	2758
sl@0	2759	EXPORT_C Tcl_StatBuf *
sl@0	2760	Tcl_AllocStatBuf() {
sl@0	2761	return (Tcl_StatBuf *) ckalloc(sizeof(Tcl_StatBuf));
sl@0	2762	}

author	sl@SLION-WIN7.fritz.box
	Fri, 15 Jun 2012 03:10:57 +0200
changeset 0	bde4ae8d615e
permissions	-rw-r--r--