1/*
2 * tclUnixFile.c --
3 *
4 *	This file contains wrappers around UNIX file handling functions.
5 *	These wrappers mask differences between Windows and UNIX.
6 *
7 * Copyright (c) 1995-1998 Sun Microsystems, Inc.
8 *
9 * See the file "license.terms" for information on usage and redistribution of
10 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
11 *
12 * RCS: @(#) $Id: tclUnixFile.c,v 1.52.2.1 2009/08/02 12:15:04 dkf Exp $
13 */
14
15#include "tclInt.h"
16#include "tclFileSystem.h"
17
18static int NativeMatchType(Tcl_Interp *interp, CONST char* nativeEntry,
19	CONST char* nativeName, Tcl_GlobTypeData *types);
20
21/*
22 *---------------------------------------------------------------------------
23 *
24 * TclpFindExecutable --
25 *
26 *	This function computes the absolute path name of the current
27 *	application, given its argv[0] value.
28 *
29 * Results:
30 *	None.
31 *
32 * Side effects:
33 *	The computed path name is stored as a ProcessGlobalValue.
34 *
35 *---------------------------------------------------------------------------
36 */
37
38void
39TclpFindExecutable(
40    CONST char *argv0)		/* The value of the application's argv[0]
41				 * (native). */
42{
43    CONST char *name, *p;
44    Tcl_StatBuf statBuf;
45    Tcl_DString buffer, nameString, cwd, utfName;
46    Tcl_Encoding encoding;
47
48    if (argv0 == NULL) {
49	return;
50    }
51    Tcl_DStringInit(&buffer);
52
53    name = argv0;
54    for (p = name; *p != '\0'; p++) {
55	if (*p == '/') {
56	    /*
57	     * The name contains a slash, so use the name directly without
58	     * doing a path search.
59	     */
60
61	    goto gotName;
62	}
63    }
64
65    p = getenv("PATH");					/* INTL: Native. */
66    if (p == NULL) {
67	/*
68	 * There's no PATH environment variable; use the default that is used
69	 * by sh.
70	 */
71
72	p = ":/bin:/usr/bin";
73    } else if (*p == '\0') {
74	/*
75	 * An empty path is equivalent to ".".
76	 */
77
78	p = "./";
79    }
80
81    /*
82     * Search through all the directories named in the PATH variable to see if
83     * argv[0] is in one of them. If so, use that file name.
84     */
85
86    while (1) {
87	while (isspace(UCHAR(*p))) {			/* INTL: BUG */
88	    p++;
89	}
90	name = p;
91	while ((*p != ':') && (*p != 0)) {
92	    p++;
93	}
94	Tcl_DStringSetLength(&buffer, 0);
95	if (p != name) {
96	    Tcl_DStringAppend(&buffer, name, p - name);
97	    if (p[-1] != '/') {
98		Tcl_DStringAppend(&buffer, "/", 1);
99	    }
100	}
101	name = Tcl_DStringAppend(&buffer, argv0, -1);
102
103	/*
104	 * INTL: The following calls to access() and stat() should not be
105	 * converted to Tclp routines because they need to operate on native
106	 * strings directly.
107	 */
108
109	if ((access(name, X_OK) == 0)			/* INTL: Native. */
110		&& (TclOSstat(name, &statBuf) == 0)	/* INTL: Native. */
111		&& S_ISREG(statBuf.st_mode)) {
112	    goto gotName;
113	}
114	if (*p == '\0') {
115	    break;
116	} else if (*(p+1) == 0) {
117	    p = "./";
118	} else {
119	    p++;
120	}
121    }
122    TclSetObjNameOfExecutable(Tcl_NewObj(), NULL);
123    goto done;
124
125    /*
126     * If the name starts with "/" then just store it
127     */
128
129  gotName:
130#ifdef DJGPP
131    if (name[1] == ':')
132#else
133    if (name[0] == '/')
134#endif
135    {
136	encoding = Tcl_GetEncoding(NULL, NULL);
137	Tcl_ExternalToUtfDString(encoding, name, -1, &utfName);
138	TclSetObjNameOfExecutable(
139		Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding);
140	Tcl_DStringFree(&utfName);
141	goto done;
142    }
143
144    /*
145     * The name is relative to the current working directory. First strip off
146     * a leading "./", if any, then add the full path name of the current
147     * working directory.
148     */
149
150    if ((name[0] == '.') && (name[1] == '/')) {
151	name += 2;
152    }
153
154    Tcl_DStringInit(&nameString);
155    Tcl_DStringAppend(&nameString, name, -1);
156
157    TclpGetCwd(NULL, &cwd);
158
159    Tcl_DStringFree(&buffer);
160    Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&cwd),
161	    Tcl_DStringLength(&cwd), &buffer);
162    if (Tcl_DStringValue(&cwd)[Tcl_DStringLength(&cwd) -1] != '/') {
163	Tcl_DStringAppend(&buffer, "/", 1);
164    }
165    Tcl_DStringFree(&cwd);
166    Tcl_DStringAppend(&buffer, Tcl_DStringValue(&nameString),
167	    Tcl_DStringLength(&nameString));
168    Tcl_DStringFree(&nameString);
169
170    encoding = Tcl_GetEncoding(NULL, NULL);
171    Tcl_ExternalToUtfDString(encoding, Tcl_DStringValue(&buffer), -1,
172	    &utfName);
173    TclSetObjNameOfExecutable(
174	    Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding);
175    Tcl_DStringFree(&utfName);
176
177  done:
178    Tcl_DStringFree(&buffer);
179}
180
181/*
182 *----------------------------------------------------------------------
183 *
184 * TclpMatchInDirectory --
185 *
186 *	This routine is used by the globbing code to search a directory for
187 *	all files which match a given pattern.
188 *
189 * Results:
190 *	The return value is a standard Tcl result indicating whether an error
191 *	occurred in globbing. Errors are left in interp, good results are
192 *	[lappend]ed to resultPtr (which must be a valid object).
193 *
194 * Side effects:
195 *	None.
196 *
197 *----------------------------------------------------------------------
198 */
199
200int
201TclpMatchInDirectory(
202    Tcl_Interp *interp,		/* Interpreter to receive errors. */
203    Tcl_Obj *resultPtr,		/* List object to lappend results. */
204    Tcl_Obj *pathPtr,		/* Contains path to directory to search. */
205    CONST char *pattern,	/* Pattern to match against. */
206    Tcl_GlobTypeData *types)	/* Object containing list of acceptable types.
207				 * May be NULL. In particular the directory
208				 * flag is very important. */
209{
210    CONST char *native;
211    Tcl_Obj *fileNamePtr;
212    int matchResult = 0;
213
214    if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) {
215	/*
216	 * The native filesystem never adds mounts.
217	 */
218
219	return TCL_OK;
220    }
221
222    fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
223    if (fileNamePtr == NULL) {
224	return TCL_ERROR;
225    }
226
227    if (pattern == NULL || (*pattern == '\0')) {
228	/*
229	 * Match a file directly.
230	 */
231	Tcl_Obj *tailPtr;
232	CONST char *nativeTail;
233
234	native = (CONST char*) Tcl_FSGetNativePath(pathPtr);
235	tailPtr = TclPathPart(interp, pathPtr, TCL_PATH_TAIL);
236	nativeTail = (CONST char*) Tcl_FSGetNativePath(tailPtr);
237	matchResult = NativeMatchType(interp, native, nativeTail, types);
238	if (matchResult == 1) {
239	    Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
240	}
241	Tcl_DecrRefCount(tailPtr);
242	Tcl_DecrRefCount(fileNamePtr);
243    } else {
244	DIR *d;
245	Tcl_DirEntry *entryPtr;
246	CONST char *dirName;
247	int dirLength;
248	int matchHidden, matchHiddenPat;
249	int nativeDirLen;
250	Tcl_StatBuf statBuf;
251	Tcl_DString ds;		/* native encoding of dir */
252	Tcl_DString dsOrig;	/* utf-8 encoding of dir */
253
254	Tcl_DStringInit(&dsOrig);
255	dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength);
256	Tcl_DStringAppend(&dsOrig, dirName, dirLength);
257
258	/*
259	 * Make sure that the directory part of the name really is a
260	 * directory.  If the directory name is "", use the name "." instead,
261	 * because some UNIX systems don't treat "" like "." automatically.
262	 * Keep the "" for use in generating file names, otherwise "glob
263	 * foo.c" would return "./foo.c".
264	 */
265
266	if (dirLength == 0) {
267	    dirName = ".";
268	} else {
269	    dirName = Tcl_DStringValue(&dsOrig);
270
271	    /*
272	     * Make sure we have a trailing directory delimiter.
273	     */
274
275	    if (dirName[dirLength-1] != '/') {
276		dirName = Tcl_DStringAppend(&dsOrig, "/", 1);
277		dirLength++;
278	    }
279	}
280
281	/*
282	 * Now open the directory for reading and iterate over the contents.
283	 */
284
285	native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds);
286
287	if ((TclOSstat(native, &statBuf) != 0)		/* INTL: Native. */
288		|| !S_ISDIR(statBuf.st_mode)) {
289	    Tcl_DStringFree(&dsOrig);
290	    Tcl_DStringFree(&ds);
291	    Tcl_DecrRefCount(fileNamePtr);
292	    return TCL_OK;
293	}
294
295	d = opendir(native);				/* INTL: Native. */
296	if (d == NULL) {
297	    Tcl_DStringFree(&ds);
298	    if (interp != NULL) {
299		Tcl_ResetResult(interp);
300		Tcl_AppendResult(interp, "couldn't read directory \"",
301			Tcl_DStringValue(&dsOrig), "\": ",
302			Tcl_PosixError(interp), (char *) NULL);
303	    }
304	    Tcl_DStringFree(&dsOrig);
305	    Tcl_DecrRefCount(fileNamePtr);
306	    return TCL_ERROR;
307	}
308
309	nativeDirLen = Tcl_DStringLength(&ds);
310
311	/*
312	 * Check to see if -type or the pattern requests hidden files.
313	 */
314
315	matchHiddenPat = (pattern[0] == '.')
316		|| ((pattern[0] == '\\') && (pattern[1] == '.'));
317	matchHidden = matchHiddenPat
318		|| (types && (types->perm & TCL_GLOB_PERM_HIDDEN));
319	while ((entryPtr = TclOSreaddir(d)) != NULL) {	/* INTL: Native. */
320	    Tcl_DString utfDs;
321	    CONST char *utfname;
322
323	    /*
324	     * Skip this file if it doesn't agree with the hidden parameters
325	     * requested by the user (via -type or pattern).
326	     */
327
328	    if (*entryPtr->d_name == '.') {
329		if (!matchHidden) continue;
330	    } else {
331#ifdef MAC_OSX_TCL
332		if (matchHiddenPat) continue;
333		/* Also need to check HFS hidden flag in TclMacOSXMatchType. */
334#else
335		if (matchHidden) continue;
336#endif
337	    }
338
339	    /*
340	     * Now check to see if the file matches, according to both type
341	     * and pattern. If so, add the file to the result.
342	     */
343
344	    utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1,
345		    &utfDs);
346	    if (Tcl_StringCaseMatch(utfname, pattern, 0)) {
347		int typeOk = 1;
348
349		if (types != NULL) {
350		    Tcl_DStringSetLength(&ds, nativeDirLen);
351		    native = Tcl_DStringAppend(&ds, entryPtr->d_name, -1);
352		    matchResult = NativeMatchType(interp, native,
353			    entryPtr->d_name, types);
354		    typeOk = (matchResult == 1);
355		}
356		if (typeOk) {
357		    Tcl_ListObjAppendElement(interp, resultPtr,
358			    TclNewFSPathObj(pathPtr, utfname,
359			    Tcl_DStringLength(&utfDs)));
360		}
361	    }
362	    Tcl_DStringFree(&utfDs);
363	    if (matchResult < 0) {
364		break;
365	    }
366	}
367
368	closedir(d);
369	Tcl_DStringFree(&ds);
370	Tcl_DStringFree(&dsOrig);
371	Tcl_DecrRefCount(fileNamePtr);
372    }
373    if (matchResult < 0) {
374	return TCL_ERROR;
375    } else {
376	return TCL_OK;
377    }
378}
379
380/*
381 *----------------------------------------------------------------------
382 *
383 * NativeMatchType --
384 *
385 *	This routine is used by the globbing code to check if a file
386 *	matches a given type description.
387 *
388 * Results:
389 *	The return value is 1, 0 or -1 indicating whether the file
390 *	matches the given criteria, does not match them, or an error
391 *	occurred (in wich case an error is left in interp).
392 *
393 * Side effects:
394 *	None.
395 *
396 *----------------------------------------------------------------------
397 */
398
399static int
400NativeMatchType(
401    Tcl_Interp *interp,       /* Interpreter to receive errors. */
402    CONST char *nativeEntry,  /* Native path to check. */
403    CONST char *nativeName,   /* Native filename to check. */
404    Tcl_GlobTypeData *types)  /* Type description to match against. */
405{
406    Tcl_StatBuf buf;
407    if (types == NULL) {
408	/*
409	 * Simply check for the file's existence, but do it with lstat, in
410	 * case it is a link to a file which doesn't exist (since that case
411	 * would not show up if we used 'access' or 'stat')
412	 */
413
414	if (TclOSlstat(nativeEntry, &buf) != 0) {
415	    return 0;
416	}
417    } else {
418	if (types->perm != 0) {
419	    if (TclOSstat(nativeEntry, &buf) != 0) {
420		/*
421		 * Either the file has disappeared between the 'readdir' call
422		 * and the 'stat' call, or the file is a link to a file which
423		 * doesn't exist (which we could ascertain with lstat), or
424		 * there is some other strange problem. In all these cases, we
425		 * define this to mean the file does not match any defined
426		 * permission, and therefore it is not added to the list of
427		 * files to return.
428		 */
429
430		return 0;
431	    }
432
433	    /*
434	     * readonly means that there are NO write permissions (even for
435	     * user), but execute is OK for anybody OR that the user immutable
436	     * flag is set (where supported).
437	     */
438
439	    if (((types->perm & TCL_GLOB_PERM_RONLY) &&
440#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE)
441			!(buf.st_flags & UF_IMMUTABLE) &&
442#endif
443			(buf.st_mode & (S_IWOTH|S_IWGRP|S_IWUSR))) ||
444		((types->perm & TCL_GLOB_PERM_R) &&
445			(access(nativeEntry, R_OK) != 0)) ||
446		((types->perm & TCL_GLOB_PERM_W) &&
447			(access(nativeEntry, W_OK) != 0)) ||
448		((types->perm & TCL_GLOB_PERM_X) &&
449			(access(nativeEntry, X_OK) != 0))
450#ifndef MAC_OSX_TCL
451		|| ((types->perm & TCL_GLOB_PERM_HIDDEN) &&
452			(*nativeName != '.'))
453#endif
454		) {
455		return 0;
456	    }
457	}
458	if (types->type != 0) {
459	    if (types->perm == 0) {
460		/*
461		 * We haven't yet done a stat on the file.
462		 */
463
464		if (TclOSstat(nativeEntry, &buf) != 0) {
465		    /*
466		     * Posix error occurred. The only ok case is if this is a
467		     * link to a nonexistent file, and the user did 'glob -l'.
468		     * So we check that here:
469		     */
470
471		    if (types->type & TCL_GLOB_TYPE_LINK) {
472			if (TclOSlstat(nativeEntry, &buf) == 0) {
473			    if (S_ISLNK(buf.st_mode)) {
474				return 1;
475			    }
476			}
477		    }
478		    return 0;
479		}
480	    }
481
482	    /*
483	     * In order bcdpfls as in 'find -t'
484	     */
485
486	    if (((types->type & TCL_GLOB_TYPE_BLOCK)&& S_ISBLK(buf.st_mode)) ||
487		((types->type & TCL_GLOB_TYPE_CHAR) && S_ISCHR(buf.st_mode)) ||
488		((types->type & TCL_GLOB_TYPE_DIR)  && S_ISDIR(buf.st_mode)) ||
489		((types->type & TCL_GLOB_TYPE_PIPE) && S_ISFIFO(buf.st_mode))||
490		((types->type & TCL_GLOB_TYPE_FILE) && S_ISREG(buf.st_mode))
491#ifdef S_ISSOCK
492		||((types->type & TCL_GLOB_TYPE_SOCK) && S_ISSOCK(buf.st_mode))
493#endif /* S_ISSOCK */
494		) {
495		/*
496		 * Do nothing - this file is ok.
497		 */
498	    } else {
499#ifdef S_ISLNK
500		if (types->type & TCL_GLOB_TYPE_LINK) {
501		    if (TclOSlstat(nativeEntry, &buf) == 0) {
502			if (S_ISLNK(buf.st_mode)) {
503			    goto filetypeOK;
504			}
505		    }
506		}
507#endif /* S_ISLNK */
508		return 0;
509	    }
510	}
511    filetypeOK: ;
512#ifdef MAC_OSX_TCL
513	if (types->macType != NULL || types->macCreator != NULL ||
514		(types->perm & TCL_GLOB_PERM_HIDDEN)) {
515	    int matchResult;
516
517	    if (types->perm == 0 && types->type == 0) {
518		/*
519		 * We haven't yet done a stat on the file.
520		 */
521
522		if (TclOSstat(nativeEntry, &buf) != 0) {
523		    return 0;
524		}
525	    }
526
527	    matchResult = TclMacOSXMatchType(interp, nativeEntry, nativeName,
528		    &buf, types);
529	    if (matchResult != 1) {
530		return matchResult;
531	    }
532	}
533#endif
534    }
535    return 1;
536}
537
538/*
539 *---------------------------------------------------------------------------
540 *
541 * TclpGetUserHome --
542 *
543 *	This function takes the specified user name and finds their home
544 *	directory.
545 *
546 * Results:
547 *	The result is a pointer to a string specifying the user's home
548 *	directory, or NULL if the user's home directory could not be
549 *	determined. Storage for the result string is allocated in bufferPtr;
550 *	the caller must call Tcl_DStringFree() when the result is no longer
551 *	needed.
552 *
553 * Side effects:
554 *	None.
555 *
556 *----------------------------------------------------------------------
557 */
558
559char *
560TclpGetUserHome(
561    CONST char *name,		/* User name for desired home directory. */
562    Tcl_DString *bufferPtr)	/* Uninitialized or free DString filled with
563				 * name of user's home directory. */
564{
565    struct passwd *pwPtr;
566    Tcl_DString ds;
567    CONST char *native;
568
569    native = Tcl_UtfToExternalDString(NULL, name, -1, &ds);
570    pwPtr = TclpGetPwNam(native);			/* INTL: Native. */
571    Tcl_DStringFree(&ds);
572
573    if (pwPtr == NULL) {
574	return NULL;
575    }
576    Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, -1, bufferPtr);
577    return Tcl_DStringValue(bufferPtr);
578}
579
580/*
581 *---------------------------------------------------------------------------
582 *
583 * TclpObjAccess --
584 *
585 *	This function replaces the library version of access().
586 *
587 * Results:
588 *	See access() documentation.
589 *
590 * Side effects:
591 *	See access() documentation.
592 *
593 *---------------------------------------------------------------------------
594 */
595
596int
597TclpObjAccess(
598    Tcl_Obj *pathPtr,		/* Path of file to access */
599    int mode)			/* Permission setting. */
600{
601    CONST char *path = Tcl_FSGetNativePath(pathPtr);
602    if (path == NULL) {
603	return -1;
604    } else {
605	return access(path, mode);
606    }
607}
608
609/*
610 *---------------------------------------------------------------------------
611 *
612 * TclpObjChdir --
613 *
614 *	This function replaces the library version of chdir().
615 *
616 * Results:
617 *	See chdir() documentation.
618 *
619 * Side effects:
620 *	See chdir() documentation.
621 *
622 *---------------------------------------------------------------------------
623 */
624
625int
626TclpObjChdir(
627    Tcl_Obj *pathPtr)		/* Path to new working directory */
628{
629    CONST char *path = Tcl_FSGetNativePath(pathPtr);
630    if (path == NULL) {
631	return -1;
632    } else {
633	return chdir(path);
634    }
635}
636
637/*
638 *----------------------------------------------------------------------
639 *
640 * TclpObjLstat --
641 *
642 *	This function replaces the library version of lstat().
643 *
644 * Results:
645 *	See lstat() documentation.
646 *
647 * Side effects:
648 *	See lstat() documentation.
649 *
650 *----------------------------------------------------------------------
651 */
652
653int
654TclpObjLstat(
655    Tcl_Obj *pathPtr,		/* Path of file to stat */
656    Tcl_StatBuf *bufPtr)	/* Filled with results of stat call. */
657{
658    return TclOSlstat(Tcl_FSGetNativePath(pathPtr), bufPtr);
659}
660
661/*
662 *---------------------------------------------------------------------------
663 *
664 * TclpGetNativeCwd --
665 *
666 *	This function replaces the library version of getcwd().
667 *
668 * Results:
669 *	The input and output are filesystem paths in native form. The result
670 *	is either the given clientData, if the working directory hasn't
671 *	changed, or a new clientData (owned by our caller), giving the new
672 *	native path, or NULL if the current directory could not be determined.
673 *	If NULL is returned, the caller can examine the standard posix error
674 *	codes to determine the cause of the problem.
675 *
676 * Side effects:
677 *	None.
678 *
679 *----------------------------------------------------------------------
680 */
681
682ClientData
683TclpGetNativeCwd(
684    ClientData clientData)
685{
686    char buffer[MAXPATHLEN+1];
687
688#ifdef USEGETWD
689    if (getwd(buffer) == NULL)				/* INTL: Native. */
690#else
691    if (getcwd(buffer, MAXPATHLEN+1) == NULL)		/* INTL: Native. */
692#endif
693    {
694	return NULL;
695    }
696    if ((clientData != NULL) && strcmp(buffer, (CONST char*)clientData) == 0) {
697	/*
698	 * No change to pwd.
699	 */
700
701	return clientData;
702    } else {
703	char *newCd = (char *) ckalloc((unsigned) (strlen(buffer) + 1));
704	strcpy(newCd, buffer);
705	return (ClientData) newCd;
706    }
707}
708
709/*
710 *---------------------------------------------------------------------------
711 *
712 * TclpGetCwd --
713 *
714 *	This function replaces the library version of getcwd(). (Obsolete
715 *	function, only retained for old extensions which may call it
716 *	directly).
717 *
718 * Results:
719 *	The result is a pointer to a string specifying the current directory,
720 *	or NULL if the current directory could not be determined. If NULL is
721 *	returned, an error message is left in the interp's result. Storage for
722 *	the result string is allocated in bufferPtr; the caller must call
723 *	Tcl_DStringFree() when the result is no longer needed.
724 *
725 * Side effects:
726 *	None.
727 *
728 *----------------------------------------------------------------------
729 */
730
731CONST char *
732TclpGetCwd(
733    Tcl_Interp *interp,		/* If non-NULL, used for error reporting. */
734    Tcl_DString *bufferPtr)	/* Uninitialized or free DString filled with
735				 * name of current directory. */
736{
737    char buffer[MAXPATHLEN+1];
738
739#ifdef USEGETWD
740    if (getwd(buffer) == NULL)				/* INTL: Native. */
741#else
742    if (getcwd(buffer, MAXPATHLEN+1) == NULL)		/* INTL: Native. */
743#endif
744    {
745	if (interp != NULL) {
746	    Tcl_AppendResult(interp,
747		    "error getting working directory name: ",
748		    Tcl_PosixError(interp), NULL);
749	}
750	return NULL;
751    }
752    return Tcl_ExternalToUtfDString(NULL, buffer, -1, bufferPtr);
753}
754
755/*
756 *---------------------------------------------------------------------------
757 *
758 * TclpReadlink --
759 *
760 *	This function replaces the library version of readlink().
761 *
762 * Results:
763 *	The result is a pointer to a string specifying the contents of the
764 *	symbolic link given by 'path', or NULL if the symbolic link could not
765 *	be read. Storage for the result string is allocated in bufferPtr; the
766 *	caller must call Tcl_DStringFree() when the result is no longer
767 *	needed.
768 *
769 * Side effects:
770 *	See readlink() documentation.
771 *
772 *---------------------------------------------------------------------------
773 */
774
775char *
776TclpReadlink(
777    CONST char *path,		/* Path of file to readlink (UTF-8). */
778    Tcl_DString *linkPtr)	/* Uninitialized or free DString filled with
779				 * contents of link (UTF-8). */
780{
781#ifndef DJGPP
782    char link[MAXPATHLEN];
783    int length;
784    CONST char *native;
785    Tcl_DString ds;
786
787    native = Tcl_UtfToExternalDString(NULL, path, -1, &ds);
788    length = readlink(native, link, sizeof(link));	/* INTL: Native. */
789    Tcl_DStringFree(&ds);
790
791    if (length < 0) {
792	return NULL;
793    }
794
795    Tcl_ExternalToUtfDString(NULL, link, length, linkPtr);
796    return Tcl_DStringValue(linkPtr);
797#else
798    return NULL;
799#endif
800}
801
802/*
803 *----------------------------------------------------------------------
804 *
805 * TclpObjStat --
806 *
807 *	This function replaces the library version of stat().
808 *
809 * Results:
810 *	See stat() documentation.
811 *
812 * Side effects:
813 *	See stat() documentation.
814 *
815 *----------------------------------------------------------------------
816 */
817
818int
819TclpObjStat(
820    Tcl_Obj *pathPtr,		/* Path of file to stat */
821    Tcl_StatBuf *bufPtr)	/* Filled with results of stat call. */
822{
823    CONST char *path = Tcl_FSGetNativePath(pathPtr);
824    if (path == NULL) {
825	return -1;
826    } else {
827	return TclOSstat(path, bufPtr);
828    }
829}
830
831#ifdef S_IFLNK
832
833Tcl_Obj*
834TclpObjLink(
835    Tcl_Obj *pathPtr,
836    Tcl_Obj *toPtr,
837    int linkAction)
838{
839    if (toPtr != NULL) {
840	CONST char *src = Tcl_FSGetNativePath(pathPtr);
841	CONST char *target = NULL;
842
843	if (src == NULL) {
844	    return NULL;
845	}
846
847	/*
848	 * If we're making a symbolic link and the path is relative, then we
849	 * must check whether it exists _relative_ to the directory in which
850	 * the src is found (not relative to the current cwd which is just not
851	 * relevant in this case).
852	 *
853	 * If we're making a hard link, then a relative path is just converted
854	 * to absolute relative to the cwd.
855	 */
856
857	if ((linkAction & TCL_CREATE_SYMBOLIC_LINK)
858		&& (Tcl_FSGetPathType(toPtr) == TCL_PATH_RELATIVE)) {
859	    Tcl_Obj *dirPtr, *absPtr;
860
861	    dirPtr = TclPathPart(NULL, pathPtr, TCL_PATH_DIRNAME);
862	    if (dirPtr == NULL) {
863		return NULL;
864	    }
865	    absPtr = Tcl_FSJoinToPath(dirPtr, 1, &toPtr);
866	    Tcl_IncrRefCount(absPtr);
867	    if (Tcl_FSAccess(absPtr, F_OK) == -1) {
868		Tcl_DecrRefCount(absPtr);
869		Tcl_DecrRefCount(dirPtr);
870
871		/*
872		 * Target doesn't exist.
873		 */
874
875		errno = ENOENT;
876		return NULL;
877	    }
878
879	    /*
880	     * Target exists; we'll construct the relative path we want below.
881	     */
882
883	    Tcl_DecrRefCount(absPtr);
884	    Tcl_DecrRefCount(dirPtr);
885	} else {
886	    target = Tcl_FSGetNativePath(toPtr);
887	    if (target == NULL) {
888		return NULL;
889	    }
890	    if (access(target, F_OK) == -1) {
891		/*
892		 * Target doesn't exist.
893		 */
894
895		errno = ENOENT;
896		return NULL;
897	    }
898	}
899
900	if (access(src, F_OK) != -1) {
901	    /*
902	     * Src exists.
903	     */
904
905	    errno = EEXIST;
906	    return NULL;
907	}
908
909	/*
910	 * Check symbolic link flag first, since we prefer to create these.
911	 */
912
913	if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
914	    int targetLen;
915	    Tcl_DString ds;
916	    Tcl_Obj *transPtr;
917
918	    /*
919	     * Now we don't want to link to the absolute, normalized path.
920	     * Relative links are quite acceptable (but links to ~user are not
921	     * -- these must be expanded first).
922	     */
923
924	    transPtr = Tcl_FSGetTranslatedPath(NULL, toPtr);
925	    if (transPtr == NULL) {
926		return NULL;
927	    }
928	    target = Tcl_GetStringFromObj(transPtr, &targetLen);
929	    target = Tcl_UtfToExternalDString(NULL, target, targetLen, &ds);
930	    Tcl_DecrRefCount(transPtr);
931
932	    if (symlink(target, src) != 0) {
933		toPtr = NULL;
934	    }
935	    Tcl_DStringFree(&ds);
936	} else if (linkAction & TCL_CREATE_HARD_LINK) {
937	    if (link(target, src) != 0) {
938		return NULL;
939	    }
940	} else {
941	    errno = ENODEV;
942	    return NULL;
943	}
944	return toPtr;
945    } else {
946	Tcl_Obj *linkPtr = NULL;
947
948	char link[MAXPATHLEN];
949	int length;
950	Tcl_DString ds;
951	Tcl_Obj *transPtr;
952
953	transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
954	if (transPtr == NULL) {
955	    return NULL;
956	}
957	Tcl_DecrRefCount(transPtr);
958
959	length = readlink(Tcl_FSGetNativePath(pathPtr), link, sizeof(link));
960	if (length < 0) {
961	    return NULL;
962	}
963
964	Tcl_ExternalToUtfDString(NULL, link, length, &ds);
965	linkPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),
966		Tcl_DStringLength(&ds));
967	Tcl_DStringFree(&ds);
968	if (linkPtr != NULL) {
969	    Tcl_IncrRefCount(linkPtr);
970	}
971	return linkPtr;
972    }
973}
974#endif /* S_IFLNK */
975
976/*
977 *---------------------------------------------------------------------------
978 *
979 * TclpFilesystemPathType --
980 *
981 *	This function is part of the native filesystem support, and returns
982 *	the path type of the given path. Right now it simply returns NULL. In
983 *	the future it could return specific path types, like 'nfs', 'samba',
984 *	'FAT32', etc.
985 *
986 * Results:
987 *	NULL at present.
988 *
989 * Side effects:
990 *	None.
991 *
992 *---------------------------------------------------------------------------
993 */
994
995Tcl_Obj *
996TclpFilesystemPathType(
997    Tcl_Obj *pathPtr)
998{
999    /*
1000     * All native paths are of the same type.
1001     */
1002
1003    return NULL;
1004}
1005
1006/*
1007 *---------------------------------------------------------------------------
1008 *
1009 * TclpNativeToNormalized --
1010 *
1011 *	Convert native format to a normalized path object, with refCount of
1012 *	zero.
1013 *
1014 *	Currently assumes all native paths are actually normalized already, so
1015 *	if the path given is not normalized this will actually just convert to
1016 *	a valid string path, but not necessarily a normalized one.
1017 *
1018 * Results:
1019 *	A valid normalized path.
1020 *
1021 * Side effects:
1022 *	None.
1023 *
1024 *---------------------------------------------------------------------------
1025 */
1026
1027Tcl_Obj *
1028TclpNativeToNormalized(
1029    ClientData clientData)
1030{
1031    Tcl_DString ds;
1032    Tcl_Obj *objPtr;
1033    int len;
1034
1035    CONST char *copy;
1036    Tcl_ExternalToUtfDString(NULL, (CONST char*)clientData, -1, &ds);
1037
1038    copy = Tcl_DStringValue(&ds);
1039    len = Tcl_DStringLength(&ds);
1040
1041    objPtr = Tcl_NewStringObj(copy,len);
1042    Tcl_DStringFree(&ds);
1043
1044    return objPtr;
1045}
1046
1047/*
1048 *---------------------------------------------------------------------------
1049 *
1050 * TclNativeCreateNativeRep --
1051 *
1052 *	Create a native representation for the given path.
1053 *
1054 * Results:
1055 *	The nativePath representation.
1056 *
1057 * Side effects:
1058 *	Memory will be allocated. The path may need to be normalized.
1059 *
1060 *---------------------------------------------------------------------------
1061 */
1062
1063ClientData
1064TclNativeCreateNativeRep(
1065    Tcl_Obj *pathPtr)
1066{
1067    char *nativePathPtr;
1068    Tcl_DString ds;
1069    Tcl_Obj *validPathPtr;
1070    int len;
1071    char *str;
1072
1073    if (TclFSCwdIsNative()) {
1074	/*
1075	 * The cwd is native, which means we can use the translated path
1076	 * without worrying about normalization (this will also usually be
1077	 * shorter so the utf-to-external conversion will be somewhat faster).
1078	 */
1079
1080	validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
1081	if (validPathPtr == NULL) {
1082	    return NULL;
1083	}
1084    } else {
1085	/*
1086	 * Make sure the normalized path is set.
1087	 */
1088
1089	validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
1090	if (validPathPtr == NULL) {
1091	    return NULL;
1092	}
1093	Tcl_IncrRefCount(validPathPtr);
1094    }
1095
1096    str = Tcl_GetStringFromObj(validPathPtr, &len);
1097    Tcl_UtfToExternalDString(NULL, str, len, &ds);
1098    len = Tcl_DStringLength(&ds) + sizeof(char);
1099    Tcl_DecrRefCount(validPathPtr);
1100    nativePathPtr = ckalloc((unsigned) len);
1101    memcpy((void*)nativePathPtr, (void*)Tcl_DStringValue(&ds), (size_t) len);
1102
1103    Tcl_DStringFree(&ds);
1104    return (ClientData)nativePathPtr;
1105}
1106
1107/*
1108 *---------------------------------------------------------------------------
1109 *
1110 * TclNativeDupInternalRep --
1111 *
1112 *	Duplicate the native representation.
1113 *
1114 * Results:
1115 *	The copied native representation, or NULL if it is not possible to
1116 *	copy the representation.
1117 *
1118 * Side effects:
1119 *	Memory will be allocated for the copy.
1120 *
1121 *---------------------------------------------------------------------------
1122 */
1123
1124ClientData
1125TclNativeDupInternalRep(
1126    ClientData clientData)
1127{
1128    char *copy;
1129    size_t len;
1130
1131    if (clientData == NULL) {
1132	return NULL;
1133    }
1134
1135    /*
1136     * ASCII representation when running on Unix.
1137     */
1138
1139    len = sizeof(char) + (strlen((CONST char*) clientData) * sizeof(char));
1140
1141    copy = (char *) ckalloc(len);
1142    memcpy((void *) copy, (void *) clientData, len);
1143    return (ClientData)copy;
1144}
1145
1146/*
1147 *---------------------------------------------------------------------------
1148 *
1149 * TclpUtime --
1150 *
1151 *	Set the modification date for a file.
1152 *
1153 * Results:
1154 *	0 on success, -1 on error.
1155 *
1156 * Side effects:
1157 *	None.
1158 *
1159 *---------------------------------------------------------------------------
1160 */
1161
1162int
1163TclpUtime(
1164    Tcl_Obj *pathPtr,		/* File to modify */
1165    struct utimbuf *tval)	/* New modification date structure */
1166{
1167    return utime(Tcl_FSGetNativePath(pathPtr), tval);
1168}
1169
1170/*
1171 * Local Variables:
1172 * mode: c
1173 * c-basic-offset: 4
1174 * fill-column: 78
1175 * End:
1176 */
1177