#define PERL_EXT
#include "EXTERN.h"
#define PERL_IN_DL_DYLD_XS
#include "perl.h"
#include "XSUB.h"
#include "dlutils.c" /* for SaveError() etc */
#undef environ
#import <mach-o/dyld.h>
static
char
*dlerror()
{
dTHX;
dMY_CXT;
return
dl_last_error;
}
static
int
dlclose(
void
*handle)
{
return
0;
}
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 a 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
;
}
sv_setpv(MY_CXT.x_dl_last_error, error);
}
static
char
*dlopen(
char
*path)
{
int
dyld_result;
NSObjectFileImage ofile;
NSModule handle = NULL;
dyld_result = NSCreateObjectFileImageFromFile(path, &ofile);
if
(dyld_result != NSObjectFileImageSuccess)
TranslateError(path, OFImage, dyld_result);
else
{
handle = NSLinkModule(ofile, path, TRUE);
NSDestroyObjectFileImage(ofile);
}
return
handle;
}
static
void
*
dlsym(
void
*handle,
char
*symbol)
{
void
*addr;
if
(NSIsSymbolNameDefined(symbol))
addr = NSAddressOfSymbol(NSLookupAndBindSymbol(symbol));
else
addr = NULL;
return
addr;
}
static
void
dl_private_init(pTHX)
{
(
void
)dl_generic_private_init(aTHX);
}
MODULE = DynaLoader PACKAGE = DynaLoader
BOOT:
(
void
)dl_private_init(aTHX);
void
*
dl_load_file(filename, flags=0)
char
* filename
int
flags
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);
DLDEBUG(2,PerlIO_printf(Perl_debug_log,
" libref=%x\n"
, RETVAL));
ST(0) = newSV_type_mortal(SVt_IV);
if
(RETVAL == NULL)
SaveError(aTHX_
"%s"
,dlerror()) ;
else
sv_setiv( ST(0), PTR2IV(RETVAL) );
void
*
dl_find_symbol(libhandle, symbolname, ign_err=0)
void
* libhandle
char
* symbolname
int
ign_err
CODE:
symbolname = Perl_form_nocontext(
"_%s"
, symbolname);
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) = newSV_type_mortal(SVt_IV);
if
(RETVAL == NULL) {
if
(!ign_err)
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
const
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_flags(perl_name,
(
void
(*)(pTHX_ CV *))symref,
filename, NULL,
XS_DYNAMIC_FILENAME)));
SV *
dl_error()
CODE:
dMY_CXT;
RETVAL = newSVsv(MY_CXT.x_dl_last_error);
OUTPUT:
RETVAL
#if defined(USE_ITHREADS)
void
CLONE(...)
CODE:
MY_CXT_CLONE;
PERL_UNUSED_VAR(items);
MY_CXT.x_dl_last_error = newSVpvs(
""
);
#endif
# end.