2010-04-02  Jan Nijtmans  <nijtmans@users.sf.net>

	* generic/tcl.decls (Tcl_LoadFile): Add missing "const" in signature,
	* generic/tclIOUtil.c (Tcl_LoadFile): and some formatting fixes
	* generic/tclDecls.h   (regenerated)

2010-04-02  Donal K. Fellows  <dkf@users.sf.net>

	* generic/tclIOUtil.c (Tcl_LoadFile): Corrections to previous commit
	* unix/tclLoadDyld.c (TclpDlopen):    to make it build on OSX.

2010-04-02  Kevin B. Kenny  <kennykb@acm.org>

	TIP #357 IMPLEMENTATION

	* generic/tcl.decls:		First round of changes to export
	* generic/tclDecls.h:		Tcl_LoadFile, Tcl_FindSymbol, and
	* generic/tclIOUtil.c:		Tcl_FSUnloadFile to the public API.
	* generic/tclInt.h:
	* generic/tclLoad.c:
	* generic/tclLoadNone.c:
	* generic/tclStubInit.c:
	* tests/fileSystem.test:
	* tests/load.test:
	* tests/unload.test:
	* unix/tclLoadDl.c:
	* unix/tclLoadDyld.c:
	* unix/tclLoadNext.c:
	* unix/tclLoadOSF.c:
	* unix/tclLoadShl.c:
	* unix/tclUnixPipe.c:
	* win/Makefile.in:
	* win/tclWinLoad.c:

	* generic/tclStrToD.c: [Bug 2952904]: Defer creation of the smallest
	floating point number until it is actually used. (This change avoids a
	bogus syslog message regarding a 'floating point software assist
	fault' on SGI systems.)

	* library/reg/pkgIndex.tcl:	[TIP #362]: Fixed first round of bugs
	* tests/registry.test:		resulting from the recent commits of
	* win/tclWinReg.c:		changes in support of the referenced
					TIP.
	
2010-03-31  Donal K. Fellows  <dkf@users.sf.net>

	* doc/registry.n: Added missing documentation of TIP#362 flags.

	* doc/package.n: [Bug 2980210]: Document the arguments taken by
	the [package present] command correctly.

	* doc/Thread.3: Added some better documentation of how to create and
	use a thread using the C-level thread API, based on realization that
	no such tutorial appeared to exist.

'\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\" Copyright (c) 2002 ActiveState Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: registry.n,v 1.8.4.9 2010/04/02 23:48:14 dgp Exp $
'\" 
.so man.macros
.TH registry n 1.1 registry "Tcl Bundled Packages"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
registry \- Manipulate the Windows registry
.SH SYNOPSIS
.sp
\fBpackage require registry 1.3\fR
.sp
\fBregistry \fR?\fI\-mode\fR? \fIoption\fR \fIkeyName\fR ?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
The \fBregistry\fR package provides a general set of operations for
manipulating the Windows registry.  The package implements the
\fBregistry\fR Tcl command.  This command is only supported on the
Windows platform.  Warning: this command should be used with caution

\fIHostname\fR specifies the name of any valid Windows
host that exports its registry.  The \fIrootname\fR component must be
one of \fBHKEY_LOCAL_MACHINE\fR, \fBHKEY_USERS\fR,
\fBHKEY_CLASSES_ROOT\fR, \fBHKEY_CURRENT_USER\fR,
\fBHKEY_CURRENT_CONFIG\fR, \fBHKEY_PERFORMANCE_DATA\fR, or
\fBHKEY_DYN_DATA\fR.  The \fIkeypath\fR can be one or more
registry key names separated by backslash (\fB\e\fR) characters.
.PP
.VS 8.6
The optional \fI\-mode\fR argument indicates which registry to work
with; when it is \fB\-32bit\fR the 32-bit registry will be used, and
when it is \fB\-64bit\fR the 64-bit registry will be used. If this
argument is omitted, the system's default registry will be the subject
of the requested operation.
.VE 8.6
.PP
\fIOption\fR indicates what to do with the registry key name.  Any
unique abbreviation for \fIoption\fR is acceptable.  The valid options
are:
.TP
\fBregistry broadcast \fIkeyName\fR ?\fB\-timeout \fImilliseconds\fR?
.

# Read the command!
set command [\fBregistry get\fR $path {}]

puts "$ext opens with $command"
.CE
.SH KEYWORDS
registry
'\" Local Variables:
'\" mode: nroff
'\" End:

# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
# Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: tcl.decls,v 1.97.2.48 2010/04/02 23:48:14 dgp Exp $

library tcl

# Define the tcl interface with several sub interfaces:
#     tclPlat	 - platform specific public
#     tclInt	 - generic private
#     tclPlatInt - platform specific private

    int Tcl_NRExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *resultPtr)
}

# TIP #356 (NR-enabled substitution) dgp
declare 626 generic {
    int Tcl_NRSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
}

# TIP #357 (Export TclLoadFile and TclpFindSymbol) kbk
declare 627 generic {
    int Tcl_LoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,
		     const char *const symv[], int flags, void *procPtrs,
		     Tcl_LoadHandle *handlePtr)
}
declare 628 generic {
    void* Tcl_FindSymbol(Tcl_Interp *interp, Tcl_LoadHandle handle,
			 const char *symbol)
}
declare 629 generic {
    int Tcl_FSUnloadFile(Tcl_Interp *interp, Tcl_LoadHandle handlePtr)
}

# ----- BASELINE -- FOR -- 8.6.0 ----- #

##############################################################################

# Define the platform specific public Tcl interface. These functions are only
# available on the designated platform.

/*
 * tclDecls.h --
 *
 *	Declarations of functions in the platform independent public Tcl API.
 *
 * Copyright (c) 1998-1999 by 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: tclDecls.h,v 1.95.2.49 2010/04/02 23:48:14 dgp Exp $
 */

#ifndef _TCLDECLS
#define _TCLDECLS

#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl

#endif
#ifndef Tcl_NRSubstObj_TCL_DECLARED
#define Tcl_NRSubstObj_TCL_DECLARED
/* 626 */
EXTERN int		Tcl_NRSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
				int flags);
#endif
#ifndef Tcl_LoadFile_TCL_DECLARED
#define Tcl_LoadFile_TCL_DECLARED
/* 627 */
EXTERN int		Tcl_LoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,
				const char *const symv[], int flags,
				void *procPtrs, Tcl_LoadHandle *handlePtr);
#endif
#ifndef Tcl_FindSymbol_TCL_DECLARED
#define Tcl_FindSymbol_TCL_DECLARED
/* 628 */
EXTERN void*		Tcl_FindSymbol(Tcl_Interp *interp,
				Tcl_LoadHandle handle, const char *symbol);
#endif
#ifndef Tcl_FSUnloadFile_TCL_DECLARED
#define Tcl_FSUnloadFile_TCL_DECLARED
/* 629 */
EXTERN int		Tcl_FSUnloadFile(Tcl_Interp *interp,
				Tcl_LoadHandle handlePtr);
#endif

