[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

typedef struct {
    AV *	x_resolve_using;
} my_cxtx_t;		/* this *must* be named my_cxtx_t */

#define DL_CXT_EXTRA	/* ask for dl_cxtx to be defined in dlutils.c */
#include "dlutils.c"	/* SaveError() etc	*/

#define dl_resolve_using	(dl_cxtx.x_resolve_using)

static char *dlerror()
{
    dTHX;
    dMY_CXT;
    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)
{
    dTHX;
    dMY_CXT;
    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 = Perl_form_nocontext(OFIErrorStrings[index], path, number);
	break;

    default:
	error = Perl_form_nocontext("%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;
    dMY_CXT;

    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;
    dMY_CXT;
	
    /* 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, Perl_form_nocontext("_%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);
    {
	dMY_CXT;
	dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI);
    }
}
 
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(Perl_debug_log, "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(Perl_debug_log, " libref=%x\n", RETVAL));
    ST(0) = sv_newmortal() ;
    if (RETVAL == NULL)
	SaveError(aTHX_ "%s",dlerror()) ;
    else
	sv_setiv( ST(0), PTR2IV(RETVAL) );


void *
dl_find_symbol(libhandle, symbolname)
    void *		libhandle
    char *		symbolname
    CODE:
#if NS_TARGET_MAJOR >= 4
    symbolname = Perl_form_nocontext("_%s", symbolname);
#endif
    DLDEBUG(2, PerlIO_printf(Perl_debug_log,
			     "dl_find_symbol(handle=%lx, symbol=%s)\n",
			     (unsigned long) libhandle, symbolname));
    RETVAL = dlsym(libhandle, symbolname);
    DLDEBUG(2, PerlIO_printf(Perl_debug_log,
			     "  symbolref = %lx\n", (unsigned long) RETVAL));
    ST(0) = sv_newmortal() ;
    if (RETVAL == NULL)
	SaveError(aTHX_ "%s",dlerror()) ;
    else
	sv_setiv( ST(0), PTR2IV(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(Perl_debug_log, "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:
    dMY_CXT;
    RETVAL = dl_last_error ;
    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
cdc73a10	47	typedef struct {
	48	AV * x_resolve_using;
	49	} my_cxtx_t; /* this must be named my_cxtx_t */
a0d0e21e	50
cdc73a10	51	#define DL_CXT_EXTRA /* ask for dl_cxtx to be defined in dlutils.c */
cdc73a10	52	#include "dlutils.c" /* SaveError() etc */
a0d0e21e	53
cdc73a10	54	#define dl_resolve_using (dl_cxtx.x_resolve_using)
a0d0e21e	55
d6bcbf1c	56	static char *dlerror()
d6bcbf1c	57	{
cdc73a10	58	dTHX;
cdc73a10	59	dMY_CXT;
d6bcbf1c	60	return dl_last_error;
	61	}
	62
	63	int dlclose(handle) /* stub only */
	64	void *handle;
	65	{
	66	return 0;
	67	}
	68
	69	#if NS_TARGET_MAJOR >= 4
	70	#import <mach-o/dyld.h>
	71
	72	enum dyldErrorSource
	73	{
	74	OFImage,
	75	};
	76
	77	static void TranslateError
	78	(const char *path, enum dyldErrorSource type, int number)
	79	{
5b877257	80	dTHX;
cdc73a10	81	dMY_CXT;
46fc3d4c	82	char *error;
d6bcbf1c	83	unsigned int index;
	84	static char *OFIErrorStrings[] =
	85	{
	86	"%s(%d): Object Image Load Failure\n",
	87	"%s(%d): Object Image Load Success\n",
	88	"%s(%d): Not an recognisable object file\n",
	89	"%s(%d): No valid architecture\n",
	90	"%s(%d): Object image has an invalid format\n",
	91	"%s(%d): Invalid access (permissions?)\n",
	92	"%s(%d): Unknown error code from NSCreateObjectFileImageFromFile\n",
	93	};
	94	#define NUM_OFI_ERRORS (sizeof(OFIErrorStrings) / sizeof(OFIErrorStrings[0]))
	95
d6bcbf1c	96	switch (type)
	97	{
	98	case OFImage:
	99	index = number;
	100	if (index > NUM_OFI_ERRORS - 1)
	101	index = NUM_OFI_ERRORS - 1;
7a3f2258	102	error = Perl_form_nocontext(OFIErrorStrings[index], path, number);
d6bcbf1c	103	break;
	104
	105	default:
7a3f2258	106	error = Perl_form_nocontext("%s(%d): Totally unknown error type %d\n",
46fc3d4c	107	path, number, type);
d6bcbf1c	108	break;
d6bcbf1c	109	}
8c52afec	110	Safefree(dl_last_error);
46fc3d4c	111	dl_last_error = savepv(error);
d6bcbf1c	112	}
	113
	114	static char dlopen(char path, int mode /* mode is ignored */)
	115	{
	116	int dyld_result;
	117	NSObjectFileImage ofile;
	118	NSModule handle = NULL;
	119
	120	dyld_result = NSCreateObjectFileImageFromFile(path, &ofile);
	121	if (dyld_result != NSObjectFileImageSuccess)
	122	TranslateError(path, OFImage, dyld_result);
	123	else
	124	{
	125	// NSLinkModule will cause the run to abort on any link error's
	126	// not very friendly but the error recovery functionality is limited.
	127	handle = NSLinkModule(ofile, path, TRUE);
	128	}
	129
	130	return handle;
	131	}
	132
	133	void *
	134	dlsym(handle, symbol)
	135	void *handle;
	136	char *symbol;
	137	{
	138	void *addr;
	139
	140	if (NSIsSymbolNameDefined(symbol))
	141	addr = NSAddressOfSymbol(NSLookupAndBindSymbol(symbol));
	142	else
	143	addr = NULL;
	144
	145	return addr;
	146	}
	147
	148	#else /* NS_TARGET_MAJOR <= 3 */
	149
	150	static NXStream *OpenError(void)
a0d0e21e	151	{
	152	return NXOpenMemory( (char *) 0, 0, NX_WRITEONLY);
	153	}
	154
d6bcbf1c	155	static void TransferError(NXStream *s)
a0d0e21e	156	{
	157	char *buffer;
	158	int len, maxlen;
cdc73a10	159	dMY_CXT;
a0d0e21e	160
a0d0e21e	161	if ( dl_last_error ) {
8c52afec	162	Safefree(dl_last_error);
a0d0e21e	163	}
a0d0e21e	164	NXGetMemoryBuffer(s, &buffer, &len, &maxlen);
8c52afec	165	New(1097, dl_last_error, len, char);
a0d0e21e	166	strcpy(dl_last_error, buffer);
	167	}
	168
d6bcbf1c	169	static void CloseError(NXStream *s)
a0d0e21e	170	{
	171	if ( s ) {
	172	NXCloseMemory( s, NX_FREEBUFFER);
	173	}
	174	}
	175
d6bcbf1c	176	static char dlopen(char path, int mode /* mode is ignored */)
a0d0e21e	177	{
a0d0e21e	178	int rld_success;
8e07c86e	179	NXStream *nxerr;
a0d0e21e	180	I32 i, psize;
	181	char *result;
	182	char **p;
2d8e6c8d	183	STRLEN n_a;
cdc73a10	184	dMY_CXT;
8e07c86e	185
	186	/* Do not load what is already loaded into this process */
	187	if (hv_fetch(dl_loaded_files, path, strlen(path), 0))
	188	return path;
a0d0e21e	189
8e07c86e	190	nxerr = OpenError();
8e07c86e	191	psize = AvFILL(dl_resolve_using) + 3;
a0d0e21e	192	p = (char *) safemalloc(psize sizeof(char*));
	193	p[0] = path;
	194	for(i=1; i<psize-1; i++) {
2d8e6c8d	195	p[i] = SvPVx(*av_fetch(dl_resolve_using, i-1, TRUE), n_a);
a0d0e21e	196	}
	197	p[psize-1] = 0;
	198	rld_success = rld_load(nxerr, (struct mach_header **)0, p,
	199	(const char *) 0);
	200	safefree((char*) p);
	201	if (rld_success) {
	202	result = path;
8e07c86e	203	/* prevent multiple loads of same file into same process */
3280af22	204	hv_store(dl_loaded_files, path, strlen(path), &PL_sv_yes, 0);
a0d0e21e	205	} else {
	206	TransferError(nxerr);
	207	result = (char*) 0;
	208	}
	209	CloseError(nxerr);
	210	return result;
	211	}
	212
a0d0e21e	213	void *
	214	dlsym(handle, symbol)
	215	void *handle;
	216	char *symbol;
	217	{
	218	NXStream *nxerr = OpenError();
a0d0e21e	219	unsigned long symref = 0;
a0d0e21e	220
7a3f2258	221	if (!rld_lookup(nxerr, Perl_form_nocontext("_%s", symbol), &symref))
a0d0e21e	222	TransferError(nxerr);
a0d0e21e	223	CloseError(nxerr);
	224	return (void*) symref;
	225	}
	226
d6bcbf1c	227	#endif /* NS_TARGET_MAJOR >= 4 */
d6bcbf1c	228
a0d0e21e	229
	230	/* ----- code from dl_dlopen.xs below here ----- */
	231
	232
	233	static void
cea2e8a9	234	dl_private_init(pTHX)
a0d0e21e	235	{
cea2e8a9	236	(void)dl_generic_private_init(aTHX);
cdc73a10	237	{
	238	dMY_CXT;
	239	dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI);
	240	}
a0d0e21e	241	}
	242
	243	MODULE = DynaLoader PACKAGE = DynaLoader
	244
	245	BOOT:
cea2e8a9	246	(void)dl_private_init(aTHX);
a0d0e21e	247
	248
	249
	250	void *
ff7f3c60	251	dl_load_file(filename, flags=0)
a0d0e21e	252	char * filename
ff7f3c60	253	int flags
ff7f3c60	254	PREINIT:
a0d0e21e	255	int mode = 1;
ff7f3c60	256	CODE:
bf49b057	257	DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
ff7f3c60	258	if (flags & 0x01)
cea2e8a9	259	Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
a0d0e21e	260	RETVAL = dlopen(filename, mode) ;
bf49b057	261	DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL));
a0d0e21e	262	ST(0) = sv_newmortal() ;
a0d0e21e	263	if (RETVAL == NULL)
cea2e8a9	264	SaveError(aTHX_ "%s",dlerror()) ;
a0d0e21e	265	else
3175b8cd	266	sv_setiv( ST(0), PTR2IV(RETVAL) );
a0d0e21e	267
	268
	269	void *
	270	dl_find_symbol(libhandle, symbolname)
	271	void * libhandle
	272	char * symbolname
	273	CODE:
d6bcbf1c	274	#if NS_TARGET_MAJOR >= 4
7a3f2258	275	symbolname = Perl_form_nocontext("_%s", symbolname);
d6bcbf1c	276	#endif
bf49b057	277	DLDEBUG(2, PerlIO_printf(Perl_debug_log,
46fc3d4c	278	"dl_find_symbol(handle=%lx, symbol=%s)\n",
46fc3d4c	279	(unsigned long) libhandle, symbolname));
a0d0e21e	280	RETVAL = dlsym(libhandle, symbolname);
bf49b057	281	DLDEBUG(2, PerlIO_printf(Perl_debug_log,
46fc3d4c	282	" symbolref = %lx\n", (unsigned long) RETVAL));
a0d0e21e	283	ST(0) = sv_newmortal() ;
a0d0e21e	284	if (RETVAL == NULL)
cea2e8a9	285	SaveError(aTHX_ "%s",dlerror()) ;
a0d0e21e	286	else
3175b8cd	287	sv_setiv( ST(0), PTR2IV(RETVAL) );
a0d0e21e	288
	289
	290	void
	291	dl_undef_symbols()
	292	PPCODE:
	293
	294
	295
	296	# These functions should not need changing on any platform:
	297
	298	void
	299	dl_install_xsub(perl_name, symref, filename="$Package")
	300	char * perl_name
	301	void * symref
	302	char * filename
	303	CODE:
bf49b057	304	DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
a0d0e21e	305	perl_name, symref));
cea2e8a9	306	ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
	307	(void()(pTHX_ CV ))symref,
	308	filename)));
a0d0e21e	309
	310
	311	char *
	312	dl_error()
	313	CODE:
cdc73a10	314	dMY_CXT;
cdc73a10	315	RETVAL = dl_last_error ;
a0d0e21e	316	OUTPUT:
	317	RETVAL
	318
	319	# end.