[p5sagit/p5-mst-13.2.git] / ext / DynaLoader / dl_next.xs

/* dl_next.xs
 * 
 * Platform:	NeXT NS 3.2
 * Author:	Anno Siegel (siegel@zrz.TU-Berlin.DE)
 * Based on:	dl_dlopen.xs by Paul Marquess
 * Created:	Aug 15th, 1994
 *
 */

/*
    And Gandalf said: 'Many folk like to know beforehand what is to
    be set on the table; but those who have laboured to prepare the
    feast like to keep their secret; for wonder makes the words of
    praise louder.'
*/

/* Porting notes:

dl_next.xs is itself a port from dl_dlopen.xs by Paul Marquess.  It
should not be used as a base for further ports though it may be used
as an example for how dl_dlopen.xs can be ported to other platforms.

The method used here is just to supply the sun style dlopen etc.
functions in terms of NeXTs rld_*.  The xs code proper is unchanged
from Paul's original.

The port could use some streamlining.  For one, error handling could
be simplified.

Anno Siegel

*/

#if NS_TARGET_MAJOR >= 4
#else
/* include these before perl headers */
#include <mach-o/rld.h>
#include <streams/streams.h>
#endif

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#define DL_LOADONCEONLY

#include "dlutils.c"	/* SaveError() etc	*/


static char * dl_last_error = (char *) 0;
static AV *dl_resolve_using = Nullav;

static char *dlerror()
{
    return dl_last_error;
}

int dlclose(handle) /* stub only */
void *handle;
{
    return 0;
}

#if NS_TARGET_MAJOR >= 4
#import <mach-o/dyld.h>

enum dyldErrorSource
{
    OFImage,
};

static void TranslateError
    (const char *path, enum dyldErrorSource type, int number)
{
    char *error;
    unsigned int index;
    static char *OFIErrorStrings[] =
    {
	"%s(%d): Object Image Load Failure\n",
	"%s(%d): Object Image Load Success\n",
	"%s(%d): Not an recognisable object file\n",
	"%s(%d): No valid architecture\n",
	"%s(%d): Object image has an invalid format\n",
	"%s(%d): Invalid access (permissions?)\n",
	"%s(%d): Unknown error code from NSCreateObjectFileImageFromFile\n",
    };
#define NUM_OFI_ERRORS (sizeof(OFIErrorStrings) / sizeof(OFIErrorStrings[0]))

    switch (type)
    {
    case OFImage:
	index = number;
	if (index > NUM_OFI_ERRORS - 1)
	    index = NUM_OFI_ERRORS - 1;
	error = form(OFIErrorStrings[index], path, number);
	break;

    default:
	error = form("%s(%d): Totally unknown error type %d\n",
		     path, number, type);
	break;
    }
    Safefree(dl_last_error);
    dl_last_error = savepv(error);
}

static char *dlopen(char *path, int mode /* mode is ignored */)
{
    int dyld_result;
    NSObjectFileImage ofile;
    NSModule handle = NULL;

    dyld_result = NSCreateObjectFileImageFromFile(path, &ofile);
    if (dyld_result != NSObjectFileImageSuccess)
	TranslateError(path, OFImage, dyld_result);
    else
    {
    	// NSLinkModule will cause the run to abort on any link error's
	// not very friendly but the error recovery functionality is limited.
	handle = NSLinkModule(ofile, path, TRUE);
    }
    
    return handle;
}

void *
dlsym(handle, symbol)
void *handle;
char *symbol;
{
    void *addr;

    if (NSIsSymbolNameDefined(symbol))
	addr = NSAddressOfSymbol(NSLookupAndBindSymbol(symbol));
    else
    	addr = NULL;

    return addr;
}

#else /* NS_TARGET_MAJOR <= 3 */

static NXStream *OpenError(void)
{
    return NXOpenMemory( (char *) 0, 0, NX_WRITEONLY);
}