typedef struct TclStubHooks {
    const struct TclPlatStubs *tclPlatStubs;
    const struct TclIntStubs *tclIntStubs;
    const struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;

    int (*tcl_ZlibStreamClose) (Tcl_ZlibStream zshandle); /* 620 */
    int (*tcl_ZlibStreamReset) (Tcl_ZlibStream zshandle); /* 621 */
    void (*tcl_SetStartupScript) (Tcl_Obj *path, const char *encoding); /* 622 */
    Tcl_Obj * (*tcl_GetStartupScript) (const char **encodingPtr); /* 623 */
    int (*tcl_CloseEx) (Tcl_Interp *interp, Tcl_Channel chan, int flags); /* 624 */
    int (*tcl_NRExprObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *resultPtr); /* 625 */
    int (*tcl_NRSubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 626 */
    int (*tcl_LoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *const symv[], int flags, void *procPtrs, Tcl_LoadHandle *handlePtr); /* 627 */
    void* (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */
    int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */
} TclStubs;

#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
extern const TclStubs *tclStubsPtr;
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */

#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)

#define Tcl_NRExprObj \
	(tclStubsPtr->tcl_NRExprObj) /* 625 */
#endif
#ifndef Tcl_NRSubstObj
#define Tcl_NRSubstObj \
	(tclStubsPtr->tcl_NRSubstObj) /* 626 */
#endif
#ifndef Tcl_LoadFile
#define Tcl_LoadFile \
	(tclStubsPtr->tcl_LoadFile) /* 627 */
#endif
#ifndef Tcl_FindSymbol
#define Tcl_FindSymbol \
	(tclStubsPtr->tcl_FindSymbol) /* 628 */
#endif
#ifndef Tcl_FSUnloadFile
#define Tcl_FSUnloadFile \
	(tclStubsPtr->tcl_FSUnloadFile) /* 629 */
#endif

#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */

/* !END!: Do not edit above this line. */

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT

#endif /* _TCLDECLS */

 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 2001-2004 Vincent Darley.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIOUtil.c,v 1.81.2.55 2010/04/02 23:48:14 dgp Exp $
 */

#include "tclInt.h"
#ifdef __WIN32__
#   include "tclWinInt.h"
#endif
#include "tclFileSystem.h"

static void		FsAddMountsToGlobResult(Tcl_Obj *resultPtr,
			    Tcl_Obj *pathPtr, const char *pattern,
			    Tcl_GlobTypeData *types);
static void		FsUpdateCwd(Tcl_Obj *cwdObj, ClientData clientData);
#ifdef TCL_THREADS
static void		FsRecacheFilesystemList(void);
#endif
static void*		DivertFindSymbol(Tcl_Interp* interp,
					 Tcl_LoadHandle loadHandle,
					 const char* symbol);
static void		DivertUnloadFile(Tcl_LoadHandle loadHandle);

/*
 * These form part of the native filesystem support. They are needed here
 * because we have a few native filesystem functions (which are the same for
 * win/unix) in this file. There is no need to place them in tclInt.h, because
 * they are not (and should not be) used anywhere else.
 */

				 * file which will be passed back to
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr)
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for this
				 * file. */
{
    const char *symbols[3];
    void *procPtrs[2];

    int res;

    /*
     * Initialize the arrays.
     */

    symbols[0] = sym1;
    symbols[1] = sym2;
    symbols[2] = NULL;


    /*
     * Perform the load.
     */

    res = Tcl_LoadFile(interp, pathPtr, symbols, 0, procPtrs, handlePtr);
    if (res == TCL_OK) {
	*proc1Ptr = (Tcl_PackageInitProc*) procPtrs[0];
	*proc2Ptr = (Tcl_PackageInitProc*) procPtrs[1];
    } else {
	*proc1Ptr = *proc2Ptr = NULL;
    }












    return res;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LoadFile --
 *
 *	Dynamically loads a binary code file into memory and returns the
 *	addresses of a number of given functions within that file, if they are
 *	defined. The appropriate function for the filesystem to which pathPtr
 *	belongs will be called.
 *
 *	Note that the native filesystem doesn't actually assume 'pathPtr' is a
 *	path. Rather it assumes pathPtr is either a path or just the name
 *	(tail) of a file which can be found somewhere in the environment's
 *	loadable path. This behaviour is not very compatible with virtual
 *	filesystems (and has other problems documented in the load man-page),
 *	so it is advised that full paths are always used.
 *






 * Results:
 *	A standard Tcl completion code. If an error occurs, an error message
 *	is left in the interp's result.
 *
 * Side effects:
 *	New code suddenly appears in memory. This may later be unloaded by
 *	calling TclFS_UnloadFile.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_LoadFile(
    Tcl_Interp *interp,		/* Used for error reporting. */
    Tcl_Obj *pathPtr,		/* Name of the file containing the desired
				 * code. */


    const char *const symbols[],	/* Names of functions to look up in the file's
				 * symbol table. */

    int flags,			/* Flags (unused) */
    void *procVPtrs,		/* Where to return the addresses corresponding
				 * to symbols[]. */
    Tcl_LoadHandle *handlePtr)	/* Filled with token for shared library
				 * information which can be used in
				 * TclpFindSymbol. */







{
    void** procPtrs = (void**) procVPtrs;
    const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    const Tcl_Filesystem *copyFsPtr;
    Tcl_FSUnloadFileProc* unloadProcPtr;
    Tcl_Obj *copyToPtr;
    Tcl_LoadHandle newLoadHandle = NULL;
    Tcl_LoadHandle divertedLoadHandle = NULL;
    Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL;
    FsDivertLoad *tvdlPtr;
    int retVal;
    int i;

    if (fsPtr == NULL) {
	Tcl_SetErrno(ENOENT);
	return TCL_ERROR;
    }

    if (fsPtr->loadFileProc != NULL) {
	int retVal = fsPtr->loadFileProc(interp, pathPtr, handlePtr,
		&unloadProcPtr);

	if (retVal == TCL_OK) {
	    if (*handlePtr == NULL) {
		return TCL_ERROR;
	    }






	    Tcl_ResetResult(interp);
	    goto resolveSymbols;
	}
	if (Tcl_GetErrno() != EXDEV) {
	    return retVal;
	}
    }

	if (!buffer) {
	    Tcl_Close(interp, data);
	    goto mustCopyToTempAnyway;
	}
	ret = Tcl_Read(data, buffer, size);
	Tcl_Close(interp, data);
	ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr,
		&unloadProcPtr);
	if (ret == TCL_OK && *handlePtr != NULL) {

	    goto resolveSymbols;
	}
    }

  mustCopyToTempAnyway:
    Tcl_ResetResult(interp);
#endif

    /*
     * Get a temporary filename to use, first to copy the file into, and then
     * to load.
     */

    copyToPtr = TclpTempFileNameForLibrary(interp, pathPtr);





    Tcl_IncrRefCount(copyToPtr);

    copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr);
    if ((copyFsPtr == NULL) || (copyFsPtr == fsPtr)) {
	/*
	 * We already know we can't use Tcl_FSLoadFile from this filesystem,
	 * and we must avoid a possible infinite loop. Try to delete the file

    /*
     * We need to reset the result now, because the cross-filesystem copy may
     * have stored the number of bytes in the result.
     */

    Tcl_ResetResult(interp);

    retVal = Tcl_LoadFile(interp, copyToPtr, symbols, 0, procPtrs,
			 &newLoadHandle);
    if (retVal != TCL_OK) {
	/*
	 * The file didn't load successfully.
	 */

	Tcl_FSDeleteFile(copyToPtr);
	Tcl_DecrRefCount(copyToPtr);

	 * We tell our caller about the real shared library which was loaded.
	 * Note that this does mean that the package list maintained by 'load'
	 * will store the original (vfs) path alongside the temporary load
	 * handle and unload proc ptr.
	 */

	*handlePtr = newLoadHandle;


	Tcl_ResetResult(interp);
	return TCL_OK;
    }

    /*
     * When we unload this file, we need to divert the unloading so we can
     * unload and cleanup the temporary file correctly.

	tvdlPtr->divertedFile = NULL;
	tvdlPtr->divertedFilesystem = NULL;
	Tcl_DecrRefCount(copyToPtr);
    }

    copyToPtr = NULL;

    
    divertedLoadHandle = (Tcl_LoadHandle)
	ckalloc(sizeof (struct Tcl_LoadHandle_));
    divertedLoadHandle->clientData = (ClientData) tvdlPtr;
    divertedLoadHandle->findSymbolProcPtr = DivertFindSymbol;
    divertedLoadHandle->unloadFileProcPtr = DivertUnloadFile;
    *handlePtr = divertedLoadHandle;

    Tcl_ResetResult(interp);
    return retVal;

  resolveSymbols:

    /* 
     * At this point, *handlePtr is already set up to the handle for the
     * loaded library. We now try to resolve the symbols.
     */
    if (symbols != NULL) {
	for (i=0 ; symbols[i] != NULL; i++) {
	    procPtrs[i] = Tcl_FindSymbol(interp, *handlePtr, symbols[i]);
	    if (procPtrs[i] == NULL) {
		/* 
		 * At least one symbol in the list was not found.
		 * Unload the file, and report the problem back to the 
		 * caller. (Tcl_FindSymbol should already have left an
		 * appropriate error message.)
		 */	
		(*handlePtr)->unloadFileProcPtr(*handlePtr);
		*handlePtr = NULL;
		return TCL_ERROR;
	    }
	}
    }
    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
 *
 * DivertFindSymbol --
 *	
 *	Find a symbol in a shared library loaded by copy-from-VFS.
 *
 *-----------------------------------------------------------------------------
 */

static void*
DivertFindSymbol(Tcl_Interp* interp, 	    /* Tcl interpreter */
		 Tcl_LoadHandle loadHandle, /* Handle to the diverted module */
		 const char* symbol)	    /* Symbol to resolve */
{
    FsDivertLoad* tvdlPtr = (FsDivertLoad*) (loadHandle->clientData);
    Tcl_LoadHandle originalHandle = tvdlPtr->loadHandle;
    return originalHandle->findSymbolProcPtr(interp, originalHandle, symbol);
}

/*
 *-----------------------------------------------------------------------------
 *
 * DivertUnloadFile --
 *
 *	Unloads a file that has been loaded by copying from VFS to the
 *	native filesystem.
 *
 * Parameters:
 *	loadHandle -- Handle of the file to unload
 *
 *-----------------------------------------------------------------------------
 */

static void
DivertUnloadFile(Tcl_LoadHandle loadHandle)
{
    FsDivertLoad* tvdlPtr = (FsDivertLoad*) (loadHandle->clientData);
    Tcl_LoadHandle originalHandle = tvdlPtr->loadHandle;

    /*
     * This test should never trigger, since we give the client data in the
     * function above.
     */

    if (tvdlPtr == NULL) {
	return;
    }

    /*
     * Call the real 'unloadfile' proc we actually used. It is very important
     * that we call this first, so that the shared library is actually
     * unloaded by the OS. Otherwise, the following 'delete' may well fail
     * because the shared library is still in use.
     */

    originalHandle->unloadFileProcPtr(originalHandle);

    /* What filesystem contains the temp copy of the library? */

    if (tvdlPtr->divertedFilesystem == NULL) {
	/*
	 * It was the native filesystem, and we have a special function
	 * available just for this purpose, which we know works even at this
	 * late stage.
	 */

	TclpDeleteFile(tvdlPtr->divertedFileNativeRep);
	NativeFreeInternalRep(tvdlPtr->divertedFileNativeRep);
    } else {
	/*
	 * Remove the temporary file we created. Note, we may crash here
	 * because encodings have been taken down already.
	 */

	if (tvdlPtr->divertedFilesystem->deleteFileProc(tvdlPtr->divertedFile)
		!= TCL_OK) {
	    /*
	     * The above may have failed because the filesystem, or something
	     * it depends upon (e.g. encodings) have been taken down because
	     * Tcl is exiting.
	     *
	     * We may need to work out how to delete this file more robustly
	     * (or give the filesystem the information it needs to delete the
	     * file more robustly).
	     *
	     * In particular, one problem might be that the filesystem cannot
	     * extract the information it needs from the above path object
	     * because Tcl's entire filesystem apparatus (the code in this
	     * file) has been finalized, and it refuses to pass the internal
	     * representation to the filesystem.
	     */
	}

	/*
	 * And free up the allocations. This will also of course remove a
	 * refCount from the Tcl_Filesystem to which this file belongs, which
	 * could then free up the filesystem if we are exiting.
	 */

	Tcl_DecrRefCount(tvdlPtr->divertedFile);
    }

    ckfree((void*)tvdlPtr);
    ckfree((void*)loadHandle);
}

/*
 * This function used to be in the platform specific directories, but it has
 * now been made to work cross-platform.
 */

int

    if (handle == NULL) {
	return TCL_ERROR;
    }

    *clientDataPtr = handle;

    *proc1Ptr = Tcl_FindSymbol(interp, handle, sym1);
    *proc2Ptr = Tcl_FindSymbol(interp, handle, sym2);
    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
 *
 * Tcl_FindSymbol --
 *
 *	Find a symbol in a loaded library
 *
 * Results:
 *	Returns a pointer to the symbol if found. If not found, returns
 *	NULL and leaves an error message in the interpreter result.
 *
 * This function was once filesystem-specific, but has been made portable
 * by having TclpDlopen return a structure that includes procedure pointers.
 *
 *-----------------------------------------------------------------------------
 */

void*
Tcl_FindSymbol(Tcl_Interp* interp,	  /* Tcl interpreter */
	       Tcl_LoadHandle loadHandle, /* Handle to the loaded library */
	       const char* symbol)        /* Name of the symbol to resolve */
{
    return (*(loadHandle->findSymbolProcPtr))(interp, loadHandle, symbol);
}

/*
 *-----------------------------------------------------------------------------
 *
 * Tcl_FSUnloadFile --
 *
 *	Unloads a library given its handle. Checks first that the library
 *	supports unloading.
 *
 *-----------------------------------------------------------------------------
 */

int
Tcl_FSUnloadFile(Tcl_Interp* interp, /* Tcl interpreter */
		 Tcl_LoadHandle handle) /* Handle of the file to unload */
{
    if (handle->unloadFileProcPtr == NULL) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp,
			     Tcl_NewStringObj("cannot unload: filesystem "
					      "does not support unloading",
					      -1));
	}
	return TCL_ERROR;
    } else {
	TclpUnloadFile(handle);
    return TCL_OK;
    }
}

