archie/tcl7.6/win/tclWinFile.c

/* 
 * tclWinFile.c --
 *
 *      This file contains temporary wrappers around UNIX file handling
 *      functions. These wrappers map the UNIX functions to Win32 HANDLE-style
 *      files, which can be manipulated through the Win32 console redirection
 *      interfaces.
 *
 * Copyright (c) 1995-1996 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * SCCS: @(#) tclWinFile.c 1.37 96/09/18 15:10:45
 */

#include <sys/stat.h>
#include "tclWinInt.h"

/*
 * The variable below caches the name of the current working directory
 * in order to avoid repeated calls to getcwd.  The string is malloc-ed.
 * NULL means the cache needs to be refreshed.
 */

static char *currentDir =  NULL;


/*
 *----------------------------------------------------------------------
 *
 * TclCreateTempFile --
 *
 *	This function opens a unique file with the property that it
 *	will be deleted when its file handle is closed.  The temporary
 *	file is created in the system temporary directory.
 *
 * Results:
 *	Returns a valid C file descriptor, or -1 on failure.
 *
 * Side effects:
 *	Creates a new temporary file.
 *
 *----------------------------------------------------------------------
 */

Tcl_File
TclCreateTempFile(contents, namePtr)
    char *contents;		/* String to write into temp file, or NULL. */
    Tcl_DString *namePtr;	/* If non-NULL, pointer to initialized 
				 * DString that is filled with the name of 
				 * the temp file that was created. */
{
    char name[MAX_PATH];
    HANDLE handle;

    if (!GetTempPath(MAX_PATH, name)
	    || !GetTempFileName(name, "TCL", 0, name)) {
	return NULL;
    }

    handle = CreateFile(name, GENERIC_READ | GENERIC_WRITE, 0, NULL,
	    CREATE_ALWAYS, FILE_ATTRIBUTE_TEMPORARY | FILE_FLAG_DELETE_ON_CLOSE,
	    NULL);

    /* 
     * Under Win32s a file created with FILE_FLAG_DELETE_ON_CLOSE won't
     * actually be deleted when it is closed.  This was causing tcl to leak
     * temp files.  The DeleteFile() call will delete the file now under
     * Win32s.  Under 95 and NT, the call will fail because the file is 
     * locked (because it was just opened), but it will get deleted when
     * it is closed, due to the FILE_FLAG_DELETE_ON_CLOSE.
     */

    DeleteFile(name);

    if (handle == INVALID_HANDLE_VALUE) {
	goto error;
    }

    /*
     * Write the file out, doing line translations on the way.
     */

    if (contents != NULL) {
	DWORD result, length;
	char *p;
	
	for (p = contents; *p != '\0'; p++) {
	    if (*p == '\n') {
		length = p - contents;
		if (length > 0) {
		    if (!WriteFile(handle, contents, length, &result, NULL)) {
			goto error;
		    }
		}
		if (!WriteFile(handle, "\r\n", 2, &result, NULL)) {
		    goto error;
		}
		contents = p+1;
	    }
	}
	length = p - contents;
	if (length > 0) {
	    if (!WriteFile(handle, contents, length, &result, NULL)) {
		goto error;
	    }
	}
    }
    if (SetFilePointer(handle, 0, NULL, FILE_BEGIN) == 0xFFFFFFFF) {
	goto error;
    }
    
    Tcl_DStringAppend(namePtr, name, -1);
    return Tcl_GetFile((ClientData) handle, TCL_WIN_FILE);

  error:
    TclWinConvertError(GetLastError());
    CloseHandle(handle);
    DeleteFile(name);
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * TclOpenFile --
 *
 *	This function wraps the normal system open() to ensure that
 *	files are opened with the _O_NOINHERIT flag set.
 *
 * Results:
 *	Same as open().
 *
 * Side effects:
 *	Same as open().
 *
 *----------------------------------------------------------------------
 */

Tcl_File
TclOpenFile(path, mode)
    char *path;
    int mode;
{
    HANDLE handle;
    DWORD accessMode;
    DWORD createMode;
    DWORD shareMode;
    DWORD flags;
    SECURITY_ATTRIBUTES sec;

    /*
     * Map the access bits to the NT access mode.
     */

    switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
	case O_RDONLY:
	    accessMode = GENERIC_READ;
	    break;
	case O_WRONLY:
	    accessMode = GENERIC_WRITE;
	    break;
	case O_RDWR:
	    accessMode = (GENERIC_READ | GENERIC_WRITE);
	    break;
	default:
	    TclWinConvertError(ERROR_INVALID_FUNCTION);
	    return NULL;
    }

    /*
     * Map the creation flags to the NT create mode.
     */

    switch (mode & (O_CREAT | O_EXCL | O_TRUNC)) {
	case (O_CREAT | O_EXCL):
	case (O_CREAT | O_EXCL | O_TRUNC):
	    createMode = CREATE_NEW;
	    break;
	case (O_CREAT | O_TRUNC):
	    createMode = CREATE_ALWAYS;
	    break;
	case O_CREAT:
	    createMode = OPEN_ALWAYS;
	    break;
	case O_TRUNC:
	case (O_TRUNC | O_EXCL):
	    createMode = TRUNCATE_EXISTING;
	    break;
	default:
	    createMode = OPEN_EXISTING;
	    break;
    }

    /*
     * If the file is not being created, use the existing file attributes.
     */

    flags = 0;
    if (!(mode & O_CREAT)) {
	flags = GetFileAttributes(path);
	if (flags == 0xFFFFFFFF) {
	    flags = 0;
	}
    }

    /*
     * Set up the security attributes so this file is not inherited by
     * child processes.
     */

    sec.nLength = sizeof(sec);
    sec.lpSecurityDescriptor = NULL;
    sec.bInheritHandle = 0;

    /*
     * Set up the file sharing mode.  We want to allow simultaneous access.
     */

    shareMode = FILE_SHARE_READ | FILE_SHARE_WRITE;

    /*
     * Now we get to create the file.
     */

    handle = CreateFile(path, accessMode, shareMode, &sec, createMode, flags,
            (HANDLE) NULL);
    if (handle == INVALID_HANDLE_VALUE) {
	DWORD err = GetLastError();
	if ((err & 0xffffL) == ERROR_OPEN_FAILED) {
	    err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND;
	}
        TclWinConvertError(err);
        return NULL;
    }

    return Tcl_GetFile((ClientData) handle, TCL_WIN_FILE);
}