static void TransferError(NXStream *s)
{
    char *buffer;
    int len, maxlen;

    if ( dl_last_error ) {
        Safefree(dl_last_error);
    }
    NXGetMemoryBuffer(s, &buffer, &len, &maxlen);
    New(1097, dl_last_error, len, char);
    strcpy(dl_last_error, buffer);
}

static void CloseError(NXStream *s)
{
    if ( s ) {
      NXCloseMemory( s, NX_FREEBUFFER);
    }
}

static char *dlopen(char *path, int mode /* mode is ignored */)
{
    int rld_success;
    NXStream *nxerr;
    I32 i, psize;
    char *result;
    char **p;
    STRLEN n_a;
	
    /* Do not load what is already loaded into this process */
    if (hv_fetch(dl_loaded_files, path, strlen(path), 0))
	return path;

    nxerr = OpenError();
    psize = AvFILL(dl_resolve_using) + 3;
    p = (char **) safemalloc(psize * sizeof(char*));
    p[0] = path;
    for(i=1; i<psize-1; i++) {
	p[i] = SvPVx(*av_fetch(dl_resolve_using, i-1, TRUE), n_a);
    }
    p[psize-1] = 0;
    rld_success = rld_load(nxerr, (struct mach_header **)0, p,
			    (const char *) 0);
    safefree((char*) p);
    if (rld_success) {
	result = path;
	/* prevent multiple loads of same file into same process */
	hv_store(dl_loaded_files, path, strlen(path), &PL_sv_yes, 0);
    } else {
	TransferError(nxerr);
	result = (char*) 0;
    }
    CloseError(nxerr);
    return result;
}

void *
dlsym(handle, symbol)
void *handle;
char *symbol;
{
    NXStream	*nxerr = OpenError();
    unsigned long	symref = 0;

    if (!rld_lookup(nxerr, form("_%s", symbol), &symref))
	TransferError(nxerr);
    CloseError(nxerr);
    return (void*) symref;
}

#endif /* NS_TARGET_MAJOR >= 4 */


/* ----- code from dl_dlopen.xs below here ----- */


static void
dl_private_init(pTHX)
{
    (void)dl_generic_private_init(aTHX);
    dl_resolve_using = get_av("DynaLoader::dl_resolve_using", 0x4);
}
 
MODULE = DynaLoader     PACKAGE = DynaLoader

BOOT:
    (void)dl_private_init(aTHX);


void *
dl_load_file(filename, flags=0)
    char *	filename
    int		flags
    PREINIT:
    int mode = 1;
    CODE:
    DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags));
    if (flags & 0x01)
	Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
    RETVAL = dlopen(filename, mode) ;
    DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL));
    ST(0) = sv_newmortal() ;
    if (RETVAL == NULL)
	SaveError(aTHX_ "%s",dlerror()) ;
    else
	sv_setiv( ST(0), (IV)RETVAL);


void *
dl_find_symbol(libhandle, symbolname)
    void *		libhandle
    char *		symbolname
    CODE:
#if NS_TARGET_MAJOR >= 4
    symbolname = form("_%s", symbolname);
#endif
    DLDEBUG(2, PerlIO_printf(PerlIO_stderr(),
			     "dl_find_symbol(handle=%lx, symbol=%s)\n",
			     (unsigned long) libhandle, symbolname));
    RETVAL = dlsym(libhandle, symbolname);
    DLDEBUG(2, PerlIO_printf(PerlIO_stderr(),
			     "  symbolref = %lx\n", (unsigned long) RETVAL));
    ST(0) = sv_newmortal() ;
    if (RETVAL == NULL)
	SaveError(aTHX_ "%s",dlerror()) ;
    else
	sv_setiv( ST(0), (IV)RETVAL);


void
dl_undef_symbols()
    PPCODE:


# These functions should not need changing on any platform:

void
dl_install_xsub(perl_name, symref, filename="$Package")
    char *	perl_name
    void *	symref 
    char *	filename
    CODE:
    DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n",
	    perl_name, symref));
    ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
					(void(*)(pTHX_ CV *))symref,
					filename)));