/*
 *-----------------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *
 *	Unloads a library given its handle
 *
 * This function was once filesystem-specific, but has been made portable
 * by having TclpDlopen return a structure that includes procedure pointers.
 *
 *-----------------------------------------------------------------------------
 */

void
TclpUnloadFile(Tcl_LoadHandle handle)
{
    if (handle->unloadFileProcPtr != NULL) {
	(*(handle->unloadFileProcPtr))(handle);
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * TclFSUnloadTempFile --
 *

 * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
 * Copyright (c) 2006-2008 by Joe Mistachkin.  All rights reserved.
 * Copyright (c) 2008 by Miguel Sofer. All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInt.h,v 1.127.2.143 2010/04/02 23:48:14 dgp Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Some numerics configuration options.

    Tcl_Obj *cond;		/* Loop condition expression. */
    Tcl_Obj *body;		/* Loop body. */
    Tcl_Obj *next;		/* Loop step script, NULL for 'while'. */
    const char *msg;		/* Error message part. */
    int word;			/* Index of the body script in the command */
} ForIterData;

/* TIP #357 - Structure doing the bookkeeping of handles for Tcl_LoadFile
 *            and Tcl_FindSymbol. This structure corresponds to an opaque
 *            typedef in tcl.h */

typedef void* TclFindSymbolProc(Tcl_Interp* interp, Tcl_LoadHandle loadHandle,
				const char* symbol);
struct Tcl_LoadHandle_ {
    ClientData clientData;	/* Client data is the load handle in the
				 * native filesystem if a module was loaded
				 * there, or an opaque pointer to a structure
				 * for further bookkeeping on load-from-VFS
				 * and load-from-memory */
    TclFindSymbolProc* findSymbolProcPtr;
				/* Procedure that resolves symbols in a
				 * loaded module */
    Tcl_FSUnloadFileProc* unloadFileProcPtr;
				/* Procedure that unloads a loaded module */
};

/*
 *----------------------------------------------------------------
 * Procedures shared among Tcl modules but not used by the outside world:
 *----------------------------------------------------------------
 */

MODULE_SCOPE int	TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr,

			    Tcl_Obj *listPtr, Tcl_Obj *argPtr);
MODULE_SCOPE Tcl_Obj *	TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
			    int indexCount, Tcl_Obj *const indexArray[]);
/* TIP #280 */
MODULE_SCOPE void	TclListLines(Tcl_Obj *listObj, int line, int n,
			    int *lines, Tcl_Obj *const *elems);
MODULE_SCOPE Tcl_Obj *	TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr);






MODULE_SCOPE Tcl_Obj *	TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr,
			    Tcl_Obj *indexPtr, Tcl_Obj *valuePtr);
MODULE_SCOPE Tcl_Obj *	TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
			    int indexCount, Tcl_Obj *const indexArray[],
			    Tcl_Obj *valuePtr);
MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name,
			    const EnsembleImplMap map[]);

			    int numBytes, int flags,
			    Tcl_Token **lastTokenPtrPtr, const char **termPtr);
MODULE_SCOPE int	TclParseAllWhiteSpace(const char *src, int numBytes);
MODULE_SCOPE int	TclProcessReturn(Tcl_Interp *interp,
			    int code, int level, Tcl_Obj *returnOpts);
MODULE_SCOPE int	TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
MODULE_SCOPE Tcl_Obj *	TclpTempFileName(void);
MODULE_SCOPE Tcl_Obj *  TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr);
MODULE_SCOPE Tcl_Obj *	TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep,
			    int len);
MODULE_SCOPE int	TclpDeleteFile(const char *path);
MODULE_SCOPE void	TclpFinalizeCondition(Tcl_Condition *condPtr);
MODULE_SCOPE void	TclpFinalizeMutex(Tcl_Mutex *mutexPtr);
MODULE_SCOPE void	TclpFinalizePipes(void);
MODULE_SCOPE void	TclpFinalizeSockets(void);

			    Tcl_Obj *resultingNameObj);
MODULE_SCOPE Tcl_Obj *	TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr,
			    Tcl_PathPart portion);
MODULE_SCOPE char *	TclpReadlink(const char *fileName,
			    Tcl_DString *linkPtr);
MODULE_SCOPE void	TclpSetInterfaces(void);
MODULE_SCOPE void	TclpSetVariables(Tcl_Interp *interp);

MODULE_SCOPE void *	TclThreadStorageKeyGet(Tcl_ThreadDataKey *keyPtr);
MODULE_SCOPE void	TclThreadStorageKeySet(Tcl_ThreadDataKey *keyPtr,
			    void *data);
MODULE_SCOPE void	TclpThreadExit(int status);
MODULE_SCOPE void	TclRememberCondition(Tcl_Condition *mutex);
MODULE_SCOPE void	TclRememberJoinableThread(Tcl_ThreadId id);
MODULE_SCOPE void	TclRememberMutex(Tcl_Mutex *mutex);

			    int numBytes, int flags, Tcl_Parse *parsePtr);
MODULE_SCOPE int	TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
			    int count, int *tokensLeftPtr, int line,
			    int* clNextOuter, const char* outerScript,
			    int flags);
MODULE_SCOPE Tcl_Obj *	TclpNativeToNormalized(ClientData clientData);
MODULE_SCOPE Tcl_Obj *	TclpFilesystemPathType(Tcl_Obj *pathPtr);


MODULE_SCOPE int	TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr,
			    Tcl_LoadHandle *loadHandle,
			    Tcl_FSUnloadFileProc **unloadProcPtr);
MODULE_SCOPE int	TclpUtime(Tcl_Obj *pathPtr, struct utimbuf *tval);
#ifdef TCL_LOAD_FROM_MEMORY
MODULE_SCOPE void *	TclpLoadMemoryGetBuffer(Tcl_Interp *interp, int size);
MODULE_SCOPE int	TclpLoadMemory(Tcl_Interp *interp, void *buffer,

/*
 * tclLoad.c --
 *
 *	This file provides the generic portion (those that are the same on all
 *	platforms) of Tcl's dynamic loading facilities.
 *
 * 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: tclLoad.c,v 1.9.4.14 2010/04/02 23:48:14 dgp Exp $
 */

#include "tclInt.h"

/*
 * The following structure describes a package that has been loaded either
 * dynamically (with the "load" command) or statically (as indicated by a call

				/* Finalisation function to unload a package
				 * from a safe interpreter. NULL means that
				 * the package cannot be unloaded. */
    int interpRefCount;		/* How many times the package has been loaded
				 * in trusted interpreters. */
    int safeInterpRefCount;	/* How many times the package has been loaded
				 * in safe interpreters. */





    struct LoadedPackage *nextPtr;
				/* Next in list of all packages loaded into
				 * this application process. NULL means end of
				 * list. */
} LoadedPackage;

