/*

 * tclMacLoad.c --

 *

 *	This procedure provides a version of the TclLoadFile for use

 *	on the Macintosh.  This procedure will only work with systems 

 *	that use the Code Fragment Manager.

 *

 * 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: tclMacLoad.c,v 1.16 2002/10/09 11:54:26 das Exp $

 */

#include <CodeFragments.h>

#include <Errors.h>

#include <Resources.h>

#include <Strings.h>

#include <FSpCompat.h>

/*

 * Seems that the 3.0.1 Universal headers leave this define out.  So we

 * define it here...

 */

#ifndef fragNoErr

    #define fragNoErr noErr

#endif

#include "tclPort.h"

#include "tclInt.h"

#include "tclMacInt.h"

#if GENERATINGPOWERPC

    #define OUR_ARCH_TYPE kPowerPCCFragArch

#else

    #define OUR_ARCH_TYPE kMotorola68KCFragArch

#endif

/*

 * The following data structure defines the structure of a code fragment

 * resource.  We can cast the resource to be of this type to access

 * any fields we need to see.

 */

struct CfrgHeader {

    long 	res1;

    long 	res2;

    long 	version;

    long 	res3;

    long 	res4;

    long 	filler1;

    long 	filler2;

    long 	itemCount;

    char	arrayStart;	/* Array of externalItems begins here. */

};

typedef struct CfrgHeader CfrgHeader, *CfrgHeaderPtr, **CfrgHeaderPtrHand;

/*

 * The below structure defines a cfrag item within the cfrag resource.

 */

struct CfrgItem {

    OSType 	archType;

    long 	updateLevel;

    long	currVersion;

    long	oldDefVersion;

    long	appStackSize;

    short	appSubFolder;

    char	usage;

    char	location;

    long	codeOffset;

    long	codeLength;

    long	res1;

    long	res2;

    short	itemSize;

    Str255	name;		/* This is actually variable sized. */

};

typedef struct CfrgItem CfrgItem;

/*

 * On MacOS, old shared libraries which contain many code fragments

 * cannot, it seems, be loaded in one go.  We need to look provide

 * the name of a code fragment while we load.  Since with the

 * separation of the 'load' and 'findsymbol' be do not necessarily

 * know a symbol name at load time, we have to store some further

 * information in a structure like this so we can ensure we load

 * properly in 'findsymbol' if the first attempts didn't work.

 */

typedef struct TclMacLoadInfo {

    int loaded;

    CFragConnectionID connID;

    FSSpec fileSpec;

} TclMacLoadInfo;

static int TryToLoad(Tcl_Interp *interp, TclMacLoadInfo *loadInfo, Tcl_Obj *pathPtr, 

		     CONST char *sym /* native */);

/*

 *----------------------------------------------------------------------

 *

 * TclpDlopen --

 *

 *	This procedure is called to carry out dynamic loading of binary

 *	code for the Macintosh.  This implementation is based on the

 *	Code Fragment Manager & will not work on other systems.

 *

 * Results:

 *	The result is TCL_ERROR, and an error message is left in

 *	the interp's result.

 *

 * Side effects:

 *	New binary code is loaded.

 *

 *----------------------------------------------------------------------

 */

int

TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)

    Tcl_Interp *interp;		/* Used for error reporting. */

    Tcl_Obj *pathPtr;		/* Name of the file containing the desired

				 * code (UTF-8). */

    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded

				 * 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. */

{

    OSErr err;

    FSSpec fileSpec;

    CONST char *native;

    TclMacLoadInfo *loadInfo;

    native = Tcl_FSGetNativePath(pathPtr);

    err = FSpLocationFromPath(strlen(native), native, &fileSpec);

    if (err != noErr) {

	Tcl_SetResult(interp, "could not locate shared library", TCL_STATIC);

	return TCL_ERROR;

    }

    loadInfo = (TclMacLoadInfo *) ckalloc(sizeof(TclMacLoadInfo));

    loadInfo->loaded = 0;

    loadInfo->fileSpec = fileSpec;

    loadInfo->connID = NULL;

    if (TryToLoad(interp, loadInfo, pathPtr, NULL) != TCL_OK) {

	ckfree((char*) loadInfo);

	return TCL_ERROR;

    }

    *loadHandle = (Tcl_LoadHandle)loadInfo;

    *unloadProcPtr = &TclpUnloadFile;

    return TCL_OK;

}

/* 

 * See the comments about 'struct TclMacLoadInfo' above. This

 * function ensures the appropriate library or symbol is

 * loaded.

 */

static int

TryToLoad(Tcl_Interp *interp, TclMacLoadInfo *loadInfo, Tcl_Obj *pathPtr,

	  CONST char *sym /* native */) 