char *
dl_error()
    CODE:
    RETVAL = LastError ;
    OUTPUT:
    RETVAL

# end.
Commit	Line	Data
a0d0e21e	1	/* dl_next.xs
	2	*
	3	* Platform: NeXT NS 3.2
	4	* Author: Anno Siegel (siegel@zrz.TU-Berlin.DE)
	5	* Based on: dl_dlopen.xs by Paul Marquess
	6	* Created: Aug 15th, 1994
	7	*
	8	*/
	9
	10	/*
	11	And Gandalf said: 'Many folk like to know beforehand what is to
	12	be set on the table; but those who have laboured to prepare the
	13	feast like to keep their secret; for wonder makes the words of
	14	praise louder.'
	15	*/
	16
	17	/* Porting notes:
	18
	19	dl_next.xs is itself a port from dl_dlopen.xs by Paul Marquess. It
	20	should not be used as a base for further ports though it may be used
	21	as an example for how dl_dlopen.xs can be ported to other platforms.
	22
	23	The method used here is just to supply the sun style dlopen etc.
	24	functions in terms of NeXTs rld_*. The xs code proper is unchanged
	25	from Paul's original.
	26
	27	The port could use some streamlining. For one, error handling could
	28	be simplified.
	29
	30	Anno Siegel
	31
	32	*/
	33
d6bcbf1c	34	#if NS_TARGET_MAJOR >= 4
d6bcbf1c	35	#else
8e07c86e	36	/* include these before perl headers */
	37	#include <mach-o/rld.h>
	38	#include <streams/streams.h>
d6bcbf1c	39	#endif
8e07c86e	40
a0d0e21e	41	#include "EXTERN.h"
	42	#include "perl.h"
	43	#include "XSUB.h"
	44
8e07c86e	45	#define DL_LOADONCEONLY
a0d0e21e	46
8e07c86e	47	#include "dlutils.c" /* SaveError() etc */
a0d0e21e	48
a0d0e21e	49
a0d0e21e	50	static char * dl_last_error = (char *) 0;
8e07c86e	51	static AV *dl_resolve_using = Nullav;
a0d0e21e	52
d6bcbf1c	53	static char *dlerror()
	54	{
	55	return dl_last_error;
	56	}
	57
	58	int dlclose(handle) /* stub only */
	59	void *handle;
	60	{
	61	return 0;
	62	}
	63
	64	#if NS_TARGET_MAJOR >= 4
	65	#import <mach-o/dyld.h>
	66
	67	enum dyldErrorSource
	68	{
	69	OFImage,
	70	};
	71
	72	static void TranslateError
	73	(const char *path, enum dyldErrorSource type, int number)
	74	{
46fc3d4c	75	char *error;
d6bcbf1c	76	unsigned int index;
	77	static char *OFIErrorStrings[] =
	78	{
	79	"%s(%d): Object Image Load Failure\n",
	80	"%s(%d): Object Image Load Success\n",
	81	"%s(%d): Not an recognisable object file\n",
	82	"%s(%d): No valid architecture\n",
	83	"%s(%d): Object image has an invalid format\n",
	84	"%s(%d): Invalid access (permissions?)\n",
	85	"%s(%d): Unknown error code from NSCreateObjectFileImageFromFile\n",
	86	};
	87	#define NUM_OFI_ERRORS (sizeof(OFIErrorStrings) / sizeof(OFIErrorStrings[0]))
	88
d6bcbf1c	89	switch (type)
	90	{
	91	case OFImage:
	92	index = number;
	93	if (index > NUM_OFI_ERRORS - 1)
	94	index = NUM_OFI_ERRORS - 1;
46fc3d4c	95	error = form(OFIErrorStrings[index], path, number);
d6bcbf1c	96	break;
	97
	98	default:
46fc3d4c	99	error = form("%s(%d): Totally unknown error type %d\n",
46fc3d4c	100	path, number, type);
d6bcbf1c	101	break;
d6bcbf1c	102	}
8c52afec	103	Safefree(dl_last_error);
46fc3d4c	104	dl_last_error = savepv(error);
d6bcbf1c	105	}
	106
	107	static char dlopen(char path, int mode /* mode is ignored */)
	108	{
	109	int dyld_result;
	110	NSObjectFileImage ofile;
	111	NSModule handle = NULL;
	112
	113	dyld_result = NSCreateObjectFileImageFromFile(path, &ofile);
	114	if (dyld_result != NSObjectFileImageSuccess)
	115	TranslateError(path, OFImage, dyld_result);
	116	else
	117	{
	118	// NSLinkModule will cause the run to abort on any link error's
	119	// not very friendly but the error recovery functionality is limited.
	120	handle = NSLinkModule(ofile, path, TRUE);
	121	}
	122
	123	return handle;
	124	}
	125
	126	void *
	127	dlsym(handle, symbol)
	128	void *handle;
	129	char *symbol;
	130	{
	131	void *addr;
	132
	133	if (NSIsSymbolNameDefined(symbol))
	134	addr = NSAddressOfSymbol(NSLookupAndBindSymbol(symbol));
	135	else
	136	addr = NULL;
	137
	138	return addr;
	139	}
	140
	141	#else /* NS_TARGET_MAJOR <= 3 */
	142
	143	static NXStream *OpenError(void)