/*

    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Interp *target;
    LoadedPackage *pkgPtr, *defaultPtr;
    Tcl_DString pkgName, tmp, initName, safeInitName;
    Tcl_DString unloadName, safeUnloadName;

    InterpPackage *ipFirstPtr, *ipPtr;
    int code, namesMatch, filesMatch, offset;
    const char *symbols[2];
    void* procPtrs[1];

    const char *p, *fullFileName, *packageName;
    Tcl_LoadHandle loadHandle;

    Tcl_UniChar ch;

    if ((objc < 2) || (objc > 4)) {
	Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?");
	return TCL_ERROR;
    }
    if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {

	/*
	 * Call platform-specific code to load the package and find the two
	 * initialization functions.
	 */

	symbols[0] = Tcl_DStringValue(&initName);
	symbols[1] = NULL;







	Tcl_MutexLock(&packageMutex);
	code = Tcl_LoadFile(interp, objv[1], symbols, 0, procPtrs, &loadHandle);

	Tcl_MutexUnlock(&packageMutex);

	if (code != TCL_OK) {
	    goto done;
	}











	/*
	 * Create a new record to describe this package.
	 */

	pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
	pkgPtr->fileName	   =
		ckalloc((unsigned) (strlen(fullFileName) + 1));
	strcpy(pkgPtr->fileName, fullFileName);
	pkgPtr->packageName	   =
		ckalloc((unsigned) (Tcl_DStringLength(&pkgName) + 1));
	strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName));
	pkgPtr->loadHandle	   = loadHandle;

	pkgPtr->initProc	   = (Tcl_PackageInitProc*) procPtrs[0];
	pkgPtr->safeInitProc	   = (Tcl_PackageInitProc*)
	    Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&safeInitName));
	pkgPtr->unloadProc	   = (Tcl_PackageUnloadProc*)
	    Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&unloadName));
	pkgPtr->safeUnloadProc	   = (Tcl_PackageUnloadProc *) 
	    Tcl_FindSymbol(interp, loadHandle,
			   Tcl_DStringValue(&safeUnloadName));
	pkgPtr->interpRefCount	   = 0;
	pkgPtr->safeInterpRefCount = 0;

	Tcl_MutexLock(&packageMutex);
	pkgPtr->nextPtr		   = firstPackagePtr;
	firstPackagePtr		   = pkgPtr;
	Tcl_MutexUnlock(&packageMutex);
	/*
	 * The Tcl_FindSymbol calls may have left a spurious error message
	 * in the interpreter result.
	 */
	Tcl_ResetResult(interp);
    }

    /*
     * Invoke the package's initialization function (either the normal one or
     * the safe one, depending on whether or not the interpreter is safe).
     */

	 * Some Unix dlls are poorly behaved - registering things like atexit
	 * calls that can't be unregistered. If you unload such dlls, you get
	 * a core on exit because it wants to call a function in the dll after
	 * it's been unloaded.
	 */

	if (pkgPtr->fileName[0] != '\0') {



		Tcl_MutexLock(&packageMutex);

	    if (Tcl_FSUnloadFile(interp, pkgPtr->loadHandle) == TCL_OK) {


		/*
		 * Remove this library from the loaded library cache.
		 */

		defaultPtr = pkgPtr;
		if (defaultPtr == firstPackagePtr) {
		    firstPackagePtr = pkgPtr->nextPtr;

			ipFirstPtr);
		ckfree(defaultPtr->fileName);
		ckfree(defaultPtr->packageName);
		ckfree((char *) defaultPtr);
		ckfree((char *) ipPtr);
		Tcl_MutexUnlock(&packageMutex);
	    } else {



		code = TCL_ERROR;
	    }
	}
#else
	Tcl_AppendResult(interp, "file \"", fullFileName,
		"\" cannot be unloaded: unloading disabled", NULL);
	code = TCL_ERROR;

	 * Some Unix dlls are poorly behaved - registering things like atexit
	 * calls that can't be unregistered. If you unload such dlls, you get
	 * a core on exit because it wants to call a function in the dll after
	 * it has been unloaded.
	 */

	if (pkgPtr->fileName[0] != '\0') {




	    Tcl_FSUnloadFile(NULL, pkgPtr->loadHandle);

	}
#endif

	ckfree(pkgPtr->fileName);
	ckfree(pkgPtr->packageName);
	ckfree((char *) pkgPtr);
    }

/*
 * tclLoadNone.c --
 *
 *	This procedure provides a version of the TclpDlopen for use in
 *	systems that don't support dynamic loading; it just returns an error.
 *
 * 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: tclLoadNone.c,v 1.11.4.3 2010/04/02 23:48:14 dgp Exp $
 */

#include "tclInt.h"

/*
 *----------------------------------------------------------------------
 *

	    TCL_STATIC);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *



























 * TclGuessPackageName --
 *
 *	If the "load" command is invoked without providing a package name,
 *	this procedure is invoked to try to figure it out.
 *
 * Results:
 *	Always returns 0 to indicate that we couldn't figure out a package

TclGuessPackageName(
    const char *fileName,	/* Name of file containing package (already
				 * translated to local form if needed). */
    Tcl_DString *bufPtr)	/* Initialized empty dstring. Append package
				 * name to this if possible. */
{
    return 0;


























}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

 *	'double' and 'mp_int' types.
 *
 * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclStrToD.c,v 1.4.2.27 2010/04/02 23:48:14 dgp Exp $
 *
 *----------------------------------------------------------------------
 */

#include <tclInt.h>
#include <stdio.h>
#include <stdlib.h>

				 * represented exactly in a 'double'. */
static int log10_DIGIT_MAX;	/* The number of decimal digits that fit in an
				 * mp_digit. */
static int log2FLT_RADIX;	/* Logarithm of the floating point radix. */
static int mantBits;		/* Number of bits in a double's significand */
static mp_int pow5[9];		/* Table of powers of 5**(2**n), up to
				 * 5**256 */

static int maxDigits;		/* The maximum number of digits to the left of
				 * the decimal point of a double. */
static int minDigits;		/* The maximum number of digits to the right
				 * of the decimal point in a double. */
static int mantDIGIT;		/* Number of mp_digit's needed to hold the
				 * significand of a double. */
static const double pow_10_2_n[] = {	/* Inexact higher powers of ten. */

    retval = BignumToBiasedFrExp(significand, &machexp);
    retval = Pow10TimesFrExp(exponent, retval, &machexp);
    if (machexp > DBL_MAX_EXP*log2FLT_RADIX) {
	retval = HUGE_VAL;
	goto returnValue;
    }
    retval = SafeLdExp(retval, machexp);
    if (retval <= 0.0) {
	retval = SafeLdExp(1.0, DBL_MIN_EXP * log2FLT_RADIX - mantBits);
    }

    /*
     * Refine the result twice. (The second refinement should be necessary
     * only if the best approximation is a power of 2 minus 1/2 ulp).
     */

    /*
     * Determine the number of decimal digits to the left and right of the
     * decimal point in the largest and smallest double, the smallest double
     * that differs from zero, and the number of mp_digits needed to represent
     * the significand of a double.
     */


    maxDigits = (int) ((DBL_MAX_EXP * log((double) FLT_RADIX)
	    + 0.5 * log(10.)) / log(10.));
    minDigits = (int) floor((DBL_MIN_EXP - DBL_MANT_DIG)
	    * log((double) FLT_RADIX) / log(10.));
    mantDIGIT = (mantBits + DIGIT_BIT-1) / DIGIT_BIT;
    log10_DIGIT_MAX = (int) floor(DIGIT_BIT * log(2.) / log(10.));

/*
 * tclStubInit.c --
 *
 *	This file contains the initializers for the Tcl stub vectors.
 *
 * Copyright (c) 1998-1999 by 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: tclStubInit.c,v 1.84.2.65 2010/04/02 23:48:14 dgp Exp $
 */

#include "tclInt.h"
#include "tommath.h"

/*
 * Remove macros that will interfere with the definitions below.

    Tcl_ZlibStreamClose, /* 620 */
    Tcl_ZlibStreamReset, /* 621 */
    Tcl_SetStartupScript, /* 622 */
    Tcl_GetStartupScript, /* 623 */
    Tcl_CloseEx, /* 624 */
    Tcl_NRExprObj, /* 625 */
    Tcl_NRSubstObj, /* 626 */
    Tcl_LoadFile, /* 627 */
    Tcl_FindSymbol, /* 628 */
    Tcl_FSUnloadFile, /* 629 */
};

/* !END!: Do not edit above this line. */

if {![package vsatisfies [package provide Tcl] 8]} {return}
if {[string compare $::tcl_platform(platform) windows]} {return}
if {[info exists ::tcl_platform(debug)]} {
    package ifneeded registry 1.3 \
            [list load [file join $dir tclreg13g.dll] registry]
} else {
    package ifneeded registry 1.3 \
            [list load [file join $dir tclreg13.dll] registry]
}

test filesystem-6.33 {empty file name} {file writable ""} 0

# Make sure the testfilesystem hasn't been registered.
if {[testConstraint testfilesystem]} {
    while {![catch {testfilesystem 0}]} {}
}