/*
 *----------------------------------------------------------------------
 *
 * TclCloseFile --
 *
 *	Closes a file on Windows.
 *
 * Results:
 *	0 on success, -1 on failure.
 *
 * Side effects:
 *	The file is closed.
 *
 *----------------------------------------------------------------------
 */

int
TclCloseFile(file)
    Tcl_File file;	/* The file to close. */
{
    HANDLE handle;
    int type;
    ClientData clientData;
    TclWinPipe *pipePtr;

    clientData = Tcl_GetFileInfo(file, &type);

    if (type == TCL_WIN_FILE) {
        handle = (HANDLE) clientData;
	if (CloseHandle(handle) == FALSE) {
	    TclWinConvertError(GetLastError());
	    return -1;
	}
    } else if (type == TCL_WIN32S_PIPE) {
	pipePtr = (TclWinPipe *) clientData;

	if (pipePtr->otherPtr != NULL) {
	    pipePtr->otherPtr->otherPtr = NULL;
	} else {
	    if (pipePtr->fileHandle != INVALID_HANDLE_VALUE) {
		CloseHandle(pipePtr->fileHandle);
	    }
	    DeleteFile(pipePtr->fileName);
	    ckfree((char *) pipePtr->fileName);
	}
	ckfree((char *) pipePtr);
    } else {
	panic("Tcl_CloseFile: unexpected file type");
    }

    Tcl_FreeFile(file);
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclSeekFile --
 *
 *	Sets the file pointer on a file indicated by the file.
 *
 * Results:
 *	The new position at which the file pointer is after it was
 *	moved, or -1 on failure.
 *
 * Side effects:
 *	May move the position at which subsequent operations on the
 *	file access it.
 *
 *----------------------------------------------------------------------
 */

int
TclSeekFile(file, offset, whence)
    Tcl_File file;	/* File to seek on. */
    int offset;			/* How much to move. */
    int whence;			/* Relative to where? */
{
    DWORD moveMethod;
    DWORD newPos;
    HANDLE handle;
    int type;

    handle = (HANDLE) Tcl_GetFileInfo(file, &type);
    if (type != TCL_WIN_FILE) {
	panic("Tcl_SeekFile: unexpected file type");
    }
    
    if (whence == SEEK_SET) {
        moveMethod = FILE_BEGIN;
    } else if (whence == SEEK_CUR) {
        moveMethod = FILE_CURRENT;
    } else {
        moveMethod = FILE_END;
    }

    newPos = SetFilePointer(handle, offset, NULL, moveMethod);
    if (newPos == 0xFFFFFFFF) {
        TclWinConvertError(GetLastError());
        return -1;
    }
    return newPos;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FindExecutable --
 *
 *	This procedure computes the absolute path name of the current
 *	application, given its argv[0] value.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The variable tclExecutableName gets filled in with the file
 *	name for the application, if we figured it out.  If we couldn't
 *	figure it out, Tcl_FindExecutable is set to NULL.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_FindExecutable(argv0)
    char *argv0;		/* The value of the application's argv[0]. */
{
    Tcl_DString buffer;
    int length;

    Tcl_DStringInit(&buffer);

    if (tclExecutableName != NULL) {
	ckfree(tclExecutableName);
	tclExecutableName = NULL;
    }

    /*
     * Under Windows we ignore argv0, and return the path for the file used to
     * create this process.
     */

    Tcl_DStringSetLength(&buffer, MAX_PATH+1);
    length = GetModuleFileName(NULL, Tcl_DStringValue(&buffer), MAX_PATH+1);
    if (length > 0) {
	tclExecutableName = (char *) ckalloc((unsigned) (length + 1));
	strcpy(tclExecutableName, Tcl_DStringValue(&buffer));
    }
    Tcl_DStringFree(&buffer);
}

/*
 *----------------------------------------------------------------------
 *
 * TclMatchFiles --
 *
 *	This routine is used by the globbing code to search a
 *	directory for all files which match a given pattern.
 *
 * Results: 
 *	If the tail argument is NULL, then the matching files are
 *	added to the interp->result.  Otherwise, TclDoGlob is called
 *	recursively for each matching subdirectory.  The return value
 *	is a standard Tcl result indicating whether an error occurred
 *	in globbing.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------- */

int
TclMatchFiles(interp, separators, dirPtr, pattern, tail)
    Tcl_Interp *interp;		/* Interpreter to receive results. */
    char *separators;		/* Directory separators to pass to TclDoGlob. */
    Tcl_DString *dirPtr;	/* Contains path to directory to search. */
    char *pattern;		/* Pattern to match against. */
    char *tail;			/* Pointer to end of pattern.  Tail must
				 * point to a location in pattern. */
{
    char drivePattern[4] = "?:\\";
    char *newPattern, *p, *dir, *root, c;
    int length, matchDotFiles;
    int result = TCL_OK;
    int baseLength = Tcl_DStringLength(dirPtr);
    Tcl_DString buffer;
    DWORD atts, volFlags;
    HANDLE handle;
    WIN32_FIND_DATA data;
    BOOL found;

    /*
     * Convert the path to normalized form since some interfaces only
     * accept backslashes.  Also, ensure that the directory ends with a
     * separator character.
     */

    Tcl_DStringInit(&buffer);
    if (baseLength == 0) {
	Tcl_DStringAppend(&buffer, ".", 1);
    } else {
	Tcl_DStringAppend(&buffer, Tcl_DStringValue(dirPtr),
		Tcl_DStringLength(dirPtr));
    }
    for (p = Tcl_DStringValue(&buffer); *p != '\0'; p++) {
	if (*p == '/') {
	    *p = '\\';
	}
    }
    p--;
    if (*p != '\\' && *p != ':') {
	Tcl_DStringAppend(&buffer, "\\", 1);
    }
    dir = Tcl_DStringValue(&buffer);
    
    /*
     * First verify that the specified path is actually a directory.
     */

    atts = GetFileAttributes(dir);
    if ((atts == 0xFFFFFFFF) || ((atts & FILE_ATTRIBUTE_DIRECTORY) == 0)) {
	Tcl_DStringFree(&buffer);
	return TCL_OK;
    }

    /*
     * Next check the volume information for the directory to see whether
     * comparisons should be case sensitive or not.  If the root is null, then
     * we use the root of the current directory.  If the root is just a drive
     * specifier, we use the root directory of the given drive.
     */

    switch (Tcl_GetPathType(dir)) {
	case TCL_PATH_RELATIVE:
	    found = GetVolumeInformation(NULL, NULL, 0, NULL,
		    NULL, &volFlags, NULL, 0);
	    break;
	case TCL_PATH_VOLUME_RELATIVE:
	    if (*dir == '\\') {
		root = NULL;
	    } else {
		root = drivePattern;
		*root = *dir;
	    }
	    found = GetVolumeInformation(root, NULL, 0, NULL,
		    NULL, &volFlags, NULL, 0);
	    break;
	case TCL_PATH_ABSOLUTE:
	    if (dir[1] == ':') {
		root = drivePattern;
		*root = *dir;
		found = GetVolumeInformation(root, NULL, 0, NULL,
			NULL, &volFlags, NULL, 0);
	    } else if (dir[1] == '\\') {
		p = strchr(dir+2, '\\');
		p = strchr(p+1, '\\');
		p++;
		c = *p;
		*p = 0;
		found = GetVolumeInformation(dir, NULL, 0, NULL,
			NULL, &volFlags, NULL, 0);
		*p = c;
	    }
	    break;
    }

    if (!found) {
	Tcl_DStringFree(&buffer);
	TclWinConvertError(GetLastError());
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "couldn't read volume information for \"",
		dirPtr->string, "\": ", Tcl_PosixError(interp), (char *) NULL);
	return TCL_ERROR;
    }
    
    /*
     * If the volume is not case sensitive, then we need to convert the pattern
     * to lower case.
     */

    length = tail - pattern;
    newPattern = ckalloc(length+1);
    if (volFlags & FS_CASE_SENSITIVE) {
	strncpy(newPattern, pattern, length);
	newPattern[length] = '\0';
    } else {
	char *src, *dest;
	for (src = pattern, dest = newPattern; src < tail; src++, dest++) {
	    *dest = (char) tolower(*src);
	}
	*dest = '\0';
    }
    
    /*
     * We need to check all files in the directory, so append a *.*
     * to the path. 
     */


    dir = Tcl_DStringAppend(&buffer, "*.*", 3);

    /*
     * Now open the directory for reading and iterate over the contents.
     */

    handle = FindFirstFile(dir, &data);
    Tcl_DStringFree(&buffer);

    if (handle == INVALID_HANDLE_VALUE) {
	TclWinConvertError(GetLastError());
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "couldn't read directory \"",
		dirPtr->string, "\": ", Tcl_PosixError(interp), (char *) NULL);
	ckfree(newPattern);
	return TCL_ERROR;
    }

    /*
     * Clean up the tail pointer.  Leave the tail pointing to the 
     * first character after the path separator or NULL. 
     */

    if (*tail == '\\') {
	tail++;
    }
    if (*tail == '\0') {
	tail = NULL;
    } else {
	tail++;
    }

    /*
     * Check to see if the pattern needs to compare with dot files.
     */

    if ((newPattern[0] == '.')
	    || ((pattern[0] == '\\') && (pattern[1] == '.'))) {
        matchDotFiles = 1;
    } else {
        matchDotFiles = 0;
    }

    /*
     * Now iterate over all of the files in the directory.
     */

    Tcl_DStringInit(&buffer);
    for (found = 1; found; found = FindNextFile(handle, &data)) {
	char *matchResult;

	/*
	 * Ignore hidden files.
	 */

	if ((data.dwFileAttributes & FILE_ATTRIBUTE_HIDDEN) 
		|| (!matchDotFiles && (data.cFileName[0] == '.'))) {
	    continue;
	}

	/*
	 * Check to see if the file matches the pattern.  If the volume is not
	 * case sensitive, we need to convert the file name to lower case.  If
	 * the volume also doesn't preserve case, then we return the lower case
	 * form of the name, otherwise we return the system form.
 	 */

	matchResult = NULL;
	if (!(volFlags & FS_CASE_SENSITIVE)) {
	    Tcl_DStringSetLength(&buffer, 0);
	    Tcl_DStringAppend(&buffer, data.cFileName, -1);
	    for (p = buffer.string; *p != '\0'; p++) {
		*p = (char) tolower(*p);
	    }
	    if (Tcl_StringMatch(buffer.string, newPattern)) {
		if (volFlags & FS_CASE_IS_PRESERVED) {
		    matchResult = data.cFileName;
		} else {
		    matchResult = buffer.string;
		}	
	    }
	} else {
	    if (Tcl_StringMatch(data.cFileName, newPattern)) {
		matchResult = data.cFileName;
	    }
	}

	if (matchResult == NULL) {
	    continue;
	}

	/*
	 * If the file matches, then we need to process the remainder of the
	 * path.  If there are more characters to process, then ensure matching
	 * files are directories and call TclDoGlob. Otherwise, just add the
	 * file to the result.
	 */

	Tcl_DStringSetLength(dirPtr, baseLength);
	Tcl_DStringAppend(dirPtr, matchResult, -1);
	if (tail == NULL) {
	    Tcl_AppendElement(interp, dirPtr->string);
	} else {
	    atts = GetFileAttributes(dirPtr->string);
	    if (atts & FILE_ATTRIBUTE_DIRECTORY) {
		Tcl_DStringAppend(dirPtr, "/", 1);
		result = TclDoGlob(interp, separators, dirPtr, tail);
		if (result != TCL_OK) {
		    break;
		}
	    }
	}
    }

    Tcl_DStringFree(&buffer);
    FindClose(handle);
    ckfree(newPattern);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclChdir --
 *
 *	Change the current working directory.
 *
 * Results:
 *	The result is a standard Tcl result.  If an error occurs and 
 *	interp isn't NULL, an error message is left in interp->result.
 *
 * Side effects:
 *	The working directory for this application is changed.  Also
 *	the cache maintained used by TclGetCwd is deallocated and
 *	set to NULL.
 *
 *----------------------------------------------------------------------
 */

int
TclChdir(interp, dirName)
    Tcl_Interp *interp;		/* If non NULL, used for error reporting. */
    char *dirName;     		/* Path to new working directory. */
{
    if (currentDir != NULL) {
	ckfree(currentDir);
	currentDir = NULL;
    }
    if (!SetCurrentDirectory(dirName)) {
	TclWinConvertError(GetLastError());
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "couldn't change working directory to \"",
		    dirName, "\": ", Tcl_PosixError(interp), (char *) NULL);
	}
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetCwd --
 *
 *	Return the path name of the current working directory.
 *
 * Results:
 *	The result is the full path name of the current working
 *	directory, or NULL if an error occurred while figuring it
 *	out.  If an error occurs and interp isn't NULL, an error
 *	message is left in interp->result.
 *
 * Side effects:
 *	The path name is cached to avoid having to recompute it
 *	on future calls;  if it is already cached, the cached
 *	value is returned.
 *
 *----------------------------------------------------------------------
 */

char *
TclGetCwd(interp)
    Tcl_Interp *interp;		/* If non NULL, used for error reporting. */
{
    char buffer[MAXPATHLEN+1], *bufPtr;

    if (currentDir == NULL) {
	if (GetCurrentDirectory(MAXPATHLEN+1, buffer) == 0) {
	    TclWinConvertError(GetLastError());
	    if (interp != NULL) {
		if (errno == ERANGE) {
		    interp->result = "working directory name is too long";
		} else {
		    Tcl_AppendResult(interp,
			    "error getting working directory name: ",
			    Tcl_PosixError(interp), (char *) NULL);
		}
	    }
	    return NULL;
	}
	/*
	 * Watch for the wierd Windows '95 c:\\UNC syntax.
	 */

	if (buffer[0] != '\0' && buffer[1] == ':' && buffer[2] == '\\'
		&& buffer[3] == '\\') {
	    bufPtr = &buffer[2];
	} else {
	    bufPtr = buffer;
	}
	currentDir = (char *) ckalloc((unsigned) (strlen(bufPtr) + 1));
	strcpy(currentDir, bufPtr);

	/*
	 * Convert to forward slashes for easier use in scripts.
	 */

	for (bufPtr = currentDir; *bufPtr != '\0'; bufPtr++) {
	    if (*bufPtr == '\\') {
		*bufPtr = '/';
	    }
	}
    }
    return currentDir;
}