a0d0e21e	144	{
	145	return NXOpenMemory( (char *) 0, 0, NX_WRITEONLY);
	146	}
	147
d6bcbf1c	148	static void TransferError(NXStream *s)
a0d0e21e	149	{
	150	char *buffer;
	151	int len, maxlen;
	152
	153	if ( dl_last_error ) {
8c52afec	154	Safefree(dl_last_error);
a0d0e21e	155	}
a0d0e21e	156	NXGetMemoryBuffer(s, &buffer, &len, &maxlen);
8c52afec	157	New(1097, dl_last_error, len, char);
a0d0e21e	158	strcpy(dl_last_error, buffer);
	159	}
	160
d6bcbf1c	161	static void CloseError(NXStream *s)
a0d0e21e	162	{
	163	if ( s ) {
	164	NXCloseMemory( s, NX_FREEBUFFER);
	165	}
	166	}
	167
d6bcbf1c	168	static char dlopen(char path, int mode /* mode is ignored */)
a0d0e21e	169	{
a0d0e21e	170	int rld_success;
8e07c86e	171	NXStream *nxerr;
a0d0e21e	172	I32 i, psize;
	173	char *result;
	174	char **p;
2d8e6c8d	175	STRLEN n_a;
8e07c86e	176
	177	/* Do not load what is already loaded into this process */
	178	if (hv_fetch(dl_loaded_files, path, strlen(path), 0))
	179	return path;
a0d0e21e	180
8e07c86e	181	nxerr = OpenError();
8e07c86e	182	psize = AvFILL(dl_resolve_using) + 3;
a0d0e21e	183	p = (char *) safemalloc(psize sizeof(char*));
	184	p[0] = path;
	185	for(i=1; i<psize-1; i++) {
2d8e6c8d	186	p[i] = SvPVx(*av_fetch(dl_resolve_using, i-1, TRUE), n_a);
a0d0e21e	187	}
	188	p[psize-1] = 0;
	189	rld_success = rld_load(nxerr, (struct mach_header **)0, p,
	190	(const char *) 0);
	191	safefree((char*) p);
	192	if (rld_success) {
	193	result = path;
8e07c86e	194	/* prevent multiple loads of same file into same process */
3280af22	195	hv_store(dl_loaded_files, path, strlen(path), &PL_sv_yes, 0);
a0d0e21e	196	} else {
	197	TransferError(nxerr);
	198	result = (char*) 0;
	199	}
	200	CloseError(nxerr);
	201	return result;
	202	}
	203
