diff options
author | markm <markm@FreeBSD.org> | 2000-06-25 11:04:01 +0000 |
---|---|---|
committer | markm <markm@FreeBSD.org> | 2000-06-25 11:04:01 +0000 |
commit | 2618fad5bbb2d0182eb31ed805c41b543c513940 (patch) | |
tree | 52ba93338b13aefd02a0055304a9eccfa0e049f5 /contrib/perl5/ext/DynaLoader | |
parent | 77644ee620b6a79cf8c538abaf7cd301a875528d (diff) | |
download | FreeBSD-src-2618fad5bbb2d0182eb31ed805c41b543c513940.zip FreeBSD-src-2618fad5bbb2d0182eb31ed805c41b543c513940.tar.gz |
Vendor import of Perl 5.006
Diffstat (limited to 'contrib/perl5/ext/DynaLoader')
-rw-r--r-- | contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL | 130 | ||||
-rw-r--r-- | contrib/perl5/ext/DynaLoader/Makefile.PL | 11 | ||||
-rw-r--r-- | contrib/perl5/ext/DynaLoader/XSLoader_pm.PL | 158 | ||||
-rw-r--r-- | contrib/perl5/ext/DynaLoader/dl_aix.xs | 200 | ||||
-rw-r--r-- | contrib/perl5/ext/DynaLoader/dl_beos.xs | 34 | ||||
-rw-r--r-- | contrib/perl5/ext/DynaLoader/dl_dld.xs | 46 | ||||
-rw-r--r-- | contrib/perl5/ext/DynaLoader/dl_dlopen.xs | 88 | ||||
-rw-r--r-- | contrib/perl5/ext/DynaLoader/dl_dyld.xs | 226 | ||||
-rw-r--r-- | contrib/perl5/ext/DynaLoader/dl_hpux.xs | 40 | ||||
-rw-r--r-- | contrib/perl5/ext/DynaLoader/dl_mpeix.xs | 32 | ||||
-rw-r--r-- | contrib/perl5/ext/DynaLoader/dl_next.xs | 41 | ||||
-rw-r--r-- | contrib/perl5/ext/DynaLoader/dl_vmesa.xs | 175 | ||||
-rw-r--r-- | contrib/perl5/ext/DynaLoader/dl_vms.xs | 65 | ||||
-rw-r--r-- | contrib/perl5/ext/DynaLoader/dlutils.c | 52 | ||||
-rw-r--r-- | contrib/perl5/ext/DynaLoader/hints/aix.pl | 10 | ||||
-rw-r--r-- | contrib/perl5/ext/DynaLoader/hints/linux.pl | 4 | ||||
-rw-r--r-- | contrib/perl5/ext/DynaLoader/hints/openbsd.pl | 3 |
17 files changed, 1055 insertions, 260 deletions
diff --git a/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL b/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL index cf7d708..e0eb604 100644 --- a/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL +++ b/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL @@ -3,7 +3,7 @@ use Config; sub to_string { my ($value) = @_; - $value =~ s/\\/\\\\'/g; + $value =~ s/\\/\\\\/g; $value =~ s/'/\\'/g; return "'$value'"; } @@ -28,7 +28,7 @@ package DynaLoader; # # Tim.Bunce@ig.co.uk, August 1994 -$VERSION = $VERSION = "1.03"; # avoid typo warning +$VERSION = "1.04"; # avoid typo warning require AutoLoader; *AUTOLOAD = \&AutoLoader::AUTOLOAD; @@ -72,12 +72,13 @@ print OUT <<'EOT'; # See dl_expandspec() for more details. Should be harmless but # inefficient to define on systems that don't need it. $do_expand = $Is_VMS = $^O eq 'VMS'; +$Is_MacOS = $^O eq 'MacOS'; @dl_require_symbols = (); # names of symbols we need @dl_resolve_using = (); # names of files to link with @dl_library_path = (); # path to look for files -@dl_librefs = (); # things we have loaded -@dl_modules = (); # Modules we have loaded +#@dl_librefs = (); # things we have loaded +#@dl_modules = (); # Modules we have loaded # This is a fix to support DLD's unfortunate desire to relink -lc @dl_resolve_using = dl_findfile('-lc') if $dlsrc eq "dl_dld.xs"; @@ -93,12 +94,24 @@ print OUT "push(\@dl_library_path, split(' ', ", print OUT <<'EOT'; -# Add to @dl_library_path any extra directories we can gather from -# environment variables. So far LD_LIBRARY_PATH is the only known -# variable used for this purpose. Others may be added later. +# Add to @dl_library_path any extra directories we can gather +# from environment variables. +if ($Is_MacOS) { + push(@dl_library_path, split(/,/, $ENV{LD_LIBRARY_PATH})) + if exists $ENV{LD_LIBRARY_PATH}; +} else { + push(@dl_library_path, split(/:/, $ENV{$Config::Config{ldlibpthname}})) + if exists $Config::Config{ldlibpthname} && + $Config::Config{ldlibpthname} ne '' && + exists $ENV{$Config::Config{ldlibpthname}} ;; + push(@dl_library_path, split(/:/, $ENV{$Config::Config{ldlibpthname}})) + if exists $Config::Config{ldlibpthname} && + $Config::Config{ldlibpthname} ne '' && + exists $ENV{$Config::Config{ldlibpthname}} ;; +# E.g. HP-UX supports both its native SHLIB_PATH *and* LD_LIBRARY_PATH. push(@dl_library_path, split(/:/, $ENV{LD_LIBRARY_PATH})) - if $ENV{LD_LIBRARY_PATH}; - + if exists $ENV{LD_LIBRARY_PATH}; +} # No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) && @@ -116,6 +129,14 @@ if ($dl_debug) { sub croak { require Carp; Carp::croak(@_) } +sub bootstrap_inherit { + my $module = $_[0]; + local *isa = *{"$module\::ISA"}; + local @isa = (@isa, 'DynaLoader'); + # Cannot goto due to delocalization. Will report errors on a wrong line? + bootstrap(@_); +} + # The bootstrap function cannot be autoloaded (without complications) # so we define it here: @@ -145,18 +166,27 @@ sub bootstrap { # It may also edit @modparts if required. $modfname = &mod2fname(\@modparts) if defined &mod2fname; - my $modpname = join('/',@modparts); + my $modpname = join(($Is_MacOS ? ':' : '/'),@modparts); print STDERR "DynaLoader::bootstrap for $module ", - "(auto/$modpname/$modfname.$dl_dlext)\n" if $dl_debug; + ($Is_MacOS + ? "(auto/$modpname/$modfname.$dl_dlext)\n" : + "(:auto:$modpname:$modfname.$dl_dlext)\n") + if $dl_debug; foreach (@INC) { chop($_ = VMS::Filespec::unixpath($_)) if $Is_VMS; - my $dir = "$_/auto/$modpname"; + my $dir; + if ($Is_MacOS) { + chop $_ if /:$/; + $dir = "$_:auto:$modpname"; + } else { + $dir = "$_/auto/$modpname"; + } next unless -d $dir; # skip over uninteresting directories # check for common cases to avoid autoload of dl_findfile - my $try = "$dir/$modfname.$dl_dlext"; + my $try = $Is_MacOS ? "$dir:$modfname.$dl_dlext" : "$dir/$modfname.$dl_dlext"; last if $file = ($do_expand) ? dl_expandspec($try) : (-f $try && $try); # no luck here, save dir for possible later dl_findfile search @@ -168,6 +198,7 @@ sub bootstrap { croak("Can't locate loadable object for module $module in \@INC (\@INC contains: @INC)") unless $file; # wording similar to error from 'require' + $file = uc($file) if $Is_VMS && $Config{d_vms_case_sensitive_symbols}; my $bootname = "boot_$module"; $bootname =~ s/\W/_/g; @dl_require_symbols = ($bootname); @@ -176,7 +207,7 @@ sub bootstrap { # The .bs file can be used to configure @dl_resolve_using etc to # match the needs of the individual module on this architecture. my $bs = $file; - $bs =~ s/(\.\w+)?$/\.bs/; # look for .bs 'beside' the library + $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library if (-s $bs) { # only read file if it's not empty print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug; eval { do $bs; }; @@ -191,7 +222,7 @@ sub bootstrap { # it executed. my $libref = dl_load_file($file, $module->dl_load_flags) or - croak("Can't load '$file' for module $module: ".dl_error()."\n"); + croak("Can't load '$file' for module $module: ".dl_error()); push(@dl_librefs,$libref); # record loaded object @@ -251,6 +282,12 @@ print OUT <<'EOT'; last arg unless wantarray; next; } + elsif ($Is_MacOS) { + if (m/:/ && -f $_) { + push(@found,$_); + last arg unless wantarray; + } + } elsif (m:/: && -f $_ && !$do_expand) { push(@found,$_); last arg unless wantarray; @@ -261,6 +298,30 @@ print OUT <<'EOT'; # Using a -L prefix is the preferred option (faster and more robust) if (m:^-L:) { s/^-L//; push(@dirs, $_); next; } + if ($Is_MacOS) { + # Otherwise we try to try to spot directories by a heuristic + # (this is a more complicated issue than it first appears) + if (m/:/ && -d $_) { push(@dirs, $_); next; } + # Only files should get this far... + my(@names, $name); # what filenames to look for + s/^-l//; + push(@names, $_); + foreach $dir (@dirs, @dl_library_path) { + next unless -d $dir; + $dir =~ s/^([^:]+)$/:$1/; + $dir =~ s/:$//; + foreach $name (@names) { + my($file) = "$dir:$name"; + print STDERR " checking in $dir for $name\n" if $dl_debug; + if (-f $file) { + push(@found, $file); + next arg; # no need to look any further + } + } + } + next; + } + # Otherwise we try to try to spot directories by a heuristic # (this is a more complicated issue than it first appears) if (m:/: && -d $_) { push(@dirs, $_); next; } @@ -350,7 +411,7 @@ sub dl_find_symbol_anywhere DynaLoader - Dynamically load C libraries into Perl code -dl_error(), dl_findfile(), dl_expandspec(), dl_load_file(), dl_find_symbol(), dl_find_symbol_anywhere(), dl_undef_symbols(), dl_install_xsub(), dl_load_flags(), bootstrap() - routines used by DynaLoader modules +dl_error(), dl_findfile(), dl_expandspec(), dl_load_file(), dl_unload_file(), dl_find_symbol(), dl_find_symbol_anywhere(), dl_undef_symbols(), dl_install_xsub(), dl_load_flags(), bootstrap() - routines used by DynaLoader modules =head1 SYNOPSIS @@ -402,6 +463,7 @@ DynaLoader Interface Summary $symref = dl_find_symbol_anywhere($symbol) Perl $libref = dl_load_file($filename, $flags) C + $status = dl_unload_file($libref) C $symref = dl_find_symbol($libref, $symbol) C @symbols = dl_undef_symbols() C dl_install_xsub($name, $symref [, $filename]) C @@ -579,6 +641,42 @@ current values of @dl_require_symbols and @dl_resolve_using if required. Linux, and is a common choice when providing a "wrapper" on other mechanisms as is done in the OS/2 port.) +=item dl_unload_file() + +Syntax: + + $status = dl_unload_file($libref) + +Dynamically unload $libref, which must be an opaque 'library reference' as +returned from dl_load_file. Returns one on success and zero on failure. + +This function is optional and may not necessarily be provided on all platforms. +If it is defined, it is called automatically when the interpreter exits for +every shared object or library loaded by DynaLoader::bootstrap. All such +library references are stored in @dl_librefs by DynaLoader::Bootstrap as it +loads the libraries. The files are unloaded in last-in, first-out order. + +This unloading is usually necessary when embedding a shared-object perl (e.g. +one configured with -Duseshrplib) within a larger application, and the perl +interpreter is created and destroyed several times within the lifetime of the +application. In this case it is possible that the system dynamic linker will +unload and then subsequently reload the shared libperl without relocating any +references to it from any files DynaLoaded by the previous incarnation of the +interpreter. As a result, any shared objects opened by DynaLoader may point to +a now invalid 'ghost' of the libperl shared object, causing apparently random +memory corruption and crashes. This behaviour is most commonly seen when using +Apache and mod_perl built with the APXS mechanism. + + SunOS: dlclose($libref) + HP-UX: ??? + Linux: ??? + NeXT: ??? + VMS: ??? + +(The dlclose() function is also used by Solaris and some versions of +Linux, and is a common choice when providing a "wrapper" on other +mechanisms as is done in the OS/2 port.) + =item dl_loadflags() Syntax: diff --git a/contrib/perl5/ext/DynaLoader/Makefile.PL b/contrib/perl5/ext/DynaLoader/Makefile.PL index 2141fde..83cbd77 100644 --- a/contrib/perl5/ext/DynaLoader/Makefile.PL +++ b/contrib/perl5/ext/DynaLoader/Makefile.PL @@ -8,14 +8,19 @@ WriteMakefile( SKIP => [qw(dynamic dynamic_lib dynamic_bs)], XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'DynaLoader_pm.PL', - PL_FILES => {'DynaLoader_pm.PL'=>'DynaLoader.pm'}, - PM => {'DynaLoader.pm' => '$(INST_LIBDIR)/DynaLoader.pm'}, - clean => {FILES => 'DynaLoader.c DynaLoader.xs DynaLoader.pm'}, + PL_FILES => {'DynaLoader_pm.PL'=>'DynaLoader.pm', + 'XSLoader_pm.PL'=>'XSLoader.pm'}, + PM => {'DynaLoader.pm' => '$(INST_LIBDIR)/DynaLoader.pm', + 'XSLoader.pm' => '$(INST_LIBDIR)/XSLoader.pm'}, + depend => {'DynaLoader.o' => 'dlutils.c'}, + clean => {FILES => 'DynaLoader.c DynaLoader.xs DynaLoader.pm ' . + 'XSLoader.pm'}, ); sub MY::postamble { ' DynaLoader.xs: $(DLSRC) + $(RM_F) $@ $(CP) $? $@ # Perform very simple tests just to check for major gaffs. diff --git a/contrib/perl5/ext/DynaLoader/XSLoader_pm.PL b/contrib/perl5/ext/DynaLoader/XSLoader_pm.PL new file mode 100644 index 0000000..8cdfd63 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/XSLoader_pm.PL @@ -0,0 +1,158 @@ +use Config; + +sub to_string { + my ($value) = @_; + $value =~ s/\\/\\\\/g; + $value =~ s/'/\\'/g; + return "'$value'"; +} + +unlink "XSLoader.pm" if -f "XSLoader.pm"; +open OUT, ">XSLoader.pm" or die $!; +print OUT <<'EOT'; +# Generated from XSLoader.pm.PL (resolved %Config::Config value) + +package XSLoader; + +# 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.' + +# (Quote from Tolkien sugested by Anno Siegel.) +# +# See pod text at end of file for documentation. +# See also ext/DynaLoader/README in source tree for other information. +# +# Tim.Bunce@ig.co.uk, August 1994 + +$VERSION = "0.01"; # avoid typo warning + +# enable debug/trace messages from DynaLoader perl code +# $dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug; + +EOT + +print OUT ' my $dl_dlext = ', to_string($Config::Config{'dlext'}), ";\n" ; + +print OUT <<'EOT'; + +# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. +package DynaLoader; +boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) && + !defined(&dl_load_file); +package XSLoader; + +1; # End of main code + +# The bootstrap function cannot be autoloaded (without complications) +# so we define it here: + +sub load { + package DynaLoader; + + my($module) = $_[0]; + + # work with static linking too + my $b = "$module\::bootstrap"; + goto &$b if defined &$b; + + goto retry unless $module and defined &dl_load_file; + + my @modparts = split(/::/,$module); + my $modfname = $modparts[-1]; + +EOT + +print OUT <<'EOT' if defined &DynaLoader::mod2fname; + # Some systems have restrictions on files names for DLL's etc. + # mod2fname returns appropriate file base name (typically truncated) + # It may also edit @modparts if required. + $modfname = &mod2fname(\@modparts) if defined &mod2fname; + +EOT + +print OUT <<'EOT'; + my $modpname = join('/',@modparts); + my $modlibname = (caller())[1]; + my $c = @modparts; + $modlibname =~ s,[\\/][^\\/]+$,, while $c--; # Q&D basename + my $file = "$modlibname/auto/$modpname/$modfname.$dl_dlext"; + +# print STDERR "XSLoader::load for $module ($file)\n" if $dl_debug; + + my $bs = $file; + $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library + + goto retry if not -f $file or -s $bs; + + my $bootname = "boot_$module"; + $bootname =~ s/\W/_/g; + @dl_require_symbols = ($bootname); + + # Many dynamic extension loading problems will appear to come from + # this section of code: XYZ failed at line 123 of DynaLoader.pm. + # Often these errors are actually occurring in the initialisation + # C code of the extension XS file. Perl reports the error as being + # in this perl code simply because this was the last perl code + # it executed. + + my $libref = dl_load_file($file, 0) or do { + require Carp; + Carp::croak("Can't load '$file' for module $module: " . dl_error()); + }; + push(@dl_librefs,$libref); # record loaded object + + my @unresolved = dl_undef_symbols(); + if (@unresolved) { + require Carp; + Carp::carp("Undefined symbols present after loading $file: @unresolved\n"); + } + + my $boot_symbol_ref = dl_find_symbol($libref, $bootname) or do { + require Carp; + Carp::croak("Can't find '$bootname' symbol in $file\n"); + }; + + my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file); + + push(@dl_modules, $module); # record loaded module + + # See comment block above + return &$xs(@_); + + retry: + require DynaLoader; + goto &DynaLoader::bootstrap_inherit; +} + +__END__ + +=head1 NAME + +XSLoader - Dynamically load C libraries into Perl code + +=head1 SYNOPSIS + + package YourPackage; + use XSLoader; + + XSLoader::load 'YourPackage', @args; + +=head1 DESCRIPTION + +This module defines a standard I<simplified> interface to the dynamic +linking mechanisms available on many platforms. Its primary purpose is +to implement cheap automatic dynamic loading of Perl modules. + +For more complicated interface see L<DynaLoader>. + +=head1 AUTHOR + +Ilya Zakharevich: extraction from DynaLoader. + +=cut +EOT + +close OUT or die $!; + diff --git a/contrib/perl5/ext/DynaLoader/dl_aix.xs b/contrib/perl5/ext/DynaLoader/dl_aix.xs index ea50408..35242ed 100644 --- a/contrib/perl5/ext/DynaLoader/dl_aix.xs +++ b/contrib/perl5/ext/DynaLoader/dl_aix.xs @@ -20,6 +20,15 @@ #include "perl.h" #include "XSUB.h" +/* When building as a 64-bit binary on AIX, define this to get the + * correct structure definitions. Also determines the field-name + * macros and gates some logic in readEntries(). -- Steven N. Hirsch + * <hirschs@btv.ibm.com> */ +#ifdef USE_64_BIT_ALL +# define __XCOFF64__ +# define __XCOFF32__ +#endif + #include <stdio.h> #include <errno.h> #include <string.h> @@ -29,6 +38,39 @@ #include <a.out.h> #include <ldfcn.h> +#ifdef USE_64_BIT_ALL +# define AIX_SCNHDR SCNHDR_64 +# define AIX_LDHDR LDHDR_64 +# define AIX_LDSYM LDSYM_64 +# define AIX_LDHDRSZ LDHDRSZ_64 +#else +# define AIX_SCNHDR SCNHDR +# define AIX_LDHDR LDHDR +# define AIX_LDSYM LDSYM +# define AIX_LDHDRSZ LDHDRSZ +#endif + +/* When using Perl extensions written in C++ the longer versions + * of load() and unload() from libC and libC_r need to be used, + * otherwise statics in the extensions won't get initialized right. + * -- Stephanie Beals <bealzy@us.ibm.com> */ + +/* Older AIX C compilers cannot deal with C++ double-slash comments in + the ibmcxx and/or xlC includes. Since we only need a single file, + be more fine-grained about what's included <hirschs@btv.ibm.com> */ +#ifdef USE_libC /* The define comes, when it comes, from hints/aix.pl. */ +# define LOAD loadAndInit +# define UNLOAD terminateAndUnload +# if defined(USE_xlC_load_h) +# include "/usr/lpp/xlC/include/load.h" +# elif defined(USE_ibmcxx_load_h) +# include "/usr/ibmcxx/include/load.h" +# endif +#else +# define LOAD load +# define UNLOAD unload +#endif + /* * AIX 4.3 does remove some useful definitions from ldfcn.h. Define * these here to compensate for that lossage. @@ -77,19 +119,18 @@ typedef struct Module { * We keep a list of all loaded modules to be able to call the fini * handlers at atexit() time. */ -static ModulePtr modList; +static ModulePtr modList; /* XXX threaded */ /* * The last error from one of the dl* routines is kept in static * variables here. Each error is returned only once to the caller. */ -static char errbuf[BUFSIZ]; -static int errvalid; +static char errbuf[BUFSIZ]; /* XXX threaded */ +static int errvalid; /* XXX threaded */ static void caterr(char *); static int readExports(ModulePtr); static void terminate(void); -static void *findMain(void); static char *strerror_failed = "(strerror failed)"; static char *strerror_r_failed = "(strerror_r failed)"; @@ -104,7 +145,7 @@ char *strerrorcat(char *str, int err) { if (buf == 0) return 0; - if (strerror_r(err, buf, sizeof(buf)) == 0) + if (strerror_r(err, buf, BUFSIZ) == 0) msg = buf; else msg = strerror_r_failed; @@ -132,7 +173,7 @@ char *strerrorcpy(char *str, int err) { if (buf == 0) return 0; - if (strerror_r(err, buf, sizeof(buf)) == 0) + if (strerror_r(err, buf, BUFSIZ) == 0) msg = buf; else msg = strerror_r_failed; @@ -154,17 +195,16 @@ char *strerrorcpy(char *str, int err) { /* ARGSUSED */ void *dlopen(char *path, int mode) { + dTHX; register ModulePtr mp; - static void *mainModule; + static int inited; /* XXX threaded */ /* * Upon the first call register a terminate handler that will - * close all libraries. Also get a reference to the main module - * for use with loadbind. + * close all libraries. */ - if (!mainModule) { - if ((mainModule = findMain()) == NULL) - return NULL; + if (!inited) { + inited++; atexit(terminate); } /* @@ -190,11 +230,19 @@ void *dlopen(char *path, int mode) safefree(mp); return NULL; } + /* * load should be declared load(const char *...). Thus we * cast the path to a normal char *. Ugly. */ - if ((mp->entry = (void *)load((char *)path, L_NOAUTODEFER, NULL)) == NULL) { + if ((mp->entry = (void *)LOAD((char *)path, +#ifdef L_LIBPATH_EXEC + L_LIBPATH_EXEC | +#endif + L_NOAUTODEFER, + NULL)) == NULL) { + int saverrno = errno; + safefree(mp->name); safefree(mp); errvalid++; @@ -206,27 +254,34 @@ void *dlopen(char *path, int mode) * can be further described by querying the loader about * the last error. */ - if (errno == ENOEXEC) { - char *tmp[BUFSIZ/sizeof(char *)]; - if (loadquery(L_GETMESSAGES, tmp, sizeof(tmp)) == -1) - strerrorcpy(errbuf, errno); + if (saverrno == ENOEXEC) { + char *moreinfo[BUFSIZ/sizeof(char *)]; + if (loadquery(L_GETMESSAGES, moreinfo, sizeof(moreinfo)) == -1) + strerrorcpy(errbuf, saverrno); else { char **p; - for (p = tmp; *p; p++) + for (p = moreinfo; *p; p++) caterr(*p); } } else - strerrorcat(errbuf, errno); + strerrorcat(errbuf, saverrno); return NULL; } mp->refCnt = 1; mp->next = modList; modList = mp; - if (loadbind(0, mainModule, mp->entry) == -1) { + /* + * Assume anonymous exports come from the module this dlopen + * is linked into, that holds true as long as dlopen and all + * of the perl core are in the same shared object. + */ + if (loadbind(0, (void *)dlopen, mp->entry) == -1) { + int saverrno = errno; + dlclose(mp); errvalid++; strcpy(errbuf, "loadbind: "); - strerrorcat(errbuf, errno); + strerrorcat(errbuf, saverrno); return NULL; } if (readExports(mp) == -1) { @@ -311,7 +366,7 @@ int dlclose(void *handle) if (--mp->refCnt > 0) return 0; - result = unload(mp->entry); + result = UNLOAD(mp->entry); if (result == -1) { errvalid++; strerrorcpy(errbuf, errno); @@ -364,11 +419,12 @@ void *calloc(size_t ne, size_t sz) */ static int readExports(ModulePtr mp) { + dTHX; LDFILE *ldp = NULL; - SCNHDR sh; - LDHDR *lhp; + AIX_SCNHDR sh; + AIX_LDHDR *lhp; char *ldbuf; - LDSYM *ls; + AIX_LDSYM *ls; int i; ExportPtr ep; @@ -412,7 +468,7 @@ static int readExports(ModulePtr mp) } /* * Traverse the list of loaded modules. The entry point - * returned by load() does actually point to the data + * returned by LOAD() does actually point to the data * segment origin. */ lp = (struct ld_info *)buf; @@ -434,7 +490,11 @@ static int readExports(ModulePtr mp) return -1; } } +#ifdef USE_64_BIT_ALL + if (TYPE(ldp) != U803XTOCMAGIC) { +#else if (TYPE(ldp) != U802TOCMAGIC) { +#endif errvalid++; strcpy(errbuf, "readExports: bad magic"); while(ldclose(ldp) == FAILURE) @@ -482,8 +542,8 @@ static int readExports(ModulePtr mp) ; return -1; } - lhp = (LDHDR *)ldbuf; - ls = (LDSYM *)(ldbuf+LDHDRSZ); + lhp = (AIX_LDHDR *)ldbuf; + ls = (AIX_LDSYM *)(ldbuf+AIX_LDHDRSZ); /* * Count the number of exports to include in our export table. */ @@ -507,15 +567,19 @@ static int readExports(ModulePtr mp) * the entry point we got from load. */ ep = mp->exports; - ls = (LDSYM *)(ldbuf+LDHDRSZ); + ls = (AIX_LDSYM *)(ldbuf+AIX_LDHDRSZ); for (i = lhp->l_nsyms; i; i--, ls++) { char *symname; if (!LDR_EXPORT(*ls)) continue; +#ifndef USE_64_BIT_ALL if (ls->l_zeroes == 0) +#endif symname = ls->l_offset+lhp->l_stoff+ldbuf; +#ifndef USE_64_BIT_ALL else symname = ls->l_name; +#endif ep->name = savepv(symname); ep->addr = (void *)((unsigned long)mp->entry + ls->l_value); ep++; @@ -526,56 +590,10 @@ static int readExports(ModulePtr mp) return 0; } -/* - * Find the main modules entry point. This is used as export pointer - * for loadbind() to be able to resolve references to the main part. - */ -static void * findMain(void) -{ - struct ld_info *lp; - char *buf; - int size = 4*1024; - int i; - void *ret; - - if ((buf = safemalloc(size)) == NULL) { - errvalid++; - strcpy(errbuf, "findMain: "); - strerrorcat(errbuf, errno); - return NULL; - } - while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) { - safefree(buf); - size += 4*1024; - if ((buf = safemalloc(size)) == NULL) { - errvalid++; - strcpy(errbuf, "findMain: "); - strerrorcat(errbuf, errno); - return NULL; - } - } - if (i == -1) { - errvalid++; - strcpy(errbuf, "findMain: "); - strerrorcat(errbuf, errno); - safefree(buf); - return NULL; - } - /* - * The first entry is the main module. The entry point - * returned by load() does actually point to the data - * segment origin. - */ - lp = (struct ld_info *)buf; - ret = lp->ldinfo_dataorg; - safefree(buf); - return ret; -} - /* dl_dlopen.xs * * Platform: SunOS/Solaris, possibly others which use dlopen. - * Author: Paul Marquess (pmarquess@bfsec.bt.co.uk) + * Author: Paul Marquess (Paul.Marquess@btinternet.com) * Created: 10th July 1994 * * Modified: @@ -597,15 +615,15 @@ static void * findMain(void) static void -dl_private_init() +dl_private_init(pTHX) { - (void)dl_generic_private_init(); + (void)dl_generic_private_init(aTHX); } MODULE = DynaLoader PACKAGE = DynaLoader BOOT: - (void)dl_private_init(); + (void)dl_private_init(aTHX); void * @@ -613,16 +631,16 @@ dl_load_file(filename, flags=0) char * filename int flags CODE: - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags)); if (flags & 0x01) - warn("Can't make loaded symbols global on this platform while loading %s",filename); + Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename); RETVAL = dlopen(filename, 1) ; - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError("%s",dlerror()) ; + SaveError(aTHX_ "%s",dlerror()) ; else - sv_setiv( ST(0), (IV)RETVAL); + sv_setiv( ST(0), PTR2IV(RETVAL) ); void * @@ -630,15 +648,15 @@ dl_find_symbol(libhandle, symbolname) void * libhandle char * symbolname CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); RETVAL = dlsym(libhandle, symbolname); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref = %x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError("%s",dlerror()) ; + SaveError(aTHX_ "%s",dlerror()) ; else - sv_setiv( ST(0), (IV)RETVAL); + sv_setiv( ST(0), PTR2IV(RETVAL)); void @@ -655,9 +673,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", + 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(*)())symref, filename))); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); char * diff --git a/contrib/perl5/ext/DynaLoader/dl_beos.xs b/contrib/perl5/ext/DynaLoader/dl_beos.xs index 42a27cb..705c8bc 100644 --- a/contrib/perl5/ext/DynaLoader/dl_beos.xs +++ b/contrib/perl5/ext/DynaLoader/dl_beos.xs @@ -18,15 +18,15 @@ #include "dlutils.c" /* SaveError() etc */ static void -dl_private_init() +dl_private_init(pTHX) { - (void)dl_generic_private_init(); + (void)dl_generic_private_init(aTHX); } MODULE = DynaLoader PACKAGE = DynaLoader BOOT: - (void)dl_private_init(); + (void)dl_private_init(aTHX); void * @@ -45,16 +45,16 @@ dl_load_file(filename, flags=0) strcpy(path, filename); } - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", path, flags)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", path, flags)); bogo = load_add_on(path); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%lx\n", (unsigned long) RETVAL)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%lx\n", (unsigned long) RETVAL)); ST(0) = sv_newmortal() ; if (bogo < 0) { - SaveError("%s", strerror(bogo)); - PerlIO_printf(PerlIO_stderr(), "load_add_on(%s) : %d (%s)\n", path, bogo, strerror(bogo)); + SaveError(aTHX_ "%s", strerror(bogo)); + PerlIO_printf(Perl_debug_log, "load_add_on(%s) : %d (%s)\n", path, bogo, strerror(bogo)); } else { RETVAL = (void *) bogo; - sv_setiv( ST(0), (IV)RETVAL); + sv_setiv( ST(0), PTR2IV(RETVAL) ); } free(path); } @@ -67,23 +67,23 @@ dl_find_symbol(libhandle, symbolname) status_t retcode; void *adr = 0; #ifdef DLSYM_NEEDS_UNDERSCORE - symbolname = form("_%s", symbolname); + symbolname = Perl_form_nocontext("_%s", symbolname); #endif RETVAL = NULL; - DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + DLDEBUG(2, PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%lx, symbol=%s)\n", (unsigned long) libhandle, symbolname)); retcode = get_image_symbol((image_id) libhandle, symbolname, B_SYMBOL_TYPE_TEXT, (void **) &adr); RETVAL = adr; - DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + DLDEBUG(2, PerlIO_printf(Perl_debug_log, " symbolref = %lx\n", (unsigned long) RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) { - SaveError("%s", strerror(retcode)) ; - PerlIO_printf(PerlIO_stderr(), "retcode = %p (%s)\n", retcode, strerror(retcode)); + SaveError(aTHX_ "%s", strerror(retcode)) ; + PerlIO_printf(Perl_debug_log, "retcode = %p (%s)\n", retcode, strerror(retcode)); } else - sv_setiv( ST(0), (IV)RETVAL); + sv_setiv( ST(0), PTR2IV(RETVAL)); void @@ -100,9 +100,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%lx)\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%lx)\n", perl_name, (unsigned long) symref)); - ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)_((CV *)))symref, filename))); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); char * diff --git a/contrib/perl5/ext/DynaLoader/dl_dld.xs b/contrib/perl5/ext/DynaLoader/dl_dld.xs index 2443ab0..d8fad2a 100644 --- a/contrib/perl5/ext/DynaLoader/dl_dld.xs +++ b/contrib/perl5/ext/DynaLoader/dl_dld.xs @@ -48,12 +48,12 @@ static AV *dl_resolve_using = Nullav; static AV *dl_require_symbols = Nullav; static void -dl_private_init() +dl_private_init(pTHX) { int dlderr; - dl_generic_private_init(); - dl_resolve_using = perl_get_av("DynaLoader::dl_resolve_using", 0x4); - dl_require_symbols = perl_get_av("DynaLoader::dl_require_symbols", 0x4); + dl_generic_private_init(aTHX); + dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); + dl_require_symbols = get_av("DynaLoader::dl_require_symbols", GV_ADDMULTI); #ifdef __linux__ dlderr = dld_init("/proc/self/exe"); if (dlderr) { @@ -61,8 +61,8 @@ dl_private_init() dlderr = dld_init(dld_find_executable(PL_origargv[0])); if (dlderr) { char *msg = dld_strerror(dlderr); - SaveError("dld_init(%s) failed: %s", PL_origargv[0], msg); - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "%s", LastError)); + SaveError(aTHX_ "dld_init(%s) failed: %s", PL_origargv[0], msg); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "%s", LastError)); } #ifdef __linux__ } @@ -85,40 +85,40 @@ dl_load_file(filename, flags=0) GV *gv; CODE: RETVAL = filename; - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags)); if (flags & 0x01) - croak("Can't make loaded symbols global on this platform while loading %s",filename); + Perl_croak(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename); max = AvFILL(dl_require_symbols); for (x = 0; x <= max; x++) { char *sym = SvPVX(*av_fetch(dl_require_symbols, x, 0)); - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dld_create_ref(%s)\n", sym)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dld_create_ref(%s)\n", sym)); if (dlderr = dld_create_reference(sym)) { - SaveError("dld_create_reference(%s): %s", sym, + SaveError(aTHX_ "dld_create_reference(%s): %s", sym, dld_strerror(dlderr)); goto haverror; } } - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dld_link(%s)\n", filename)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dld_link(%s)\n", filename)); if (dlderr = dld_link(filename)) { - SaveError("dld_link(%s): %s", filename, dld_strerror(dlderr)); + SaveError(aTHX_ "dld_link(%s): %s", filename, dld_strerror(dlderr)); goto haverror; } max = AvFILL(dl_resolve_using); for (x = 0; x <= max; x++) { char *sym = SvPVX(*av_fetch(dl_resolve_using, x, 0)); - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dld_link(%s)\n", sym)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dld_link(%s)\n", sym)); if (dlderr = dld_link(sym)) { - SaveError("dld_link(%s): %s", sym, dld_strerror(dlderr)); + SaveError(aTHX_ "dld_link(%s): %s", sym, dld_strerror(dlderr)); goto haverror; } } - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "libref=%s\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "libref=%s\n", RETVAL)); haverror: ST(0) = sv_newmortal() ; if (dlderr == 0) - sv_setiv(ST(0), (IV)RETVAL); + sv_setiv(ST(0), PTR2IV(RETVAL)); void * @@ -126,16 +126,16 @@ dl_find_symbol(libhandle, symbolname) void * libhandle char * symbolname CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); RETVAL = (void *)dld_get_func(symbolname); /* if RETVAL==NULL we should try looking for a non-function symbol */ - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref = %x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError("dl_find_symbol: Unable to find '%s' symbol", symbolname) ; + SaveError(aTHX_ "dl_find_symbol: Unable to find '%s' symbol", symbolname) ; else - sv_setiv(ST(0), (IV)RETVAL); + sv_setiv(ST(0), PTR2IV(RETVAL)); void @@ -160,9 +160,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", + 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(*)())symref, filename))); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); char * diff --git a/contrib/perl5/ext/DynaLoader/dl_dlopen.xs b/contrib/perl5/ext/DynaLoader/dl_dlopen.xs index 2459205..8e4936d 100644 --- a/contrib/perl5/ext/DynaLoader/dl_dlopen.xs +++ b/contrib/perl5/ext/DynaLoader/dl_dlopen.xs @@ -1,15 +1,17 @@ /* dl_dlopen.xs * * Platform: SunOS/Solaris, possibly others which use dlopen. - * Author: Paul Marquess (pmarquess@bfsec.bt.co.uk) + * Author: Paul Marquess (Paul.Marquess@btinternet.com) * Created: 10th July 1994 * * Modified: - * 15th July 1994 - Added code to explicitly save any error messages. - * 3rd August 1994 - Upgraded to v3 spec. - * 9th August 1994 - Changed to use IV - * 10th August 1994 - Tim Bunce: Added RTLD_LAZY, switchable debugging, - * basic FreeBSD support, removed ClearError + * 15th July 1994 - Added code to explicitly save any error messages. + * 3rd August 1994 - Upgraded to v3 spec. + * 9th August 1994 - Changed to use IV + * 10th August 1994 - Tim Bunce: Added RTLD_LAZY, switchable debugging, + * basic FreeBSD support, removed ClearError + * 29th Feburary 2000 - Alan Burlison: Added functionality to close dlopen'd + * files when the interpreter exits * */ @@ -37,6 +39,17 @@ RTLD_LAZY (==2) on Solaris 2. + dlclose + ------- + int + dlclose(handle) + void * handle; + + This function takes the handle returned by a previous invocation of + dlopen and closes the associated dynamic object file. It returns zero + on success, and non-zero on failure. + + dlsym ------ void * @@ -57,7 +70,7 @@ Returns a null-terminated string which describes the last error that occurred with either dlopen or dlsym. After each call to dlerror the error message will be reset to a null pointer. The - SaveError function is used to save the error as soo as it happens. + SaveError function is used to save the error as soon as it happens. Return Types @@ -131,24 +144,35 @@ static void -dl_private_init() +dl_private_init(pTHX) { - (void)dl_generic_private_init(); + (void)dl_generic_private_init(aTHX); } MODULE = DynaLoader PACKAGE = DynaLoader BOOT: - (void)dl_private_init(); + (void)dl_private_init(aTHX); void * dl_load_file(filename, flags=0) char * filename int flags - PREINIT: + PREINIT: int mode = RTLD_LAZY; - CODE: + CODE: +{ +#if defined(DLOPEN_WONT_DO_RELATIVE_PATHS) + char pathbuf[PATH_MAX + 2]; + if (*filename != '/' && strchr(filename, '/')) { + if (getcwd(pathbuf, PATH_MAX - strlen(filename))) { + strcat(pathbuf, "/"); + strcat(pathbuf, filename); + filename = pathbuf; + } + } +#endif #ifdef RTLD_NOW if (dl_nonlazy) mode = RTLD_NOW; @@ -157,16 +181,30 @@ dl_load_file(filename, flags=0) #ifdef RTLD_GLOBAL mode |= RTLD_GLOBAL; #else - warn("Can't make loaded symbols global on this platform while loading %s",filename); + Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename); #endif - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags)); RETVAL = dlopen(filename, mode) ; - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%lx\n", (unsigned long) RETVAL)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%lx\n", (unsigned long) RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError("%s",dlerror()) ; + SaveError(aTHX_ "%s",dlerror()) ; else - sv_setiv( ST(0), (IV)RETVAL); + sv_setiv( ST(0), PTR2IV(RETVAL)); +} + + +int +dl_unload_file(libref) + void * libref + CODE: + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_unload_file(%lx):\n", libref)); + RETVAL = (dlclose(libref) == 0 ? 1 : 0); + if (!RETVAL) + SaveError(aTHX_ "%s", dlerror()) ; + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " retval = %d\n", RETVAL)); + OUTPUT: + RETVAL void * @@ -175,19 +213,19 @@ dl_find_symbol(libhandle, symbolname) char * symbolname CODE: #ifdef DLSYM_NEEDS_UNDERSCORE - symbolname = form("_%s", symbolname); + symbolname = Perl_form_nocontext("_%s", symbolname); #endif - DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + 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(PerlIO_stderr(), + DLDEBUG(2, PerlIO_printf(Perl_debug_log, " symbolref = %lx\n", (unsigned long) RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError("%s",dlerror()) ; + SaveError(aTHX_ "%s",dlerror()) ; else - sv_setiv( ST(0), (IV)RETVAL); + sv_setiv( ST(0), PTR2IV(RETVAL)); void @@ -204,9 +242,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%lx)\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%lx)\n", perl_name, (unsigned long) symref)); - ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)_((CV *)))symref, filename))); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); char * diff --git a/contrib/perl5/ext/DynaLoader/dl_dyld.xs b/contrib/perl5/ext/DynaLoader/dl_dyld.xs new file mode 100644 index 0000000..688e474 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dl_dyld.xs @@ -0,0 +1,226 @@ +/* dl_dyld.xs + * + * Platform: Darwin (Mac OS) + * Author: Wilfredo Sanchez <wsanchez@apple.com> + * Based on: dl_next.xs by Paul Marquess + * Based on: dl_dlopen.xs by Anno Siegel + * 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_dyld.xs is based on dl_next.xs by Anno Siegel. + +dl_next.xs is in turn 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 NeXT's/Apple's dyld. The xs code proper is +unchanged from Paul's original. + +The port could use some streamlining. For one, error handling could +be simplified. + +This should be useable as a replacement for dl_next.xs, but it has not +been tested on NeXT platforms. + + Wilfredo Sanchez + +*/ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define DL_LOADONCEONLY + +#include "dlutils.c" /* SaveError() etc */ + +#undef environ +#undef bool +#import <mach-o/dyld.h> + +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; +} + +enum dyldErrorSource +{ + OFImage, +}; + +static void TranslateError + (const char *path, enum dyldErrorSource type, int number) +{ + dTHX; + 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; +} + + + +/* ----- 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", 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: + 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) = 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: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_hpux.xs b/contrib/perl5/ext/DynaLoader/dl_hpux.xs index a82e0ea..582c047 100644 --- a/contrib/perl5/ext/DynaLoader/dl_hpux.xs +++ b/contrib/perl5/ext/DynaLoader/dl_hpux.xs @@ -33,16 +33,16 @@ static AV *dl_resolve_using = Nullav; static void -dl_private_init() +dl_private_init(pTHX) { - (void)dl_generic_private_init(); - dl_resolve_using = perl_get_av("DynaLoader::dl_resolve_using", 0x4); + (void)dl_generic_private_init(aTHX); + dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); } MODULE = DynaLoader PACKAGE = DynaLoader BOOT: - (void)dl_private_init(); + (void)dl_private_init(aTHX); void * @@ -53,9 +53,9 @@ dl_load_file(filename, flags=0) shl_t obj = NULL; int i, max, bind_type; CODE: - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags)); if (flags & 0x01) - warn("Can't make loaded symbols global on this platform while loading %s",filename); + Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename); if (dl_nonlazy) { bind_type = BIND_IMMEDIATE|BIND_VERBOSE; } else { @@ -76,23 +76,23 @@ dl_load_file(filename, flags=0) max = AvFILL(dl_resolve_using); for (i = 0; i <= max; i++) { char *sym = SvPVX(*av_fetch(dl_resolve_using, i, 0)); - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s) (dependent)\n", sym)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s) (dependent)\n", sym)); obj = shl_load(sym, bind_type, 0L); if (obj == NULL) { goto end; } } - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s): ", filename)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s): ", filename)); obj = shl_load(filename, bind_type, 0L); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", obj)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", obj)); end: ST(0) = sv_newmortal() ; if (obj == NULL) - SaveError("%s",Strerror(errno)); + SaveError(aTHX_ "%s",Strerror(errno)); else - sv_setiv( ST(0), (IV)obj); + sv_setiv( ST(0), PTR2IV(obj) ); void * @@ -104,9 +104,9 @@ dl_find_symbol(libhandle, symbolname) void *symaddr = NULL; int status; #ifdef __hp9000s300 - symbolname = form("_%s", symbolname); + symbolname = Perl_form_nocontext("_%s", symbolname); #endif - DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + DLDEBUG(2, PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%lx, symbol=%s)\n", (unsigned long) libhandle, symbolname)); @@ -114,17 +114,17 @@ dl_find_symbol(libhandle, symbolname) errno = 0; status = shl_findsym(&obj, symbolname, TYPE_PROCEDURE, &symaddr); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref(PROCEDURE) = %x\n", symaddr)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " symbolref(PROCEDURE) = %x\n", symaddr)); if (status == -1 && errno == 0) { /* try TYPE_DATA instead */ status = shl_findsym(&obj, symbolname, TYPE_DATA, &symaddr); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref(DATA) = %x\n", symaddr)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " symbolref(DATA) = %x\n", symaddr)); } if (status == -1) { - SaveError("%s",(errno) ? Strerror(errno) : "Symbol not found") ; + SaveError(aTHX_ "%s",(errno) ? Strerror(errno) : "Symbol not found") ; } else { - sv_setiv( ST(0), (IV)symaddr); + sv_setiv( ST(0), PTR2IV(symaddr) ); } @@ -142,9 +142,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", + 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(*)())symref, filename))); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); char * diff --git a/contrib/perl5/ext/DynaLoader/dl_mpeix.xs b/contrib/perl5/ext/DynaLoader/dl_mpeix.xs index 4cc07ec..7d27901 100644 --- a/contrib/perl5/ext/DynaLoader/dl_mpeix.xs +++ b/contrib/perl5/ext/DynaLoader/dl_mpeix.xs @@ -33,16 +33,16 @@ typedef struct { static AV *dl_resolve_using = Nullav; static void -dl_private_init() +dl_private_init(pTHX) { - (void)dl_generic_private_init(); - dl_resolve_using = perl_get_av("DynaLoader::dl_resolve_using", 0x4); + (void)dl_generic_private_init(aTHX); + dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); } MODULE = DynaLoader PACKAGE = DynaLoader BOOT: - (void)dl_private_init(); + (void)dl_private_init(aTHX); void * dl_load_file(filename, flags=0) @@ -53,10 +53,10 @@ dl_load_file(filename, flags=0) p_mpe_dld obj = NULL; int i; CODE: - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename, + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename, flags)); if (flags & 0x01) - warn("Can't make loaded symbols global on this platform while loading %s + Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s ",filename); obj = (p_mpe_dld) safemalloc(sizeof(t_mpe_dld)); memzero(obj, sizeof(t_mpe_dld)); @@ -68,13 +68,13 @@ flags)); else sprintf(obj->filename," %s ",filename); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," libref=%x\n", obj)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log," libref=%x\n", obj)); ST(0) = sv_newmortal() ; if (obj == NULL) - SaveError("%s",Strerror(errno)); + SaveError(aTHX_"%s",Strerror(errno)); else - sv_setiv( ST(0), (IV)obj); + sv_setiv( ST(0), PTR2IV(obj) ); void * dl_find_symbol(libhandle, symbolname) @@ -86,7 +86,7 @@ dl_find_symbol(libhandle, symbolname) char symname[PATH_MAX + 3]; void * symaddr = NULL; int status; - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(),"dl_find_symbol(handle=%x, symbol=%s)\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); ST(0) = sv_newmortal() ; errno = 0; @@ -95,12 +95,12 @@ dl_find_symbol(libhandle, symbolname) HPGETPROCPLABEL(8, symname, &symaddr, &status, obj->filename, 1, 0, &datalen, 1, 0, 0); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," symbolref(PROCEDURE) = %x, status=%x\n", symaddr, status)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log," symbolref(PROCEDURE) = %x, status=%x\n", symaddr, status)); if (status != 0) { - SaveError("%s",(errno) ? Strerror(errno) : "Symbol not found") ; + SaveError(aTHX_"%s",(errno) ? Strerror(errno) : "Symbol not found") ; } else { - sv_setiv( ST(0), (IV)symaddr); + sv_setiv( ST(0), PTR2IV(symaddr) ); } void @@ -115,9 +115,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(),"dl_install_xsub(name=%s, symref=%x)\n", + 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(*)())symref, filename))); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); char * dl_error() diff --git a/contrib/perl5/ext/DynaLoader/dl_next.xs b/contrib/perl5/ext/DynaLoader/dl_next.xs index dfa8a3e..b8c19f2 100644 --- a/contrib/perl5/ext/DynaLoader/dl_next.xs +++ b/contrib/perl5/ext/DynaLoader/dl_next.xs @@ -72,6 +72,7 @@ enum dyldErrorSource static void TranslateError (const char *path, enum dyldErrorSource type, int number) { + dTHX; char *error; unsigned int index; static char *OFIErrorStrings[] = @@ -92,11 +93,11 @@ static void TranslateError index = number; if (index > NUM_OFI_ERRORS - 1) index = NUM_OFI_ERRORS - 1; - error = form(OFIErrorStrings[index], path, number); + error = Perl_form_nocontext(OFIErrorStrings[index], path, number); break; default: - error = form("%s(%d): Totally unknown error type %d\n", + error = Perl_form_nocontext("%s(%d): Totally unknown error type %d\n", path, number, type); break; } @@ -209,7 +210,7 @@ char *symbol; NXStream *nxerr = OpenError(); unsigned long symref = 0; - if (!rld_lookup(nxerr, form("_%s", symbol), &symref)) + if (!rld_lookup(nxerr, Perl_form_nocontext("_%s", symbol), &symref)) TransferError(nxerr); CloseError(nxerr); return (void*) symref; @@ -222,16 +223,16 @@ char *symbol; static void -dl_private_init() +dl_private_init(pTHX) { - (void)dl_generic_private_init(); - dl_resolve_using = perl_get_av("DynaLoader::dl_resolve_using", 0x4); + (void)dl_generic_private_init(aTHX); + dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); } MODULE = DynaLoader PACKAGE = DynaLoader BOOT: - (void)dl_private_init(); + (void)dl_private_init(aTHX); @@ -242,16 +243,16 @@ dl_load_file(filename, flags=0) PREINIT: int mode = 1; CODE: - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags)); if (flags & 0x01) - warn("Can't make loaded symbols global on this platform while loading %s",filename); + 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)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError("%s",dlerror()) ; + SaveError(aTHX_ "%s",dlerror()) ; else - sv_setiv( ST(0), (IV)RETVAL); + sv_setiv( ST(0), PTR2IV(RETVAL) ); void * @@ -260,19 +261,19 @@ dl_find_symbol(libhandle, symbolname) char * symbolname CODE: #if NS_TARGET_MAJOR >= 4 - symbolname = form("_%s", symbolname); + symbolname = Perl_form_nocontext("_%s", symbolname); #endif - DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + 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(PerlIO_stderr(), + DLDEBUG(2, PerlIO_printf(Perl_debug_log, " symbolref = %lx\n", (unsigned long) RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError("%s",dlerror()) ; + SaveError(aTHX_ "%s",dlerror()) ; else - sv_setiv( ST(0), (IV)RETVAL); + sv_setiv( ST(0), PTR2IV(RETVAL) ); void @@ -289,9 +290,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", + 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(*)())symref, filename))); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); char * diff --git a/contrib/perl5/ext/DynaLoader/dl_vmesa.xs b/contrib/perl5/ext/DynaLoader/dl_vmesa.xs new file mode 100644 index 0000000..8595e44 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dl_vmesa.xs @@ -0,0 +1,175 @@ +/* dl_vmesa.xs + * + * Platform: VM/ESA, possibly others which use dllload etc. + * Author: Neale Ferguson (neale@mailbox.tabnsw.com.au) + * Created: 23rd Septemer, 1998 + * + * + */ + +/* Porting notes: + + + Definition of VM/ESA dynamic Linking functions + ============================================== + In order to make this implementation easier to understand here is a + quick definition of the VM/ESA Dynamic Linking functions which are + used here. + + dlopen + ------ + void * + dlopen(const char *path) + + This function takes the name of a dynamic object file and returns + a descriptor which can be used by dlsym later. It returns NULL on + error. + + + dllsym + ------ + void * + dlsym(void *handle, char *symbol) + + Takes the handle returned from dlopen and the name of a symbol to + get the address of. If the symbol was found a pointer is + returned. It returns NULL on error. + + dlerror + ------- + char * dlerror() + + Returns a null-terminated string which describes the last error + that occurred with the other dll functions. After each call to + dlerror the error message will be reset to a null pointer. The + SaveError function is used to save the error as soo as it happens. + + + Return Types + ============ + In this implementation the two functions, dl_load_file & + dl_find_symbol, return void *. This is because the underlying SunOS + dynamic linker calls also return void *. This is not necessarily + the case for all architectures. For example, some implementation + will want to return a char * for dl_load_file. + + If void * is not appropriate for your architecture, you will have to + change the void * to whatever you require. If you are not certain of + how Perl handles C data types, I suggest you start by consulting + Dean Roerich's Perl 5 API document. Also, have a look in the typemap + file (in the ext directory) for a fairly comprehensive list of types + that are already supported. If you are completely stuck, I suggest you + post a message to perl5-porters, comp.lang.perl.misc or if you are really + desperate to me. + + Remember when you are making any changes that the return value from + dl_load_file is used as a parameter in the dl_find_symbol + function. Also the return value from find_symbol is used as a parameter + to install_xsub. + + + Dealing with Error Messages + ============================ + In order to make the handling of dynamic linking errors as generic as + possible you should store any error messages associated with your + implementation with the StoreError function. + + In the case of VM/ESA the function dlerror returns the error message + associated with the last dynamic link error. As the VM/ESA dynamic + linker functions return NULL on error every call to a VM/ESA dynamic + dynamic link routine is coded like this + + RETVAL = dlopen(filename) ; + if (RETVAL == NULL) + SaveError(aTHX_ "%s",dlerror()) ; + + Note that SaveError() takes a printf format string. Use a "%s" as + the first parameter if the error may contain and % characters. + +*/ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include <dll.h> + + +#include "dlutils.c" /* SaveError() etc */ + + +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: + if (flags & 0x01) + Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags)); + RETVAL = dlopen(filename) ; + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%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_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: + 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=%lx)\n", + perl_name, (unsigned long) symref)); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_vms.xs b/contrib/perl5/ext/DynaLoader/dl_vms.xs index 08fd2f3..d7a1f86 100644 --- a/contrib/perl5/ext/DynaLoader/dl_vms.xs +++ b/contrib/perl5/ext/DynaLoader/dl_vms.xs @@ -65,6 +65,12 @@ static AV *dl_require_symbols = Nullav; #include <ssdef.h> #include <starlet.h> +#if defined(VMS_WE_ARE_CASE_SENSITIVE) +#define DL_CASE_SENSITIVE 1<<4 +#else +#define DL_CASE_SENSITIVE 0 +#endif + typedef unsigned long int vmssts; struct libref { @@ -112,6 +118,7 @@ dl_set_error(sts,stv) vmssts stv; { vmssts vec[3]; + dTHX; vec[0] = stv ? 2 : 1; vec[1] = sts; vec[2] = stv; @@ -121,12 +128,13 @@ dl_set_error(sts,stv) static unsigned int findsym_handler(void *sig, void *mech) { + dTHX; unsigned long int myvec[8],args, *usig = (unsigned long int *) sig; /* Be paranoid and assume signal vector passed in might be readonly */ myvec[0] = args = usig[0] > 10 ? 9 : usig[0] - 1; while (--args) myvec[args] = usig[args]; _ckvmssts(sys$putmsg(myvec,copy_errmsg,0,0)); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "findsym_handler: received\n\t%s\n",LastError)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "findsym_handler: received\n\t%s\n",LastError)); return SS$_CONTINUE; } @@ -140,16 +148,16 @@ my_find_image_symbol(struct dsc$descriptor_s *imgname, { unsigned long int retsts; VAXC$ESTABLISH(findsym_handler); - retsts = lib$find_image_symbol(imgname,symname,entry,defspec); + retsts = lib$find_image_symbol(imgname,symname,entry,defspec,DL_CASE_SENSITIVE); return retsts; } static void -dl_private_init() +dl_private_init(pTHX) { - dl_generic_private_init(); - dl_require_symbols = perl_get_av("DynaLoader::dl_require_symbols", 0x4); + dl_generic_private_init(aTHX); + dl_require_symbols = get_av("DynaLoader::dl_require_symbols", 0x4); /* Set up the static control blocks for dl_expand_filespec() */ dlfab = cc$rms_fab; dlnam = cc$rms_nam; @@ -162,7 +170,7 @@ dl_private_init() MODULE = DynaLoader PACKAGE = DynaLoader BOOT: - (void)dl_private_init(); + (void)dl_private_init(aTHX); void dl_expandspec(filespec) @@ -177,11 +185,11 @@ dl_expandspec(filespec) dlfab.fab$b_fns = strlen(vmsspec); dlfab.fab$l_dna = 0; dlfab.fab$b_dns = 0; - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_expand_filespec(%s):\n",vmsspec)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_expand_filespec(%s):\n",vmsspec)); /* On the first pass, just parse the specification string */ dlnam.nam$b_nop = NAM$M_SYNCHK; sts = sys$parse(&dlfab); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tSYNCHK sys$parse = %d\n",sts)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tSYNCHK sys$parse = %d\n",sts)); if (!(sts & 1)) { dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); ST(0) = &PL_sv_undef; @@ -194,7 +202,7 @@ dl_expandspec(filespec) dlnam.nam$b_type + dlnam.nam$b_ver); deflen += dlnam.nam$b_type + dlnam.nam$b_ver; memcpy(vmsspec,dlnam.nam$l_name,dlnam.nam$b_name); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tsplit filespec: name = %.*s, default = %.*s\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tsplit filespec: name = %.*s, default = %.*s\n", dlnam.nam$b_name,vmsspec,deflen,defspec)); /* . . . and go back to expand it */ dlnam.nam$b_nop = 0; @@ -202,7 +210,7 @@ dl_expandspec(filespec) dlfab.fab$b_dns = deflen; dlfab.fab$b_fns = dlnam.nam$b_name; sts = sys$parse(&dlfab); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tname/default sys$parse = %d\n",sts)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tname/default sys$parse = %d\n",sts)); if (!(sts & 1)) { dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); ST(0) = &PL_sv_undef; @@ -210,14 +218,14 @@ dl_expandspec(filespec) else { /* Now find the actual file */ sts = sys$search(&dlfab); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tsys$search = %d\n",sts)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tsys$search = %d\n",sts)); if (!(sts & 1)) { dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); ST(0) = &PL_sv_undef; } else { - ST(0) = sv_2mortal(newSVpv(dlnam.nam$l_rsa,dlnam.nam$b_rsl)); - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "\tresult = \\%.*s\\\n", + ST(0) = sv_2mortal(newSVpvn(dlnam.nam$l_rsa,dlnam.nam$b_rsl)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "\tresult = \\%.*s\\\n", dlnam.nam$b_rsl,dlnam.nam$l_rsa)); } } @@ -228,6 +236,7 @@ dl_load_file(filespec, flags) char * filespec int flags PREINIT: + dTHX; char vmsspec[NAM$C_MAXRSS]; SV *reqSV, **reqSVhndl; STRLEN deflen; @@ -244,16 +253,16 @@ dl_load_file(filespec, flags) void (*entry)(); CODE: - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filespec,flags)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filespec,flags)); specdsc.dsc$a_pointer = tovmsspec(filespec,vmsspec); specdsc.dsc$w_length = strlen(specdsc.dsc$a_pointer); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tVMS-ified filespec is %s\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tVMS-ified filespec is %s\n", specdsc.dsc$a_pointer)); New(1399,dlptr,1,struct libref); dlptr->name.dsc$b_dtype = dlptr->defspec.dsc$b_dtype = DSC$K_DTYPE_T; dlptr->name.dsc$b_class = dlptr->defspec.dsc$b_class = DSC$K_CLASS_S; sts = sys$filescan(&specdsc,namlst,0); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tsys$filescan: returns %d, name is %.*s\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tsys$filescan: returns %d, name is %.*s\n", sts,namlst[0].len,namlst[0].string)); if (!(sts & 1)) { failed = 1; @@ -269,21 +278,21 @@ dl_load_file(filespec, flags) memcpy(dlptr->defspec.dsc$a_pointer + deflen, namlst[0].string + namlst[0].len, dlptr->defspec.dsc$w_length - deflen); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tlibref = name: %s, defspec: %.*s\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tlibref = name: %s, defspec: %.*s\n", dlptr->name.dsc$a_pointer, dlptr->defspec.dsc$w_length, dlptr->defspec.dsc$a_pointer)); if (!(reqSVhndl = av_fetch(dl_require_symbols,0,FALSE)) || !(reqSV = *reqSVhndl)) { - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\t@dl_require_symbols empty, returning untested libref\n")); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\t@dl_require_symbols empty, returning untested libref\n")); } else { symdsc.dsc$w_length = SvCUR(reqSV); symdsc.dsc$a_pointer = SvPVX(reqSV); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\t$dl_require_symbols[0] = %.*s\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\t$dl_require_symbols[0] = %.*s\n", symdsc.dsc$w_length, symdsc.dsc$a_pointer)); sts = my_find_image_symbol(&(dlptr->name),&symdsc, &entry,&(dlptr->defspec)); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tlib$find_image_symbol returns %d\n",sts)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tlib$find_image_symbol returns %d\n",sts)); if (!(sts&1)) { failed = 1; dl_set_error(sts,0); @@ -298,7 +307,7 @@ dl_load_file(filespec, flags) ST(0) = &PL_sv_undef; } else { - ST(0) = sv_2mortal(newSViv((IV) dlptr)); + ST(0) = sv_2mortal(newSViv(PTR2IV(dlptr))); } @@ -313,19 +322,19 @@ dl_find_symbol(librefptr,symname) void (*entry)(); vmssts sts; - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_find_dymbol(%.*s,%.*s):\n", + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_find_dymbol(%.*s,%.*s):\n", thislib.name.dsc$w_length, thislib.name.dsc$a_pointer, symdsc.dsc$w_length,symdsc.dsc$a_pointer)); sts = my_find_image_symbol(&(thislib.name),&symdsc, &entry,&(thislib.defspec)); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tlib$find_image_symbol returns %d\n",sts)); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tentry point is %d\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tlib$find_image_symbol returns %d\n",sts)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tentry point is %d\n", (unsigned long int) entry)); if (!(sts & 1)) { /* error message already saved by findsym_handler */ ST(0) = &PL_sv_undef; } - else ST(0) = sv_2mortal(newSViv((IV) entry)); + else ST(0) = sv_2mortal(newSViv(PTR2IV(entry))); void @@ -341,9 +350,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", + 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(*)())symref, filename))); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); char * diff --git a/contrib/perl5/ext/DynaLoader/dlutils.c b/contrib/perl5/ext/DynaLoader/dlutils.c index bfa1f78..9d88f5f 100644 --- a/contrib/perl5/ext/DynaLoader/dlutils.c +++ b/contrib/perl5/ext/DynaLoader/dlutils.c @@ -3,6 +3,9 @@ * Currently this file is simply #included into dl_*.xs/.c files. * It should really be split into a dlutils.h and dlutils.c * + * Modified: + * 29th Feburary 2000 - Alan Burlison: Added functionality to close dlopen'd + * files when the interpreter exits */ @@ -18,46 +21,77 @@ static HV *dl_loaded_files = Nullhv; /* only needed on a few systems */ #ifdef DEBUGGING -static int dl_debug = 0; /* value copied from $DynaLoader::dl_error */ +static int dl_debug = 0; /* value copied from $DynaLoader::dl_debug */ #define DLDEBUG(level,code) if (dl_debug>=level) { code; } #else #define DLDEBUG(level,code) #endif +/* Close all dlopen'd files */ static void -dl_generic_private_init(CPERLarg) /* called by dl_*.xs dl_private_init() */ +dl_unload_all_files(pTHXo_ void *unused) +{ + CV *sub; + AV *dl_librefs; + SV *dl_libref; + + if ((sub = get_cv("DynaLoader::dl_unload_file", FALSE)) != NULL) { + dl_librefs = get_av("DynaLoader::dl_librefs", FALSE); + while ((dl_libref = av_pop(dl_librefs)) != &PL_sv_undef) { + dSP; + ENTER; + SAVETMPS; + PUSHMARK(SP); + XPUSHs(sv_2mortal(dl_libref)); + PUTBACK; + call_sv((SV*)sub, G_DISCARD | G_NODEBUG); + FREETMPS; + LEAVE; + } + } +} + + +static void +dl_generic_private_init(pTHXo) /* called by dl_*.xs dl_private_init() */ { char *perl_dl_nonlazy; #ifdef DEBUGGING - dl_debug = SvIV( perl_get_sv("DynaLoader::dl_debug", 0x04) ); + SV *sv = get_sv("DynaLoader::dl_debug", 0); + dl_debug = sv ? SvIV(sv) : 0; #endif if ( (perl_dl_nonlazy = getenv("PERL_DL_NONLAZY")) != NULL ) dl_nonlazy = atoi(perl_dl_nonlazy); if (dl_nonlazy) - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "DynaLoader bind mode is 'non-lazy'\n")); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "DynaLoader bind mode is 'non-lazy'\n")); #ifdef DL_LOADONCEONLY if (!dl_loaded_files) dl_loaded_files = newHV(); /* provide cache for dl_*.xs if needed */ #endif +#ifdef DL_UNLOAD_ALL_AT_EXIT + call_atexit(&dl_unload_all_files, (void*)0); +#endif } /* SaveError() takes printf style args and saves the result in LastError */ static void -SaveError(CPERLarg_ char* pat, ...) +SaveError(pTHXo_ char* pat, ...) { va_list args; + SV *msv; char *message; - int len; + STRLEN len; /* This code is based on croak/warn, see mess() in util.c */ va_start(args, pat); - message = mess(pat, &args); + msv = vmess(pat, &args); va_end(args); - len = strlen(message) + 1 ; /* include terminating null char */ + message = SvPV(msv,len); + len++; /* include terminating null char */ /* Allocate some memory for the error message */ if (LastError) @@ -67,6 +101,6 @@ SaveError(CPERLarg_ char* pat, ...) /* Copy message into LastError (including terminating null char) */ strncpy(LastError, message, len) ; - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "DynaLoader: stored error msg '%s'\n",LastError)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "DynaLoader: stored error msg '%s'\n",LastError)); } diff --git a/contrib/perl5/ext/DynaLoader/hints/aix.pl b/contrib/perl5/ext/DynaLoader/hints/aix.pl new file mode 100644 index 0000000..7dde941 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/hints/aix.pl @@ -0,0 +1,10 @@ +# See dl_aix.xs for details. +use Config; +if ($Config{libs} =~ /-lC/ && -f '/lib/libC.a') { + $self->{CCFLAGS} = $Config{ccflags} . ' -DUSE_libC'; + if (-f '/usr/ibmcxx/include/load.h') { + $self->{CCFLAGS} .= ' -DUSE_ibmcxx_load_h'; + } elsif (-f '/usr/lpp/xlC/include/load.h') { + $self->{CCFLAGS} .= ' -DUSE_xlC_load_h'; + } +} diff --git a/contrib/perl5/ext/DynaLoader/hints/linux.pl b/contrib/perl5/ext/DynaLoader/hints/linux.pl new file mode 100644 index 0000000..06f4f4c --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/hints/linux.pl @@ -0,0 +1,4 @@ +# XXX Configure test needed. +# Some Linux releases like to hide their <nlist.h> +$self->{CCFLAGS} = $Config{ccflags} . ' -I/usr/include/libelf' + if -f "/usr/include/libelf/nlist.h"; diff --git a/contrib/perl5/ext/DynaLoader/hints/openbsd.pl b/contrib/perl5/ext/DynaLoader/hints/openbsd.pl new file mode 100644 index 0000000..aeaa92c --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/hints/openbsd.pl @@ -0,0 +1,3 @@ +# XXX Configure test needed? +# Some OpenBSDs seem to have a dlopen() that won't accept relative paths +$self->{CCFLAGS} = $Config{ccflags} . ' -DDLOPEN_WONT_DO_RELATIVE_PATHS'; |