* RE: FW: Can't build Insight with Cygwin
2005-12-23 16:17 Re:FW: Can't build Insight with Cygwin wilfried.fauvel
@ 2005-12-23 16:21 ` Peter Rockett
2005-12-23 16:24 ` Spen
1 sibling, 0 replies; 13+ messages in thread
From: Peter Rockett @ 2005-12-23 16:21 UTC (permalink / raw)
To: 'insight'
[-- Attachment #1: Type: text/plain, Size: 4532 bytes --]
Thanks for the advice Wilfred but I have sorted this problem myself in the
meantime after a little Googling. The tcl/win branch now builds fine. Keith:
Attached the three files with all changes clearly annotated (with "pir").
That's the good news...
The bad news is that gdb breaks. I have managed to solve one problem - an
obvious problem in a source file which clearly the latest version of gcc
will not tolerate. Other problems remain but I guess this is not the
appropriate list for raising purely gdb problems....
Peter
> -----Original Message-----
> From: insight-owner@sourceware.org
> [mailto:insight-owner@sourceware.org] On Behalf Of
> wilfried.fauvel@laposte.net
> Sent: 23 December 2005 13:38
> To: insight
> Subject: Re:FW: Can't build Insight with Cygwin
>
>
> Hi,
>
> I think you can use the patch command
> (http://www.gnu.org/software/patch/patch.html) with the .diff
> file, I have made it manually : you only have to open the
> three files listed ("RCS file:") in the .diff file, and
> replace the - lines by the + lines at the corresponding
> patterns. I have tested to build on another config (with the
> same cygwin version : 1.5.18(0.132/4/2), and the same
> sources), and it seems to crash still ...
>
> Good luck.
>
> > Hi
> >
> > Thanks, Wilfred! This at least confirms my view that there did not
> > seem to be any regular way this source could build. If I read it
> > right, Dave Korn has confirmed that the Win32Dll.c code
> relies on an
> > idiosyncrasy of an earlier version of gcc. Wilfred, can you post a
> > patch? I have read Dave Korn's fix but as I have always studiously
> > avoided assembler I just don't understand what to do to
> implement it!
> >
> > BTW: Keith, I have used the latest cygwin download which I think is
> > gcc 3.4... (see Dave Korn's post). I am interested in Insight under
> > Windows because I have used MSVC in the past (great debugger!) but
> > want to migrate to gnu for cross-platform reasons. There's a lot of
> > IDEs available for gcc but debugging support is generally
> poor. Hence
> > the interest in Insight. Keith, I guess the cygwin compiler on your
> > Win2K box is an old version...
> >
> > Finally, I tried building with mingw 3.4.4 and the
> offending section
> > in tcl/win seems to build OK!! But mingw breaks on the ./bfd
> > sub-directory. Output below. Any ideas on this one? This looks like
> > something has coughed in the make file - again, I've studiously
> > avoided using make...
> >
> >
> > Peter
> >
> >
> ######################################################################
> > ######
> > #############################
> > >
> > > make[2]: Entering directory `/c/insight-6.4/bfd'
> > > Making info in doc
> > > make[3]: Entering directory `/c/insight-6.4/bfd/doc'
> > > restore=: && backupdir=".am$$" && \
> > > am__cwd=`pwd` && cd ../.././bfd/doc && \
> > > rm -rf $backupdir && mkdir $backupdir && \
> > > for f in ../.././bfd/doc/bfd.info ../.././bfd/doc/bfd.info-[0-9]
> > > ../.././bfd/doc/bfd.info-[0-9][0-9]
> > > ../.././bfd/doc/bfd.i[0-9] ../.././bfd/doc/bfd.i[0-9][0-9]; do \
> > > if test -f $f; then mv $f $backupdir; restore=mv; else :;
> > > fi; \ done; \ cd "$am__cwd"; \
> > > if makeinfo --split-size=5000000 --split-size=5000000 -I
> > > ../.././bfd/doc \
> > > -o ../.././bfd/doc/bfd.info ../.././bfd/doc/bfd.texinfo; \ then \
> > > rc=0; \
> > > cd ../.././bfd/doc; \
> > > else \
> > > rc=$?; \
> > > cd ../.././bfd/doc && \
> > > $restore $backupdir/* `echo "./../.././bfd/doc/bfd.info" |
> > > sed 's|[^/]*$||'`; \ fi; \ rm -rf $backupdir; exit $rc
> > > section mapping'.ss reference to nonexistent node `mmo a New
> > > Hash Table Type'.ference to nonexistent node `Deriving
> > > makeinfo: Removing output file `../.././bfd/doc/bfd.info' due
> > > to errors; use --force to preserve.
> > > make[3]: *** [../.././bfd/doc/bfd.info] Error 2
> > > make[3]: Leaving directory `/c/insight-6.4/bfd/doc'
> > > make[2]: *** [info-recursive] Error 1
> > > make[2]: Leaving directory `/c/insight-6.4/bfd'
> > > make[1]: *** [all-bfd] Error 2
> > > make[1]: Leaving directory `/c/insight-6.4'
> > > make: *** [all] Error 2
> > >
> >
>
> Accédez au courrier électronique de La Poste :
> www.laposte.net ; Jusqu'au 25 décembre, participez au grand
> jeu du Calendrier de l'Avent et
> gagnez tous les jours de nombreux lots, + de 300 cadeaux en jeu !
>
>
>
>
[-- Attachment #2: tclWinFCmd.c --]
[-- Type: application/octet-stream, Size: 56790 bytes --]
/* used attribute added on line 472 - pir (23.12.2005) */
/*
* tclWinFCmd.c
*
* This file implements the Windows specific portion of file manipulation
* subcommands of the "file" command.
*
* Copyright (c) 1996-1998 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclWinFCmd.c,v 1.34 2003/02/04 17:06:53 vincentdarley Exp $
*/
#include "tclWinInt.h"
/*
* The following constants specify the type of callback when
* TraverseWinTree() calls the traverseProc()
*/
#define DOTREE_PRED 1 /* pre-order directory */
#define DOTREE_POSTD 2 /* post-order directory */
#define DOTREE_F 3 /* regular file */
/*
* Callbacks for file attributes code.
*/
static int GetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp,
int objIndex, Tcl_Obj *fileName,
Tcl_Obj **attributePtrPtr));
static int GetWinFileLongName _ANSI_ARGS_((Tcl_Interp *interp,
int objIndex, Tcl_Obj *fileName,
Tcl_Obj **attributePtrPtr));
static int GetWinFileShortName _ANSI_ARGS_((Tcl_Interp *interp,
int objIndex, Tcl_Obj *fileName,
Tcl_Obj **attributePtrPtr));
static int SetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp,
int objIndex, Tcl_Obj *fileName,
Tcl_Obj *attributePtr));
static int CannotSetAttribute _ANSI_ARGS_((Tcl_Interp *interp,
int objIndex, Tcl_Obj *fileName,
Tcl_Obj *attributePtr));
/*
* Constants and variables necessary for file attributes subcommand.
*/
enum {
WIN_ARCHIVE_ATTRIBUTE,
WIN_HIDDEN_ATTRIBUTE,
WIN_LONGNAME_ATTRIBUTE,
WIN_READONLY_ATTRIBUTE,
WIN_SHORTNAME_ATTRIBUTE,
WIN_SYSTEM_ATTRIBUTE
};
static int attributeArray[] = {FILE_ATTRIBUTE_ARCHIVE, FILE_ATTRIBUTE_HIDDEN,
0, FILE_ATTRIBUTE_READONLY, 0, FILE_ATTRIBUTE_SYSTEM};
CONST char *tclpFileAttrStrings[] = {
"-archive", "-hidden", "-longname", "-readonly",
"-shortname", "-system", (char *) NULL
};
CONST TclFileAttrProcs tclpFileAttrProcs[] = {
{GetWinFileAttributes, SetWinFileAttributes},
{GetWinFileAttributes, SetWinFileAttributes},
{GetWinFileLongName, CannotSetAttribute},
{GetWinFileAttributes, SetWinFileAttributes},
{GetWinFileShortName, CannotSetAttribute},
{GetWinFileAttributes, SetWinFileAttributes}};
#if defined(HAVE_NO_SEH) && defined(TCL_MEM_DEBUG)
static void *INITIAL_ESP,
*INITIAL_EBP,
*INITIAL_HANDLER,
*RESTORED_ESP,
*RESTORED_EBP,
*RESTORED_HANDLER;
#endif /* HAVE_NO_SEH && TCL_MEM_DEBUG */
/*
* Prototype for the TraverseWinTree callback function.
*/
typedef int (TraversalProc)(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr,
int type, Tcl_DString *errorPtr);
/*
* Declarations for local procedures defined in this file:
*/
static void StatError(Tcl_Interp *interp, Tcl_Obj *fileName);
static int ConvertFileNameFormat(Tcl_Interp *interp,
int objIndex, Tcl_Obj *fileName, int longShort,
Tcl_Obj **attributePtrPtr);
static int DoCopyFile(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr);
static int DoCreateDirectory(CONST TCHAR *pathPtr);
static int DoRemoveJustDirectory(CONST TCHAR *nativeSrc,
int ignoreError, Tcl_DString *errorPtr);
static int DoRemoveDirectory(Tcl_DString *pathPtr, int recursive,
Tcl_DString *errorPtr);
static int DoRenameFile(CONST TCHAR *nativeSrc, CONST TCHAR *dstPtr);
static int TraversalCopy(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr,
int type, Tcl_DString *errorPtr);
static int TraversalDelete(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr,
int type, Tcl_DString *errorPtr);
static int TraverseWinTree(TraversalProc *traverseProc,
Tcl_DString *sourcePtr, Tcl_DString *dstPtr,
Tcl_DString *errorPtr);
\f
/*
*---------------------------------------------------------------------------
*
* TclpObjRenameFile, DoRenameFile --
*
* Changes the name of an existing file or directory, from src to dst.
* If src and dst refer to the same file or directory, does nothing
* and returns success. Otherwise if dst already exists, it will be
* deleted and replaced by src subject to the following conditions:
* If src is a directory, dst may be an empty directory.
* If src is a file, dst may be a file.
* In any other situation where dst already exists, the rename will
* fail.
*
* Results:
* If the file or directory was successfully renamed, returns TCL_OK.
* Otherwise the return value is TCL_ERROR and errno is set to
* indicate the error. Some possible values for errno are:
*
* ENAMETOOLONG: src or dst names are too long.
* EACCES: src or dst parent directory can't be read and/or written.
* EEXIST: dst is a non-empty directory.
* EINVAL: src is a root directory or dst is a subdirectory of src.
* EISDIR: dst is a directory, but src is not.
* ENOENT: src doesn't exist. src or dst is "".
* ENOTDIR: src is a directory, but dst is not.
* EXDEV: src and dst are on different filesystems.
*
* EACCES: exists an open file already referring to src or dst.
* EACCES: src or dst specify the current working directory (NT).
* EACCES: src specifies a char device (nul:, com1:, etc.)
* EEXIST: dst specifies a char device (nul:, com1:, etc.) (NT)
* EACCES: dst specifies a char device (nul:, com1:, etc.) (95)
*
* Side effects:
* The implementation supports cross-filesystem renames of files,
* but the caller should be prepared to emulate cross-filesystem
* renames of directories if errno is EXDEV.
*
*---------------------------------------------------------------------------
*/
int
TclpObjRenameFile(srcPathPtr, destPathPtr)
Tcl_Obj *srcPathPtr;
Tcl_Obj *destPathPtr;
{
return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr),
Tcl_FSGetNativePath(destPathPtr));
}
static int
DoRenameFile(
CONST TCHAR *nativeSrc, /* Pathname of file or dir to be renamed
* (native). */
CONST TCHAR *nativeDst) /* New pathname for file or directory
* (native). */
{
DWORD srcAttr, dstAttr;
int retval = -1;
/*
* The MoveFile API acts differently under Win95/98 and NT
* WRT NULL and "". Avoid passing these values.
*/
if (nativeSrc == NULL || nativeSrc[0] == '\0' ||
nativeDst == NULL || nativeDst[0] == '\0') {
Tcl_SetErrno(ENOENT);
return TCL_ERROR;
}
/*
* The MoveFile API would throw an exception under NT
* if one of the arguments is a char block device.
*/
#ifdef HAVE_NO_SEH
# ifdef TCL_MEM_DEBUG
__asm__ __volatile__ (
"movl %%esp, %0" "\n\t"
"movl %%ebp, %1" "\n\t"
"movl %%fs:0, %2" "\n\t"
: "=m"(INITIAL_ESP),
"=m"(INITIAL_EBP),
"=r"(INITIAL_HANDLER) );
# endif /* TCL_MEM_DEBUG */
__asm__ __volatile__ (
"pushl %ebp" "\n\t"
"pushl $__except_dorenamefile_handler" "\n\t"
"pushl %fs:0" "\n\t"
"movl %esp, %fs:0");
#else
__try {
#endif /* HAVE_NO_SEH */
if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
retval = TCL_OK;
}
#ifdef HAVE_NO_SEH
__asm__ __volatile__ (
"jmp dorenamefile_pop" "\n"
"dorenamefile_reentry:" "\n\t"
"movl %%fs:0, %%eax" "\n\t"
"movl 0x8(%%eax), %%esp" "\n\t"
"movl 0x8(%%esp), %%ebp" "\n"
"dorenamefile_pop:" "\n\t"
"movl (%%esp), %%eax" "\n\t"
"movl %%eax, %%fs:0" "\n\t"
"add $12, %%esp" "\n\t"
:
:
: "%eax");
# ifdef TCL_MEM_DEBUG
__asm__ __volatile__ (
"movl %%esp, %0" "\n\t"
"movl %%ebp, %1" "\n\t"
"movl %%fs:0, %2" "\n\t"
: "=m"(RESTORED_ESP),
"=m"(RESTORED_EBP),
"=r"(RESTORED_HANDLER) );
if (INITIAL_ESP != RESTORED_ESP)
panic("ESP restored incorrectly");
if (INITIAL_EBP != RESTORED_EBP)
panic("EBP restored incorrectly");
if (INITIAL_HANDLER != RESTORED_HANDLER)
panic("HANDLER restored incorrectly");
# endif /* TCL_MEM_DEBUG */
#else
} __except (EXCEPTION_EXECUTE_HANDLER) {}
#endif /* HAVE_NO_SEH */
/*
* Avoid using control flow statements in the SEH guarded block!
*/
if (retval != -1)
return retval;
TclWinConvertError(GetLastError());
srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
if (srcAttr == 0xffffffff) {
if ((*tclWinProcs->getFullPathNameProc)(nativeSrc, 0, NULL, NULL) >= MAX_PATH) {
errno = ENAMETOOLONG;
return TCL_ERROR;
}
srcAttr = 0;
}
if (dstAttr == 0xffffffff) {
if ((*tclWinProcs->getFullPathNameProc)(nativeDst, 0, NULL, NULL) >= MAX_PATH) {
errno = ENAMETOOLONG;
return TCL_ERROR;
}
dstAttr = 0;
}
if (errno == EBADF) {
errno = EACCES;
return TCL_ERROR;
}
if (errno == EACCES) {
decode:
if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
TCHAR *nativeSrcRest, *nativeDstRest;
CONST char **srcArgv, **dstArgv;
int size, srcArgc, dstArgc;
WCHAR nativeSrcPath[MAX_PATH];
WCHAR nativeDstPath[MAX_PATH];
Tcl_DString srcString, dstString;
CONST char *src, *dst;
size = (*tclWinProcs->getFullPathNameProc)(nativeSrc, MAX_PATH,
nativeSrcPath, &nativeSrcRest);
if ((size == 0) || (size > MAX_PATH)) {
return TCL_ERROR;
}
size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH,
nativeDstPath, &nativeDstRest);
if ((size == 0) || (size > MAX_PATH)) {
return TCL_ERROR;
}
(*tclWinProcs->charLowerProc)((TCHAR *) nativeSrcPath);
(*tclWinProcs->charLowerProc)((TCHAR *) nativeDstPath);
src = Tcl_WinTCharToUtf((TCHAR *) nativeSrcPath, -1, &srcString);
dst = Tcl_WinTCharToUtf((TCHAR *) nativeDstPath, -1, &dstString);
if (strncmp(src, dst, (size_t) Tcl_DStringLength(&srcString)) == 0) {
/*
* Trying to move a directory into itself.
*/
errno = EINVAL;
Tcl_DStringFree(&srcString);
Tcl_DStringFree(&dstString);
return TCL_ERROR;
}
Tcl_SplitPath(src, &srcArgc, &srcArgv);
Tcl_SplitPath(dst, &dstArgc, &dstArgv);
Tcl_DStringFree(&srcString);
Tcl_DStringFree(&dstString);
if (srcArgc == 1) {
/*
* They are trying to move a root directory. Whether
* or not it is across filesystems, this cannot be
* done.
*/
Tcl_SetErrno(EINVAL);
} else if ((srcArgc > 0) && (dstArgc > 0) &&
(strcmp(srcArgv[0], dstArgv[0]) != 0)) {
/*
* If src is a directory and dst filesystem != src
* filesystem, errno should be EXDEV. It is very
* important to get this behavior, so that the caller
* can respond to a cross filesystem rename by
* simulating it with copy and delete. The MoveFile
* system call already handles the case of moving a
* file between filesystems.
*/
Tcl_SetErrno(EXDEV);
}
ckfree((char *) srcArgv);
ckfree((char *) dstArgv);
}
/*
* Other types of access failure is that dst is a read-only
* filesystem, that an open file referred to src or dest, or that
* src or dest specified the current working directory on the
* current filesystem. EACCES is returned for those cases.
*/
} else if (Tcl_GetErrno() == EEXIST) {
/*
* Reports EEXIST any time the target already exists. If it makes
* sense, remove the old file and try renaming again.
*/
if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) {
/*
* Overwrite empty dst directory with src directory. The
* following call will remove an empty directory. If it
* fails, it's because it wasn't empty.
*/
if (DoRemoveJustDirectory(nativeDst, 0, NULL) == TCL_OK) {
/*
* Now that that empty directory is gone, we can try
* renaming again. If that fails, we'll put this empty
* directory back, for completeness.
*/
if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
return TCL_OK;
}
/*
* Some new error has occurred. Don't know what it
* could be, but report this one.
*/
TclWinConvertError(GetLastError());
(*tclWinProcs->createDirectoryProc)(nativeDst, NULL);
(*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr);
if (Tcl_GetErrno() == EACCES) {
/*
* Decode the EACCES to a more meaningful error.
*/
goto decode;
}
}
} else { /* (dstAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */
Tcl_SetErrno(ENOTDIR);
}
} else { /* (srcAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */
if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) {
Tcl_SetErrno(EISDIR);
} else {
/*
* Overwrite existing file by:
*
* 1. Rename existing file to temp name.
* 2. Rename old file to new name.
* 3. If success, delete temp file. If failure,
* put temp file back to old name.
*/
TCHAR *nativeRest, *nativeTmp, *nativePrefix;
int result, size;
WCHAR tempBuf[MAX_PATH];
size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH,
tempBuf, &nativeRest);
if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) {
return TCL_ERROR;
}
nativeTmp = (TCHAR *) tempBuf;
((char *) nativeRest)[0] = '\0';
((char *) nativeRest)[1] = '\0'; /* In case it's Unicode. */
result = TCL_ERROR;
nativePrefix = (tclWinProcs->useWide)
? (TCHAR *) L"tclr" : (TCHAR *) "tclr";
if ((*tclWinProcs->getTempFileNameProc)(nativeTmp,
nativePrefix, 0, tempBuf) != 0) {
/*
* Strictly speaking, need the following DeleteFile and
* MoveFile to be joined as an atomic operation so no
* other app comes along in the meantime and creates the
* same temp file.
*/
nativeTmp = (TCHAR *) tempBuf;
(*tclWinProcs->deleteFileProc)(nativeTmp);
if ((*tclWinProcs->moveFileProc)(nativeDst, nativeTmp) != FALSE) {
if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
(*tclWinProcs->setFileAttributesProc)(nativeTmp,
FILE_ATTRIBUTE_NORMAL);
(*tclWinProcs->deleteFileProc)(nativeTmp);
return TCL_OK;
} else {
(*tclWinProcs->deleteFileProc)(nativeDst);
(*tclWinProcs->moveFileProc)(nativeTmp, nativeDst);
}
}
/*
* Can't backup dst file or move src file. Return that
* error. Could happen if an open file refers to dst.
*/
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
/*
* Decode the EACCES to a more meaningful error.
*/
goto decode;
}
}
return result;
}
}
}
return TCL_ERROR;
}
#ifdef HAVE_NO_SEH
static
__attribute__ ((used, /* pir - 23.12.2005 */ cdecl))
EXCEPTION_DISPOSITION
_except_dorenamefile_handler(
struct _EXCEPTION_RECORD *ExceptionRecord,
void *EstablisherFrame,
struct _CONTEXT *ContextRecord,
void *DispatcherContext)
{
__asm__ __volatile__ (
"jmp dorenamefile_reentry");
/* Nuke compiler warning about unused static function */
_except_dorenamefile_handler(NULL, NULL, NULL, NULL);
return 0; /* Function does not return */
}
#endif /* HAVE_NO_SEH */
\f
/*
*---------------------------------------------------------------------------
*
* TclpObjCopyFile, DoCopyFile --
*
* Copy a single file (not a directory). If dst already exists and
* is not a directory, it is removed.
*
* Results:
* If the file was successfully copied, returns TCL_OK. Otherwise
* the return value is TCL_ERROR and errno is set to indicate the
* error. Some possible values for errno are:
*
* EACCES: src or dst parent directory can't be read and/or written.
* EISDIR: src or dst is a directory.
* ENOENT: src doesn't exist. src or dst is "".
*
* EACCES: exists an open file already referring to dst (95).
* EACCES: src specifies a char device (nul:, com1:, etc.) (NT)
* ENOENT: src specifies a char device (nul:, com1:, etc.) (95)
*
* Side effects:
* It is not an error to copy to a char device.
*
*---------------------------------------------------------------------------
*/
int
TclpObjCopyFile(srcPathPtr, destPathPtr)
Tcl_Obj *srcPathPtr;
Tcl_Obj *destPathPtr;
{
return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr),
Tcl_FSGetNativePath(destPathPtr));
}
static int
DoCopyFile(
CONST TCHAR *nativeSrc, /* Pathname of file to be copied (native). */
CONST TCHAR *nativeDst) /* Pathname of file to copy to (native). */
{
int retval = -1;
/*
* The CopyFile API acts differently under Win95/98 and NT
* WRT NULL and "". Avoid passing these values.
*/
if (nativeSrc == NULL || nativeSrc[0] == '\0' ||
nativeDst == NULL || nativeDst[0] == '\0') {
Tcl_SetErrno(ENOENT);
return TCL_ERROR;
}
/*
* The CopyFile API would throw an exception under NT if one
* of the arguments is a char block device.
*/
#ifdef HAVE_NO_SEH
# ifdef TCL_MEM_DEBUG
__asm__ __volatile__ (
"movl %%esp, %0" "\n\t"
"movl %%ebp, %1" "\n\t"
"movl %%fs:0, %2" "\n\t"
: "=m"(INITIAL_ESP),
"=m"(INITIAL_EBP),
"=r"(INITIAL_HANDLER) );
# endif /* TCL_MEM_DEBUG */
__asm__ __volatile__ (
"pushl %ebp" "\n\t"
"pushl $__except_docopyfile_handler" "\n\t"
"pushl %fs:0" "\n\t"
"movl %esp, %fs:0");
#else
__try {
#endif /* HAVE_NO_SEH */
if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
retval = TCL_OK;
}
#ifdef HAVE_NO_SEH
__asm__ __volatile__ (
"jmp docopyfile_pop" "\n"
"docopyfile_reentry:" "\n\t"
"movl %%fs:0, %%eax" "\n\t"
"movl 0x8(%%eax), %%esp" "\n\t"
"movl 0x8(%%esp), %%ebp" "\n"
"docopyfile_pop:" "\n\t"
"movl (%%esp), %%eax" "\n\t"
"movl %%eax, %%fs:0" "\n\t"
"add $12, %%esp" "\n\t"
:
:
: "%eax");
# ifdef TCL_MEM_DEBUG
__asm__ __volatile__ (
"movl %%esp, %0" "\n\t"
"movl %%ebp, %1" "\n\t"
"movl %%fs:0, %2" "\n\t"
: "=m"(RESTORED_ESP),
"=m"(RESTORED_EBP),
"=r"(RESTORED_HANDLER) );
if (INITIAL_ESP != RESTORED_ESP)
panic("ESP restored incorrectly");
if (INITIAL_EBP != RESTORED_EBP)
panic("EBP restored incorrectly");
if (INITIAL_HANDLER != RESTORED_HANDLER)
panic("HANDLER restored incorrectly");
# endif /* TCL_MEM_DEBUG */
#else
} __except (EXCEPTION_EXECUTE_HANDLER) {}
#endif /* HAVE_NO_SEH */
/*
* Avoid using control flow statements in the SEH guarded block!
*/
if (retval != -1)
return retval;
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EBADF) {
Tcl_SetErrno(EACCES);
return TCL_ERROR;
}
if (Tcl_GetErrno() == EACCES) {
DWORD srcAttr, dstAttr;
srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
if (srcAttr != 0xffffffff) {
if (dstAttr == 0xffffffff) {
dstAttr = 0;
}
if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) ||
(dstAttr & FILE_ATTRIBUTE_DIRECTORY)) {
if (srcAttr & FILE_ATTRIBUTE_REPARSE_POINT) {
/* Source is a symbolic link -- copy it */
if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst) == 0) {
return TCL_OK;
}
}
Tcl_SetErrno(EISDIR);
}
if (dstAttr & FILE_ATTRIBUTE_READONLY) {
(*tclWinProcs->setFileAttributesProc)(nativeDst,
dstAttr & ~((DWORD)FILE_ATTRIBUTE_READONLY));
if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
return TCL_OK;
}
/*
* Still can't copy onto dst. Return that error, and
* restore attributes of dst.
*/
TclWinConvertError(GetLastError());
(*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr);
}
}
}
return TCL_ERROR;
}
#ifdef HAVE_NO_SEH
static
__attribute__ ((cdecl))
EXCEPTION_DISPOSITION
_except_docopyfile_handler(
struct _EXCEPTION_RECORD *ExceptionRecord,
void *EstablisherFrame,
struct _CONTEXT *ContextRecord,
void *DispatcherContext)
{
__asm__ __volatile__ (
"jmp docopyfile_reentry");
_except_docopyfile_handler(NULL,NULL,NULL,NULL);
return 0; /* Function does not return */
}
#endif /* HAVE_NO_SEH */
\f
/*
*---------------------------------------------------------------------------
*
* TclpObjDeleteFile, TclpDeleteFile --
*
* Removes a single file (not a directory).
*
* Results:
* If the file was successfully deleted, returns TCL_OK. Otherwise
* the return value is TCL_ERROR and errno is set to indicate the
* error. Some possible values for errno are:
*
* EACCES: a parent directory can't be read and/or written.
* EISDIR: path is a directory.
* ENOENT: path doesn't exist or is "".
*
* EACCES: exists an open file already referring to path.
* EACCES: path is a char device (nul:, com1:, etc.)
*
* Side effects:
* The file is deleted, even if it is read-only.
*
*---------------------------------------------------------------------------
*/
int
TclpObjDeleteFile(pathPtr)
Tcl_Obj *pathPtr;
{
return TclpDeleteFile(Tcl_FSGetNativePath(pathPtr));
}
int
TclpDeleteFile(
CONST TCHAR *nativePath) /* Pathname of file to be removed (native). */
{
DWORD attr;
/*
* The DeleteFile API acts differently under Win95/98 and NT
* WRT NULL and "". Avoid passing these values.
*/
if (nativePath == NULL || nativePath[0] == '\0') {
Tcl_SetErrno(ENOENT);
return TCL_ERROR;
}
if ((*tclWinProcs->deleteFileProc)(nativePath) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
if (attr != 0xffffffff) {
if (attr & FILE_ATTRIBUTE_DIRECTORY) {
if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
/* It is a symbolic link -- remove it */
if (TclWinSymLinkDelete(nativePath, 0) == 0) {
return TCL_OK;
}
}
/*
* If we fall through here, it is a directory.
*
* Windows NT reports removing a directory as EACCES instead
* of EISDIR.
*/
Tcl_SetErrno(EISDIR);
} else if (attr & FILE_ATTRIBUTE_READONLY) {
int res = (*tclWinProcs->setFileAttributesProc)(nativePath,
attr & ~((DWORD)FILE_ATTRIBUTE_READONLY));
if ((res != 0) && ((*tclWinProcs->deleteFileProc)(nativePath)
!= FALSE)) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
if (res != 0) {
(*tclWinProcs->setFileAttributesProc)(nativePath, attr);
}
}
}
} else if (Tcl_GetErrno() == ENOENT) {
attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
if (attr != 0xffffffff) {
if (attr & FILE_ATTRIBUTE_DIRECTORY) {
/*
* Windows 95 reports removing a directory as ENOENT instead
* of EISDIR.
*/
Tcl_SetErrno(EISDIR);
}
}
} else if (Tcl_GetErrno() == EINVAL) {
/*
* Windows NT reports removing a char device as EINVAL instead of
* EACCES.
*/
Tcl_SetErrno(EACCES);
}
return TCL_ERROR;
}
\f
/*
*---------------------------------------------------------------------------
*
* TclpObjCreateDirectory --
*
* Creates the specified directory. All parent directories of the
* specified directory must already exist. The directory is
* automatically created with permissions so that user can access
* the new directory and create new files or subdirectories in it.
*
* Results:
* If the directory was successfully created, returns TCL_OK.
* Otherwise the return value is TCL_ERROR and errno is set to
* indicate the error. Some possible values for errno are:
*
* EACCES: a parent directory can't be read and/or written.
* EEXIST: path already exists.
* ENOENT: a parent directory doesn't exist.
*
* Side effects:
* A directory is created.
*
*---------------------------------------------------------------------------
*/
int
TclpObjCreateDirectory(pathPtr)
Tcl_Obj *pathPtr;
{
return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr));
}
static int
DoCreateDirectory(
CONST TCHAR *nativePath) /* Pathname of directory to create (native). */
{
DWORD error;
if ((*tclWinProcs->createDirectoryProc)(nativePath, NULL) == 0) {
error = GetLastError();
TclWinConvertError(error);
return TCL_ERROR;
}
return TCL_OK;
}
\f
/*
*---------------------------------------------------------------------------
*
* TclpObjCopyDirectory --
*
* Recursively copies a directory. The target directory dst must
* not already exist. Note that this function does not merge two
* directory hierarchies, even if the target directory is an an
* empty directory.
*
* Results:
* If the directory was successfully copied, returns TCL_OK.
* Otherwise the return value is TCL_ERROR, errno is set to indicate
* the error, and the pathname of the file that caused the error
* is stored in errorPtr. See TclpCreateDirectory and TclpCopyFile
* for a description of possible values for errno.
*
* Side effects:
* An exact copy of the directory hierarchy src will be created
* with the name dst. If an error occurs, the error will
* be returned immediately, and remaining files will not be
* processed.
*
*---------------------------------------------------------------------------
*/
int
TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
Tcl_Obj *srcPathPtr;
Tcl_Obj *destPathPtr;
Tcl_Obj **errorPtr;
{
Tcl_DString ds;
Tcl_DString srcString, dstString;
int ret;
Tcl_WinUtfToTChar(Tcl_FSGetTranslatedStringPath(NULL,srcPathPtr),
-1, &srcString);
Tcl_WinUtfToTChar(Tcl_FSGetTranslatedStringPath(NULL,destPathPtr),
-1, &dstString);
ret = TraverseWinTree(TraversalCopy, &srcString, &dstString, &ds);
Tcl_DStringFree(&srcString);
Tcl_DStringFree(&dstString);
if (ret != TCL_OK) {
*errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
Tcl_DStringFree(&ds);
Tcl_IncrRefCount(*errorPtr);
}
return ret;
}
\f
/*
*----------------------------------------------------------------------
*
* TclpObjRemoveDirectory, DoRemoveDirectory --
*
* Removes directory (and its contents, if the recursive flag is set).
*
* Results:
* If the directory was successfully removed, returns TCL_OK.
* Otherwise the return value is TCL_ERROR, errno is set to indicate
* the error, and the pathname of the file that caused the error
* is stored in errorPtr. Some possible values for errno are:
*
* EACCES: path directory can't be read and/or written.
* EEXIST: path is a non-empty directory.
* EINVAL: path is root directory or current directory.
* ENOENT: path doesn't exist or is "".
* ENOTDIR: path is not a directory.
*
* EACCES: path is a char device (nul:, com1:, etc.) (95)
* EINVAL: path is a char device (nul:, com1:, etc.) (NT)
*
* Side effects:
* Directory removed. If an error occurs, the error will be returned
* immediately, and remaining files will not be deleted.
*
*----------------------------------------------------------------------
*/
int
TclpObjRemoveDirectory(pathPtr, recursive, errorPtr)
Tcl_Obj *pathPtr;
int recursive;
Tcl_Obj **errorPtr;
{
Tcl_DString ds;
int ret;
if (recursive) {
/*
* In the recursive case, the string rep is used to construct a
* Tcl_DString which may be used extensively, so we can't
* optimize this case easily.
*/
Tcl_DString native;
Tcl_WinUtfToTChar(Tcl_FSGetTranslatedStringPath(NULL, pathPtr),
-1, &native);
ret = DoRemoveDirectory(&native, recursive, &ds);
Tcl_DStringFree(&native);
} else {
ret = DoRemoveJustDirectory(Tcl_FSGetNativePath(pathPtr),
0, &ds);
}
if (ret != TCL_OK) {
int len = Tcl_DStringLength(&ds);
if (len > 0) {
*errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
Tcl_IncrRefCount(*errorPtr);
}
Tcl_DStringFree(&ds);
}
return ret;
}
static int
DoRemoveJustDirectory(
CONST TCHAR *nativePath, /* Pathname of directory to be removed
* (native). */
int ignoreError, /* If non-zero, don't initialize the
* errorPtr under some circumstances
* on return. */
Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
* DString filled with UTF-8 name of file
* causing error. */
{
/*
* The RemoveDirectory API acts differently under Win95/98 and NT
* WRT NULL and "". Avoid passing these values.
*/
if (nativePath == NULL || nativePath[0] == '\0') {
Tcl_SetErrno(ENOENT);
goto end;
}
if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
DWORD attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
if (attr != 0xffffffff) {
if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
/*
* Windows 95 reports calling RemoveDirectory on a file as an
* EACCES, not an ENOTDIR.
*/
Tcl_SetErrno(ENOTDIR);
goto end;
}
if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
/* It is a symbolic link -- remove it */
if (TclWinSymLinkDelete(nativePath, 1) != 0) {
goto end;
}
}
if (attr & FILE_ATTRIBUTE_READONLY) {
attr &= ~FILE_ATTRIBUTE_READONLY;
if ((*tclWinProcs->setFileAttributesProc)(nativePath, attr) == FALSE) {
goto end;
}
if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
(*tclWinProcs->setFileAttributesProc)(nativePath,
attr | FILE_ATTRIBUTE_READONLY);
}
/*
* Windows 95 and Win32s report removing a non-empty directory
* as EACCES, not EEXIST. If the directory is not empty,
* change errno so caller knows what's going on.
*/
if (TclWinGetPlatformId() != VER_PLATFORM_WIN32_NT) {
CONST char *path, *find;
HANDLE handle;
WIN32_FIND_DATAA data;
Tcl_DString buffer;
int len;
path = (CONST char *) nativePath;
Tcl_DStringInit(&buffer);
len = strlen(path);
find = Tcl_DStringAppend(&buffer, path, len);
if ((len > 0) && (find[len - 1] != '\\')) {
Tcl_DStringAppend(&buffer, "\\", 1);
}
find = Tcl_DStringAppend(&buffer, "*.*", 3);
handle = FindFirstFileA(find, &data);
if (handle != INVALID_HANDLE_VALUE) {
while (1) {
if ((strcmp(data.cFileName, ".") != 0)
&& (strcmp(data.cFileName, "..") != 0)) {
/*
* Found something in this directory.
*/
Tcl_SetErrno(EEXIST);
break;
}
if (FindNextFileA(handle, &data) == FALSE) {
break;
}
}
FindClose(handle);
}
Tcl_DStringFree(&buffer);
}
}
}
if (Tcl_GetErrno() == ENOTEMPTY) {
/*
* The caller depends on EEXIST to signify that the directory is
* not empty, not ENOTEMPTY.
*/
Tcl_SetErrno(EEXIST);
}
if ((ignoreError != 0) && (Tcl_GetErrno() == EEXIST)) {
/*
* If we're being recursive, this error may actually
* be ok, so we don't want to initialise the errorPtr
* yet.
*/
return TCL_ERROR;
}
end:
if (errorPtr != NULL) {
Tcl_WinTCharToUtf(nativePath, -1, errorPtr);
}
return TCL_ERROR;
}
static int
DoRemoveDirectory(
Tcl_DString *pathPtr, /* Pathname of directory to be removed
* (native). */
int recursive, /* If non-zero, removes directories that
* are nonempty. Otherwise, will only remove
* empty directories. */
Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
* DString filled with UTF-8 name of file
* causing error. */
{
int res = DoRemoveJustDirectory(Tcl_DStringValue(pathPtr), recursive,
errorPtr);
if ((res == TCL_ERROR) && (recursive != 0) && (Tcl_GetErrno() == EEXIST)) {
/*
* The directory is nonempty, but the recursive flag has been
* specified, so we recursively remove all the files in the directory.
*/
return TraverseWinTree(TraversalDelete, pathPtr, NULL, errorPtr);
} else {
return res;
}
}
\f
/*
*---------------------------------------------------------------------------
*
* TraverseWinTree --
*
* Traverse directory tree specified by sourcePtr, calling the function
* traverseProc for each file and directory encountered. If destPtr
* is non-null, each of name in the sourcePtr directory is appended to
* the directory specified by destPtr and passed as the second argument
* to traverseProc() .
*
* Results:
* Standard Tcl result.
*
* Side effects:
* None caused by TraverseWinTree, however the user specified
* traverseProc() may change state. If an error occurs, the error will
* be returned immediately, and remaining files will not be processed.
*
*---------------------------------------------------------------------------
*/
static int
TraverseWinTree(
TraversalProc *traverseProc,/* Function to call for every file and
* directory in source hierarchy. */
Tcl_DString *sourcePtr, /* Pathname of source directory to be
* traversed (native). */
Tcl_DString *targetPtr, /* Pathname of directory to traverse in
* parallel with source directory (native),
* may be NULL. */
Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
* DString filled with UTF-8 name of file
* causing error. */
{
DWORD sourceAttr;
TCHAR *nativeSource, *nativeTarget, *nativeErrfile;
int result, found, sourceLen, targetLen, oldSourceLen, oldTargetLen;
HANDLE handle;
WIN32_FIND_DATAT data;
nativeErrfile = NULL;
result = TCL_OK;
oldTargetLen = 0; /* lint. */
nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr);
nativeTarget = (TCHAR *) (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr));
oldSourceLen = Tcl_DStringLength(sourcePtr);
sourceAttr = (*tclWinProcs->getFileAttributesProc)(nativeSource);
if (sourceAttr == 0xffffffff) {
nativeErrfile = nativeSource;
goto end;
}
if ((sourceAttr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
/*
* Process the regular file
*/
return (*traverseProc)(nativeSource, nativeTarget, DOTREE_F, errorPtr);
}
if (tclWinProcs->useWide) {
Tcl_DStringAppend(sourcePtr, (char *) L"\\*.*", 4 * sizeof(WCHAR) + 1);
Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
} else {
Tcl_DStringAppend(sourcePtr, "\\*.*", 4);
}
nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr);
handle = (*tclWinProcs->findFirstFileProc)(nativeSource, &data);
if (handle == INVALID_HANDLE_VALUE) {
/*
* Can't read directory
*/
TclWinConvertError(GetLastError());
nativeErrfile = nativeSource;
goto end;
}
nativeSource[oldSourceLen + 1] = '\0';
Tcl_DStringSetLength(sourcePtr, oldSourceLen);
result = (*traverseProc)(nativeSource, nativeTarget, DOTREE_PRED, errorPtr);
if (result != TCL_OK) {
FindClose(handle);
return result;
}
sourceLen = oldSourceLen;
if (tclWinProcs->useWide) {
sourceLen += sizeof(WCHAR);
Tcl_DStringAppend(sourcePtr, (char *) L"\\", sizeof(WCHAR) + 1);
Tcl_DStringSetLength(sourcePtr, sourceLen);
} else {
sourceLen += 1;
Tcl_DStringAppend(sourcePtr, "\\", 1);
}
if (targetPtr != NULL) {
oldTargetLen = Tcl_DStringLength(targetPtr);
targetLen = oldTargetLen;
if (tclWinProcs->useWide) {
targetLen += sizeof(WCHAR);
Tcl_DStringAppend(targetPtr, (char *) L"\\", sizeof(WCHAR) + 1);
Tcl_DStringSetLength(targetPtr, targetLen);
} else {
targetLen += 1;
Tcl_DStringAppend(targetPtr, "\\", 1);
}
}
found = 1;
for ( ; found; found = (*tclWinProcs->findNextFileProc)(handle, &data)) {
TCHAR *nativeName;
int len;
if (tclWinProcs->useWide) {
WCHAR *wp;
wp = data.w.cFileName;
if (*wp == '.') {
wp++;
if (*wp == '.') {
wp++;
}
if (*wp == '\0') {
continue;
}
}
nativeName = (TCHAR *) data.w.cFileName;
len = Tcl_UniCharLen(data.w.cFileName) * sizeof(WCHAR);
} else {
if ((strcmp(data.a.cFileName, ".") == 0)
|| (strcmp(data.a.cFileName, "..") == 0)) {
continue;
}
nativeName = (TCHAR *) data.a.cFileName;
len = strlen(data.a.cFileName);
}
/*
* Append name after slash, and recurse on the file.
*/
Tcl_DStringAppend(sourcePtr, (char *) nativeName, len + 1);
Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
if (targetPtr != NULL) {
Tcl_DStringAppend(targetPtr, (char *) nativeName, len + 1);
Tcl_DStringSetLength(targetPtr, Tcl_DStringLength(targetPtr) - 1);
}
result = TraverseWinTree(traverseProc, sourcePtr, targetPtr,
errorPtr);
if (result != TCL_OK) {
break;
}
/*
* Remove name after slash.
*/
Tcl_DStringSetLength(sourcePtr, sourceLen);
if (targetPtr != NULL) {
Tcl_DStringSetLength(targetPtr, targetLen);
}
}
FindClose(handle);
/*
* Strip off the trailing slash we added
*/
Tcl_DStringSetLength(sourcePtr, oldSourceLen + 1);
Tcl_DStringSetLength(sourcePtr, oldSourceLen);
if (targetPtr != NULL) {
Tcl_DStringSetLength(targetPtr, oldTargetLen + 1);
Tcl_DStringSetLength(targetPtr, oldTargetLen);
}
if (result == TCL_OK) {
/*
* Call traverseProc() on a directory after visiting all the
* files in that directory.
*/
result = (*traverseProc)(Tcl_DStringValue(sourcePtr),
(targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)),
DOTREE_POSTD, errorPtr);
}
end:
if (nativeErrfile != NULL) {
TclWinConvertError(GetLastError());
if (errorPtr != NULL) {
Tcl_WinTCharToUtf(nativeErrfile, -1, errorPtr);
}
result = TCL_ERROR;
}
return result;
}
\f
/*
*----------------------------------------------------------------------
*
* TraversalCopy
*
* Called from TraverseUnixTree in order to execute a recursive
* copy of a directory.
*
* Results:
* Standard Tcl result.
*
* Side effects:
* Depending on the value of type, src may be copied to dst.
*
*----------------------------------------------------------------------
*/
static int
TraversalCopy(
CONST TCHAR *nativeSrc, /* Source pathname to copy. */
CONST TCHAR *nativeDst, /* Destination pathname of copy. */
int type, /* Reason for call - see TraverseWinTree() */
Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled
* with UTF-8 name of file causing error. */
{
switch (type) {
case DOTREE_F: {
if (DoCopyFile(nativeSrc, nativeDst) == TCL_OK) {
return TCL_OK;
}
break;
}
case DOTREE_PRED: {
if (DoCreateDirectory(nativeDst) == TCL_OK) {
DWORD attr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
if ((*tclWinProcs->setFileAttributesProc)(nativeDst, attr) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
}
break;
}
case DOTREE_POSTD: {
return TCL_OK;
}
}
/*
* There shouldn't be a problem with src, because we already
* checked it to get here.
*/
if (errorPtr != NULL) {
Tcl_WinTCharToUtf(nativeDst, -1, errorPtr);
}
return TCL_ERROR;
}
\f
/*
*----------------------------------------------------------------------
*
* TraversalDelete --
*
* Called by procedure TraverseWinTree for every file and
* directory that it encounters in a directory hierarchy. This
* procedure unlinks files, and removes directories after all the
* containing files have been processed.
*
* Results:
* Standard Tcl result.
*
* Side effects:
* Files or directory specified by src will be deleted. If an
* error occurs, the windows error is converted to a Posix error
* and errno is set accordingly.
*
*----------------------------------------------------------------------
*/
static int
TraversalDelete(
CONST TCHAR *nativeSrc, /* Source pathname to delete. */
CONST TCHAR *dstPtr, /* Not used. */
int type, /* Reason for call - see TraverseWinTree() */
Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled
* with UTF-8 name of file causing error. */
{
switch (type) {
case DOTREE_F: {
if (TclpDeleteFile(nativeSrc) == TCL_OK) {
return TCL_OK;
}
break;
}
case DOTREE_PRED: {
return TCL_OK;
}
case DOTREE_POSTD: {
if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) {
return TCL_OK;
}
break;
}
}
if (errorPtr != NULL) {
Tcl_WinTCharToUtf(nativeSrc, -1, errorPtr);
}
return TCL_ERROR;
}
\f
/*
*----------------------------------------------------------------------
*
* StatError --
*
* Sets the object result with the appropriate error.
*
* Results:
* None.
*
* Side effects:
* The interp's object result is set with an error message
* based on the objIndex, fileName and errno.
*
*----------------------------------------------------------------------
*/
static void
StatError(
Tcl_Interp *interp, /* The interp that has the error */
Tcl_Obj *fileName) /* The name of the file which caused the
* error. */
{
TclWinConvertError(GetLastError());
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"could not read \"", Tcl_GetString(fileName),
"\": ", Tcl_PosixError(interp),
(char *) NULL);
}
\f
/*
*----------------------------------------------------------------------
*
* GetWinFileAttributes --
*
* Returns a Tcl_Obj containing the value of a file attribute.
* This routine gets the -hidden, -readonly or -system attribute.
*
* Results:
* Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
* will have ref count 0. If the return value is not TCL_OK,
* attributePtrPtr is not touched.
*
* Side effects:
* A new object is allocated if the file is valid.
*
*----------------------------------------------------------------------
*/
static int
GetWinFileAttributes(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
DWORD result;
CONST TCHAR *nativeName;
int attr;
nativeName = Tcl_FSGetNativePath(fileName);
result = (*tclWinProcs->getFileAttributesProc)(nativeName);
if (result == 0xffffffff) {
StatError(interp, fileName);
return TCL_ERROR;
}
attr = (int)(result & attributeArray[objIndex]);
if ((objIndex == WIN_HIDDEN_ATTRIBUTE) && (attr != 0)) {
/*
* It is hidden. However there is a bug on some Windows
* OSes in which root volumes (drives) formatted as NTFS
* are declared hidden when they are not (and cannot be).
*
* We test for, and fix that case, here.
*/
int len;
char *str = Tcl_GetStringFromObj(fileName,&len);
if (len < 4) {
if (len == 0) {
/*
* Not sure if this is possible, but we pass it on
* anyway
*/
} else if (len == 1 && (str[0] == '/' || str[0] == '\\')) {
/* Path is pointing to the root volume */
attr = 0;
} else if ((str[1] == ':')
&& (len == 2 || (str[2] == '/' || str[2] == '\\'))) {
/* Path is of the form 'x:' or 'x:/' or 'x:\' */
attr = 0;
}
}
}
*attributePtrPtr = Tcl_NewBooleanObj(attr);
return TCL_OK;
}
\f
/*
*----------------------------------------------------------------------
*
* ConvertFileNameFormat --
*
* Returns a Tcl_Obj containing either the long or short version of the
* file name.
*
* Results:
* Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
* will have ref count 0. If the return value is not TCL_OK,
* attributePtrPtr is not touched.
*
* Warning: if you pass this function a drive name like 'c:' it
* will actually return the current working directory on that
* drive. To avoid this, make sure the drive name ends in a
* slash, like this 'c:/'.
*
* Side effects:
* A new object is allocated if the file is valid.
*
*----------------------------------------------------------------------
*/
static int
ConvertFileNameFormat(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
Tcl_Obj *fileName, /* The name of the file. */
int longShort, /* 0 to short name, 1 to long name. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
int pathc, i;
Tcl_Obj *splitPath;
int result = TCL_OK;
splitPath = Tcl_FSSplitPath(fileName, &pathc);
if (splitPath == NULL || pathc == 0) {
if (interp != NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"could not read \"", Tcl_GetString(fileName),
"\": no such file or directory",
(char *) NULL);
}
result = TCL_ERROR;
goto cleanup;
}
for (i = 0; i < pathc; i++) {
Tcl_Obj *elt;
char *pathv;
int pathLen;
Tcl_ListObjIndex(NULL, splitPath, i, &elt);
pathv = Tcl_GetStringFromObj(elt, &pathLen);
if ((pathv[0] == '/')
|| ((pathLen == 3) && (pathv[1] == ':'))
|| (strcmp(pathv, ".") == 0)
|| (strcmp(pathv, "..") == 0)) {
/*
* Handle "/", "//machine/export", "c:/", "." or ".." by just
* copying the string literally. Uppercase the drive letter,
* just because it looks better under Windows to do so.
*/
simple:
/* Here we are modifying the string representation in place */
/* I believe this is legal, since this won't affect any
* file representation this thing may have. */
pathv[0] = (char) Tcl_UniCharToUpper(UCHAR(pathv[0]));
} else {
Tcl_Obj *tempPath;
Tcl_DString ds;
Tcl_DString dsTemp;
TCHAR *nativeName;
char *tempString;
int tempLen;
WIN32_FIND_DATAT data;
HANDLE handle;
DWORD attr;
tempPath = Tcl_FSJoinPath(splitPath, i+1);
Tcl_IncrRefCount(tempPath);
/*
* We'd like to call Tcl_FSGetNativePath(tempPath)
* but that is likely to lead to infinite loops
*/
Tcl_DStringInit(&ds);
tempString = Tcl_GetStringFromObj(tempPath,&tempLen);
nativeName = Tcl_WinUtfToTChar(tempString, tempLen, &ds);
Tcl_DecrRefCount(tempPath);
handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data);
if (handle == INVALID_HANDLE_VALUE) {
/*
* FindFirstFile() doesn't like root directories. We
* would only get a root directory here if the caller
* specified "c:" or "c:." and the current directory on the
* drive was the root directory
*/
attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
if ((attr != 0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) {
Tcl_DStringFree(&ds);
goto simple;
}
}
if (handle == INVALID_HANDLE_VALUE) {
Tcl_DStringFree(&ds);
if (interp != NULL) {
StatError(interp, fileName);
}
result = TCL_ERROR;
goto cleanup;
}
if (tclWinProcs->useWide) {
nativeName = (TCHAR *) data.w.cAlternateFileName;
if (longShort) {
if (data.w.cFileName[0] != '\0') {
nativeName = (TCHAR *) data.w.cFileName;
}
} else {
if (data.w.cAlternateFileName[0] == '\0') {
nativeName = (TCHAR *) data.w.cFileName;
}
}
} else {
nativeName = (TCHAR *) data.a.cAlternateFileName;
if (longShort) {
if (data.a.cFileName[0] != '\0') {
nativeName = (TCHAR *) data.a.cFileName;
}
} else {
if (data.a.cAlternateFileName[0] == '\0') {
nativeName = (TCHAR *) data.a.cFileName;
}
}
}
/*
* Purify reports a extraneous UMR in Tcl_WinTCharToUtf() trying
* to dereference nativeName as a Unicode string. I have proven
* to myself that purify is wrong by running the following
* example when nativeName == data.w.cAlternateFileName and
* noting that purify doesn't complain about the first line,
* but does complain about the second.
*
* fprintf(stderr, "%d\n", data.w.cAlternateFileName[0]);
* fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]);
*/
Tcl_DStringInit(&dsTemp);
Tcl_WinTCharToUtf(nativeName, -1, &dsTemp);
/* Deal with issues of tildes being absolute */
if (Tcl_DStringValue(&dsTemp)[0] == '~') {
tempPath = Tcl_NewStringObj("./",2);
Tcl_AppendToObj(tempPath, Tcl_DStringValue(&dsTemp),
Tcl_DStringLength(&dsTemp));
} else {
tempPath = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp),
Tcl_DStringLength(&dsTemp));
}
Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath);
Tcl_DStringFree(&ds);
Tcl_DStringFree(&dsTemp);
FindClose(handle);
}
}
*attributePtrPtr = Tcl_FSJoinPath(splitPath, -1);
cleanup:
if (splitPath != NULL) {
Tcl_DecrRefCount(splitPath);
}
return result;
}
\f
/*
*----------------------------------------------------------------------
*
* GetWinFileLongName --
*
* Returns a Tcl_Obj containing the long version of the file
* name.
*
* Results:
* Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
* will have ref count 0. If the return value is not TCL_OK,
* attributePtrPtr is not touched.
*
* Side effects:
* A new object is allocated if the file is valid.
*
*----------------------------------------------------------------------
*/
static int
GetWinFileLongName(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
return ConvertFileNameFormat(interp, objIndex, fileName, 1, attributePtrPtr);
}
\f
/*
*----------------------------------------------------------------------
*
* GetWinFileShortName --
*
* Returns a Tcl_Obj containing the short version of the file
* name.
*
* Results:
* Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
* will have ref count 0. If the return value is not TCL_OK,
* attributePtrPtr is not touched.
*
* Side effects:
* A new object is allocated if the file is valid.
*
*----------------------------------------------------------------------
*/
static int
GetWinFileShortName(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
return ConvertFileNameFormat(interp, objIndex, fileName, 0, attributePtrPtr);
}
\f
/*
*----------------------------------------------------------------------
*
* SetWinFileAttributes --
*
* Set the file attributes to the value given by attributePtr.
* This routine sets the -hidden, -readonly, or -system attributes.
*
* Results:
* Standard TCL error.
*
* Side effects:
* The file's attribute is set.
*
*----------------------------------------------------------------------
*/
static int
SetWinFileAttributes(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj *attributePtr) /* The new value of the attribute. */
{
DWORD fileAttributes;
int yesNo;
int result;
CONST TCHAR *nativeName;
nativeName = Tcl_FSGetNativePath(fileName);
fileAttributes = (*tclWinProcs->getFileAttributesProc)(nativeName);
if (fileAttributes == 0xffffffff) {
StatError(interp, fileName);
return TCL_ERROR;
}
result = Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo);
if (result != TCL_OK) {
return result;
}
if (yesNo) {
fileAttributes |= (attributeArray[objIndex]);
} else {
fileAttributes &= ~(attributeArray[objIndex]);
}
if (!(*tclWinProcs->setFileAttributesProc)(nativeName, fileAttributes)) {
StatError(interp, fileName);
return TCL_ERROR;
}
return result;
}
\f
/*
*----------------------------------------------------------------------
*
* SetWinFileLongName --
*
* The attribute in question is a readonly attribute and cannot
* be set.
*
* Results:
* TCL_ERROR
*
* Side effects:
* The object result is set to a pertinent error message.
*
*----------------------------------------------------------------------
*/
static int
CannotSetAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj *attributePtr) /* The new value of the attribute. */
{
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"cannot set attribute \"", tclpFileAttrStrings[objIndex],
"\" for file \"", Tcl_GetString(fileName),
"\": attribute is readonly",
(char *) NULL);
return TCL_ERROR;
}
\f
/*
*---------------------------------------------------------------------------
*
* TclpObjListVolumes --
*
* Lists the currently mounted volumes
*
* Results:
* The list of volumes.
*
* Side effects:
* None
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
TclpObjListVolumes(void)
{
Tcl_Obj *resultPtr, *elemPtr;
char buf[40 * 4]; /* There couldn't be more than 30 drives??? */
int i;
char *p;
resultPtr = Tcl_NewObj();
/*
* On Win32s:
* GetLogicalDriveStrings() isn't implemented.
* GetLogicalDrives() returns incorrect information.
*/
if (GetLogicalDriveStringsA(sizeof(buf), buf) == 0) {
/*
* GetVolumeInformation() will detects all drives, but causes
* chattering on empty floppy drives. We only do this if
* GetLogicalDriveStrings() didn't work. It has also been reported
* that on some laptops it takes a while for GetVolumeInformation()
* to return when pinging an empty floppy drive, another reason to
* try to avoid calling it.
*/
buf[1] = ':';
buf[2] = '/';
buf[3] = '\0';
for (i = 0; i < 26; i++) {
buf[0] = (char) ('a' + i);
if (GetVolumeInformationA(buf, NULL, 0, NULL, NULL, NULL, NULL, 0)
|| (GetLastError() == ERROR_NOT_READY)) {
elemPtr = Tcl_NewStringObj(buf, -1);
Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
}
}
} else {
for (p = buf; *p != '\0'; p += 4) {
p[2] = '/';
elemPtr = Tcl_NewStringObj(p, -1);
Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
}
}
Tcl_IncrRefCount(resultPtr);
return resultPtr;
}
[-- Attachment #3: tclWin32Dll.c --]
[-- Type: application/octet-stream, Size: 17963 bytes --]
/* used attribute added on line 396 - pir (23.12.2005) */
/*
* tclWin32Dll.c --
*
* This file contains the DLL entry point.
*
* Copyright (c) 1995-1996 Sun Microsystems, Inc.
* Copyright (c) 1998-2000 Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclWin32Dll.c,v 1.16 2002/06/13 09:40:01 vincentdarley Exp $
*/
#include "tclWinInt.h"
/*
* The following data structures are used when loading the thunking
* library for execing child processes under Win32s.
*/
typedef DWORD (WINAPI UT32PROC)(LPVOID lpBuff, DWORD dwUserDefined,
LPVOID *lpTranslationList);
typedef BOOL (WINAPI UTREGISTER)(HANDLE hModule, LPCSTR SixteenBitDLL,
LPCSTR InitName, LPCSTR ProcName, UT32PROC **ThirtyTwoBitThunk,
FARPROC UT32Callback, LPVOID Buff);
typedef VOID (WINAPI UTUNREGISTER)(HANDLE hModule);
/*
* The following variables keep track of information about this DLL
* on a per-instance basis. Each time this DLL is loaded, it gets its own
* new data segment with its own copy of all static and global information.
*/
static HINSTANCE hInstance; /* HINSTANCE of this DLL. */
static int platformId; /* Running under NT, or 95/98? */
#ifdef HAVE_NO_SEH
static void *ESP;
static void *EBP;
#endif /* HAVE_NO_SEH */
/*
* The following function tables are used to dispatch to either the
* wide-character or multi-byte versions of the operating system calls,
* depending on whether the Unicode calls are available.
*/
static TclWinProcs asciiProcs = {
0,
(BOOL (WINAPI *)(CONST TCHAR *, LPDCB)) BuildCommDCBA,
(TCHAR *(WINAPI *)(TCHAR *)) CharLowerA,
(BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *, BOOL)) CopyFileA,
(BOOL (WINAPI *)(CONST TCHAR *, LPSECURITY_ATTRIBUTES)) CreateDirectoryA,
(HANDLE (WINAPI *)(CONST TCHAR *, DWORD, DWORD, SECURITY_ATTRIBUTES *,
DWORD, DWORD, HANDLE)) CreateFileA,
(BOOL (WINAPI *)(CONST TCHAR *, TCHAR *, LPSECURITY_ATTRIBUTES,
LPSECURITY_ATTRIBUTES, BOOL, DWORD, LPVOID, CONST TCHAR *,
LPSTARTUPINFOA, LPPROCESS_INFORMATION)) CreateProcessA,
(BOOL (WINAPI *)(CONST TCHAR *)) DeleteFileA,
(HANDLE (WINAPI *)(CONST TCHAR *, WIN32_FIND_DATAT *)) FindFirstFileA,
(BOOL (WINAPI *)(HANDLE, WIN32_FIND_DATAT *)) FindNextFileA,
(BOOL (WINAPI *)(WCHAR *, LPDWORD)) GetComputerNameA,
(DWORD (WINAPI *)(DWORD, WCHAR *)) GetCurrentDirectoryA,
(DWORD (WINAPI *)(CONST TCHAR *)) GetFileAttributesA,
(DWORD (WINAPI *)(CONST TCHAR *, DWORD nBufferLength, WCHAR *,
TCHAR **)) GetFullPathNameA,
(DWORD (WINAPI *)(HMODULE, WCHAR *, int)) GetModuleFileNameA,
(DWORD (WINAPI *)(CONST TCHAR *, WCHAR *, DWORD)) GetShortPathNameA,
(UINT (WINAPI *)(CONST TCHAR *, CONST TCHAR *, UINT uUnique,
WCHAR *)) GetTempFileNameA,
(DWORD (WINAPI *)(DWORD, WCHAR *)) GetTempPathA,
(BOOL (WINAPI *)(CONST TCHAR *, WCHAR *, DWORD, LPDWORD, LPDWORD, LPDWORD,
WCHAR *, DWORD)) GetVolumeInformationA,
(HINSTANCE (WINAPI *)(CONST TCHAR *)) LoadLibraryA,
(TCHAR (WINAPI *)(WCHAR *, CONST TCHAR *)) lstrcpyA,
(BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *)) MoveFileA,
(BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryA,
(DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD,
WCHAR *, TCHAR **)) SearchPathA,
(BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryA,
(BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesA,
NULL,
NULL,
};
static TclWinProcs unicodeProcs = {
1,
(BOOL (WINAPI *)(CONST TCHAR *, LPDCB)) BuildCommDCBW,
(TCHAR *(WINAPI *)(TCHAR *)) CharLowerW,
(BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *, BOOL)) CopyFileW,
(BOOL (WINAPI *)(CONST TCHAR *, LPSECURITY_ATTRIBUTES)) CreateDirectoryW,
(HANDLE (WINAPI *)(CONST TCHAR *, DWORD, DWORD, SECURITY_ATTRIBUTES *,
DWORD, DWORD, HANDLE)) CreateFileW,
(BOOL (WINAPI *)(CONST TCHAR *, TCHAR *, LPSECURITY_ATTRIBUTES,
LPSECURITY_ATTRIBUTES, BOOL, DWORD, LPVOID, CONST TCHAR *,
LPSTARTUPINFOA, LPPROCESS_INFORMATION)) CreateProcessW,
(BOOL (WINAPI *)(CONST TCHAR *)) DeleteFileW,
(HANDLE (WINAPI *)(CONST TCHAR *, WIN32_FIND_DATAT *)) FindFirstFileW,
(BOOL (WINAPI *)(HANDLE, WIN32_FIND_DATAT *)) FindNextFileW,
(BOOL (WINAPI *)(WCHAR *, LPDWORD)) GetComputerNameW,
(DWORD (WINAPI *)(DWORD, WCHAR *)) GetCurrentDirectoryW,
(DWORD (WINAPI *)(CONST TCHAR *)) GetFileAttributesW,
(DWORD (WINAPI *)(CONST TCHAR *, DWORD nBufferLength, WCHAR *,
TCHAR **)) GetFullPathNameW,
(DWORD (WINAPI *)(HMODULE, WCHAR *, int)) GetModuleFileNameW,
(DWORD (WINAPI *)(CONST TCHAR *, WCHAR *, DWORD)) GetShortPathNameW,
(UINT (WINAPI *)(CONST TCHAR *, CONST TCHAR *, UINT uUnique,
WCHAR *)) GetTempFileNameW,
(DWORD (WINAPI *)(DWORD, WCHAR *)) GetTempPathW,
(BOOL (WINAPI *)(CONST TCHAR *, WCHAR *, DWORD, LPDWORD, LPDWORD, LPDWORD,
WCHAR *, DWORD)) GetVolumeInformationW,
(HINSTANCE (WINAPI *)(CONST TCHAR *)) LoadLibraryW,
(TCHAR (WINAPI *)(WCHAR *, CONST TCHAR *)) lstrcpyW,
(BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *)) MoveFileW,
(BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryW,
(DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD,
WCHAR *, TCHAR **)) SearchPathW,
(BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryW,
(BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesW,
NULL,
NULL,
};
TclWinProcs *tclWinProcs;
static Tcl_Encoding tclWinTCharEncoding;
/*
* The following declaration is for the VC++ DLL entry point.
*/
BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason,
LPVOID reserved);
#ifdef __WIN32__
#ifndef STATIC_BUILD
\f
/*
*----------------------------------------------------------------------
*
* DllEntryPoint --
*
* This wrapper function is used by Borland to invoke the
* initialization code for Tcl. It simply calls the DllMain
* routine.
*
* Results:
* See DllMain.
*
* Side effects:
* See DllMain.
*
*----------------------------------------------------------------------
*/
BOOL APIENTRY
DllEntryPoint(hInst, reason, reserved)
HINSTANCE hInst; /* Library instance handle. */
DWORD reason; /* Reason this function is being called. */
LPVOID reserved; /* Not used. */
{
return DllMain(hInst, reason, reserved);
}
\f
/*
*----------------------------------------------------------------------
*
* DllMain --
*
* This routine is called by the VC++ C run time library init
* code, or the DllEntryPoint routine. It is responsible for
* initializing various dynamically loaded libraries.
*
* Results:
* TRUE on sucess, FALSE on failure.
*
* Side effects:
* Establishes 32-to-16 bit thunk and initializes sockets library.
*
*----------------------------------------------------------------------
*/
BOOL APIENTRY
DllMain(hInst, reason, reserved)
HINSTANCE hInst; /* Library instance handle. */
DWORD reason; /* Reason this function is being called. */
LPVOID reserved; /* Not used. */
{
switch (reason) {
case DLL_PROCESS_ATTACH:
TclWinInit(hInst);
return TRUE;
case DLL_PROCESS_DETACH:
if (hInst == hInstance) {
Tcl_Finalize();
}
break;
}
return TRUE;
}
#endif /* !STATIC_BUILD */
#endif /* __WIN32__ */
\f
/*
*----------------------------------------------------------------------
*
* TclWinGetTclInstance --
*
* Retrieves the global library instance handle.
*
* Results:
* Returns the global library instance handle.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
HINSTANCE
TclWinGetTclInstance()
{
return hInstance;
}
\f
/*
*----------------------------------------------------------------------
*
* TclWinInit --
*
* This function initializes the internal state of the tcl library.
*
* Results:
* None.
*
* Side effects:
* Initializes the tclPlatformId variable.
*
*----------------------------------------------------------------------
*/
void
TclWinInit(hInst)
HINSTANCE hInst; /* Library instance handle. */
{
OSVERSIONINFO os;
hInstance = hInst;
os.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
GetVersionEx(&os);
platformId = os.dwPlatformId;
/*
* We no longer support Win32s, so just in case someone manages to
* get a runtime there, make sure they know that.
*/
if (platformId == VER_PLATFORM_WIN32s) {
panic("Win32s is not a supported platform");
}
tclWinProcs = &asciiProcs;
}
\f
/*
*----------------------------------------------------------------------
*
* TclWinGetPlatformId --
*
* Determines whether running under NT, 95, or Win32s, to allow
* runtime conditional code.
*
* Results:
* The return value is one of:
* VER_PLATFORM_WIN32s Win32s on Windows 3.1. (not supported)
* VER_PLATFORM_WIN32_WINDOWS Win32 on Windows 95.
* VER_PLATFORM_WIN32_NT Win32 on Windows NT
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclWinGetPlatformId()
{
return platformId;
}
\f
/*
*-------------------------------------------------------------------------
*
* TclWinNoBackslash --
*
* We're always iterating through a string in Windows, changing the
* backslashes to slashes for use in Tcl.
*
* Results:
* All backslashes in given string are changed to slashes.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
char *
TclWinNoBackslash(
char *path) /* String to change. */
{
char *p;
for (p = path; *p != '\0'; p++) {
if (*p == '\\') {
*p = '/';
}
}
return path;
}
\f
/*
*----------------------------------------------------------------------
*
* TclpCheckStackSpace --
*
* Detect if we are about to blow the stack. Called before an
* evaluation can happen when nesting depth is checked.
*
* Results:
* 1 if there is enough stack space to continue; 0 if not.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclpCheckStackSpace()
{
int retval = 0;
/*
* We can recurse only if there is at least TCL_WIN_STACK_THRESHOLD
* bytes of stack space left. alloca() is cheap on windows; basically
* it just subtracts from the stack pointer causing the OS to throw an
* exception if the stack pointer is set below the bottom of the stack.
*/
#ifdef HAVE_NO_SEH
__asm__ __volatile__ (
"movl %esp, _ESP" "\n\t"
"movl %ebp, _EBP");
__asm__ __volatile__ (
"pushl $__except_checkstackspace_handler" "\n\t"
"pushl %fs:0" "\n\t"
"mov %esp, %fs:0");
#else
__try {
#endif /* HAVE_NO_SEH */
alloca(TCL_WIN_STACK_THRESHOLD);
retval = 1;
#ifdef HAVE_NO_SEH
__asm__ __volatile__ (
"jmp checkstackspace_pop" "\n"
"checkstackspace_reentry:" "\n\t"
"movl _ESP, %esp" "\n\t"
"movl _EBP, %ebp");
__asm__ __volatile__ (
"checkstackspace_pop:" "\n\t"
"mov (%esp), %eax" "\n\t"
"mov %eax, %fs:0" "\n\t"
"add $8, %esp");
#else
} __except (EXCEPTION_EXECUTE_HANDLER) {}
#endif /* HAVE_NO_SEH */
/*
* Avoid using control flow statements in the SEH guarded block!
*/
return retval;
}
#ifdef HAVE_NO_SEH
static
__attribute__ ((used, /* pir - 23.12.2005 */cdecl))
EXCEPTION_DISPOSITION
_except_checkstackspace_handler(
struct _EXCEPTION_RECORD *ExceptionRecord,
void *EstablisherFrame,
struct _CONTEXT *ContextRecord,
void *DispatcherContext)
{
__asm__ __volatile__ (
"jmp checkstackspace_reentry");
return 0; /* Function does not return */
}
#endif /* HAVE_NO_SEH */
\f
/*
*----------------------------------------------------------------------
*
* TclWinGetPlatform --
*
* This is a kludge that allows the test library to get access
* the internal tclPlatform variable.
*
* Results:
* Returns a pointer to the tclPlatform variable.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
TclPlatformType *
TclWinGetPlatform()
{
return &tclPlatform;
}
\f
/*
*---------------------------------------------------------------------------
*
* TclWinSetInterfaces --
*
* A helper proc that allows the test library to change the
* tclWinProcs structure to dispatch to either the wide-character
* or multi-byte versions of the operating system calls, depending
* on whether Unicode is the system encoding.
*
* As well as this, we can also try to load in some additional
* procs which may/may not be present depending on the current
* Windows version (e.g. Win95 will not have the procs below).
*
* Results:
* None.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
void
TclWinSetInterfaces(
int wide) /* Non-zero to use wide interfaces, 0
* otherwise. */
{
Tcl_FreeEncoding(tclWinTCharEncoding);
if (wide) {
tclWinProcs = &unicodeProcs;
tclWinTCharEncoding = Tcl_GetEncoding(NULL, "unicode");
if (tclWinProcs->getFileAttributesExProc == NULL) {
HINSTANCE hInstance = LoadLibraryA("kernel32");
if (hInstance != NULL) {
tclWinProcs->getFileAttributesExProc =
(BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS,
LPVOID)) GetProcAddress(hInstance, "GetFileAttributesExW");
tclWinProcs->createHardLinkProc =
(BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*,
LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance,
"CreateHardLinkW");
FreeLibrary(hInstance);
}
}
} else {
tclWinProcs = &asciiProcs;
tclWinTCharEncoding = NULL;
if (tclWinProcs->getFileAttributesExProc == NULL) {
HINSTANCE hInstance = LoadLibraryA("kernel32");
if (hInstance != NULL) {
tclWinProcs->getFileAttributesExProc =
(BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS,
LPVOID)) GetProcAddress(hInstance, "GetFileAttributesExA");
tclWinProcs->createHardLinkProc =
(BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*,
LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance,
"CreateHardLinkA");
FreeLibrary(hInstance);
}
}
}
}
\f
/*
*---------------------------------------------------------------------------
*
* Tcl_WinUtfToTChar, Tcl_WinTCharToUtf --
*
* Convert between UTF-8 and Unicode when running Windows NT or
* the current ANSI code page when running Windows 95.
*
* On Mac, Unix, and Windows 95, all strings exchanged between Tcl
* and the OS are "char" oriented. We need only one Tcl_Encoding to
* convert between UTF-8 and the system's native encoding. We use
* NULL to represent that encoding.
*
* On NT, some strings exchanged between Tcl and the OS are "char"
* oriented, while others are in Unicode. We need two Tcl_Encoding
* APIs depending on whether we are targeting a "char" or Unicode
* interface.
*
* Calling Tcl_UtfToExternal() or Tcl_ExternalToUtf() with an
* encoding of NULL should always used to convert between UTF-8
* and the system's "char" oriented encoding. The following two
* functions are used in Windows-specific code to convert between
* UTF-8 and Unicode strings (NT) or "char" strings(95). This saves
* you the trouble of writing the following type of fragment over and
* over:
*
* if (running NT) {
* encoding <- Tcl_GetEncoding("unicode");
* nativeBuffer <- UtfToExternal(encoding, utfBuffer);
* Tcl_FreeEncoding(encoding);
* } else {
* nativeBuffer <- UtfToExternal(NULL, utfBuffer);
* }
*
* By convention, in Windows a TCHAR is a character in the ANSI code
* page on Windows 95, a Unicode character on Windows NT. If you
* plan on targeting a Unicode interfaces when running on NT and a
* "char" oriented interface while running on 95, these functions
* should be used. If you plan on targetting the same "char"
* oriented function on both 95 and NT, use Tcl_UtfToExternal()
* with an encoding of NULL.
*
* Results:
* The result is a pointer to the string in the desired target
* encoding. Storage for the result string is allocated in
* dsPtr; the caller must call Tcl_DStringFree() when the result
* is no longer needed.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
TCHAR *
Tcl_WinUtfToTChar(string, len, dsPtr)
CONST char *string; /* Source string in UTF-8. */
int len; /* Source string length in bytes, or < 0 for
* strlen(). */
Tcl_DString *dsPtr; /* Uninitialized or free DString in which
* the converted string is stored. */
{
return (TCHAR *) Tcl_UtfToExternalDString(tclWinTCharEncoding,
string, len, dsPtr);
}
char *
Tcl_WinTCharToUtf(string, len, dsPtr)
CONST TCHAR *string; /* Source string in Unicode when running
* NT, ANSI when running 95. */
int len; /* Source string length in bytes, or < 0 for
* platform-specific string length. */
Tcl_DString *dsPtr; /* Uninitialized or free DString in which
* the converted string is stored. */
{
return Tcl_ExternalToUtfDString(tclWinTCharEncoding,
(CONST char *) string, len, dsPtr);
}
[-- Attachment #4: tclWinChan.c --]
[-- Type: application/octet-stream, Size: 36738 bytes --]
/* used attribute added on line 1109 - pir (23.12.2005) */
/*
* tclWinChan.c
*
* Channel drivers for Windows channels based on files, command
* pipes and TCP sockets.
*
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclWinChan.c,v 1.24 2002/07/08 10:08:58 vincentdarley Exp $
*/
#include "tclWinInt.h"
/*
* State flags used in the info structures below.
*/
#define FILE_PENDING (1<<0) /* Message is pending in the queue. */
#define FILE_ASYNC (1<<1) /* Channel is non-blocking. */
#define FILE_APPEND (1<<2) /* File is in append mode. */
#define FILE_TYPE_SERIAL (FILE_TYPE_PIPE+1)
#define FILE_TYPE_CONSOLE (FILE_TYPE_PIPE+2)
/*
* The following structure contains per-instance data for a file based channel.
*/
typedef struct FileInfo {
Tcl_Channel channel; /* Pointer to channel structure. */
int validMask; /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, or TCL_EXCEPTION: indicates
* which operations are valid on the file. */
int watchMask; /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, or TCL_EXCEPTION: indicates
* which events should be reported. */
int flags; /* State flags, see above for a list. */
HANDLE handle; /* Input/output file. */
struct FileInfo *nextPtr; /* Pointer to next registered file. */
int dirty; /* Boolean flag. Set if the OS may have data
* pending on the channel */
} FileInfo;
typedef struct ThreadSpecificData {
/*
* List of all file channels currently open.
*/
FileInfo *firstFilePtr;
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* The following structure is what is added to the Tcl event queue when
* file events are generated.
*/
typedef struct FileEvent {
Tcl_Event header; /* Information that is standard for
* all events. */
FileInfo *infoPtr; /* Pointer to file info structure. Note
* that we still have to verify that the
* file exists before dereferencing this
* pointer. */
} FileEvent;
/*
* Static routines for this file:
*/
static int FileBlockProc _ANSI_ARGS_((ClientData instanceData,
int mode));
static void FileChannelExitHandler _ANSI_ARGS_((
ClientData clientData));
static void FileCheckProc _ANSI_ARGS_((ClientData clientData,
int flags));
static int FileCloseProc _ANSI_ARGS_((ClientData instanceData,
Tcl_Interp *interp));
static int FileEventProc _ANSI_ARGS_((Tcl_Event *evPtr,
int flags));
static int FileGetHandleProc _ANSI_ARGS_((ClientData instanceData,
int direction, ClientData *handlePtr));
static ThreadSpecificData *FileInit _ANSI_ARGS_((void));
static int FileInputProc _ANSI_ARGS_((ClientData instanceData,
char *buf, int toRead, int *errorCode));
static int FileOutputProc _ANSI_ARGS_((ClientData instanceData,
CONST char *buf, int toWrite, int *errorCode));
static int FileSeekProc _ANSI_ARGS_((ClientData instanceData,
long offset, int mode, int *errorCode));
static Tcl_WideInt FileWideSeekProc _ANSI_ARGS_((ClientData instanceData,
Tcl_WideInt offset, int mode, int *errorCode));
static void FileSetupProc _ANSI_ARGS_((ClientData clientData,
int flags));
static void FileWatchProc _ANSI_ARGS_((ClientData instanceData,
int mask));
/*
* This structure describes the channel type structure for file based IO.
*/
static Tcl_ChannelType fileChannelType = {
"file", /* Type name. */
TCL_CHANNEL_VERSION_3, /* v3 channel */
FileCloseProc, /* Close proc. */
FileInputProc, /* Input proc. */
FileOutputProc, /* Output proc. */
FileSeekProc, /* Seek proc. */
NULL, /* Set option proc. */
NULL, /* Get option proc. */
FileWatchProc, /* Set up the notifier to watch the channel. */
FileGetHandleProc, /* Get an OS handle from channel. */
NULL, /* close2proc. */
FileBlockProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
FileWideSeekProc, /* Wide seek proc. */
};
#ifdef HAVE_NO_SEH
static void *ESP;
static void *EBP;
#endif /* HAVE_NO_SEH */
\f
/*
*----------------------------------------------------------------------
*
* FileInit --
*
* This function creates the window used to simulate file events.
*
* Results:
* None.
*
* Side effects:
* Creates a new window and creates an exit handler.
*
*----------------------------------------------------------------------
*/
static ThreadSpecificData *
FileInit()
{
ThreadSpecificData *tsdPtr =
(ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
if (tsdPtr == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
tsdPtr->firstFilePtr = NULL;
Tcl_CreateEventSource(FileSetupProc, FileCheckProc, NULL);
Tcl_CreateThreadExitHandler(FileChannelExitHandler, NULL);
}
return tsdPtr;
}
\f
/*
*----------------------------------------------------------------------
*
* FileChannelExitHandler --
*
* This function is called to cleanup the channel driver before
* Tcl is unloaded.
*
* Results:
* None.
*
* Side effects:
* Destroys the communication window.
*
*----------------------------------------------------------------------
*/
static void
FileChannelExitHandler(clientData)
ClientData clientData; /* Old window proc */
{
Tcl_DeleteEventSource(FileSetupProc, FileCheckProc, NULL);
}
\f
/*
*----------------------------------------------------------------------
*
* FileSetupProc --
*
* This procedure is invoked before Tcl_DoOneEvent blocks waiting
* for an event.
*
* Results:
* None.
*
* Side effects:
* Adjusts the block time if needed.
*
*----------------------------------------------------------------------
*/
void
FileSetupProc(data, flags)
ClientData data; /* Not used. */
int flags; /* Event flags as passed to Tcl_DoOneEvent. */
{
FileInfo *infoPtr;
Tcl_Time blockTime = { 0, 0 };
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!(flags & TCL_FILE_EVENTS)) {
return;
}
/*
* Check to see if there is a ready file. If so, poll.
*/
for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (infoPtr->watchMask) {
Tcl_SetMaxBlockTime(&blockTime);
break;
}
}
}
\f
/*
*----------------------------------------------------------------------
*
* FileCheckProc --
*
* This procedure is called by Tcl_DoOneEvent to check the file
* event source for events.
*
* Results:
* None.
*
* Side effects:
* May queue an event.
*
*----------------------------------------------------------------------
*/
static void
FileCheckProc(data, flags)
ClientData data; /* Not used. */
int flags; /* Event flags as passed to Tcl_DoOneEvent. */
{
FileEvent *evPtr;
FileInfo *infoPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!(flags & TCL_FILE_EVENTS)) {
return;
}
/*
* Queue events for any ready files that don't already have events
* queued (caused by persistent states that won't generate WinSock
* events).
*/
for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (infoPtr->watchMask && !(infoPtr->flags & FILE_PENDING)) {
infoPtr->flags |= FILE_PENDING;
evPtr = (FileEvent *) ckalloc(sizeof(FileEvent));
evPtr->header.proc = FileEventProc;
evPtr->infoPtr = infoPtr;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
}
}
}
\f
/*----------------------------------------------------------------------
*
* FileEventProc --
*
* This function is invoked by Tcl_ServiceEvent when a file event
* reaches the front of the event queue. This procedure invokes
* Tcl_NotifyChannel on the file.
*
* Results:
* Returns 1 if the event was handled, meaning it should be removed
* from the queue. Returns 0 if the event was not handled, meaning
* it should stay on the queue. The only time the event isn't
* handled is if the TCL_FILE_EVENTS flag bit isn't set.
*
* Side effects:
* Whatever the notifier callback does.
*
*----------------------------------------------------------------------
*/
static int
FileEventProc(evPtr, flags)
Tcl_Event *evPtr; /* Event to service. */
int flags; /* Flags that indicate what events to
* handle, such as TCL_FILE_EVENTS. */
{
FileEvent *fileEvPtr = (FileEvent *)evPtr;
FileInfo *infoPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!(flags & TCL_FILE_EVENTS)) {
return 0;
}
/*
* Search through the list of watched files for the one whose handle
* matches the event. We do this rather than simply dereferencing
* the handle in the event so that files can be deleted while the
* event is in the queue.
*/
for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (fileEvPtr->infoPtr == infoPtr) {
infoPtr->flags &= ~(FILE_PENDING);
Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask);
break;
}
}
return 1;
}
\f
/*
*----------------------------------------------------------------------
*
* FileBlockProc --
*
* Set blocking or non-blocking mode on channel.
*
* Results:
* 0 if successful, errno when failed.
*
* Side effects:
* Sets the device into blocking or non-blocking mode.
*
*----------------------------------------------------------------------
*/
static int
FileBlockProc(instanceData, mode)
ClientData instanceData; /* Instance data for channel. */
int mode; /* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
FileInfo *infoPtr = (FileInfo *) instanceData;
/*
* Files on Windows can not be switched between blocking and nonblocking,
* hence we have to emulate the behavior. This is done in the input
* function by checking against a bit in the state. We set or unset the
* bit here to cause the input function to emulate the correct behavior.
*/
if (mode == TCL_MODE_NONBLOCKING) {
infoPtr->flags |= FILE_ASYNC;
} else {
infoPtr->flags &= ~(FILE_ASYNC);
}
return 0;
}
\f
/*
*----------------------------------------------------------------------
*
* FileCloseProc --
*
* Closes the IO channel.
*
* Results:
* 0 if successful, the value of errno if failed.
*
* Side effects:
* Closes the physical channel
*
*----------------------------------------------------------------------
*/
static int
FileCloseProc(instanceData, interp)
ClientData instanceData; /* Pointer to FileInfo structure. */
Tcl_Interp *interp; /* Not used. */
{
FileInfo *fileInfoPtr = (FileInfo *) instanceData;
FileInfo **nextPtrPtr;
int errorCode = 0;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* Remove the file from the watch list.
*/
FileWatchProc(instanceData, 0);
/*
* Don't close the Win32 handle if the handle is a standard channel
* during the exit process. Otherwise, one thread may kill the stdio
* of another.
*/
if (!TclInExit()
|| ((GetStdHandle(STD_INPUT_HANDLE) != fileInfoPtr->handle)
&& (GetStdHandle(STD_OUTPUT_HANDLE) != fileInfoPtr->handle)
&& (GetStdHandle(STD_ERROR_HANDLE) != fileInfoPtr->handle))) {
if (CloseHandle(fileInfoPtr->handle) == FALSE) {
TclWinConvertError(GetLastError());
errorCode = errno;
}
}
for (nextPtrPtr = &(tsdPtr->firstFilePtr); (*nextPtrPtr) != NULL;
nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
if ((*nextPtrPtr) == fileInfoPtr) {
(*nextPtrPtr) = fileInfoPtr->nextPtr;
break;
}
}
ckfree((char *)fileInfoPtr);
return errorCode;
}
\f
/*
*----------------------------------------------------------------------
*
* FileSeekProc --
*
* Seeks on a file-based channel. Returns the new position.
*
* Results:
* -1 if failed, the new position if successful. If failed, it
* also sets *errorCodePtr to the error code.
*
* Side effects:
* Moves the location at which the channel will be accessed in
* future operations.
*
*----------------------------------------------------------------------
*/
static int
FileSeekProc(instanceData, offset, mode, errorCodePtr)
ClientData instanceData; /* File state. */
long offset; /* Offset to seek to. */
int mode; /* Relative to where should we seek? */
int *errorCodePtr; /* To store error code. */
{
FileInfo *infoPtr = (FileInfo *) instanceData;
DWORD moveMethod;
DWORD newPos, newPosHigh;
DWORD oldPos, oldPosHigh;
*errorCodePtr = 0;
if (mode == SEEK_SET) {
moveMethod = FILE_BEGIN;
} else if (mode == SEEK_CUR) {
moveMethod = FILE_CURRENT;
} else {
moveMethod = FILE_END;
}
/*
* Save our current place in case we need to roll-back the seek.
*/
oldPosHigh = (DWORD)0;
oldPos = SetFilePointer(infoPtr->handle, (LONG)0, &oldPosHigh,
FILE_CURRENT);
if (oldPos == INVALID_SET_FILE_POINTER) {
int winError = GetLastError();
if (winError != NO_ERROR) {
TclWinConvertError(winError);
*errorCodePtr = errno;
return -1;
}
}
newPosHigh = (DWORD)(offset < 0 ? -1 : 0);
newPos = SetFilePointer(infoPtr->handle, (LONG) offset, &newPosHigh,
moveMethod);
if (newPos == INVALID_SET_FILE_POINTER) {
int winError = GetLastError();
if (winError != NO_ERROR) {
TclWinConvertError(winError);
*errorCodePtr = errno;
return -1;
}
}
/*
* Check for expressability in our return type, and roll-back otherwise.
*/
if (newPosHigh != 0) {
*errorCodePtr = EOVERFLOW;
SetFilePointer(infoPtr->handle, (LONG)oldPos, &oldPosHigh, FILE_BEGIN);
return -1;
}
return (int) newPos;
}
\f
/*
*----------------------------------------------------------------------
*
* FileWideSeekProc --
*
* Seeks on a file-based channel. Returns the new position.
*
* Results:
* -1 if failed, the new position if successful. If failed, it
* also sets *errorCodePtr to the error code.
*
* Side effects:
* Moves the location at which the channel will be accessed in
* future operations.
*
*----------------------------------------------------------------------
*/
static Tcl_WideInt
FileWideSeekProc(instanceData, offset, mode, errorCodePtr)
ClientData instanceData; /* File state. */
Tcl_WideInt offset; /* Offset to seek to. */
int mode; /* Relative to where should we seek? */
int *errorCodePtr; /* To store error code. */
{
FileInfo *infoPtr = (FileInfo *) instanceData;
DWORD moveMethod;
DWORD newPos, newPosHigh;
*errorCodePtr = 0;
if (mode == SEEK_SET) {
moveMethod = FILE_BEGIN;
} else if (mode == SEEK_CUR) {
moveMethod = FILE_CURRENT;
} else {
moveMethod = FILE_END;
}
newPosHigh = (DWORD)(offset >> 32);
newPos = SetFilePointer(infoPtr->handle, (LONG) offset, &newPosHigh,
moveMethod);
if (newPos == INVALID_SET_FILE_POINTER) {
int winError = GetLastError();
if (winError != NO_ERROR) {
TclWinConvertError(winError);
*errorCodePtr = errno;
return -1;
}
}
return ((Tcl_WideInt) newPos) | (((Tcl_WideInt) newPosHigh) << 32);
}
\f
/*
*----------------------------------------------------------------------
*
* FileInputProc --
*
* Reads input from the IO channel into the buffer given. Returns
* count of how many bytes were actually read, and an error indication.
*
* Results:
* A count of how many bytes were read is returned and an error
* indication is returned in an output argument.
*
* Side effects:
* Reads input from the actual channel.
*
*----------------------------------------------------------------------
*/
static int
FileInputProc(instanceData, buf, bufSize, errorCode)
ClientData instanceData; /* File state. */
char *buf; /* Where to store data read. */
int bufSize; /* How much space is available
* in the buffer? */
int *errorCode; /* Where to store error code. */
{
FileInfo *infoPtr;
DWORD bytesRead;
*errorCode = 0;
infoPtr = (FileInfo *) instanceData;
/*
* Note that we will block on reads from a console buffer until a
* full line has been entered. The only way I know of to get
* around this is to write a console driver. We should probably
* do this at some point, but for now, we just block. The same
* problem exists for files being read over the network.
*/
if (ReadFile(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &bytesRead,
(LPOVERLAPPED) NULL) != FALSE) {
return bytesRead;
}
TclWinConvertError(GetLastError());
*errorCode = errno;
if (errno == EPIPE) {
return 0;
}
return -1;
}
\f
/*
*----------------------------------------------------------------------
*
* FileOutputProc --
*
* Writes the given output on the IO channel. Returns count of how
* many characters were actually written, and an error indication.
*
* Results:
* A count of how many characters were written is returned and an
* error indication is returned in an output argument.
*
* Side effects:
* Writes output on the actual channel.
*
*----------------------------------------------------------------------
*/
static int
FileOutputProc(instanceData, buf, toWrite, errorCode)
ClientData instanceData; /* File state. */
CONST char *buf; /* The data buffer. */
int toWrite; /* How many bytes to write? */
int *errorCode; /* Where to store error code. */
{
FileInfo *infoPtr = (FileInfo *) instanceData;
DWORD bytesWritten;
*errorCode = 0;
/*
* If we are writing to a file that was opened with O_APPEND, we need to
* seek to the end of the file before writing the current buffer.
*/
if (infoPtr->flags & FILE_APPEND) {
SetFilePointer(infoPtr->handle, 0, NULL, FILE_END);
}
if (WriteFile(infoPtr->handle, (LPVOID) buf, (DWORD) toWrite, &bytesWritten,
(LPOVERLAPPED) NULL) == FALSE) {
TclWinConvertError(GetLastError());
*errorCode = errno;
return -1;
}
infoPtr->dirty = 1;
return bytesWritten;
}
\f
/*
*----------------------------------------------------------------------
*
* FileWatchProc --
*
* Called by the notifier to set up to watch for events on this
* channel.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
FileWatchProc(instanceData, mask)
ClientData instanceData; /* File state. */
int mask; /* What events to watch for; OR-ed
* combination of TCL_READABLE,
* TCL_WRITABLE and TCL_EXCEPTION. */
{
FileInfo *infoPtr = (FileInfo *) instanceData;
Tcl_Time blockTime = { 0, 0 };
/*
* Since the file is always ready for events, we set the block time
* to zero so we will poll.
*/
infoPtr->watchMask = mask & infoPtr->validMask;
if (infoPtr->watchMask) {
Tcl_SetMaxBlockTime(&blockTime);
}
}
\f
/*
*----------------------------------------------------------------------
*
* FileGetHandleProc --
*
* Called from Tcl_GetChannelHandle to retrieve OS handles from
* a file based channel.
*
* Results:
* Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if
* there is no handle for the specified direction.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
FileGetHandleProc(instanceData, direction, handlePtr)
ClientData instanceData; /* The file state. */
int direction; /* TCL_READABLE or TCL_WRITABLE */
ClientData *handlePtr; /* Where to store the handle. */
{
FileInfo *infoPtr = (FileInfo *) instanceData;
if (direction & infoPtr->validMask) {
*handlePtr = (ClientData) infoPtr->handle;
return TCL_OK;
} else {
return TCL_ERROR;
}
}
\f
/*
*----------------------------------------------------------------------
*
* TclpOpenFileChannel --
*
* Open an File based channel on Unix systems.
*
* Results:
* The new channel or NULL. If NULL, the output argument
* errorCodePtr is set to a POSIX error.
*
* Side effects:
* May open the channel and may cause creation of a file on the
* file system.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
TclpOpenFileChannel(interp, pathPtr, mode, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
* can be NULL. */
Tcl_Obj *pathPtr; /* Name of file to open. */
int mode; /* POSIX mode. */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
Tcl_Channel channel = 0;
int channelPermissions;
DWORD accessMode, createMode, shareMode, flags, consoleParams, type;
CONST TCHAR *nativeName;
DCB dcb;
HANDLE handle;
char channelName[16 + TCL_INTEGER_SPACE];
TclFile readFile = NULL;
TclFile writeFile = NULL;
nativeName = (TCHAR*) Tcl_FSGetNativePath(pathPtr);
if (nativeName == NULL) {
return NULL;
}
switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
case O_RDONLY:
accessMode = GENERIC_READ;
channelPermissions = TCL_READABLE;
break;
case O_WRONLY:
accessMode = GENERIC_WRITE;
channelPermissions = TCL_WRITABLE;
break;
case O_RDWR:
accessMode = (GENERIC_READ | GENERIC_WRITE);
channelPermissions = (TCL_READABLE | TCL_WRITABLE);
break;
default:
panic("TclpOpenFileChannel: invalid mode value");
break;
}
/*
* 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 being created, get the file attributes from the
* permissions argument, else use the existing file attributes.
*/
if (mode & O_CREAT) {
if (permissions & S_IWRITE) {
flags = FILE_ATTRIBUTE_NORMAL;
} else {
flags = FILE_ATTRIBUTE_READONLY;
}
} else {
flags = (*tclWinProcs->getFileAttributesProc)(nativeName);
if (flags == 0xFFFFFFFF) {
flags = 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 = (*tclWinProcs->createFileProc)(nativeName, accessMode,
shareMode, NULL, createMode, flags, (HANDLE) NULL);
if (handle == INVALID_HANDLE_VALUE) {
DWORD err;
err = GetLastError();
if ((err & 0xffffL) == ERROR_OPEN_FAILED) {
err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND;
}
TclWinConvertError(err);
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp, "couldn't open \"",
Tcl_GetString(pathPtr), "\": ",
Tcl_PosixError(interp), (char *) NULL);
}
return NULL;
}
type = GetFileType(handle);
/*
* If the file is a character device, we need to try to figure out
* whether it is a serial port, a console, or something else. We
* test for the console case first because this is more common.
*/
if (type == FILE_TYPE_CHAR) {
if (GetConsoleMode(handle, &consoleParams)) {
type = FILE_TYPE_CONSOLE;
} else {
dcb.DCBlength = sizeof( DCB ) ;
if (GetCommState(handle, &dcb)) {
type = FILE_TYPE_SERIAL;
}
}
}
channel = NULL;
switch (type) {
case FILE_TYPE_SERIAL:
/*
* Reopen channel for OVERLAPPED operation
* Normally this shouldn't fail, because the channel exists
*/
handle = TclWinSerialReopen(handle, nativeName, accessMode);
if (handle == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp, "couldn't reopen serial \"",
Tcl_GetString(pathPtr), "\": ",
Tcl_PosixError(interp), (char *) NULL);
}
return NULL;
}
channel = TclWinOpenSerialChannel(handle, channelName,
channelPermissions);
break;
case FILE_TYPE_CONSOLE:
channel = TclWinOpenConsoleChannel(handle, channelName,
channelPermissions);
break;
case FILE_TYPE_PIPE:
if (channelPermissions & TCL_READABLE) {
readFile = TclWinMakeFile(handle);
}
if (channelPermissions & TCL_WRITABLE) {
writeFile = TclWinMakeFile(handle);
}
channel = TclpCreateCommandChannel(readFile, writeFile, NULL, 0, NULL);
break;
case FILE_TYPE_CHAR:
case FILE_TYPE_DISK:
case FILE_TYPE_UNKNOWN:
channel = TclWinOpenFileChannel(handle, channelName,
channelPermissions,
(mode & O_APPEND) ? FILE_APPEND : 0);
break;
default:
/*
* The handle is of an unknown type, probably /dev/nul equivalent
* or possibly a closed handle.
*/
channel = NULL;
Tcl_AppendResult(interp, "couldn't open \"",
Tcl_GetString(pathPtr), "\": ",
"bad file type", (char *) NULL);
break;
}
return channel;
}
\f
/*
*----------------------------------------------------------------------
*
* Tcl_MakeFileChannel --
*
* Creates a Tcl_Channel from an existing platform specific file
* handle.
*
* Results:
* The Tcl_Channel created around the preexisting file.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_MakeFileChannel(rawHandle, mode)
ClientData rawHandle; /* OS level handle */
int mode; /* ORed combination of TCL_READABLE and
* TCL_WRITABLE to indicate file mode. */
{
char channelName[16 + TCL_INTEGER_SPACE];
Tcl_Channel channel = NULL;
HANDLE handle = (HANDLE) rawHandle;
HANDLE dupedHandle;
DCB dcb;
DWORD consoleParams, type;
TclFile readFile = NULL;
TclFile writeFile = NULL;
BOOL result;
if (mode == 0) {
return NULL;
}
/*
* GetFileType() returns FILE_TYPE_UNKNOWN for invalid handles.
*/
type = GetFileType(handle);
/*
* If the file is a character device, we need to try to figure out
* whether it is a serial port, a console, or something else. We
* test for the console case first because this is more common.
*/
if (type == FILE_TYPE_CHAR) {
if (GetConsoleMode(handle, &consoleParams)) {
type = FILE_TYPE_CONSOLE;
} else {
dcb.DCBlength = sizeof( DCB ) ;
if (GetCommState(handle, &dcb)) {
type = FILE_TYPE_SERIAL;
}
}
}
switch (type)
{
case FILE_TYPE_SERIAL:
channel = TclWinOpenSerialChannel(handle, channelName, mode);
break;
case FILE_TYPE_CONSOLE:
channel = TclWinOpenConsoleChannel(handle, channelName, mode);
break;
case FILE_TYPE_PIPE:
if (mode & TCL_READABLE)
{
readFile = TclWinMakeFile(handle);
}
if (mode & TCL_WRITABLE)
{
writeFile = TclWinMakeFile(handle);
}
channel = TclpCreateCommandChannel(readFile, writeFile, NULL, 0, NULL);
break;
case FILE_TYPE_DISK:
case FILE_TYPE_CHAR:
channel = TclWinOpenFileChannel(handle, channelName, mode, 0);
break;
case FILE_TYPE_UNKNOWN:
default:
/*
* The handle is of an unknown type. Test the validity of this OS
* handle by duplicating it, then closing the dupe. The Win32 API
* doesn't provide an IsValidHandle() function, so we have to emulate
* it here. This test will not work on a console handle reliably,
* which is why we can't test every handle that comes into this
* function in this way.
*/
result = DuplicateHandle(GetCurrentProcess(), handle,
GetCurrentProcess(), &dupedHandle, 0, FALSE,
DUPLICATE_SAME_ACCESS);
if (result != 0) {
/*
* Unable to make a duplicate. It's definately invalid at this
* point.
*/
return NULL;
}
/*
* Use structured exception handling (Win32 SEH) to protect the close
* of this duped handle which might throw EXCEPTION_INVALID_HANDLE.
*/
#ifdef HAVE_NO_SEH
__asm__ __volatile__ (
"movl %esp, _ESP" "\n\t"
"movl %ebp, _EBP");
__asm__ __volatile__ (
"pushl $__except_makefilechannel_handler" "\n\t"
"pushl %fs:0" "\n\t"
"mov %esp, %fs:0");
result = 0;
#else
__try {
#endif /* HAVE_NO_SEH */
CloseHandle(dupedHandle);
#ifdef HAVE_NO_SEH
__asm__ __volatile__ (
"jmp makefilechannel_pop" "\n"
"makefilechannel_reentry:" "\n\t"
"movl _ESP, %esp" "\n\t"
"movl _EBP, %ebp");
result = 1; /* True when exception was raised */
__asm__ __volatile__ (
"makefilechannel_pop:" "\n\t"
"mov (%esp), %eax" "\n\t"
"mov %eax, %fs:0" "\n\t"
"add $8, %esp");
if (result)
return NULL;
#else
}
__except (EXCEPTION_EXECUTE_HANDLER) {
/*
* Definately an invalid handle. So, therefore, the original
* is invalid also.
*/
return NULL;
}
#endif /* HAVE_NO_SEH */
/* Fall through, the handle is valid. */
/*
* Create the undefined channel, anyways, because we know the handle
* is valid to something.
*/
channel = TclWinOpenFileChannel(handle, channelName, mode, 0);
}
return channel;
}
#ifdef HAVE_NO_SEH
static
__attribute__ ((used,/* pir - 23.12.2005 */cdecl))
EXCEPTION_DISPOSITION
_except_makefilechannel_handler(
struct _EXCEPTION_RECORD *ExceptionRecord,
void *EstablisherFrame,
struct _CONTEXT *ContextRecord,
void *DispatcherContext)
{
__asm__ __volatile__ (
"jmp makefilechannel_reentry");
return 0; /* Function does not return */
}
#endif
\f
/*
*----------------------------------------------------------------------
*
* TclpGetDefaultStdChannel --
*
* Constructs a channel for the specified standard OS handle.
*
* Results:
* Returns the specified default standard channel, or NULL.
*
* Side effects:
* May cause the creation of a standard channel and the underlying
* file.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
TclpGetDefaultStdChannel(type)
int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */
{
Tcl_Channel channel;
HANDLE handle;
int mode;
char *bufMode;
DWORD handleId; /* Standard handle to retrieve. */
switch (type) {
case TCL_STDIN:
handleId = STD_INPUT_HANDLE;
mode = TCL_READABLE;
bufMode = "line";
break;
case TCL_STDOUT:
handleId = STD_OUTPUT_HANDLE;
mode = TCL_WRITABLE;
bufMode = "line";
break;
case TCL_STDERR:
handleId = STD_ERROR_HANDLE;
mode = TCL_WRITABLE;
bufMode = "none";
break;
default:
panic("TclGetDefaultStdChannel: Unexpected channel type");
break;
}
handle = GetStdHandle(handleId);
/*
* Note that we need to check for 0 because Windows may return 0 if this
* is not a console mode application, even though this is not a valid
* handle.
*/
if ((handle == INVALID_HANDLE_VALUE) || (handle == 0)) {
return (Tcl_Channel) NULL;
}
channel = Tcl_MakeFileChannel(handle, mode);
if (channel == NULL) {
return (Tcl_Channel) NULL;
}
/*
* Set up the normal channel options for stdio handles.
*/
if ((Tcl_SetChannelOption((Tcl_Interp *) NULL, channel, "-translation",
"auto") == TCL_ERROR)
|| (Tcl_SetChannelOption((Tcl_Interp *) NULL, channel, "-eofchar",
"\032 {}") == TCL_ERROR)
|| (Tcl_SetChannelOption((Tcl_Interp *) NULL, channel,
"-buffering", bufMode) == TCL_ERROR)) {
Tcl_Close((Tcl_Interp *) NULL, channel);
return (Tcl_Channel) NULL;
}
return channel;
}
\f
/*
*----------------------------------------------------------------------
*
* TclWinOpenFileChannel --
*
* Constructs a File channel for the specified standard OS handle.
* This is a helper function to break up the construction of
* channels into File, Console, or Serial.
*
* Results:
* Returns the new channel, or NULL.
*
* Side effects:
* May open the channel and may cause creation of a file on the
* file system.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
TclWinOpenFileChannel(handle, channelName, permissions, appendMode)
HANDLE handle;
char *channelName;
int permissions;
int appendMode;
{
FileInfo *infoPtr;
ThreadSpecificData *tsdPtr;
tsdPtr = FileInit();
/*
* See if a channel with this handle already exists.
*/
for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (infoPtr->handle == (HANDLE) handle) {
return (permissions == infoPtr->validMask) ? infoPtr->channel : NULL;
}
}
infoPtr = (FileInfo *) ckalloc((unsigned) sizeof(FileInfo));
infoPtr->nextPtr = tsdPtr->firstFilePtr;
tsdPtr->firstFilePtr = infoPtr;
infoPtr->validMask = permissions;
infoPtr->watchMask = 0;
infoPtr->flags = appendMode;
infoPtr->handle = handle;
infoPtr->dirty = 0;
wsprintfA(channelName, "file%lx", (int) infoPtr);
infoPtr->channel = Tcl_CreateChannel(&fileChannelType, channelName,
(ClientData) infoPtr, permissions);
/*
* Files have default translation of AUTO and ^Z eof char, which
* means that a ^Z will be accepted as EOF when reading.
*/
Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
return infoPtr->channel;
}
/*
*----------------------------------------------------------------------
*
* TclWinFlushDirtyChannels --
*
* Flush all dirty channels to disk, so that requesting the
* size of any file returns the correct value.
*
* Results:
* None.
*
* Side effects:
* Information is actually written to disk now, rather than
* later. Don't call this too often, or there will be a
* performance hit (i.e. only call when we need to ask for
* the size of a file).
*
*----------------------------------------------------------------------
*/
void
TclWinFlushDirtyChannels ()
{
FileInfo *infoPtr;
ThreadSpecificData *tsdPtr;
tsdPtr = FileInit();
/*
* Flush all channels which are dirty, i.e. may have data pending
* in the OS
*/
for (infoPtr = tsdPtr->firstFilePtr;
infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (infoPtr->dirty) {
FlushFileBuffers(infoPtr->handle);
infoPtr->dirty = 0;
}
}
}
^ permalink raw reply [flat|nested] 13+ messages in thread