a0d0e21e	204	void *
	205	dlsym(handle, symbol)
	206	void *handle;
	207	char *symbol;
	208	{
	209	NXStream *nxerr = OpenError();
a0d0e21e	210	unsigned long symref = 0;
a0d0e21e	211
89475926	212	if (!rld_lookup(nxerr, form("_%s", symbol), &symref))
a0d0e21e	213	TransferError(nxerr);
a0d0e21e	214	CloseError(nxerr);
	215	return (void*) symref;
	216	}
	217
d6bcbf1c	218	#endif /* NS_TARGET_MAJOR >= 4 */
d6bcbf1c	219
a0d0e21e	220
	221	/* ----- code from dl_dlopen.xs below here ----- */
	222
	223
	224	static void
cea2e8a9	225	dl_private_init(pTHX)
a0d0e21e	226	{
cea2e8a9	227	(void)dl_generic_private_init(aTHX);
cea2e8a9	228	dl_resolve_using = get_av("DynaLoader::dl_resolve_using", 0x4);
a0d0e21e	229	}
	230
	231	MODULE = DynaLoader PACKAGE = DynaLoader
	232
	233	BOOT:
cea2e8a9	234	(void)dl_private_init(aTHX);
a0d0e21e	235
	236
	237
	238	void *
ff7f3c60	239	dl_load_file(filename, flags=0)
a0d0e21e	240	char * filename
ff7f3c60	241	int flags
ff7f3c60	242	PREINIT:
a0d0e21e	243	int mode = 1;
ff7f3c60	244	CODE:
	245	DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags));
	246	if (flags & 0x01)
cea2e8a9	247	Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
a0d0e21e	248	RETVAL = dlopen(filename, mode) ;
760ac839	249	DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL));
a0d0e21e	250	ST(0) = sv_newmortal() ;
a0d0e21e	251	if (RETVAL == NULL)
cea2e8a9	252	SaveError(aTHX_ "%s",dlerror()) ;
a0d0e21e	253	else
	254	sv_setiv( ST(0), (IV)RETVAL);
	255
	256
	257	void *
	258	dl_find_symbol(libhandle, symbolname)
	259	void * libhandle
	260	char * symbolname
	261	CODE:
d6bcbf1c	262	#if NS_TARGET_MAJOR >= 4
46fc3d4c	263	symbolname = form("_%s", symbolname);
d6bcbf1c	264	#endif
46fc3d4c	265	DLDEBUG(2, PerlIO_printf(PerlIO_stderr(),
	266	"dl_find_symbol(handle=%lx, symbol=%s)\n",
	267	(unsigned long) libhandle, symbolname));
a0d0e21e	268	RETVAL = dlsym(libhandle, symbolname);
46fc3d4c	269	DLDEBUG(2, PerlIO_printf(PerlIO_stderr(),
46fc3d4c	270	" symbolref = %lx\n", (unsigned long) RETVAL));
a0d0e21e	271	ST(0) = sv_newmortal() ;
a0d0e21e	272	if (RETVAL == NULL)
cea2e8a9	273	SaveError(aTHX_ "%s",dlerror()) ;
a0d0e21e	274	else
	275	sv_setiv( ST(0), (IV)RETVAL);
	276
	277
	278	void
	279	dl_undef_symbols()
	280	PPCODE:
	281
	282
	283
	284	# These functions should not need changing on any platform:
	285
	286	void
	287	dl_install_xsub(perl_name, symref, filename="$Package")
	288	char * perl_name
	289	void * symref
	290	char * filename
	291	CODE:
760ac839	292	DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n",
a0d0e21e	293	perl_name, symref));
cea2e8a9	294	ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
	295	(void()(pTHX_ CV ))symref,
	296	filename)));
a0d0e21e	297
	298
	299	char *
	300	dl_error()
	301	CODE:
	302	RETVAL = LastError ;
	303	OUTPUT:
	304	RETVAL
	305
	306	# end.