test filesystem-7.1.1 {load from vfs} -setup {
    set dir [pwd]
} -constraints {win testsimplefilesystem} -body {
    # This may cause a crash on exit
    cd [file dirname [info nameof]]
    set dde [lindex [glob *dde*[info sharedlib]] 0]
    testsimplefilesystem 1
    # This loads dde via a complex copy-to-temp operation
    load simplefs:/$dde dde
    testsimplefilesystem 0
    return ok
    # The real result of this test is what happens when Tcl exits.
} -cleanup {
    cd $dir
} -result ok
test filesystem-7.1.2 {load from vfs, and then unload again} -setup {
    set dir [pwd]
} -constraints {win testsimplefilesystem} -body {
    # This may cause a crash on exit
    cd [file dirname [info nameof]]
    set reg [lindex [glob tclreg*[info sharedlib]] 0]
    testsimplefilesystem 1
    # This loads reg via a complex copy-to-temp operation
    load simplefs:/$reg Registry
    unload simplefs:/$reg
    testsimplefilesystem 0
    return ok
    # The real result of this test is what happens when Tcl exits.
} -cleanup {
    cd $dir
} -result ok
test filesystem-7.2 {cross-filesystem copy from vfs maintains mtime} -setup {
    set dir [pwd]

# Commands covered:  load
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by 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: load.test,v 1.11.4.9 2010/04/02 23:48:14 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Figure out what extension is used for shared libraries on this

	[list $dll $loaded] {
    load [file join $testDir pkgb$ext] pKgB child
    list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \
	    [catch {pkgb_sub 12 10} msg2] $msg2
} {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}}
test load-2.3 {loading with no _Init procedure} -constraints [list $dll $loaded] \
-body {
    list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg $errorCode
} -match glob \
    -result [list 1 {cannot find symbol "Foo_Init"*} \
		 {TCL LOOKUP LOAD_SYMBOL *Foo_Init}]
