diff options
Diffstat (limited to 'contrib/perl5/ext/DynaLoader')
| -rw-r--r-- | contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL | 729 | ||||
| -rw-r--r-- | contrib/perl5/ext/DynaLoader/Makefile.PL | 29 | ||||
| -rw-r--r-- | contrib/perl5/ext/DynaLoader/README | 53 | ||||
| -rw-r--r-- | contrib/perl5/ext/DynaLoader/dl_aix.xs | 670 | ||||
| -rw-r--r-- | contrib/perl5/ext/DynaLoader/dl_cygwin32.xs | 153 | ||||
| -rw-r--r-- | contrib/perl5/ext/DynaLoader/dl_dld.xs | 175 | ||||
| -rw-r--r-- | contrib/perl5/ext/DynaLoader/dl_dlopen.xs | 219 | ||||
| -rw-r--r-- | contrib/perl5/ext/DynaLoader/dl_hpux.xs | 157 | ||||
| -rw-r--r-- | contrib/perl5/ext/DynaLoader/dl_mpeix.xs | 128 | ||||
| -rw-r--r-- | contrib/perl5/ext/DynaLoader/dl_next.xs | 303 | ||||
| -rw-r--r-- | contrib/perl5/ext/DynaLoader/dl_none.xs | 19 | ||||
| -rw-r--r-- | contrib/perl5/ext/DynaLoader/dl_vms.xs | 356 | ||||
| -rw-r--r-- | contrib/perl5/ext/DynaLoader/dlutils.c | 72 |
13 files changed, 3063 insertions, 0 deletions
diff --git a/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL b/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL new file mode 100644 index 0000000..4c41559 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL @@ -0,0 +1,729 @@ + +use Config; + +sub to_string { + my ($value) = @_; + $value =~ s/\\/\\\\'/g; + $value =~ s/'/\\'/g; + return "'$value'"; +} + +unlink "DynaLoader.pm" if -f "DynaLoader.pm"; +open OUT, ">DynaLoader.pm" or die $!; +print OUT <<'EOT'; + +# Generated from DynaLoader.pm.PL (resolved %Config::Config values) + +package DynaLoader; + +# 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 = $VERSION = "1.03"; # avoid typo warning + +require AutoLoader; +*AUTOLOAD = \&AutoLoader::AUTOLOAD; + +# The following require can't be removed during maintenance +# releases, sadly, because of the risk of buggy code that does +# require Carp; Carp::croak "..."; without brackets dying +# if Carp hasn't been loaded in earlier compile time. :-( +# We'll let those bugs get found on the development track. +require Carp if $] < 5.00450; + + +# enable debug/trace messages from DynaLoader perl code +$dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug; + +# +# Flags to alter dl_load_file behaviour. Assigned bits: +# 0x01 make symbols available for linking later dl_load_file's. +# (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL)) +# (ignored under VMS; effect is built-in to image linking) +# +# This is called as a class method $module->dl_load_flags. The +# definition here will be inherited and result on "default" loading +# behaviour unless a sub-class of DynaLoader defines its own version. +# + +sub dl_load_flags { 0x00 } + +# ($dl_dlext, $dlsrc) +# = @Config::Config{'dlext', 'dlsrc'}; +EOT + +print OUT " (\$dl_dlext, \$dlsrc) = (", + to_string($Config::Config{'dlext'}), ",", + to_string($Config::Config{'dlsrc'}), ")\n;" ; + +print OUT <<'EOT'; + +# Some systems need special handling to expand file specifications +# (VMS support by Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>) +# 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'; + +@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 + +# 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"; + +# Initialise @dl_library_path with the 'standard' library path +# for this platform as determined by Configure + +# push(@dl_library_path, split(' ', $Config::Config{'libpth'}); +EOT + +print OUT "push(\@dl_library_path, split(' ', ", + to_string($Config::Config{'libpth'}), "));\n"; + +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. +push(@dl_library_path, split(/:/, $ENV{LD_LIBRARY_PATH})) + if $ENV{LD_LIBRARY_PATH}; + + +# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. +boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader); + + +if ($dl_debug) { + print STDERR "DynaLoader.pm loaded (@INC, @dl_library_path)\n"; + print STDERR "DynaLoader not linked into this perl\n" + unless defined(&boot_DynaLoader); +} + +1; # End of main code + + +sub croak { require Carp; Carp::croak(@_) } + +# The bootstrap function cannot be autoloaded (without complications) +# so we define it here: + +sub bootstrap { + # use local vars to enable $module.bs script to edit values + local(@args) = @_; + local($module) = $args[0]; + local(@dirs, $file); + + unless ($module) { + require Carp; + Carp::confess("Usage: DynaLoader::bootstrap(module)"); + } + + # A common error on platforms which don't support dynamic loading. + # Since it's fatal and potentially confusing we give a detailed message. + croak("Can't load module $module, dynamic loading not available in this perl.\n". + " (You may need to build a new perl executable which either supports\n". + " dynamic loading or has the $module module statically linked into it.)\n") + unless defined(&dl_load_file); + + my @modparts = split(/::/,$module); + my $modfname = $modparts[-1]; + + # 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; + + my $modpname = join('/',@modparts); + + print STDERR "DynaLoader::bootstrap for $module ", + "(auto/$modpname/$modfname.$dl_dlext)\n" if $dl_debug; + + foreach (@INC) { + chop($_ = VMS::Filespec::unixpath($_)) if $Is_VMS; + my $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"; + last if $file = ($do_expand) ? dl_expandspec($try) : (-f $try && $try); + + # no luck here, save dir for possible later dl_findfile search + push @dirs, $dir; + } + # last resort, let dl_findfile have a go in all known locations + $file = dl_findfile(map("-L$_",@dirs,@INC), $modfname) unless $file; + + croak("Can't locate loadable object for module $module in \@INC (\@INC contains: @INC)") + unless $file; # wording similar to error from 'require' + + my $bootname = "boot_$module"; + $bootname =~ s/\W/_/g; + @dl_require_symbols = ($bootname); + + # Execute optional '.bootstrap' perl script for this module. + # 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 + if (-s $bs) { # only read file if it's not empty + print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug; + eval { do $bs; }; + warn "$bs: $@\n" if $@; + } + + # 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, $module->dl_load_flags) or + croak("Can't load '$file' for module $module: ".dl_error()."\n"); + + 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 + 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 + &$xs(@args); +} + + +#sub _check_file { # private utility to handle dl_expandspec vs -f tests +# my($file) = @_; +# return $file if (!$do_expand && -f $file); # the common case +# return $file if ( $do_expand && ($file=dl_expandspec($file))); +# return undef; +#} + + +# Let autosplit and the autoloader deal with these functions: +__END__ + + +sub dl_findfile { + # Read ext/DynaLoader/DynaLoader.doc for detailed information. + # This function does not automatically consider the architecture + # or the perl library auto directories. + my (@args) = @_; + my (@dirs, $dir); # which directories to search + my (@found); # full paths to real files we have found +EOT + +print OUT ' my $dl_ext= ' . to_string($Config::Config{'dlext'}) . + "; # \$Config::Config{'dlext'} suffix for perl extensions\n"; +print OUT ' my $dl_so = ' . to_string($Config::Config{'so'}) . + "; # \$Config::Config{'so'} suffix for shared libraries\n"; + +print OUT <<'EOT'; + + print STDERR "dl_findfile(@args)\n" if $dl_debug; + + # accumulate directories but process files as they appear + arg: foreach(@args) { + # Special fast case: full filepath requires no search + if ($Is_VMS && m%[:>/\]]% && -f $_) { + push(@found,dl_expandspec(VMS::Filespec::vmsify($_))); + last arg unless wantarray; + next; + } + elsif (m:/: && -f $_ && !$do_expand) { + push(@found,$_); + last arg unless wantarray; + next; + } + + # Deal with directories first: + # Using a -L prefix is the preferred option (faster and more robust) + if (m:^-L:) { s/^-L//; push(@dirs, $_); 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; } + + # VMS: we may be using native VMS directry syntax instead of + # Unix emulation, so check this as well + if ($Is_VMS && /[:>\]]/ && -d $_) { push(@dirs, $_); next; } + + # Only files should get this far... + my(@names, $name); # what filenames to look for + if (m:-l: ) { # convert -lname to appropriate library name + s/-l//; + push(@names,"lib$_.$dl_so"); + push(@names,"lib$_.a"); + } else { # Umm, a bare name. Try various alternatives: + # these should be ordered with the most likely first + push(@names,"$_.$dl_ext") unless m/\.$dl_ext$/o; + push(@names,"$_.$dl_so") unless m/\.$dl_so$/o; + push(@names,"lib$_.$dl_so") unless m:/:; + push(@names,"$_.a") if !m/\.a$/ and $dlsrc eq "dl_dld.xs"; + push(@names, $_); + } + foreach $dir (@dirs, @dl_library_path) { + next unless -d $dir; + chop($dir = VMS::Filespec::unixpath($dir)) if $Is_VMS; + foreach $name (@names) { + my($file) = "$dir/$name"; + print STDERR " checking in $dir for $name\n" if $dl_debug; + $file = ($do_expand) ? dl_expandspec($file) : (-f $file && $file); + #$file = _check_file($file); + if ($file) { + push(@found, $file); + next arg; # no need to look any further + } + } + } + } + if ($dl_debug) { + foreach(@dirs) { + print STDERR " dl_findfile ignored non-existent directory: $_\n" unless -d $_; + } + print STDERR "dl_findfile found: @found\n"; + } + return $found[0] unless wantarray; + @found; +} + + +sub dl_expandspec { + my($spec) = @_; + # Optional function invoked if DynaLoader.pm sets $do_expand. + # Most systems do not require or use this function. + # Some systems may implement it in the dl_*.xs file in which case + # this autoload version will not be called but is harmless. + + # This function is designed to deal with systems which treat some + # 'filenames' in a special way. For example VMS 'Logical Names' + # (something like unix environment variables - but different). + # This function should recognise such names and expand them into + # full file paths. + # Must return undef if $spec is invalid or file does not exist. + + my $file = $spec; # default output to input + + if ($Is_VMS) { # dl_expandspec should be defined in dl_vms.xs + require Carp; + Carp::croak("dl_expandspec: should be defined in XS file!\n"); + } else { + return undef unless -f $file; + } + print STDERR "dl_expandspec($spec) => $file\n" if $dl_debug; + $file; +} + +sub dl_find_symbol_anywhere +{ + my $sym = shift; + my $libref; + foreach $libref (@dl_librefs) { + my $symref = dl_find_symbol($libref,$sym); + return $symref if $symref; + } + return undef; +} + +=head1 NAME + +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 + +=head1 SYNOPSIS + + package YourPackage; + require DynaLoader; + @ISA = qw(... DynaLoader ...); + bootstrap YourPackage; + + # optional method for 'global' loading + sub dl_load_flags { 0x01 } + + +=head1 DESCRIPTION + +This document defines a standard generic interface to the dynamic +linking mechanisms available on many platforms. Its primary purpose is +to implement automatic dynamic loading of Perl modules. + +This document serves as both a specification for anyone wishing to +implement the DynaLoader for a new platform and as a guide for +anyone wishing to use the DynaLoader directly in an application. + +The DynaLoader is designed to be a very simple high-level +interface that is sufficiently general to cover the requirements +of SunOS, HP-UX, NeXT, Linux, VMS and other platforms. + +It is also hoped that the interface will cover the needs of OS/2, NT +etc and also allow pseudo-dynamic linking (using C<ld -A> at runtime). + +It must be stressed that the DynaLoader, by itself, is practically +useless for accessing non-Perl libraries because it provides almost no +Perl-to-C 'glue'. There is, for example, no mechanism for calling a C +library function or supplying arguments. A C::DynaLib module +is available from CPAN sites which performs that function for some +common system types. + +DynaLoader Interface Summary + + @dl_library_path + @dl_resolve_using + @dl_require_symbols + $dl_debug + @dl_librefs + @dl_modules + Implemented in: + bootstrap($modulename) Perl + @filepaths = dl_findfile(@names) Perl + $flags = $modulename->dl_load_flags Perl + $symref = dl_find_symbol_anywhere($symbol) Perl + + $libref = dl_load_file($filename, $flags) C + $symref = dl_find_symbol($libref, $symbol) C + @symbols = dl_undef_symbols() C + dl_install_xsub($name, $symref [, $filename]) C + $message = dl_error C + +=over 4 + +=item @dl_library_path + +The standard/default list of directories in which dl_findfile() will +search for libraries etc. Directories are searched in order: +$dl_library_path[0], [1], ... etc + +@dl_library_path is initialised to hold the list of 'normal' directories +(F</usr/lib>, etc) determined by B<Configure> (C<$Config{'libpth'}>). This should +ensure portability across a wide range of platforms. + +@dl_library_path should also be initialised with any other directories +that can be determined from the environment at runtime (such as +LD_LIBRARY_PATH for SunOS). + +After initialisation @dl_library_path can be manipulated by an +application using push and unshift before calling dl_findfile(). +Unshift can be used to add directories to the front of the search order +either to save search time or to override libraries with the same name +in the 'normal' directories. + +The load function that dl_load_file() calls may require an absolute +pathname. The dl_findfile() function and @dl_library_path can be +used to search for and return the absolute pathname for the +library/object that you wish to load. + +=item @dl_resolve_using + +A list of additional libraries or other shared objects which can be +used to resolve any undefined symbols that might be generated by a +later call to load_file(). + +This is only required on some platforms which do not handle dependent +libraries automatically. For example the Socket Perl extension +library (F<auto/Socket/Socket.so>) contains references to many socket +functions which need to be resolved when it's loaded. Most platforms +will automatically know where to find the 'dependent' library (e.g., +F</usr/lib/libsocket.so>). A few platforms need to be told the +location of the dependent library explicitly. Use @dl_resolve_using +for this. + +Example usage: + + @dl_resolve_using = dl_findfile('-lsocket'); + +=item @dl_require_symbols + +A list of one or more symbol names that are in the library/object file +to be dynamically loaded. This is only required on some platforms. + +=item @dl_librefs + +An array of the handles returned by successful calls to dl_load_file(), +made by bootstrap, in the order in which they were loaded. +Can be used with dl_find_symbol() to look for a symbol in any of +the loaded files. + +=item @dl_modules + +An array of module (package) names that have been bootstrap'ed. + +=item dl_error() + +Syntax: + + $message = dl_error(); + +Error message text from the last failed DynaLoader function. Note +that, similar to errno in unix, a successful function call does not +reset this message. + +Implementations should detect the error as soon as it occurs in any of +the other functions and save the corresponding message for later +retrieval. This will avoid problems on some platforms (such as SunOS) +where the error message is very temporary (e.g., dlerror()). + +=item $dl_debug + +Internal debugging messages are enabled when $dl_debug is set true. +Currently setting $dl_debug only affects the Perl side of the +DynaLoader. These messages should help an application developer to +resolve any DynaLoader usage problems. + +$dl_debug is set to C<$ENV{'PERL_DL_DEBUG'}> if defined. + +For the DynaLoader developer/porter there is a similar debugging +variable added to the C code (see dlutils.c) and enabled if Perl was +built with the B<-DDEBUGGING> flag. This can also be set via the +PERL_DL_DEBUG environment variable. Set to 1 for minimal information or +higher for more. + +=item dl_findfile() + +Syntax: + + @filepaths = dl_findfile(@names) + +Determine the full paths (including file suffix) of one or more +loadable files given their generic names and optionally one or more +directories. Searches directories in @dl_library_path by default and +returns an empty list if no files were found. + +Names can be specified in a variety of platform independent forms. Any +names in the form B<-lname> are converted into F<libname.*>, where F<.*> is +an appropriate suffix for the platform. + +If a name does not already have a suitable prefix and/or suffix then +the corresponding file will be searched for by trying combinations of +prefix and suffix appropriate to the platform: "$name.o", "lib$name.*" +and "$name". + +If any directories are included in @names they are searched before +@dl_library_path. Directories may be specified as B<-Ldir>. Any other +names are treated as filenames to be searched for. + +Using arguments of the form C<-Ldir> and C<-lname> is recommended. + +Example: + + @dl_resolve_using = dl_findfile(qw(-L/usr/5lib -lposix)); + + +=item dl_expandspec() + +Syntax: + + $filepath = dl_expandspec($spec) + +Some unusual systems, such as VMS, require special filename handling in +order to deal with symbolic names for files (i.e., VMS's Logical Names). + +To support these systems a dl_expandspec() function can be implemented +either in the F<dl_*.xs> file or code can be added to the autoloadable +dl_expandspec() function in F<DynaLoader.pm>. See F<DynaLoader.pm> for +more information. + +=item dl_load_file() + +Syntax: + + $libref = dl_load_file($filename, $flags) + +Dynamically load $filename, which must be the path to a shared object +or library. An opaque 'library reference' is returned as a handle for +the loaded object. Returns undef on error. + +The $flags argument to alters dl_load_file behaviour. +Assigned bits: + + 0x01 make symbols available for linking later dl_load_file's. + (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL)) + (ignored under VMS; this is a normal part of image linking) + +(On systems that provide a handle for the loaded object such as SunOS +and HPUX, $libref will be that handle. On other systems $libref will +typically be $filename or a pointer to a buffer containing $filename. +The application should not examine or alter $libref in any way.) + +This is the function that does the real work. It should use the +current values of @dl_require_symbols and @dl_resolve_using if required. + + SunOS: dlopen($filename) + HP-UX: shl_load($filename) + Linux: dld_create_reference(@dl_require_symbols); dld_link($filename) + NeXT: rld_load($filename, @dl_resolve_using) + VMS: lib$find_image_symbol($filename,$dl_require_symbols[0]) + +(The dlopen() 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: + + $flags = dl_loadflags $modulename; + +Designed to be a method call, and to be overridden by a derived class +(i.e. a class which has DynaLoader in its @ISA). The definition in +DynaLoader itself returns 0, which produces standard behavior from +dl_load_file(). + +=item dl_find_symbol() + +Syntax: + + $symref = dl_find_symbol($libref, $symbol) + +Return the address of the symbol $symbol or C<undef> if not found. If the +target system has separate functions to search for symbols of different +types then dl_find_symbol() should search for function symbols first and +then other types. + +The exact manner in which the address is returned in $symref is not +currently defined. The only initial requirement is that $symref can +be passed to, and understood by, dl_install_xsub(). + + SunOS: dlsym($libref, $symbol) + HP-UX: shl_findsym($libref, $symbol) + Linux: dld_get_func($symbol) and/or dld_get_symbol($symbol) + NeXT: rld_lookup("_$symbol") + VMS: lib$find_image_symbol($libref,$symbol) + + +=item dl_find_symbol_anywhere() + +Syntax: + + $symref = dl_find_symbol_anywhere($symbol) + +Applies dl_find_symbol() to the members of @dl_librefs and returns +the first match found. + +=item dl_undef_symbols() + +Example + + @symbols = dl_undef_symbols() + +Return a list of symbol names which remain undefined after load_file(). +Returns C<()> if not known. Don't worry if your platform does not provide +a mechanism for this. Most do not need it and hence do not provide it, +they just return an empty list. + + +=item dl_install_xsub() + +Syntax: + + dl_install_xsub($perl_name, $symref [, $filename]) + +Create a new Perl external subroutine named $perl_name using $symref as +a pointer to the function which implements the routine. This is simply +a direct call to newXSUB(). Returns a reference to the installed +function. + +The $filename parameter is used by Perl to identify the source file for +the function if required by die(), caller() or the debugger. If +$filename is not defined then "DynaLoader" will be used. + + +=item bootstrap() + +Syntax: + +bootstrap($module) + +This is the normal entry point for automatic dynamic loading in Perl. + +It performs the following actions: + +=over 8 + +=item * + +locates an auto/$module directory by searching @INC + +=item * + +uses dl_findfile() to determine the filename to load + +=item * + +sets @dl_require_symbols to C<("boot_$module")> + +=item * + +executes an F<auto/$module/$module.bs> file if it exists +(typically used to add to @dl_resolve_using any files which +are required to load the module on the current platform) + +=item * + +calls dl_load_flags() to determine how to load the file. + +=item * + +calls dl_load_file() to load the file + +=item * + +calls dl_undef_symbols() and warns if any symbols are undefined + +=item * + +calls dl_find_symbol() for "boot_$module" + +=item * + +calls dl_install_xsub() to install it as "${module}::bootstrap" + +=item * + +calls &{"${module}::bootstrap"} to bootstrap the module (actually +it uses the function reference returned by dl_install_xsub for speed) + +=back + +=back + + +=head1 AUTHOR + +Tim Bunce, 11 August 1994. + +This interface is based on the work and comments of (in no particular +order): Larry Wall, Robert Sanders, Dean Roehrich, Jeff Okamoto, Anno +Siegel, Thomas Neumann, Paul Marquess, Charles Bailey, myself and others. + +Larry Wall designed the elegant inherited bootstrap mechanism and +implemented the first Perl 5 dynamic loader using it. + +Solaris global loading added by Nick Ing-Simmons with design/coding +assistance from Tim Bunce, January 1996. + +=cut +EOT + +close OUT or die $!; + diff --git a/contrib/perl5/ext/DynaLoader/Makefile.PL b/contrib/perl5/ext/DynaLoader/Makefile.PL new file mode 100644 index 0000000..7a75115 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/Makefile.PL @@ -0,0 +1,29 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'DynaLoader', + LINKTYPE => 'static', + DEFINE => '-DPERL_CORE -DLIBC="$(LIBC)"', + MAN3PODS => ' ', # Pods will be built by installman. + 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'}, +); + +sub MY::postamble { + ' +DynaLoader.xs: $(DLSRC) + $(CP) $? $@ + +# Perform very simple tests just to check for major gaffs. +# We can\'t do much more for platforms we are not executing on. +test-xs: + for i in dl_*xs; \ + do $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSUBPPARGS) $$i > /dev/null; \ + done +'; +} + diff --git a/contrib/perl5/ext/DynaLoader/README b/contrib/perl5/ext/DynaLoader/README new file mode 100644 index 0000000..0551cf3 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/README @@ -0,0 +1,53 @@ +Perl 5 DynaLoader + +See DynaLoader.pm for detailed specification. + +This module is very similar to the other Perl 5 modules except that +Configure selects which dl_*.xs file to use. + +After Configure has been run the Makefile.PL will generate a Makefile +which will run xsubpp on a specific dl_*.xs file and write the output +to DynaLoader.c + +After that the processing is the same as any other module. + +Note that, to be effective, the DynaLoader module must be _statically_ +linked into perl! Configure should arrange this. + +This interface is based on the work and comments of (in no particular +order): Larry Wall, Robert Sanders, Dean Roehrich, Jeff Okamoto, Anno +Siegel, Thomas Neumann, Paul Marquess, Charles Bailey and others. + +The dl_*.xs files should either be named after the dynamic linking +operating system interface used if that interface is available on more +than one type of system, e.g.: + dlopen for dlopen()/dlsym() type functions (SunOS, BSD) + dld for the GNU dld library functions (linux, ?) +or else the osname, e.g., hpux, next, vms etc. + +Both are determined by Configure and so only those specific names that +Configure knows/uses will work. + +If porting the DynaLoader to a platform that has a core dynamic linking +interface similar to an existing generic type, e.g., dlopen or dld, +please try to port the corresponding dl_*.xs file (using #ifdef's if +required). + +Otherwise, or if that proves too messy, create a new dl_*.xs file named +after your osname. Configure will give preference to a dl_$osname.xs +file if one exists. + +The file dl_dlopen.xs is a reference implementation by Paul Marquess +which is a good place to start if porting from scratch. For more complex +platforms take a look at dl_dld.xs. The dlutils.c file holds some +common definitions that are #included into the dl_*.xs files. + +After the initial implementation of a new DynaLoader dl_*.xs file you +may need to edit or create ext/MODULE/MODULE.bs files (library bootstrap +files) to reflect the needs of your platform and linking software. + +Refer to DynaLoader.pm, lib/ExtUtils/MakeMaker.pm and any existing +ext/MODULE/MODULE.bs files for more information. + +Tim Bunce. +August 1994 diff --git a/contrib/perl5/ext/DynaLoader/dl_aix.xs b/contrib/perl5/ext/DynaLoader/dl_aix.xs new file mode 100644 index 0000000..ea50408 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dl_aix.xs @@ -0,0 +1,670 @@ +/* dl_aix.xs + * + * Written: 8/31/94 by Wayne Scott (wscott@ichips.intel.com) + * + * All I did was take Jens-Uwe Mager's libdl emulation library for + * AIX and merged it with the dl_dlopen.xs file to create a dynamic library + * package that works for AIX. + * + * I did change all malloc's, free's, strdup's, calloc's to use the perl + * equilvant. I also removed some stuff we will not need. Call fini() + * on statup... It can probably be trimmed more. + */ + +/* + * @(#)dlfcn.c 1.5 revision of 93/02/14 20:14:17 + * This is an unpublished work copyright (c) 1992 Helios Software GmbH + * 3000 Hannover 1, Germany + */ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include <stdio.h> +#include <errno.h> +#include <string.h> +#include <stdlib.h> +#include <sys/types.h> +#include <sys/ldr.h> +#include <a.out.h> +#include <ldfcn.h> + +/* + * AIX 4.3 does remove some useful definitions from ldfcn.h. Define + * these here to compensate for that lossage. + */ +#ifndef BEGINNING +# define BEGINNING SEEK_SET +#endif +#ifndef FSEEK +# define FSEEK(ldptr,o,p) fseek(IOPTR(ldptr),(p==BEGINNING)?(OFFSET(ldptr) +o):o,p) +#endif +#ifndef FREAD +# define FREAD(p,s,n,ldptr) fread(p,s,n,IOPTR(ldptr)) +#endif + +/* If using PerlIO, redefine these macros from <ldfcn.h> */ +#ifdef USE_PERLIO +#define FSEEK(ldptr,o,p) PerlIO_seek(IOPTR(ldptr),(p==BEGINNING)?(OFFSET(ldptr)+o):o,p) +#define FREAD(p,s,n,ldptr) PerlIO_read(IOPTR(ldptr),p,s*n) +#endif + +/* + * We simulate dlopen() et al. through a call to load. Because AIX has + * no call to find an exported symbol we read the loader section of the + * loaded module and build a list of exported symbols and their virtual + * address. + */ + +typedef struct { + char *name; /* the symbols's name */ + void *addr; /* its relocated virtual address */ +} Export, *ExportPtr; + +/* + * The void * handle returned from dlopen is actually a ModulePtr. + */ +typedef struct Module { + struct Module *next; + char *name; /* module name for refcounting */ + int refCnt; /* the number of references */ + void *entry; /* entry point from load */ + int nExports; /* the number of exports found */ + ExportPtr exports; /* the array of exports */ +} Module, *ModulePtr; + +/* + * We keep a list of all loaded modules to be able to call the fini + * handlers at atexit() time. + */ +static ModulePtr modList; + +/* + * 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 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)"; + +char *strerrorcat(char *str, int err) { + int strsiz = strlen(str); + int msgsiz; + char *msg; + +#ifdef USE_THREADS + char *buf = malloc(BUFSIZ); + + if (buf == 0) + return 0; + if (strerror_r(err, buf, sizeof(buf)) == 0) + msg = buf; + else + msg = strerror_r_failed; + msgsiz = strlen(msg); + if (strsiz + msgsiz < BUFSIZ) + strcat(str, msg); + free(buf); +#else + if ((msg = strerror(err)) == 0) + msg = strerror_failed; + msgsiz = strlen(msg); /* Note msg = buf and free() above. */ + if (strsiz + msgsiz < BUFSIZ) /* Do not move this after #endif. */ + strcat(str, msg); +#endif + + return str; +} + +char *strerrorcpy(char *str, int err) { + int msgsiz; + char *msg; + +#ifdef USE_THREADS + char *buf = malloc(BUFSIZ); + + if (buf == 0) + return 0; + if (strerror_r(err, buf, sizeof(buf)) == 0) + msg = buf; + else + msg = strerror_r_failed; + msgsiz = strlen(msg); + if (msgsiz < BUFSIZ) + strcpy(str, msg); + free(buf); +#else + if ((msg = strerror(err)) == 0) + msg = strerror_failed; + msgsiz = strlen(msg); /* Note msg = buf and free() above. */ + if (msgsiz < BUFSIZ) /* Do not move this after #endif. */ + strcpy(str, msg); +#endif + + return str; +} + +/* ARGSUSED */ +void *dlopen(char *path, int mode) +{ + register ModulePtr mp; + static void *mainModule; + + /* + * 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. + */ + if (!mainModule) { + if ((mainModule = findMain()) == NULL) + return NULL; + atexit(terminate); + } + /* + * Scan the list of modules if have the module already loaded. + */ + for (mp = modList; mp; mp = mp->next) + if (strcmp(mp->name, path) == 0) { + mp->refCnt++; + return mp; + } + Newz(1000,mp,1,Module); + if (mp == NULL) { + errvalid++; + strcpy(errbuf, "Newz: "); + strerrorcat(errbuf, errno); + return NULL; + } + + if ((mp->name = savepv(path)) == NULL) { + errvalid++; + strcpy(errbuf, "savepv: "); + strerrorcat(errbuf, errno); + 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) { + safefree(mp->name); + safefree(mp); + errvalid++; + strcpy(errbuf, "dlopen: "); + strcat(errbuf, path); + strcat(errbuf, ": "); + /* + * If AIX says the file is not executable, the error + * 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); + else { + char **p; + for (p = tmp; *p; p++) + caterr(*p); + } + } else + strerrorcat(errbuf, errno); + return NULL; + } + mp->refCnt = 1; + mp->next = modList; + modList = mp; + if (loadbind(0, mainModule, mp->entry) == -1) { + dlclose(mp); + errvalid++; + strcpy(errbuf, "loadbind: "); + strerrorcat(errbuf, errno); + return NULL; + } + if (readExports(mp) == -1) { + dlclose(mp); + return NULL; + } + return mp; +} + +/* + * Attempt to decipher an AIX loader error message and append it + * to our static error message buffer. + */ +static void caterr(char *s) +{ + register char *p = s; + + while (*p >= '0' && *p <= '9') + p++; + switch(atoi(s)) { + case L_ERROR_TOOMANY: + strcat(errbuf, "to many errors"); + break; + case L_ERROR_NOLIB: + strcat(errbuf, "can't load library"); + strcat(errbuf, p); + break; + case L_ERROR_UNDEF: + strcat(errbuf, "can't find symbol"); + strcat(errbuf, p); + break; + case L_ERROR_RLDBAD: + strcat(errbuf, "bad RLD"); + strcat(errbuf, p); + break; + case L_ERROR_FORMAT: + strcat(errbuf, "bad exec format in"); + strcat(errbuf, p); + break; + case L_ERROR_ERRNO: + strerrorcat(errbuf, atoi(++p)); + break; + default: + strcat(errbuf, s); + break; + } +} + +void *dlsym(void *handle, const char *symbol) +{ + register ModulePtr mp = (ModulePtr)handle; + register ExportPtr ep; + register int i; + + /* + * Could speed up search, but I assume that one assigns + * the result to function pointers anyways. + */ + for (ep = mp->exports, i = mp->nExports; i; i--, ep++) + if (strcmp(ep->name, symbol) == 0) + return ep->addr; + errvalid++; + strcpy(errbuf, "dlsym: undefined symbol "); + strcat(errbuf, symbol); + return NULL; +} + +char *dlerror(void) +{ + if (errvalid) { + errvalid = 0; + return errbuf; + } + return NULL; +} + +int dlclose(void *handle) +{ + register ModulePtr mp = (ModulePtr)handle; + int result; + register ModulePtr mp1; + + if (--mp->refCnt > 0) + return 0; + result = unload(mp->entry); + if (result == -1) { + errvalid++; + strerrorcpy(errbuf, errno); + } + if (mp->exports) { + register ExportPtr ep; + register int i; + for (ep = mp->exports, i = mp->nExports; i; i--, ep++) + if (ep->name) + safefree(ep->name); + safefree(mp->exports); + } + if (mp == modList) + modList = mp->next; + else { + for (mp1 = modList; mp1; mp1 = mp1->next) + if (mp1->next == mp) { + mp1->next = mp->next; + break; + } + } + safefree(mp->name); + safefree(mp); + return result; +} + +static void terminate(void) +{ + while (modList) + dlclose(modList); +} + +/* Added by Wayne Scott + * This is needed because the ldopen system call calls + * calloc to allocated a block of date. The ldclose call calls free. + * Without this we get this system calloc and perl's free, resulting + * in a "Bad free" message. This way we always use perl's malloc. + */ +void *calloc(size_t ne, size_t sz) +{ + void *out; + + out = (void *) safemalloc(ne*sz); + memzero(out, ne*sz); + return(out); +} + +/* + * Build the export table from the XCOFF .loader section. + */ +static int readExports(ModulePtr mp) +{ + LDFILE *ldp = NULL; + SCNHDR sh; + LDHDR *lhp; + char *ldbuf; + LDSYM *ls; + int i; + ExportPtr ep; + + if ((ldp = ldopen(mp->name, ldp)) == NULL) { + struct ld_info *lp; + char *buf; + int size = 4*1024; + if (errno != ENOENT) { + errvalid++; + strcpy(errbuf, "readExports: "); + strerrorcat(errbuf, errno); + return -1; + } + /* + * The module might be loaded due to the LIBPATH + * environment variable. Search for the loaded + * module using L_GETINFO. + */ + if ((buf = safemalloc(size)) == NULL) { + errvalid++; + strcpy(errbuf, "readExports: "); + strerrorcat(errbuf, errno); + return -1; + } + while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) { + safefree(buf); + size += 4*1024; + if ((buf = safemalloc(size)) == NULL) { + errvalid++; + strcpy(errbuf, "readExports: "); + strerrorcat(errbuf, errno); + return -1; + } + } + if (i == -1) { + errvalid++; + strcpy(errbuf, "readExports: "); + strerrorcat(errbuf, errno); + safefree(buf); + return -1; + } + /* + * Traverse the list of loaded modules. The entry point + * returned by load() does actually point to the data + * segment origin. + */ + lp = (struct ld_info *)buf; + while (lp) { + if (lp->ldinfo_dataorg == mp->entry) { + ldp = ldopen(lp->ldinfo_filename, ldp); + break; + } + if (lp->ldinfo_next == 0) + lp = NULL; + else + lp = (struct ld_info *)((char *)lp + lp->ldinfo_next); + } + safefree(buf); + if (!ldp) { + errvalid++; + strcpy(errbuf, "readExports: "); + strerrorcat(errbuf, errno); + return -1; + } + } + if (TYPE(ldp) != U802TOCMAGIC) { + errvalid++; + strcpy(errbuf, "readExports: bad magic"); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + if (ldnshread(ldp, _LOADER, &sh) != SUCCESS) { + errvalid++; + strcpy(errbuf, "readExports: cannot read loader section header"); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + /* + * We read the complete loader section in one chunk, this makes + * finding long symbol names residing in the string table easier. + */ + if ((ldbuf = (char *)safemalloc(sh.s_size)) == NULL) { + errvalid++; + strcpy(errbuf, "readExports: "); + strerrorcat(errbuf, errno); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + if (FSEEK(ldp, sh.s_scnptr, BEGINNING) != OKFSEEK) { + errvalid++; + strcpy(errbuf, "readExports: cannot seek to loader section"); + safefree(ldbuf); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } +/* This first case is a hack, since it assumes that the 3rd parameter to + FREAD is 1. See the redefinition of FREAD above to see how this works. */ +#ifdef USE_PERLIO + if (FREAD(ldbuf, sh.s_size, 1, ldp) != sh.s_size) { +#else + if (FREAD(ldbuf, sh.s_size, 1, ldp) != 1) { +#endif + errvalid++; + strcpy(errbuf, "readExports: cannot read loader section"); + safefree(ldbuf); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + lhp = (LDHDR *)ldbuf; + ls = (LDSYM *)(ldbuf+LDHDRSZ); + /* + * Count the number of exports to include in our export table. + */ + for (i = lhp->l_nsyms; i; i--, ls++) { + if (!LDR_EXPORT(*ls)) + continue; + mp->nExports++; + } + Newz(1001, mp->exports, mp->nExports, Export); + if (mp->exports == NULL) { + errvalid++; + strcpy(errbuf, "readExports: "); + strerrorcat(errbuf, errno); + safefree(ldbuf); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + /* + * Fill in the export table. All entries are relative to + * the entry point we got from load. + */ + ep = mp->exports; + ls = (LDSYM *)(ldbuf+LDHDRSZ); + for (i = lhp->l_nsyms; i; i--, ls++) { + char *symname; + if (!LDR_EXPORT(*ls)) + continue; + if (ls->l_zeroes == 0) + symname = ls->l_offset+lhp->l_stoff+ldbuf; + else + symname = ls->l_name; + ep->name = savepv(symname); + ep->addr = (void *)((unsigned long)mp->entry + ls->l_value); + ep++; + } + safefree(ldbuf); + while(ldclose(ldp) == FAILURE) + ; + 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) + * 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 + * + */ + +/* Porting notes: + + see dl_dlopen.xs + +*/ + +#include "dlutils.c" /* SaveError() etc */ + + +static void +dl_private_init() +{ + (void)dl_generic_private_init(); +} + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + + +void * +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)); + if (flags & 0x01) + warn("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)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("%s",dlerror()) ; + else + sv_setiv( ST(0), (IV)RETVAL); + + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n", + libhandle, symbolname)); + RETVAL = dlsym(libhandle, symbolname); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref = %x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("%s",dlerror()) ; + else + sv_setiv( ST(0), (IV)RETVAL); + + +void +dl_undef_symbols() + PPCODE: + + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", + perl_name, symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_cygwin32.xs b/contrib/perl5/ext/DynaLoader/dl_cygwin32.xs new file mode 100644 index 0000000..2b75637 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dl_cygwin32.xs @@ -0,0 +1,153 @@ +/* dl_cygwin32.xs + * + * Platform: Win32 (Windows NT/Windows 95) + * Author: Wei-Yuen Tan (wyt@hip.com) + * Created: A warm day in June, 1995 + * + * Modified: + * August 23rd 1995 - rewritten after losing everything when I + * wiped off my NT partition (eek!) + */ +/* Modified from the original dl_win32.xs to work with cygwin32 + -John Cerney 3/26/97 +*/ +/* Porting notes: + +I merely took Paul's dl_dlopen.xs, took out extraneous stuff and +replaced the appropriate SunOS calls with the corresponding Win32 +calls. + +*/ + +#define WIN32_LEAN_AND_MEAN +// Defines from windows needed for this function only. Can't include full +// Cygwin32 windows headers because of problems with CONTEXT redefinition +// Removed logic to tell not dynamically load static modules. It is assumed that all +// modules are dynamically built. This should be similar to the behavoir on sunOS. +// Leaving in the logic would have required changes to the standard perlmain.c code +// +// // Includes call a dll function to initialize it's impure_ptr. +#include <stdio.h> +void (*impure_setupptr)(struct _reent *); // pointer to the impure_setup routine + +//#include <windows.h> +#define LOAD_WITH_ALTERED_SEARCH_PATH (8) +typedef void *HANDLE; +typedef HANDLE HINSTANCE; +#define STDCALL __attribute__ ((stdcall)) +typedef int STDCALL (*FARPROC)(); + +HINSTANCE +STDCALL +LoadLibraryExA( + char* lpLibFileName, + HANDLE hFile, + unsigned int dwFlags + ); +unsigned int +STDCALL +GetLastError( + void + ); +FARPROC +STDCALL +GetProcAddress( + HINSTANCE hModule, + char* lpProcName + ); + +#include <string.h> + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "dlutils.c" /* SaveError() etc */ + +static void +dl_private_init() +{ + (void)dl_generic_private_init(); +} + + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + +void * +dl_load_file(filename,flags=0) + char * filename + int flags + PREINIT: + CODE: + DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); + + RETVAL = (void*) LoadLibraryExA(filename, NULL, LOAD_WITH_ALTERED_SEARCH_PATH ) ; + + DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL){ + SaveError("%d",GetLastError()) ; + } + else{ + // setup the dll's impure_ptr: + impure_setupptr = GetProcAddress(RETVAL, "impure_setup"); + if( impure_setupptr == NULL){ + printf( + "Cygwin32 dynaloader error: could not load impure_setup symbol\n"); + RETVAL = NULL; + } + else{ + // setup the DLLs impure_ptr: + (*impure_setupptr)(_impure_ptr); + sv_setiv( ST(0), (IV)RETVAL); + } + } + + + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: + DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", + libhandle, symbolname)); + RETVAL = (void*) GetProcAddress((HINSTANCE) libhandle, symbolname); + DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("%d",GetLastError()) ; + else + sv_setiv( ST(0), (IV)RETVAL); + + +void +dl_undef_symbols() + PPCODE: + + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", + perl_name, symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_dld.xs b/contrib/perl5/ext/DynaLoader/dl_dld.xs new file mode 100644 index 0000000..2443ab0 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dl_dld.xs @@ -0,0 +1,175 @@ +/* + * Written 3/1/94, Robert Sanders <Robert.Sanders@linux.org> + * + * based upon the file "dl.c", which is + * Copyright (c) 1994, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Date: 1994/03/07 00:21:43 $ + * $Source: /home/rsanders/src/perl5alpha6/RCS/dld_dl.c,v $ + * $Revision: 1.4 $ + * $State: Exp $ + * + * $Log: dld_dl.c,v $ + * Removed implicit link against libc. 1994/09/14 William Setzer. + * + * Integrated other DynaLoader changes. 1994/06/08 Tim Bunce. + * + * rewrote dl_load_file, misc updates. 1994/09/03 William Setzer. + * + * Revision 1.4 1994/03/07 00:21:43 rsanders + * added min symbol count for load_libs and switched order so system libs + * are loaded after app-specified libs. + * + * Revision 1.3 1994/03/05 01:17:26 rsanders + * added path searching. + * + * Revision 1.2 1994/03/05 00:52:39 rsanders + * added package-specified libraries. + * + * Revision 1.1 1994/03/05 00:33:40 rsanders + * Initial revision + * + * + */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include <dld.h> /* GNU DLD header file */ +#include <unistd.h> + +#include "dlutils.c" /* for SaveError() etc */ + +static AV *dl_resolve_using = Nullav; +static AV *dl_require_symbols = Nullav; + +static void +dl_private_init() +{ + 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); +#ifdef __linux__ + dlderr = dld_init("/proc/self/exe"); + if (dlderr) { +#endif + 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)); + } +#ifdef __linux__ + } +#endif +} + + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + + +char * +dl_load_file(filename, flags=0) + char * filename + int flags + PREINIT: + int dlderr,x,max; + GV *gv; + CODE: + RETVAL = filename; + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "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); + 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)); + if (dlderr = dld_create_reference(sym)) { + SaveError("dld_create_reference(%s): %s", sym, + dld_strerror(dlderr)); + goto haverror; + } + } + + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dld_link(%s)\n", filename)); + if (dlderr = dld_link(filename)) { + SaveError("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)); + if (dlderr = dld_link(sym)) { + SaveError("dld_link(%s): %s", sym, dld_strerror(dlderr)); + goto haverror; + } + } + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "libref=%s\n", RETVAL)); +haverror: + ST(0) = sv_newmortal() ; + if (dlderr == 0) + sv_setiv(ST(0), (IV)RETVAL); + + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "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)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("dl_find_symbol: Unable to find '%s' symbol", symbolname) ; + else + sv_setiv(ST(0), (IV)RETVAL); + + +void +dl_undef_symbols() + PPCODE: + if (dld_undefined_sym_count) { + int x; + char **undef_syms = dld_list_undefined_sym(); + EXTEND(SP, dld_undefined_sym_count); + for (x=0; x < dld_undefined_sym_count; x++) + PUSHs(sv_2mortal(newSVpv(undef_syms[x]+1, 0))); + free(undef_syms); + } + + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", + perl_name, symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_dlopen.xs b/contrib/perl5/ext/DynaLoader/dl_dlopen.xs new file mode 100644 index 0000000..2459205 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dl_dlopen.xs @@ -0,0 +1,219 @@ +/* dl_dlopen.xs + * + * Platform: SunOS/Solaris, possibly others which use dlopen. + * Author: Paul Marquess (pmarquess@bfsec.bt.co.uk) + * 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 + * + */ + +/* Porting notes: + + + Definition of Sunos dynamic Linking functions + ============================================= + In order to make this implementation easier to understand here is a + quick definition of the SunOS Dynamic Linking functions which are + used here. + + dlopen + ------ + void * + dlopen(path, mode) + char * path; + int mode; + + 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. + + The mode parameter must be set to 1 for Solaris 1 and to + RTLD_LAZY (==2) on Solaris 2. + + + dlsym + ------ + void * + dlsym(handle, symbol) + 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. If DL_PREPEND_UNDERSCORE is + defined an underscore will be added to the start of symbol. This + is required on some platforms (freebsd). + + dlerror + ------ + char * dlerror() + + 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. + + + 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 SunOS the function dlerror returns the error message + associated with the last dynamic link error. As the SunOS dynamic + linker functions dlopen & dlsym both return NULL on error every call + to a SunOS dynamic link routine is coded like this + + RETVAL = dlopen(filename, 1) ; + if (RETVAL == NULL) + SaveError("%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" + +#ifdef I_DLFCN +#include <dlfcn.h> /* the dynamic linker include file for Sunos/Solaris */ +#else +#include <nlist.h> +#include <link.h> +#endif + +#ifndef RTLD_LAZY +# define RTLD_LAZY 1 /* Solaris 1 */ +#endif + +#ifndef HAS_DLERROR +# ifdef __NetBSD__ +# define dlerror() strerror(errno) +# else +# define dlerror() "Unknown error - dlerror() not implemented" +# endif +#endif + + +#include "dlutils.c" /* SaveError() etc */ + + +static void +dl_private_init() +{ + (void)dl_generic_private_init(); +} + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + + +void * +dl_load_file(filename, flags=0) + char * filename + int flags + PREINIT: + int mode = RTLD_LAZY; + CODE: +#ifdef RTLD_NOW + if (dl_nonlazy) + mode = RTLD_NOW; +#endif + if (flags & 0x01) +#ifdef RTLD_GLOBAL + mode |= RTLD_GLOBAL; +#else + warn("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)); + RETVAL = dlopen(filename, mode) ; + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%lx\n", (unsigned long) RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("%s",dlerror()) ; + else + sv_setiv( ST(0), (IV)RETVAL); + + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: +#ifdef DLSYM_NEEDS_UNDERSCORE + symbolname = form("_%s", symbolname); +#endif + DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + "dl_find_symbol(handle=%lx, symbol=%s)\n", + (unsigned long) libhandle, symbolname)); + RETVAL = dlsym(libhandle, symbolname); + DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + " symbolref = %lx\n", (unsigned long) RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("%s",dlerror()) ; + else + sv_setiv( ST(0), (IV)RETVAL); + + +void +dl_undef_symbols() + PPCODE: + + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%lx)\n", + perl_name, (unsigned long) symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)_((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 new file mode 100644 index 0000000..a82e0ea --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dl_hpux.xs @@ -0,0 +1,157 @@ +/* + * Author: Jeff Okamoto (okamoto@corp.hp.com) + * Version: 2.1, 1995/1/25 + */ + +/* o Added BIND_VERBOSE to dl_nonlazy condition to add names of missing + * symbols to stderr message on fatal error. + * + * o Added BIND_NONFATAL comment to default condition. + * + * Chuck Phillips (cdp@fc.hp.com) + * Version: 2.2, 1997/5/4 */ + +#ifdef __hp9000s300 +#define magic hpux_magic +#define MAGIC HPUX_MAGIC +#endif + +#include <dl.h> +#ifdef __hp9000s300 +#undef magic +#undef MAGIC +#endif + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + + +#include "dlutils.c" /* for SaveError() etc */ + +static AV *dl_resolve_using = Nullav; + + +static void +dl_private_init() +{ + (void)dl_generic_private_init(); + dl_resolve_using = perl_get_av("DynaLoader::dl_resolve_using", 0x4); +} + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + + +void * +dl_load_file(filename, flags=0) + char * filename + int flags + PREINIT: + shl_t obj = NULL; + int i, max, bind_type; + CODE: + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "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); + if (dl_nonlazy) { + bind_type = BIND_IMMEDIATE|BIND_VERBOSE; + } else { + bind_type = BIND_DEFERRED; + /* For certain libraries, like DCE, deferred binding often causes run + * time problems. Adding BIND_NONFATAL to BIND_IMMEDIATE still allows + * unresolved references in situations like this. */ + /* bind_type = BIND_IMMEDIATE|BIND_NONFATAL; */ + } + /* BIND_NOSTART removed from bind_type because it causes the shared library's */ + /* initialisers not to be run. This causes problems with all of the static objects */ + /* in the library. */ +#ifdef DEBUGGING + if (dl_debug) + bind_type |= BIND_VERBOSE; +#endif /* DEBUGGING */ + + 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)); + obj = shl_load(sym, bind_type, 0L); + if (obj == NULL) { + goto end; + } + } + + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s): ", filename)); + obj = shl_load(filename, bind_type, 0L); + + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", obj)); +end: + ST(0) = sv_newmortal() ; + if (obj == NULL) + SaveError("%s",Strerror(errno)); + else + sv_setiv( ST(0), (IV)obj); + + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: + shl_t obj = (shl_t) libhandle; + void *symaddr = NULL; + int status; +#ifdef __hp9000s300 + symbolname = form("_%s", symbolname); +#endif + DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + "dl_find_symbol(handle=%lx, symbol=%s)\n", + (unsigned long) libhandle, symbolname)); + + ST(0) = sv_newmortal() ; + errno = 0; + + status = shl_findsym(&obj, symbolname, TYPE_PROCEDURE, &symaddr); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " 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)); + } + + if (status == -1) { + SaveError("%s",(errno) ? Strerror(errno) : "Symbol not found") ; + } else { + sv_setiv( ST(0), (IV)symaddr); + } + + +void +dl_undef_symbols() + PPCODE: + + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", + perl_name, symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_mpeix.xs b/contrib/perl5/ext/DynaLoader/dl_mpeix.xs new file mode 100644 index 0000000..808c3b0 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dl_mpeix.xs @@ -0,0 +1,128 @@ +/* + * Author: Mark Klein (mklein@dis.com) + * Version: 2.1, 1996/07/25 + * Version: 2.2, 1997/09/25 Mark Bixby (markb@cccd.edu) + */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#ifdef __GNUC__ +extern void HPGETPROCPLABEL( int parms, + char * procname, + int * plabel, + int * status, + char * firstfile, + int casesensitive, + int symboltype, + int * datasize, + int position, + int searchpath, + int binding); +#else +#pragma intrinsic HPGETPROCPLABEL +#endif +#include "dlutils.c" /* for SaveError() etc */ + +typedef struct { + char filename[PATH_MAX + 3]; + } t_mpe_dld, *p_mpe_dld; + +static AV *dl_resolve_using = Nullav; + +static void +dl_private_init() +{ + (void)dl_generic_private_init(); + dl_resolve_using = perl_get_av("DynaLoader::dl_resolve_using", 0x4); +} + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + +void * +dl_load_file(filename, flags=0) + char * filename + int flags + PREINIT: + char buf[PATH_MAX + 3]; + p_mpe_dld obj = NULL; + int i; + CODE: + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "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); + obj = (p_mpe_dld) safemalloc(sizeof(t_mpe_dld)); + memzero(obj, sizeof(t_mpe_dld)); + if (filename[0] == '.') + { + getcwd(buf,sizeof(buf)); + sprintf(obj->filename,"$%s/%s$",buf,filename); + } + else + sprintf(obj->filename,"$%s$",filename); + + DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," libref=%x\n", obj)); + + ST(0) = sv_newmortal() ; + if (obj == NULL) + SaveError("%s",Strerror(errno)); + else + sv_setiv( ST(0), (IV)obj); + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: + int datalen; + p_mpe_dld obj = (p_mpe_dld) libhandle; + char symname[PATH_MAX + 3]; + void * symaddr = NULL; + int status; + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(),"dl_find_symbol(handle=%x, symbol=%s)\n", + libhandle, symbolname)); + ST(0) = sv_newmortal() ; + errno = 0; + + sprintf(symname, "$%s$", symbolname); + HPGETPROCPLABEL(8, symname, &symaddr, &status, obj->filename, 1, + 0, &datalen, 1, 0, 0); + + DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," symbolref(PROCEDURE) = %x\n", symaddr)); + + if (status != 0) { + SaveError("%s",(errno) ? Strerror(errno) : "Symbol not found") ; + } else { + sv_setiv( ST(0), (IV)symaddr); + } + +void +dl_undef_symbols() + PPCODE: + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(),"dl_install_xsub(name=%s, symref=%x)\n", + perl_name, symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_next.xs b/contrib/perl5/ext/DynaLoader/dl_next.xs new file mode 100644 index 0000000..2b547f0 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dl_next.xs @@ -0,0 +1,303 @@ +/* dl_next.xs + * + * Platform: NeXT NS 3.2 + * Author: Anno Siegel (siegel@zrz.TU-Berlin.DE) + * Based on: dl_dlopen.xs by Paul Marquess + * Created: Aug 15th, 1994 + * + */ + +/* + And Gandalf said: 'Many folk like to know beforehand what is to + be set on the table; but those who have laboured to prepare the + feast like to keep their secret; for wonder makes the words of + praise louder.' +*/ + +/* Porting notes: + +dl_next.xs is itself a port from dl_dlopen.xs by Paul Marquess. It +should not be used as a base for further ports though it may be used +as an example for how dl_dlopen.xs can be ported to other platforms. + +The method used here is just to supply the sun style dlopen etc. +functions in terms of NeXTs rld_*. The xs code proper is unchanged +from Paul's original. + +The port could use some streamlining. For one, error handling could +be simplified. + +Anno Siegel + +*/ + +#if NS_TARGET_MAJOR >= 4 +#else +/* include these before perl headers */ +#include <mach-o/rld.h> +#include <streams/streams.h> +#endif + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define DL_LOADONCEONLY + +#include "dlutils.c" /* SaveError() etc */ + + +static char * dl_last_error = (char *) 0; +static AV *dl_resolve_using = Nullav; + +static char *dlerror() +{ + return dl_last_error; +} + +int dlclose(handle) /* stub only */ +void *handle; +{ + return 0; +} + +#if NS_TARGET_MAJOR >= 4 +#import <mach-o/dyld.h> + +enum dyldErrorSource +{ + OFImage, +}; + +static void TranslateError + (const char *path, enum dyldErrorSource type, int number) +{ + char *error; + unsigned int index; + static char *OFIErrorStrings[] = + { + "%s(%d): Object Image Load Failure\n", + "%s(%d): Object Image Load Success\n", + "%s(%d): Not an recognisable object file\n", + "%s(%d): No valid architecture\n", + "%s(%d): Object image has an invalid format\n", + "%s(%d): Invalid access (permissions?)\n", + "%s(%d): Unknown error code from NSCreateObjectFileImageFromFile\n", + }; +#define NUM_OFI_ERRORS (sizeof(OFIErrorStrings) / sizeof(OFIErrorStrings[0])) + + switch (type) + { + case OFImage: + index = number; + if (index > NUM_OFI_ERRORS - 1) + index = NUM_OFI_ERRORS - 1; + error = form(OFIErrorStrings[index], path, number); + break; + + default: + error = form("%s(%d): Totally unknown error type %d\n", + path, number, type); + break; + } + Safefree(dl_last_error); + dl_last_error = savepv(error); +} + +static char *dlopen(char *path, int mode /* mode is ignored */) +{ + int dyld_result; + NSObjectFileImage ofile; + NSModule handle = NULL; + + dyld_result = NSCreateObjectFileImageFromFile(path, &ofile); + if (dyld_result != NSObjectFileImageSuccess) + TranslateError(path, OFImage, dyld_result); + else + { + // NSLinkModule will cause the run to abort on any link error's + // not very friendly but the error recovery functionality is limited. + handle = NSLinkModule(ofile, path, TRUE); + } + + return handle; +} + +void * +dlsym(handle, symbol) +void *handle; +char *symbol; +{ + void *addr; + + if (NSIsSymbolNameDefined(symbol)) + addr = NSAddressOfSymbol(NSLookupAndBindSymbol(symbol)); + else + addr = NULL; + + return addr; +} + +#else /* NS_TARGET_MAJOR <= 3 */ + +static NXStream *OpenError(void) +{ + return NXOpenMemory( (char *) 0, 0, NX_WRITEONLY); +} + +static void TransferError(NXStream *s) +{ + char *buffer; + int len, maxlen; + + if ( dl_last_error ) { + Safefree(dl_last_error); + } + NXGetMemoryBuffer(s, &buffer, &len, &maxlen); + New(1097, dl_last_error, len, char); + strcpy(dl_last_error, buffer); +} + +static void CloseError(NXStream *s) +{ + if ( s ) { + NXCloseMemory( s, NX_FREEBUFFER); + } +} + +static char *dlopen(char *path, int mode /* mode is ignored */) +{ + int rld_success; + NXStream *nxerr; + I32 i, psize; + char *result; + char **p; + + /* 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), PL_na); + } + p[psize-1] = 0; + rld_success = rld_load(nxerr, (struct mach_header **)0, p, + (const char *) 0); + safefree((char*) p); + if (rld_success) { + result = path; + /* prevent multiple loads of same file into same process */ + hv_store(dl_loaded_files, path, strlen(path), &PL_sv_yes, 0); + } else { + TransferError(nxerr); + result = (char*) 0; + } + CloseError(nxerr); + return result; +} + +void * +dlsym(handle, symbol) +void *handle; +char *symbol; +{ + NXStream *nxerr = OpenError(); + unsigned long symref = 0; + + if (!rld_lookup(nxerr, form("_%s", symbol), &symref)) + TransferError(nxerr); + CloseError(nxerr); + return (void*) symref; +} + +#endif /* NS_TARGET_MAJOR >= 4 */ + + +/* ----- code from dl_dlopen.xs below here ----- */ + + +static void +dl_private_init() +{ + (void)dl_generic_private_init(); + dl_resolve_using = perl_get_av("DynaLoader::dl_resolve_using", 0x4); +} + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + + + +void * +dl_load_file(filename, flags=0) + char * filename + int flags + PREINIT: + int mode = 1; + CODE: + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags)); + if (flags & 0x01) + warn("Can't make loaded symbols global on this platform while loading %s",filename); + RETVAL = dlopen(filename, mode) ; + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("%s",dlerror()) ; + else + sv_setiv( ST(0), (IV)RETVAL); + + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: +#if NS_TARGET_MAJOR >= 4 + symbolname = form("_%s", symbolname); +#endif + DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + "dl_find_symbol(handle=%lx, symbol=%s)\n", + (unsigned long) libhandle, symbolname)); + RETVAL = dlsym(libhandle, symbolname); + DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + " symbolref = %lx\n", (unsigned long) RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("%s",dlerror()) ; + else + sv_setiv( ST(0), (IV)RETVAL); + + +void +dl_undef_symbols() + PPCODE: + + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", + perl_name, symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_none.xs b/contrib/perl5/ext/DynaLoader/dl_none.xs new file mode 100644 index 0000000..5a193e4 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dl_none.xs @@ -0,0 +1,19 @@ +/* dl_none.xs + * + * Stubs for platforms that do not support dynamic linking + */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +MODULE = DynaLoader PACKAGE = DynaLoader + +char * +dl_error() + CODE: + RETVAL = "Not implemented"; + OUTPUT: + RETVAL + +# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_vms.xs b/contrib/perl5/ext/DynaLoader/dl_vms.xs new file mode 100644 index 0000000..974fd58 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dl_vms.xs @@ -0,0 +1,356 @@ +/* dl_vms.xs + * + * Platform: OpenVMS, VAX or AXP + * Author: Charles Bailey bailey@genetics.upenn.edu + * Revised: 12-Dec-1994 + * + * Implementation Note + * This section is added as an aid to users and DynaLoader developers, in + * order to clarify the process of dynamic linking under VMS. + * dl_vms.xs uses the supported VMS dynamic linking call, which allows + * a running program to map an arbitrary file of executable code and call + * routines within that file. This is done via the VMS RTL routine + * lib$find_image_symbol, whose calling sequence is as follows: + * status = lib$find_image_symbol(imgname,symname,symval,defspec); + * where + * status = a standard VMS status value (unsigned long int) + * imgname = a fixed-length string descriptor, passed by + * reference, containing the NAME ONLY of the image + * file to be mapped. An attempt will be made to + * translate this string as a logical name, so it may + * not contain any characters which are not allowed in + * logical names. If no translation is found, imgname + * is used directly as the name of the image file. + * symname = a fixed-length string descriptor, passed by + * reference, containing the name of the routine + * to be located. + * symval = an unsigned long int, passed by reference, into + * which is written the entry point address of the + * routine whose name is specified in symname. + * defspec = a fixed-length string descriptor, passed by + * reference, containing a default file specification + * whichis used to fill in any missing parts of the + * image file specification after the imgname argument + * is processed. + * In order to accommodate the handling of the imgname argument, the routine + * dl_expandspec() is provided for use by perl code (e.g. dl_findfile) + * which wants to see what image file lib$find_image_symbol would use if + * it were passed a given file specification. The file specification passed + * to dl_expandspec() and dl_load_file() can be partial or complete, and can + * use VMS or Unix syntax; these routines perform the necessary conversions. + * In general, writers of perl extensions need only conform to the + * procedures set out in the DynaLoader documentation, and let the details + * be taken care of by the routines here and in DynaLoader.pm. If anyone + * comes across any incompatibilities, please let me know. Thanks. + * + */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "dlutils.c" /* dl_debug, LastError; SaveError not used */ + +static AV *dl_require_symbols = Nullav; + +/* N.B.: + * dl_debug and LastError are static vars; you'll need to deal + * with them appropriately if you need context independence + */ + +#include <descrip.h> +#include <fscndef.h> +#include <lib$routines.h> +#include <rms.h> +#include <ssdef.h> +#include <starlet.h> + +typedef unsigned long int vmssts; + +struct libref { + struct dsc$descriptor_s name; + struct dsc$descriptor_s defspec; +}; + +/* Static data for dl_expand_filespec() - This is static to save + * initialization on each call; if you need context-independence, + * just make these auto variables in dl_expandspec() and dl_load_file() + */ +static char dlesa[NAM$C_MAXRSS], dlrsa[NAM$C_MAXRSS]; +static struct FAB dlfab; +static struct NAM dlnam; + +/* $PutMsg action routine - records error message in LastError */ +static vmssts +copy_errmsg(msg,unused) + struct dsc$descriptor_s * msg; + vmssts unused; +{ + if (*(msg->dsc$a_pointer) == '%') { /* first line */ + if (LastError) + strncpy((LastError = saferealloc(LastError,msg->dsc$w_length+1)), + msg->dsc$a_pointer, msg->dsc$w_length); + else + strncpy((LastError = safemalloc(msg->dsc$w_length+1)), + msg->dsc$a_pointer, msg->dsc$w_length); + LastError[msg->dsc$w_length] = '\0'; + } + else { /* continuation line */ + int errlen = strlen(LastError); + LastError = saferealloc(LastError, errlen + msg->dsc$w_length + 2); + LastError[errlen] = '\n'; LastError[errlen+1] = '\0'; + strncat(LastError, msg->dsc$a_pointer, msg->dsc$w_length); + LastError[errlen+msg->dsc$w_length+1] = '\0'; + } + return 0; +} + +/* Use $PutMsg to retrieve error message for failure status code */ +static void +dl_set_error(sts,stv) + vmssts sts; + vmssts stv; +{ + vmssts vec[3]; + + vec[0] = stv ? 2 : 1; + vec[1] = sts; vec[2] = stv; + _ckvmssts(sys$putmsg(vec,copy_errmsg,0,0)); +} + +static unsigned int +findsym_handler(void *sig, void *mech) +{ + 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)); + return SS$_CONTINUE; +} + +/* wrapper for lib$find_image_symbol, so signalled errors can be saved + * for dl_error and then returned */ +static unsigned long int +my_find_image_symbol(struct dsc$descriptor_s *imgname, + struct dsc$descriptor_s *symname, + void (**entry)(), + struct dsc$descriptor_s *defspec) +{ + unsigned long int retsts; + VAXC$ESTABLISH(findsym_handler); + retsts = lib$find_image_symbol(imgname,symname,entry,defspec); + return retsts; +} + + +static void +dl_private_init() +{ + dl_generic_private_init(); + dl_require_symbols = perl_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; + dlfab.fab$l_nam = &dlnam; + dlnam.nam$l_esa = dlesa; + dlnam.nam$b_ess = sizeof dlesa; + dlnam.nam$l_rsa = dlrsa; + dlnam.nam$b_rss = sizeof dlrsa; +} +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + +void +dl_expandspec(filespec) + char * filespec + CODE: + char vmsspec[NAM$C_MAXRSS], defspec[NAM$C_MAXRSS]; + size_t deflen; + vmssts sts; + + tovmsspec(filespec,vmsspec); + dlfab.fab$l_fna = vmsspec; + 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)); + /* 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)); + if (!(sts & 1)) { + dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); + ST(0) = &PL_sv_undef; + } + else { + /* Now set up a default spec - everything but the name */ + deflen = dlnam.nam$l_name - dlesa; + memcpy(defspec,dlesa,deflen); + memcpy(defspec+deflen,dlnam.nam$l_type, + 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", + dlnam.nam$b_name,vmsspec,deflen,defspec)); + /* . . . and go back to expand it */ + dlnam.nam$b_nop = 0; + dlfab.fab$l_dna = defspec; + 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)); + if (!(sts & 1)) { + dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); + ST(0) = &PL_sv_undef; + } + else { + /* Now find the actual file */ + sts = sys$search(&dlfab); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\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", + dlnam.nam$b_rsl,dlnam.nam$l_rsa)); + } + } + } + +void +dl_load_file(filespec, flags) + char * filespec + int flags + PREINIT: + char vmsspec[NAM$C_MAXRSS]; + SV *reqSV, **reqSVhndl; + STRLEN deflen; + struct dsc$descriptor_s + specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}, + symdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; + struct fscnlst { + unsigned short int len; + unsigned short int code; + char *string; + } namlst[2] = {{0,FSCN$_NAME,0},{0,0,0}}; + struct libref *dlptr; + vmssts sts, failed = 0; + void (*entry)(); + CODE: + + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "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", + 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", + sts,namlst[0].len,namlst[0].string)); + if (!(sts & 1)) { + failed = 1; + dl_set_error(sts,0); + } + else { + dlptr->name.dsc$w_length = namlst[0].len; + dlptr->name.dsc$a_pointer = savepvn(namlst[0].string,namlst[0].len); + dlptr->defspec.dsc$w_length = specdsc.dsc$w_length - namlst[0].len; + New(1097, dlptr->defspec.dsc$a_pointer, dlptr->defspec.dsc$w_length + 1, char); + deflen = namlst[0].string - specdsc.dsc$a_pointer; + memcpy(dlptr->defspec.dsc$a_pointer,specdsc.dsc$a_pointer,deflen); + 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", + 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")); + } + 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", + 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)); + if (!(sts&1)) { + failed = 1; + dl_set_error(sts,0); + } + } + } + + if (failed) { + Safefree(dlptr->name.dsc$a_pointer); + Safefree(dlptr->defspec.dsc$a_pointer); + Safefree(dlptr); + ST(0) = &PL_sv_undef; + } + else { + ST(0) = sv_2mortal(newSViv((IV) dlptr)); + } + + +void +dl_find_symbol(librefptr,symname) + void * librefptr + SV * symname + CODE: + struct libref thislib = *((struct libref *)librefptr); + struct dsc$descriptor_s + symdsc = {SvCUR(symname),DSC$K_DTYPE_T,DSC$K_CLASS_S,SvPVX(symname)}; + void (*entry)(); + vmssts sts; + + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "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", + (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)); + + +void +dl_undef_symbols() + PPCODE: + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", + perl_name, symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/contrib/perl5/ext/DynaLoader/dlutils.c b/contrib/perl5/ext/DynaLoader/dlutils.c new file mode 100644 index 0000000..bfa1f78 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dlutils.c @@ -0,0 +1,72 @@ +/* dlutils.c - handy functions and definitions for dl_*.xs files + * + * Currently this file is simply #included into dl_*.xs/.c files. + * It should really be split into a dlutils.h and dlutils.c + * + */ + + +/* pointer to allocated memory for last error message */ +static char *LastError = (char*)NULL; + +/* flag for immediate rather than lazy linking (spots unresolved symbol) */ +static int dl_nonlazy = 0; + +#ifdef DL_LOADONCEONLY +static HV *dl_loaded_files = Nullhv; /* only needed on a few systems */ +#endif + + +#ifdef DEBUGGING +static int dl_debug = 0; /* value copied from $DynaLoader::dl_error */ +#define DLDEBUG(level,code) if (dl_debug>=level) { code; } +#else +#define DLDEBUG(level,code) +#endif + + +static void +dl_generic_private_init(CPERLarg) /* called by dl_*.xs dl_private_init() */ +{ + char *perl_dl_nonlazy; +#ifdef DEBUGGING + dl_debug = SvIV( perl_get_sv("DynaLoader::dl_debug", 0x04) ); +#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")); +#ifdef DL_LOADONCEONLY + if (!dl_loaded_files) + dl_loaded_files = newHV(); /* provide cache for dl_*.xs if needed */ +#endif +} + + +/* SaveError() takes printf style args and saves the result in LastError */ +static void +SaveError(CPERLarg_ char* pat, ...) +{ + va_list args; + char *message; + int len; + + /* This code is based on croak/warn, see mess() in util.c */ + + va_start(args, pat); + message = mess(pat, &args); + va_end(args); + + len = strlen(message) + 1 ; /* include terminating null char */ + + /* Allocate some memory for the error message */ + if (LastError) + LastError = (char*)saferealloc(LastError, len) ; + else + LastError = (char *) safemalloc(len) ; + + /* 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)); +} + |