{

    OSErr err;

    CFragConnectionID connID;

    Ptr dummy;

    short fragFileRef, saveFileRef;

    Handle fragResource;

    UInt32 offset = 0;

    UInt32 length = kCFragGoesToEOF;

    Str255 errName;

    StringPtr fragName=NULL;

    if (loadInfo->loaded == 1) {

        return TCL_OK;

    }

    /*

     * See if this fragment has a 'cfrg' resource.  It will tell us where

     * to look for the fragment in the file.  If it doesn't exist we will

     * assume we have a ppc frag using the whole data fork.  If it does

     * exist we find the frag that matches the one we are looking for and

     * get the offset and size from the resource.

     */

    saveFileRef = CurResFile();

    SetResLoad(false);

    fragFileRef = FSpOpenResFile(&loadInfo->fileSpec, fsRdPerm);

    SetResLoad(true);

    if (fragFileRef != -1) {

	if (sym != NULL) {

	    UseResFile(fragFileRef);

	    fragResource = Get1Resource(kCFragResourceType, kCFragResourceID);

	    HLock(fragResource);

	    if (ResError() == noErr) {

		CfrgItem* srcItem;

		long itemCount, index;

		Ptr itemStart;

		itemCount = (*(CfrgHeaderPtrHand)fragResource)->itemCount;

		itemStart = &(*(CfrgHeaderPtrHand)fragResource)->arrayStart;

		for (index = 0; index < itemCount;

		     index++, itemStart += srcItem->itemSize) {

		    srcItem = (CfrgItem*)itemStart;

		    if (srcItem->archType != OUR_ARCH_TYPE) continue;

		    if (!strncasecmp(sym, (char *) srcItem->name + 1,

			    strlen(sym))) {

			offset = srcItem->codeOffset;

			length = srcItem->codeLength;

			fragName=srcItem->name;

		    }

		}

	    }

	}

	/*

	 * Close the resource file.  If the extension wants to reopen the

	 * resource fork it should use the tclMacLibrary.c file during it's

	 * construction.

	 */

	HUnlock(fragResource);

	ReleaseResource(fragResource);

	CloseResFile(fragFileRef);

	UseResFile(saveFileRef);

	if (sym == NULL) {

	    /* We just return */

	    return TCL_OK;

	}

    }

    /*

     * Now we can attempt to load the fragment using the offset & length

     * obtained from the resource.  We don't worry about the main entry point

     * as we are going to search for specific entry points passed to us.

     */

    err = GetDiskFragment(&loadInfo->fileSpec, offset, length, fragName,

	    kLoadCFrag, &connID, &dummy, errName);

    if (err != fragNoErr) {

	p2cstr(errName);

	if(pathPtr) {

	Tcl_AppendResult(interp, "couldn't load file \"", 

			 Tcl_GetString(pathPtr),

			 "\": ", errName, (char *) NULL);

	} else if(sym) {

	Tcl_AppendResult(interp, "couldn't load library \"", 

			 sym,

			 "\": ", errName, (char *) NULL);

	}

	return TCL_ERROR;

    }

    loadInfo->connID = connID;

    loadInfo->loaded = 1;

    return TCL_OK;

}

/*

 *----------------------------------------------------------------------

 *

 * TclpFindSymbol --

 *

 *	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.

 *

 *----------------------------------------------------------------------

 */

Tcl_PackageInitProc*

TclpFindSymbol(interp, loadHandle, symbol) 

    Tcl_Interp *interp;

    Tcl_LoadHandle loadHandle;

    CONST char *symbol;

{

    Tcl_DString ds;

    Tcl_PackageInitProc *proc=NULL;

    TclMacLoadInfo *loadInfo = (TclMacLoadInfo *)loadHandle;

    Str255 symbolName;

    CFragSymbolClass symClass;

    OSErr err;

    if (loadInfo->loaded == 0) {

	int res;

	/*

	 * First thing we must do is infer the package name from the

	 * sym variable.  We do this by removing the '_Init'.

	 */

	Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);

	Tcl_DStringSetLength(&ds, Tcl_DStringLength(&ds) - 5);

	res = TryToLoad(interp, loadInfo, NULL, Tcl_DStringValue(&ds));

	Tcl_DStringFree(&ds);

	if (res != TCL_OK) {

	    return NULL;

	}

    }

    Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);

    strcpy((char *) symbolName + 1, Tcl_DStringValue(&ds));

    symbolName[0] = (unsigned) Tcl_DStringLength(&ds);

    err = FindSymbol(loadInfo->connID, symbolName, (Ptr *) &proc, &symClass);

    Tcl_DStringFree(&ds);

    if (err != fragNoErr || symClass == kDataCFragSymbol) {

	Tcl_SetResult(interp,

		"could not find Initialization routine in library",

		TCL_STATIC);

	return NULL;

    }

    return proc;

}

/*

 *----------------------------------------------------------------------

 *

 * TclpUnloadFile --

 *

 *	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

TclpUnloadFile(loadHandle)

    Tcl_LoadHandle loadHandle;	/* loadHandle returned by a previous call

				 * to TclpDlopen().  The loadHandle is 

				 * a token that represents the loaded 

				 * file. */

{

    TclMacLoadInfo *loadInfo = (TclMacLoadInfo *)loadHandle;

    if (loadInfo->loaded) {

	CloseConnection((CFragConnectionID*) &(loadInfo->connID));

    }

    ckfree((char*)loadInfo);

}

/*

 *----------------------------------------------------------------------

 *

 * 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 name;  generic code will then try to guess the package

 *	from the file name.  A return value of 1 would have meant that

 *	we figured out the package name and put it in bufPtr.

 *

 * Side effects:

 *	None.

 *

 *----------------------------------------------------------------------

 */

int

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;

}