test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] {
    list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg
} {1 {can't use package in a safe interpreter: no Pkga_SafeInit procedure}}

test load-3.1 {error in _Init procedure, same interpreter} \
	[list $dll $loaded] {
    list [catch {load [file join $testDir pkge$ext] pkge} msg] \

# registry.test --
#
# This file contains a collection of tests for the registry command.
# Sourcing this file into Tcl runs the tests and generates output for
# errors.  No output means no errors were found.
#
# In order for these tests to run, the registry package must be on the
# auto_path or the registry package must have been loaded already.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.  All rights reserved.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# RCS: @(#) $Id: registry.test,v 1.14.2.12 2010/04/02 23:48:14 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

testConstraint reg 0

    list [catch {registry -64bit} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
test registry-1.2 {argument parsing for registry command} {win reg} {
    list [catch {registry foo} msg] $msg
} {1 {bad option "foo": must be broadcast, delete, get, keys, set, type, or values}}
test registry-1.2a {argument parsing for registry command} {win reg} {
    list [catch {registry -33bit foo} msg] $msg
} {1 {bad mode "-33bit": must be -32bit or -64bit}}

test registry-1.3 {argument parsing for registry command} {win reg} {
    list [catch {registry d} msg] $msg
} {1 {wrong # args: should be "registry delete keyName ?valueName?"}}
test registry-1.3a {argument parsing for registry command} {win reg} {
    list [catch {registry -32bit d} msg] $msg
} {1 {wrong # args: should be "registry -32bit delete keyName ?valueName?"}}

        # This test will only succeed if the current user does not have
        # registry access on the specified machine.
        registry set {\\mom\HKEY_CURRENT_USER\TclFoobar} bar foobar
    } -returnCodes error -result {unable to open key: Access is denied.}

test registry-12.1 {BroadcastValue} -constraints {win reg} -body {
    registry broadcast
} -returnCodes error -result "wrong # args: should be \"registry broadcast keyName ?-timeout milliseconds?\""
test registry-12.2 {BroadcastValue} -constraints {win reg} -body {
    registry broadcast "" -time
} -returnCodes error -result "wrong # args: should be \"registry broadcast keyName ?-timeout milliseconds?\""
test registry-12.3 {BroadcastValue} -constraints {win reg} -body {
    registry broadcast "" - 500
} -returnCodes error -result "wrong # args: should be \"registry broadcast keyName ?-timeout milliseconds?\""
test registry-12.4 {BroadcastValue} -constraints {win reg} -body {
    registry broadcast {Environment}
} -result {1 0}
test registry-12.5 {BroadcastValue} -constraints {win reg} -body {
    registry b {}
} -result {1 0}


# Commands covered:  unload
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2003-2004 by Georgios Petasis
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: unload.test,v 1.1.2.8 2010/04/02 23:48:14 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Figure out what extension is used for shared libraries on this

set alreadyLoaded [info loaded]
testConstraint $loaded [expr {![string match *pkgua* $alreadyLoaded]}]

set alreadyTotalLoaded [info loaded]

# Certain tests require the 'teststaticpkg' command from tcltest
testConstraint teststaticpkg [llength [info commands teststaticpkg]]

# Certain tests need the 'testsimplefilsystem' in tcltest
testConstraint testsimplefilesystem \
	[llength [info commands testsimplefilesystem]]

# Basic tests: parameter testing...
test unload-1.1 {basic errors} -returnCodes error -body {
    unload
} -result {wrong # args: should be "unload ?-switch ...? fileName ?packageName? ?interp?"}
test unload-1.2 {basic errors} -returnCodes error -body {
    unload a b c d

test unload-4.6 {basic unloading of unloadable package from a safe interpreter, with guess for package name} \
	[list $dll $loaded] {
    list [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
	    [unload [file join $testDir pkgua$ext] {} child-trusted] \
	    [child-trusted eval info commands pkgua_*] \
	    [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
} {{. {} {}} {} {} {. . .}}

test unload-5.1 {unload a module loaded from vfs} \
     -constraints [list $dll $loaded testsimplefilesystem] \
     -setup {
	 set dir [pwd]
	 cd $testDir
	 testsimplefilesystem 1
	 load simplefs:/pkgua$ext pkgua
     } \
    -body {
	list [catch {unload simplefs:/pkgua$ext} msg] $msg
    } \
    -result {0 {}}



# cleanup
interp delete child
interp delete child-trusted
unset ext
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

/*
 * tclLoadDl.c --
 *
 *	This procedure provides a version of the TclLoadFile that works with
 *	the "dlopen" and "dlsym" library procedures for dynamic loading.
 *
 * 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: tclLoadDl.c,v 1.13.4.5 2010/04/02 23:48:14 dgp Exp $
 */

#include "tclInt.h"
#ifdef NO_DLFCN_H
#   include "../compat/dlfcn.h"
#else
#   include <dlfcn.h>

#   define RTLD_NOW 1
#endif

#ifndef RTLD_GLOBAL
#   define RTLD_GLOBAL 0
#endif

/* Static procedures defined within this file */

static void* FindSymbol(Tcl_Interp* interp, Tcl_LoadHandle loadHandle,
			const char* symbol);
static void UnloadFile(Tcl_LoadHandle loadHandle);

/*
 *---------------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns a handle
 *	to the new code.

				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr)
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for this
				 * file. */
{
    void *handle;
    Tcl_LoadHandle newHandle;
    const char *native;

    /*
     * First try the full path the user gave us. This is particularly
     * important if the cwd is inside a vfs, and we are trying to load using a
     * relative path.
     */

	const char *errorStr = dlerror();

	Tcl_AppendResult(interp, "couldn't load file \"",
		Tcl_GetString(pathPtr), "\": ", errorStr, NULL);
	return TCL_ERROR;
    }
    newHandle = (Tcl_LoadHandle) ckalloc(sizeof(*newHandle));
    newHandle->clientData = (ClientData) handle;
    newHandle->findSymbolProcPtr = &FindSymbol;
    newHandle->unloadFileProcPtr = &UnloadFile;
    *unloadProcPtr = &UnloadFile;
    *loadHandle = newHandle;

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * FindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with a
 *	previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if it is
 *	found. Otherwise returns NULL and may leave an error message in the
 *	interp's result.
 *
 *----------------------------------------------------------------------
 */

static void *
FindSymbol(
    Tcl_Interp *interp,		/* Place to put error messages. */
    Tcl_LoadHandle loadHandle,	/* Value from TcpDlopen(). */
    const char *symbol)		/* Symbol to look up. */
{
    const char *native;
    Tcl_DString newName, ds;
    void *handle = (void *)(loadHandle->clientData);
    Tcl_PackageInitProc *proc;

    /*
     * Some platforms still add an underscore to the beginning of symbol
     * names. If we can't find a name without an underscore, try again with
     * the underscore.
     */

    native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
    proc = (Tcl_PackageInitProc *) dlsym(handle,	/* INTL: Native. */
	    native);
    if (proc == NULL) {
	Tcl_DStringInit(&newName);
	Tcl_DStringAppend(&newName, "_", 1);
	native = Tcl_DStringAppend(&newName, native, -1);
	proc = (Tcl_PackageInitProc *) dlsym(handle,	/* INTL: Native. */
		native);
	Tcl_DStringFree(&newName);
    }
    Tcl_DStringFree(&ds);
    if (proc == NULL && interp != NULL) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "cannot find symbol \"", symbol, "\": ",
			 dlerror(), NULL);
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol,
			 NULL);
    }
    return proc;
}

/*
 *----------------------------------------------------------------------
 *
 * UnloadFile --
 *
 *	Unloads a dynamically loaded binary code file from memory. Code
 *	pointers in the formerly loaded file are no longer valid after calling
 *	this function.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Code removed from memory.
 *
 *----------------------------------------------------------------------
 */

static void
UnloadFile(
    Tcl_LoadHandle loadHandle)	/* loadHandle returned by a previous call to
				 * TclpDlopen(). The loadHandle is a token
				 * that represents the loaded file. */
{
    void *handle;

    handle = (void *)(loadHandle->clientData);
    dlclose(handle);
    ckfree((char*)loadHandle);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *

 *
 * Copyright (c) 1995 Apple Computer, Inc.
 * Copyright (c) 2001-2007 Daniel A. Steffen <das@users.sourceforge.net>
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadDyld.c,v 1.14.4.15 2010/04/02 23:48:14 dgp Exp $
 */

#include "tclInt.h"

#ifndef MODULE_SCOPE
#define MODULE_SCOPE extern
#endif

#if (TCL_DYLD_USE_DLFCN && MAC_OS_X_VERSION_MIN_REQUIRED < 1040) || \
	defined(TCL_LOAD_FROM_MEMORY)
MODULE_SCOPE long tclMacOSXDarwinRelease;
#endif

#ifdef TCL_DEBUG_LOAD
#define TclLoadDbgMsg(m, ...) \
    do {								\
	fprintf(stderr, "%s:%d: %s(): " m ".\n",			\
		strrchr(__FILE__, '/')+1, __LINE__, __func__,		\
		##__VA_ARGS__);						\
    } while (0)
#else
#define TclLoadDbgMsg(m, ...)
#endif

/*
 * Static functions defined in this file.
 */

static void *		FindSymbol(Tcl_Interp *interp,
			    Tcl_LoadHandle loadHandle, const char *symbol);
static void		UnloadFile(Tcl_LoadHandle handle);

#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
/*
 *----------------------------------------------------------------------
 *
 * DyldOFIErrorMsg --
 *
 *	Converts a numerical NSObjectFileImage error into an error message
 *	string.
 *
 * Results:
 *	Error message string.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static const char *
DyldOFIErrorMsg(
    int err)
{
    switch(err) {
    case NSObjectFileImageSuccess:
	return NULL;
    case NSObjectFileImageFailure:

				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr)
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for this
				 * file. */
{
    Tcl_DyldLoadHandle *dyldLoadHandle;
    Tcl_LoadHandle newHandle;
#if TCL_DYLD_USE_DLFCN
    void *dlHandle = NULL;
#endif
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
    const struct mach_header *dyldLibHeader = NULL;
    Tcl_DyldModuleHandle *modulePtr = NULL;
#endif

#if TCL_DYLD_USE_DLFCN
	dyldLoadHandle->dlHandle = dlHandle;
#endif
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
	dyldLoadHandle->dyldLibHeader = dyldLibHeader;
	dyldLoadHandle->modulePtr = modulePtr;
#endif
	newHandle = (Tcl_LoadHandle) ckalloc(sizeof(*newHandle));
	newHandle->clientData = dyldLoadHandle;
	newHandle->findSymbolProcPtr = &FindSymbol;
	newHandle->unloadFileProcPtr = &UnloadFile;
	*unloadProcPtr = &UnloadFile;
	*loadHandle = newHandle;
	result = TCL_OK;
    } else {
	Tcl_AppendResult(interp, errMsg, NULL);
#if TCL_DYLD_USE_NSMODULE
	if (objFileImageErrMsg) {
	    Tcl_AppendResult(interp, "\nNSCreateObjectFileImageFromFile() "
		    "error: ", objFileImageErrMsg, NULL);
	}
#endif
	result = TCL_ERROR;
    }
    if(fileName) {
	Tcl_DStringFree(&ds);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * FindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with a
 *	previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if it is
 *	found. Otherwise returns NULL and may leave an error message in the
 *	interp's result.
 *
 *----------------------------------------------------------------------
 */

static void *
FindSymbol(
    Tcl_Interp *interp,		/* For error reporting. */
    Tcl_LoadHandle loadHandle,	/* Handle from TclpDlopen. */
    const char *symbol)		/* Symbol name to look up. */
{
    Tcl_DyldLoadHandle *dyldLoadHandle = loadHandle->clientData;
    Tcl_PackageInitProc *proc = NULL;
    const char *errMsg = NULL;
    Tcl_DString ds;
    const char *native;

    native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
#if TCL_DYLD_USE_DLFCN

		TclLoadDbgMsg("NSAddressOfSymbol() failed");
	    }
	}
	Tcl_DStringFree(&newName);
#endif /* TCL_DYLD_USE_NSMODULE */
    }
    Tcl_DStringFree(&ds);
    if (errMsg && (interp != NULL)) {
	Tcl_AppendResult(interp, errMsg, NULL);
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol,
		NULL);
    }
    return proc;
}

/*
 *----------------------------------------------------------------------
 *
 * UnloadFile --
 *
 *	Unloads a dynamically loaded binary code file from memory. Code
 *	pointers in the formerly loaded file are no longer valid after calling
 *	this function.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Code dissapears from memory. Note that dyld currently only supports
 *	unloading of binaries of type MH_BUNDLE loaded with NSLinkModule() in
 *	TclpDlopen() above.
 *
 *----------------------------------------------------------------------
 */

static void
UnloadFile(
    Tcl_LoadHandle loadHandle)	/* loadHandle returned by a previous call to
				 * TclpDlopen(). The loadHandle is a token
				 * that represents the loaded file. */
{
    Tcl_DyldLoadHandle *dyldLoadHandle = loadHandle->clientData;

#if TCL_DYLD_USE_DLFCN
    if (dyldLoadHandle->dlHandle) {
	int result;

	result = dlclose(dyldLoadHandle->dlHandle);
	if (!result) {

	    }
	    ptr = modulePtr;
	    modulePtr = modulePtr->nextPtr;
	    ckfree(ptr);
	}
#endif /* TCL_DYLD_USE_NSMODULE */
    }
    ckfree((char *) dyldLoadHandle);
    ckfree((char *) loadHandle);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *

				 * file which will be passed back to
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr)
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for this
				 * file. */
{
    Tcl_LoadHandle newHandle;
    Tcl_DyldLoadHandle *dyldLoadHandle;
    NSObjectFileImage dyldObjFileImage = NULL;
    Tcl_DyldModuleHandle *modulePtr;
    NSModule module;
    const char *objFileImageErrMsg = NULL;

    /*

    dyldLoadHandle = (Tcl_DyldLoadHandle *)
	    ckalloc(sizeof(Tcl_DyldLoadHandle));
#if TCL_DYLD_USE_DLFCN
    dyldLoadHandle->dlHandle = NULL;
#endif
    dyldLoadHandle->dyldLibHeader = NULL;
    dyldLoadHandle->modulePtr = modulePtr;
    newHandle = (Tcl_LoadHandle) ckalloc(sizeof(*newHandle));
    newHandle->clientData = dyldLoadHandle;
    newHandle->findSymbolProcPtr = &FindSymbol;
    newHandle->unloadFileProcPtr = &UnloadFile;
    *loadHandle = newHandle;
    *unloadProcPtr = &UnloadFile;
    return TCL_OK;
}
#endif /* TCL_LOAD_FROM_MEMORY */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 79
 * End:
 */

/*
 * tclLoadNext.c --
 *
 *	This procedure provides a version of the TclLoadFile that works with
 *	NeXTs rld_* dynamic loading. This file provided by Pedja Bogdanovich.
 *
 * 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: tclLoadNext.c,v 1.11.4.4 2010/04/02 23:48:14 dgp Exp $
 */

#include "tclInt.h"
#include <mach-o/rld.h>
#include <streams/streams.h>

/* Static procedures defined within this file */

static void* FindSymbol(Tcl_Interp* interp, Tcl_LoadHandle loadHandle,
			const char* symbol);
static void UnloadFile(Tcl_LoadHandle loadHandle);


/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns a handle

				 * file which will be passed back to
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr)
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for this
				 * file. */
{
    Tcl_LoadHandle newHandle;
    struct mach_header *header;
    char *fileName;
    char *files[2];
    const char *native;
    int result = 1;

    NXStream *errorStream = NXOpenMemory(0,0,NX_READWRITE);

	Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ",
		data, NULL);
	NXCloseMemory(errorStream, NX_FREEBUFFER);
	return TCL_ERROR;
    }
    NXCloseMemory(errorStream, NX_FREEBUFFER);

    newHandle = (Tcl_LoadHandle) ckalloc(sizeof(*newHandle));
    newHandle->clientData = (ClientData) 1;
    newHandle->findSymbolProcPtr = &FindSymbol;
    newHandle->unloadFileProcPtr = &UnloadFile;
    *loadHandle = newHandle;
    *unloadProcPtr = &UnloadFile;

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * FindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with a
 *	previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if it is
 *	found. Otherwise returns NULL and may leave an error message in the
 *	interp's result.
 *
 *----------------------------------------------------------------------
 */

static void*
FindSymbol(
    Tcl_Interp *interp,
    Tcl_LoadHandle loadHandle,
    const char *symbol)
{
    Tcl_PackageInitProc *proc = NULL;
    if (symbol) {
	char sym[strlen(symbol) + 2];

	sym[0] = '_';
	sym[1] = 0;
	strcat(sym, symbol);
	rld_lookup(NULL, sym, (unsigned long *)&proc);
    }
    if (proc == NULL && interp != NULL) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "cannot find symbol \"", symbol,
			 "\"", NULL);
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL);
    }
    return proc;
}

/*
 *----------------------------------------------------------------------
 *
 * UnloadFile --
 *
 *	Unloads a dynamically loaded binary code file from memory. Code
 *	pointers in the formerly loaded file are no longer valid after calling
 *	this function.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Does nothing.  Can anything be done?
 *
 *----------------------------------------------------------------------
 */

void
UnloadFile(
    Tcl_LoadHandle loadHandle)	/* loadHandle returned by a previous call to
				 * TclpDlopen(). The loadHandle is a token
				 * that represents the loaded file. */
{
    ckfree((char*) loadHandle);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *

 *	John Robert LoVerso <loverso@freebsd.osf.org>
 *
 * 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: tclLoadOSF.c,v 1.11.4.4 2010/04/02 23:48:14 dgp Exp $
 */

#include "tclInt.h"
#include <sys/types.h>
#include <loader.h>

/* Static functions defined within this file */

static void* FindSymbol(Tcl_Interp* interp, Tcl_LoadHandle loadHandle,
		       const char* symbol);
static void UnloadFile(Tcl_LoadHandle handle);

/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns a handle

				 * file which will be passed back to
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr)
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for this
				 * file. */
{
    Tcl_LoadHandle newHandle;
    ldr_module_t lm;
    char *pkg;
    char *fileName = Tcl_GetString(pathPtr);
    const char *native;

    /*
     * First try the full path the user gave us.  This is particularly

     */

    if ((pkg = strrchr(fileName, '/')) == NULL) {
        pkg = fileName;
    } else {
	pkg++;
    }
    newHandle = (Tcl_LoadHandle*) ckalloc(sizeof(*newHandle));
    newHandle->clientData = pkg;
    newHandle->findSymbolProcPtr = &FindSymbol;
    newHandle->unloadFileProcPtr = &UnloadFile;
    *loadHandle = newHandle;
    *unloadProcPtr = &UnloadFile;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * FindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with a
 *	previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if it is
 *	found.  Otherwise returns NULL and may leave an error message in the
 *	interp's result.
 *
 *----------------------------------------------------------------------
 */

static void *
FindSymbol(
    Tcl_Interp *interp,
    Tcl_LoadHandle loadHandle,
    const char *symbol)
{
    void* retval = ldr_lookup_package((char *)loadHandle, symbol);
    if (retval == NULL && interp != NULL) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "cannot find symbol\"", symbol, "\"", NULL);
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL);
    }
    return retval;
}

/*
 *----------------------------------------------------------------------
 *
 * UnloadFile --
 *
 *	Unloads a dynamically loaded binary code file from memory. Code
 *	pointers in the formerly loaded file are no longer valid after calling
 *	this function.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Does nothing.  Can anything be done?
 *
 *----------------------------------------------------------------------
 */

static void
UnloadFile(
    Tcl_LoadHandle loadHandle)	/* loadHandle returned by a previous call to
				 * TclpDlopen(). The loadHandle is a token
				 * that represents the loaded file. */
{
    ckfree((char*) loadHandle);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *

/*
 * tclLoadShl.c --
 *
 *	This procedure provides a version of the TclLoadFile that works with
 *	the "shl_load" and "shl_findsym" library procedures for dynamic
 *	loading (e.g. for HP machines).
 *
 * 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: tclLoadShl.c,v 1.13.4.5 2010/04/02 23:48:14 dgp Exp $
 */

#include <dl.h>

/*
 * On some HP machines, dl.h defines EXTERN; remove that definition.
 */

#ifdef EXTERN
#   undef EXTERN
#endif

#include "tclInt.h"

/* Static functions defined within this file */

static void* FindSymbol(Tcl_Interp* interp, Tcl_LoadHandle loadHandle,
			const char* symbol);
static void
UnloadFile(Tcl_LoadHandle handle);


/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns a handle

				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr)
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for this
				 * file. */
{
    shl_t handle;
    Tcl_LoadHandle newHandle;
    const char *native;
    char *fileName = Tcl_GetString(pathPtr);

    /*
     * The flags below used to be BIND_IMMEDIATE; they were changed at the
     * suggestion of Wolfgang Kechel (wolfgang@prs.de): "This enables
     * verbosity for missing symbols when loading a shared lib and allows to

    }

    if (handle == NULL) {
	Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ",
		Tcl_PosixError(interp), (char *) NULL);
	return TCL_ERROR;
    }
    newHandle = (Tcl_LoadHandle) ckalloc(sizeof(*newHandle));
    newHandle->clientData = handle;
    newHandle->findSymbolProcPtr = &FindSymbol;
    newHandle->unloadFileProcPtr = *unloadProcPtr = &UnloadFile;
    *loadHandle = newHandle;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with a
 *	previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if it is
 *	found.  Otherwise returns NULL and may leave an error message in the
 *	interp's result.
 *
 *----------------------------------------------------------------------
 */

static void*
FindSymbol(
    Tcl_Interp *interp,
    Tcl_LoadHandle loadHandle,
    const char *symbol)
{
    Tcl_DString newName;
    Tcl_PackageInitProc *proc = NULL;
    shl_t handle = (shl_t)(loadHandle->clientData);

    /*
     * Some versions of the HP system software still use "_" at the beginning
     * of exported symbols while others don't; try both forms of each name.
     */

    if (shl_findsym(&handle, symbol, (short) TYPE_PROCEDURE,
	    (void *) &proc) != 0) {
	Tcl_DStringInit(&newName);
	Tcl_DStringAppend(&newName, "_", 1);
	Tcl_DStringAppend(&newName, symbol, -1);
	if (shl_findsym(&handle, Tcl_DStringValue(&newName),
		(short) TYPE_PROCEDURE, (void *) &proc) != 0) {
	    proc = NULL;
	}
	Tcl_DStringFree(&newName);
    }
    if (proc == NULL && interp != NULL) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "cannot find symbol\"", symbol, 
			 "\": ", Tcl_PosixError(interp), NULL);
    }
    return proc;
}

/*
 *----------------------------------------------------------------------
 *
 * UnloadFile --
 *
 *	Unloads a dynamically loaded binary code file from memory.  Code
 *	pointers in the formerly loaded file are no longer valid after calling
 *	this function.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Code removed from memory.
 *
 *----------------------------------------------------------------------
 */

static void
UnloadFile(
    Tcl_LoadHandle loadHandle)	/* loadHandle returned by a previous call to
				 * TclpDlopen(). The loadHandle is a token
				 * that represents the loaded file. */
{
    shl_t handle;

    handle = (shl_t) (loadHandle -> clientData);
    shl_unload(handle);
    ckfree((char*) loadHandle);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *

/*
 * tclUnixPipe.c --
 *
 *	This file implements the UNIX-specific exec pipeline functions, the
 *	"pipe" channel driver, and the "pid" Tcl command.
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-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: tclUnixPipe.c,v 1.23.4.23 2010/04/02 23:48:14 dgp Exp $
 */

#include "tclInt.h"

#ifdef USE_VFORK
#define fork vfork
#endif

    fcntl(fd, F_SETFD, FD_CLOEXEC);
    unlink(fileName);			/* INTL: Native. */

    result = TclpNativeToNormalized((ClientData) fileName);
    close(fd);
    return result;
}

/*
 *-----------------------------------------------------------------------------
 *
 * TclpTempFileNameForLibrary --
 *
 *	Constructs a file name in the native file system where a
 *	dynamically loaded library may be placed.
 *
 * Results:
 *	Returns the constructed file name. If an error occurs,
 *	returns NULL and leaves an error message in the interpreter
 *	result.
 *
 * On Unix, it works to load a shared object from a file of any
 * name, so this function is merely a thin wrapper around
 * TclpTempFileName().
 *	
 *-----------------------------------------------------------------------------
 */

Tcl_Obj*
TclpTempFileNameForLibrary(Tcl_Interp* interp, /* Tcl interpreter */
			   Tcl_Obj* path)      /* Path name of the library
						* in the VFS */
{
    Tcl_Obj* retval;
    retval = TclpTempFileName();
    if (retval == NULL) {
	Tcl_AppendResult(interp, "couldn't create temporary file: ",
		Tcl_PosixError(interp), NULL);
    }
    return retval;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpCreatePipe --
 *
 *	Creates a pipe - simply calls the pipe() function.

#
# This file is a Makefile for Tcl.  If it has the name "Makefile.in" then it
# is a template for a Makefile; to generate the actual Makefile, run
# "./configure", which is a configuration script generated by the "autoconf"
# program (constructs like "@foo@" will get replaced in the actual Makefile.
#
# RCS: @(#) $Id: Makefile.in,v 1.71.2.62 2010/04/02 23:48:14 dgp Exp $

VERSION = @TCL_VERSION@

#--------------------------------------------------------------------------
# Things you can change to personalize the Makefile for your own site (you can
# make these changes in either Makefile.in or Makefile, but changes to
# Makefile will get lost if you re-run the configuration script).

	    if [ ! -d $$i ] ; then \
		echo "Making directory $$i"; \
		$(MKDIR) $$i; \
		chmod 755 $$i; \
		else true; \
		fi; \
	    done;
	@for i in dde${DDEDOTVER} reg${REGDOTVER}; \
	    do \
	    if [ ! -d $(LIB_INSTALL_DIR)/$$i ] ; then \
		echo "Making directory $(LIB_INSTALL_DIR)/$$i"; \
		$(MKDIR) $(LIB_INSTALL_DIR)/$$i; \
		else true; \
		fi; \
	    done;

/*
 * tclWinLoad.c --
 *
 *	This function provides a version of the TclLoadFile that works with
 *	the Windows "LoadLibrary" and "GetProcAddress" API for dynamic
 *	loading.
 *
 * 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: tclWinLoad.c,v 1.15.4.9 2010/04/02 23:48:14 dgp Exp $
 */

#include "tclWinInt.h"

/*
 * Mutex protecting static data in this file;
 */

static Tcl_Mutex loadMutex;

/*
 * Name of the directory in the native filesystem where DLLs used in this
 * process are copied prior to loading.
 */

static WCHAR* dllDirectoryName = NULL;

/* Static functions defined within this file */

void* FindSymbol(Tcl_Interp* interp, Tcl_LoadHandle loadHandle,
		 const char* symbol);
void UnloadFile(Tcl_LoadHandle loadHandle);


/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns a handle

				 * file which will be passed back to
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr)
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for this
				 * file. */
{
    HINSTANCE hInstance;
    const TCHAR *nativeName;
    Tcl_LoadHandle handlePtr;

    /*
     * First try the full path the user gave us. This is particularly
     * important if the cwd is inside a vfs, and we are trying to load using a
     * relative path.
     */

    nativeName = Tcl_FSGetNativePath(pathPtr);
    hInstance = tclWinProcs->loadLibraryProc(nativeName);
    if (hInstance == NULL) {
	/*
	 * Let the OS loader examine the binary search path for whatever
	 * string the user gave us which hopefully refers to a file on the
	 * binary path.
	 */

	Tcl_DString ds;
	const char *fileName = Tcl_GetString(pathPtr);

	nativeName = tclWinProcs->utf2tchar(fileName, -1, &ds);
	hInstance = tclWinProcs->loadLibraryProc(nativeName);
	Tcl_DStringFree(&ds);
    }



    if (hInstance == NULL) {
	DWORD lastError = GetLastError();

#if 0
	/*
	 * It would be ideal if the FormatMessage stuff worked better, but
	 * unfortunately it doesn't seem to want to...
	 */

	    break;
	default:
	    TclWinConvertError(lastError);
	    Tcl_AppendResult(interp, Tcl_PosixError(interp), NULL);
	}
	return TCL_ERROR;
    } else {
	handlePtr = 
	    (Tcl_LoadHandle) ckalloc(sizeof(struct Tcl_LoadHandle_));
	handlePtr->clientData = (ClientData) hInstance;
	handlePtr->findSymbolProcPtr = &FindSymbol;
	handlePtr->unloadFileProcPtr = &UnloadFile;
	*loadHandle = (Tcl_LoadHandle) handlePtr;
	*unloadProcPtr = &UnloadFile;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * FindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with a
 *	previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if it is
 *	found. Otherwise returns NULL and may leave an error message in the
 *	interp's result.
 *
 *----------------------------------------------------------------------
 */

void *
FindSymbol(
    Tcl_Interp *interp,
    Tcl_LoadHandle loadHandle,
    const char *symbol)
{
    Tcl_PackageInitProc *proc = NULL;
    HINSTANCE hInstance = (HINSTANCE)(loadHandle->clientData);

    /*
     * For each symbol, check for both Symbol and _Symbol, since Borland
     * generates C symbols with a leading '_' by default.
     */

    proc = (void*) GetProcAddress(hInstance, symbol);
    if (proc == NULL) {
	Tcl_DString ds;
	const char* sym2;
	Tcl_DStringInit(&ds);
	Tcl_DStringAppend(&ds, "_", 1);
	sym2 = Tcl_DStringAppend(&ds, symbol, -1);
	proc = (Tcl_PackageInitProc *) GetProcAddress(hInstance, sym2);
	Tcl_DStringFree(&ds);
    }
    if (proc == NULL && interp != NULL) {
	Tcl_AppendResult(interp, "cannot find symbol \"", symbol, "\"", NULL);
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL);
    }
    return proc;
}

/*
 *----------------------------------------------------------------------
 *
 * UnloadFile --
 *
 *	Unloads a dynamically loaded binary code file from memory. Code
 *	pointers in the formerly loaded file are no longer valid after calling
 *	this function.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Code removed from memory.
 *
 *----------------------------------------------------------------------
 */

void
UnloadFile(
    Tcl_LoadHandle loadHandle)	/* loadHandle returned by a previous call to
				 * TclpDlopen(). The loadHandle is a token
				 * that represents the loaded file. */
{


    HINSTANCE hInstance = (HINSTANCE) loadHandle->clientData;
    FreeLibrary(hInstance);
    ckfree((char*) loadHandle);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *

    const char *fileName,	/* Name of file containing package (already
				 * translated to local form if needed). */
    Tcl_DString *bufPtr)	/* Initialized empty dstring. Append package
				 * name to this if possible. */
{
    return 0;
}

/*
 *-----------------------------------------------------------------------------
 *
 * TclpTempFileNameForLibrary --
 *
 *	Constructs a temporary file name for loading a shared object (DLL).
 *
 * Results:
 *	Returns the constructed file name.
 *
 * On Windows, a DLL is identified by the final component of its path name.
 * Cross linking among DLL's (and hence, preloading) will not work unless
 * this name is preserved when copying a DLL from a VFS to a temp file for
 * preloading. For this reason, all DLLs in a given process are copied
 * to a temp directory, and their names are preserved.
 *
 *-----------------------------------------------------------------------------
 */

Tcl_Obj*
TclpTempFileNameForLibrary(Tcl_Interp* interp, /* Tcl interpreter */
			   Tcl_Obj* path)      /* Path name of the DLL in
						* the VFS */
{
    size_t nameLen;		/* Length of the temp folder name */
    WCHAR name[MAX_PATH];	/* Path name of the temp folder */
    BOOL status;		/* Status from Win32 API calls */
    Tcl_Obj* fileName;		/* Name of the temp file */
    Tcl_Obj* tail;		/* Tail of the source path */

    /*
     * Determine the name of the directory to use, and create it.
     * (Keep trying with new names until an attempt to create the directory
     * succeeds)
     */

    nameLen = 0;
    if (dllDirectoryName == NULL) {
	Tcl_MutexLock(&loadMutex);
	if (dllDirectoryName == NULL) {
	    if ((nameLen = GetTempPathW(MAX_PATH, name)) >= 0) {
		if (nameLen >= MAX_PATH-12) {
		    Tcl_SetErrno(ENAMETOOLONG);
		    nameLen = 0;
		} else {
		    wcscpy(name+nameLen, L"TCLXXXXXXXX");
		    nameLen += 11;
		}
	    }
	    status = 1;
	    if (nameLen != 0) {
		DWORD id;
		int i = 0;
		id = GetCurrentProcessId();
		for (;;) {
		    DWORD lastError;
		    wsprintfW(name+nameLen-8, L"%08x", id);
		    status = CreateDirectoryW(name, NULL);
		    if (status) {
			break;
		    }
		    if ((lastError = GetLastError()) != ERROR_ALREADY_EXISTS) {
			TclWinConvertError(lastError);
			break;
		    } else if (++i > 256) {
			TclWinConvertError(lastError);
			break;
		    }
		    id *= 16777619;
		}
	    }
	    if (status != 0) {
		dllDirectoryName = (WCHAR*)
		    ckalloc((nameLen+1) * sizeof(WCHAR));
		wcscpy(dllDirectoryName, name);
	    }
	}
	Tcl_MutexUnlock(&loadMutex);
    }
    if (dllDirectoryName == NULL) {
	Tcl_AppendResult(interp, "couldn't create temporary directory: ",
			 Tcl_PosixError(interp), NULL);
    }
    fileName = TclpNativeToNormalized((ClientData) dllDirectoryName);
    tail = TclPathPart(interp, path, TCL_PATH_TAIL);
    if (tail == NULL) {
	Tcl_DecrRefCount(fileName);
	return NULL;
    } else {
	Tcl_AppendToObj(fileName, "/", 1);
	Tcl_AppendObjToObj(fileName, tail);
	return fileName;
    }    
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

/*
 * tclWinReg.c --
 *
 *	This file contains the implementation of the "registry" Tcl built-in
 *	command. This command is built as a dynamically loadable extension in
 *	a separate DLL.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by 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: tclWinReg.c,v 1.21.4.24 2010/04/02 23:48:14 dgp Exp $
 */

#undef STATIC_BUILD
#ifndef USE_TCL_STUBS
#   define USE_TCL_STUBS
#endif
#include "tclInt.h"

	}
	errString = "keyName ?-timeout milliseconds?";
	break;
    case DeleteIdx:		/* delete */
	if (argc == 1) {
	    return DeleteKey(interp, objv[n], mode);
	} else if (argc == 2) {
	    return DeleteValue(interp, objv[n], objv[n+1], mode);
	}
	errString = "keyName ?valueName?";
	break;
    case GetIdx:		/* get */
	if (argc == 2) {
	    return GetValue(interp, objv[n], objv[n+1], mode);
	}
	errString = "keyName valueName";
	break;
    case KeysIdx:		/* keys */
	if (argc == 1) {
	    return GetKeyNames(interp, objv[n], NULL, mode);
	} else if (argc == 2) {
	    return GetKeyNames(interp, objv[n], objv[n+1], mode);
	}
	errString = "keyName ?pattern?";
	break;
    case SetIdx:		/* set */
	if (argc == 1) {
	    HKEY key;

	    /*
	     * Create the key and then close it immediately.
	     */

	    mode |= KEY_ALL_ACCESS;
	    if (OpenKey(interp, objv[n], mode, 1, &key) != TCL_OK) {
		return TCL_ERROR;
	    }
	    RegCloseKey(key);
	    return TCL_OK;
	} else if (argc == 3) {
	    return SetValue(interp, objv[n], objv[n+1], objv[n+2], NULL,
		    mode);
	} else if (argc == 4) {
	    return SetValue(interp, objv[n], objv[n+1], objv[n+2], objv[n+3],
		    mode);
	}
	errString = "keyName ?valueName data ?type??";
	break;
    case TypeIdx:		/* type */
	if (argc == 2) {
	    return GetType(interp, objv[n], objv[n+1], mode);
	}
	errString = "keyName valueName";
	break;
    case ValuesIdx:		/* values */
	if (argc == 1) {
	    return GetValueNames(interp, objv[n], NULL, mode);
	} else if (argc == 2) {
	    return GetValueNames(interp, objv[n], objv[n+1], mode);
	}
	errString = "keyName ?pattern?";
	break;
    }
    Tcl_WrongNumArgs(interp, (mode ? 3 : 2), objv, errString);
    return TCL_ERROR;
}