diff options
Diffstat (limited to 'ext/DynaLoader')
| -rw-r--r-- | ext/DynaLoader/DynaLoader.doc | 257 | ||||
| -rw-r--r-- | ext/DynaLoader/DynaLoader.pm | 243 | ||||
| -rw-r--r-- | ext/DynaLoader/Makefile.SH | 185 | ||||
| -rw-r--r-- | ext/DynaLoader/README | 53 | ||||
| -rw-r--r-- | ext/DynaLoader/dl_aix.xs | 582 | ||||
| -rw-r--r-- | ext/DynaLoader/dl_dld.xs | 173 | ||||
| -rw-r--r-- | ext/DynaLoader/dl_dlopen.xs | 201 | ||||
| -rw-r--r-- | ext/DynaLoader/dl_hpux.xs | 101 | ||||
| -rw-r--r-- | ext/DynaLoader/dl_next.xs | 213 | ||||
| -rw-r--r-- | ext/DynaLoader/dl_none.xs | 19 | ||||
| -rw-r--r-- | ext/DynaLoader/dl_vms.xs | 324 | ||||
| -rw-r--r-- | ext/DynaLoader/dlutils.c | 85 |
12 files changed, 2436 insertions, 0 deletions
diff --git a/ext/DynaLoader/DynaLoader.doc b/ext/DynaLoader/DynaLoader.doc new file mode 100644 index 0000000000..85d606ff9b --- /dev/null +++ b/ext/DynaLoader/DynaLoader.doc @@ -0,0 +1,257 @@ +======================================================================= +Specification for the Generic Dynamic Linking 'DynaLoader' Module + +This specification 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. + +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 allow pseudo-dynamic linking (using ld -A at runtime). + +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. + +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. It is anticipated that any +glue that may be developed in the future will be implemented in a +seperate dynamically loaded module. + +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. + +Larry Wall designed the elegant inherited bootstrap mechanism and +implemented the first perl 5 dynamic loader using it. + +Tim Bunce +11th August 1994 + +---------------------------------------------------------------------- +DynaLoader Interface Summary + + @dl_library_path + @dl_resolve_using + @dl_require_symbols + $dl_debug + Implemented in: + bootstrap($modulename) Perl + @filepaths = dl_findfile(@names) Perl + + $libref = dl_load_file($filename) C + $symref = dl_find_symbol($libref, $symbol) C + @symbols = dl_undef_symbols() C + dl_install_xsub($name, $symref [, $filename]) C + $message = dl_error C + + +---------------------------------------------------------------------- +@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 +(/usr/lib etc) determined by Configure ($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. + + +---------------------------------------------------------------------- +@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 +(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., +/usr/lib/libsocket.so). A few platforms need to to be told the location +of the dependent library explicitly. Use @dl_resolve_using for this. + +Example usage: @dl_resolve_using = dl_findfile('-lsocket'); + + +---------------------------------------------------------------------- +@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. + + +---------------------------------------------------------------------- +$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()). + + +---------------------------------------------------------------------- +$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 $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 is +compiled with the -DDEBUGGING flag. This can also be set via the +PERL_DL_DEBUG environment variable. Set to 1 for minimal information or +higher for more. + + +---------------------------------------------------------------------- +@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 '-lname' are converted into 'libname.*', where .* 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 -Ldir. Any other names +are treated as filenames to be searched for. + +Using arguments of the form -Ldir and -lname is recommended. + +Example: @dl_resolve_using = dl_findfile(qw(-L/usr/5lib -lposix)); + + +---------------------------------------------------------------------- +$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 dl_*.xs file or code can be added to the autoloadable +dl_expandspec function in DynaLoader.pm. See DynaLoader.pm for more +information. + + + +---------------------------------------------------------------------- +$libref = dl_load_file($filename) + +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. + +(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 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]) + + +---------------------------------------------------------------------- +$symref = dl_find_symbol($libref, $symbol) + +Return the address of the symbol $symbol or 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) + + +---------------------------------------------------------------------- +@symbols = dl_undef_symbols() + +Return a list of symbol names which remain undefined after load_file(). +Returns () 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. + + +---------------------------------------------------------------------- +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. + + +---------------------------------------------------------------------- +bootstrap($module) + +This is the normal entry point for automatic dynamic loading in Perl. + +It performs the following actions: + 1. locates an auto/$module directory by searching @INC + 2. uses dl_findfile() to determine the filename to load + 3. sets @dl_require_symbols to ("boot_$module") + 4. executes an auto/$module/$^R/$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) + 5. calls dl_load_file() to load the file + 6. calls dl_undef_symbols() and warns if any symbols are undefined + 7. calls dl_find_symbol() for "boot_$module" + 8. calls dl_install_xsub() to install it as "${module}::bootstrap" + 9. calls &{"${module}::bootstrap"} to bootstrap the module + + +====================================================================== +End. diff --git a/ext/DynaLoader/DynaLoader.pm b/ext/DynaLoader/DynaLoader.pm new file mode 100644 index 0000000000..61d9a8566e --- /dev/null +++ b/ext/DynaLoader/DynaLoader.pm @@ -0,0 +1,243 @@ +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. +# +# Read ext/DynaLoader/README and DynaLoader.doc for +# detailed information. +# +# Tim.Bunce@ig.co.uk, August 1994 + +use Config; +use Carp; +use AutoLoader; + +@ISA=(AutoLoader); + + +# enable messages from DynaLoader perl code +$dl_debug = 0 unless $dl_debug; +$dl_debug = $ENV{'PERL_DL_DEBUG'} if $ENV{'PERL_DL_DEBUG'}; + +$dl_so = $dl_dlext = ""; # avoid typo warnings +$dl_so = $Config{'so'}; # suffix for shared libraries +$dl_dlext = $Config{'dlext'}; # suffix for dynamic modules + +# 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 = ($Config{'osname'} 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 + +# This is a fix to support DLD's unfortunate desire to relink -lc +@dl_resolve_using = dl_findfile('-lc') if $Config{'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{'libpth'})); + +# 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 if defined &boot_DynaLoader; + +print STDERR "DynaLoader.pm loaded (@dl_library_path)\n" + if ($dl_debug >= 2); + +# Temporary interface checks for recent changes (Aug 1994) +if (defined(&dl_load_file)){ +die "dl_error not defined" unless defined (&dl_error); +die "dl_undef_symbols not defined" unless defined (&dl_undef_symbols); +} + +1; # End of main code + + +# 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); + + croak "Usage: DynaLoader::bootstrap(module)" + unless ($module); + + croak "Can't load module $module, DynaLoader not linked into this perl" + unless defined(&dl_load_file); + + print STDERR "DynaLoader::bootstrap($module)\n" if $dl_debug; + + my(@modparts) = split(/::/,$module); + my($modfname) = $modparts[-1]; + my($modpname) = join('/',@modparts); + foreach (@INC) { + my $dir = "$_/auto/$modpname"; + next unless -d $dir; # skip over uninteresting directories + + # check for common cases to avoid autoload of dl_findfile + last if ($file=_check_file("$dir/$modfname.$dl_dlext")); + + # no luck here, save dir for possible later dl_findfile search + push(@dirs, "-L$dir"); + } + # last resort, let dl_findfile have a go in all known locations + $file = dl_findfile(@dirs, map("-L$_",@INC), $modfname) unless $file; + + croak "Can't find loadable object for module $module in \@INC" + unless $file; + + 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/\.$dl_dlext$/\.bs/o; # look for .bs 'beside' the library + if (-f $bs) { + local($osname, $dlsrc) = @Config{'osname','dlsrc'}; + print STDERR "$bs ($osname, $dlsrc)\n" if $dl_debug; + $@ = ""; + do $bs; + warn "$bs: $@\n" if $@; + } + + my $libref = DynaLoader::dl_load_file($file) or + croak "Can't load '$file' for module $module: ".&dl_error."\n"; + + my(@unresolved) = dl_undef_symbols(); + carp "Undefined symbols present after loading $file: @unresolved\n" + if (@unresolved); + + my $boot_symbol_ref = dl_find_symbol($libref, $bootname) or + croak "Can't find '$bootname' symbol in $file\n"; + + dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file); + &{"${module}::bootstrap"}(@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 + my ($vms) = ($Config{'osname'} eq 'VMS'); + + 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 (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 ($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_so") unless m/\.$dl_so$/o; + push(@names,"lib$_.$dl_so") unless m:/:; + push(@names,"$_.o") unless m/\.(o|$dl_so)$/o; + push(@names,"$_.a") unless m/\.a$/; + push(@names, $_); + } + foreach $dir (@dirs, @dl_library_path) { + next unless -d $dir; + foreach $name (@names) { + my($file) = "$dir/$name"; + print STDERR " checking in $dir for $name\n" if $dl_debug; + $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 + my($osname) = $Config{'osname'}; + + if ($osname eq 'VMS'){ # dl_expandspec should be defined in dl_vms.xs + 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; +} diff --git a/ext/DynaLoader/Makefile.SH b/ext/DynaLoader/Makefile.SH new file mode 100644 index 0000000000..2b10fefd1a --- /dev/null +++ b/ext/DynaLoader/Makefile.SH @@ -0,0 +1,185 @@ +: This forces SH files to create target in same directory as SH file. +: This is so that make depend always knows where to find SH derivatives. + +case "$0" in +*/*) cd `expr X$0 : 'X\(.*\)/'` ;; +esac + +if test -f config.sh; then TOP=.; +elif test -f ../config.sh; then TOP=..; +elif test -f ../../config.sh; then TOP=../..; +elif test -f ../../../config.sh; then TOP=../../..; +elif test -f ../../../../config.sh; then TOP=../../../..; +else + echo "Can't find config.sh."; exit 1 +fi + +: Find absolute path name for TOP. This is needed when we cd to TOP +: to run perl on autosplit. +oldpwd=`pwd`; cd $TOP; ABSTOP=`pwd`; cd $oldpwd + +case $CONFIG in +'') + . $TOP/config.sh + ;; +esac + +: Find out directory name. This is also the extension name. +ext=`pwd | $sed -e 's@.*/@@'` + +: This extension might have its own typemap +if test -f typemap; then + exttypemap='typemap' +else + exttypemap='' +fi + +: This extension might need additional libraries. +potential_libs="" +. $TOP/ext/util/extliblist + +echo "Extracting ext/$ext/Makefile (with variable substitutions)" +: This section of the file will have variable substitutions done on it. +: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. +: Protect any dollar signs and backticks that you do not want interpreted +: by putting a backslash in front. You may delete these comments. +$spitshell >Makefile << !GROK!THIS! +# +# This Makefile is for the $ext extension to perl. +# + +DLSRC = $dlsrc +CC = $cc +RANLIB = $ranlib +TOP = $TOP +ABSTOP = $ABSTOP +LDFLAGS = $ldflags +CLDFLAGS = $ldflags +SMALL = $small +LARGE = $large $split + +# To use an alternate make, set \$altmake in config.sh. +MAKE = ${altmake-make} + +EXT = $ext + +# $ext might have its own typemap +EXTTYPEMAP = $exttypemap + +# The following are used to build and install shared libraries for +# dynamic loading. +LDDLFLAGS = $lddlflags +CCDLFLAGS = $ccdlflags +CCCDLFLAGS = $cccdlflags +SO = $so +DLEXT = $dlext + +# $ext might need to be linked with some extra libraries. +# EXTRALIBS = full list of libraries needed for static linking. +# Only those libraries that actually exist are included. +# DYNLOADLIBS = list of those libraries that are needed but can be +# linked in dynamically on this platform. On SunOS, for +# example, this would be .so* libraries, but not archive +# libraries. The bootstrap file is installed only if +# this list is not empty. +# STATLOADLIBS = list of those libraries which must be statically +# linked into the shared library. On SunOS 4.1.3, +# for example, I have only an archive version of +# -lm, and it must be linked in statically. +EXTRALIBS = $extralibs +DYNALOADLIBS = $dynaloadlibs +STATLOADLIBS = $statloadlibs + +!GROK!THIS! + +$spitshell >>Makefile <<'!NO!SUBS!' + +# Where to put things: +AUTO = $(TOP)/lib/auto +INSTALLSTATIC = $(EXT).a +INSTALLPM = $(TOP)/lib/$(EXT).pm + +PERL = $(ABSTOP)/miniperl +XSUBPP = $(TOP)/ext/xsubpp +SHELL = /bin/sh +CCCMD = `sh $(shellflags) $(TOP)/cflags $@` + +.c.o: + $(CCCMD) $(CCCDLFLAGS) -I$(TOP) $*.c + +all: static +# Phony target to force checking subdirectories. +FORCE: + +config: + +# Target for Dynamic Loading: +# If we hit here, there's a mistake somewhere. +dynamic: static + @echo "The DynaLoader extension must be built for static linking" + false + +# Target for Static Loading: +static: $(INSTALLSTATIC) $(INSTALLPM) + +$(INSTALLSTATIC): $(EXT).o + ar cr $@ $(EXT).o + $(RANLIB) $@ + echo $(EXTRALIBS) >> $(TOP)/ext.libs + +$(EXT).c: $(DLSRC) dlutils.c $(XSUBPP) $(TOP)/ext/typemap $(EXTTYPEMAP) $(TOP)/cflags Makefile + $(PERL) $(XSUBPP) $(DLSRC) >tmp + mv tmp $@ + +$(INSTALLPM): $(EXT).pm + rm -f $@ + cp $(EXT).pm $@ + cd $(TOP); $(PERL) autosplit $(EXT) + +# 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) $(XSUBPP) $$i > /dev/null; done + +clean: + rm -f *.o *.a mon.out core $(EXT).c so_locations $(BOOTSTRAP) + +realclean: clean + rm -f makefile Makefile + rm -f $(INSTALLPM) $(INSTALLSTATIC) + rm -rf $(AUTO)/$(EXT) + +purge: realclean + +$(EXT).o : $(TOP)/EXTERN.h +$(EXT).o : $(TOP)/perl.h +$(EXT).o : $(TOP)/embed.h +$(EXT).o : $(TOP)/config.h +$(EXT).o : $(TOP)/unixish.h +$(EXT).o : $(TOP)/handy.h +$(EXT).o : $(TOP)/regexp.h +$(EXT).o : $(TOP)/sv.h +$(EXT).o : $(TOP)/util.h +$(EXT).o : $(TOP)/form.h +$(EXT).o : $(TOP)/gv.h +$(EXT).o : $(TOP)/cv.h +$(EXT).o : $(TOP)/opcode.h +$(EXT).o : $(TOP)/op.h +$(EXT).o : $(TOP)/cop.h +$(EXT).o : $(TOP)/av.h +$(EXT).o : $(TOP)/hv.h +$(EXT).o : $(TOP)/mg.h +$(EXT).o : $(TOP)/scope.h +$(EXT).o : $(TOP)/pp.h +$(EXT).o : $(TOP)/proto.h +$(EXT).o : $(TOP)/XSUB.h + +Makefile: Makefile.SH $(TOP)/config.sh ; /bin/sh Makefile.SH +$(TOP)/config.h: $(TOP)/config.sh; cd $(TOP); /bin/sh config_h.SH +$(TOP)/embed.h: $(TOP)/config.sh; cd $(TOP); /bin/sh embed_h.SH +$(TOP)/cflags: $(TOP)/config.sh; cd $(TOP); /bin/sh cflags.SH + +!NO!SUBS! +chmod 644 Makefile +$eunicefix Makefile + diff --git a/ext/DynaLoader/README b/ext/DynaLoader/README new file mode 100644 index 0000000000..19dd8e72f6 --- /dev/null +++ b/ext/DynaLoader/README @@ -0,0 +1,53 @@ +Perl 5 DynaLoader + +See DynaLoader.doc 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.SH 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 to reflect +the needs of your platform and linking software. + +Refer to DynaLoader.doc, ext/utils/mkbootstrap and any existing +ext/MODULE/MODULE.bs files for more information. + +Tim Bunce. +August 1994 diff --git a/ext/DynaLoader/dl_aix.xs b/ext/DynaLoader/dl_aix.xs new file mode 100644 index 0000000000..f8bace1314 --- /dev/null +++ b/ext/DynaLoader/dl_aix.xs @@ -0,0 +1,582 @@ +/* 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> + +/* + * 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); + + +/* 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: "); + strcat(errbuf, strerror(errno)); + return NULL; + } + + if ((mp->name = savepv(path)) == NULL) { + errvalid++; + strcpy(errbuf, "savepv: "); + strcat(errbuf, strerror(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) + strcpy(errbuf, strerror(errno)); + else { + char **p; + for (p = tmp; *p; p++) + caterr(*p); + } + } else + strcat(errbuf, strerror(errno)); + return NULL; + } + mp->refCnt = 1; + mp->next = modList; + modList = mp; + if (loadbind(0, mainModule, mp->entry) == -1) { + dlclose(mp); + errvalid++; + strcpy(errbuf, "loadbind: "); + strcat(errbuf, strerror(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: + strcat(errbuf, strerror(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++; + strcpy(errbuf, strerror(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: "); + strcat(errbuf, strerror(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: "); + strcat(errbuf, strerror(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: "); + strcat(errbuf, strerror(errno)); + return -1; + } + } + if (i == -1) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(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: "); + strcat(errbuf, strerror(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: "); + strcat(errbuf, strerror(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; + } + if (FREAD(ldbuf, sh.s_size, 1, ldp) != 1) { + 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: "); + strcat(errbuf, strerror(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: "); + strcat(errbuf, strerror(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: "); + strcat(errbuf, strerror(errno)); + return NULL; + } + } + if (i == -1) { + errvalid++; + strcpy(errbuf, "findMain: "); + strcat(errbuf, strerror(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) + char * filename + CODE: + DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); + RETVAL = dlopen(filename, 1) ; + DLDEBUG(2,fprintf(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,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", + libhandle, symbolname)); + RETVAL = dlsym(libhandle, symbolname); + DLDEBUG(2,fprintf(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,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/ext/DynaLoader/dl_dld.xs b/ext/DynaLoader/dl_dld.xs new file mode 100644 index 0000000000..31f625a26d --- /dev/null +++ b/ext/DynaLoader/dl_dld.xs @@ -0,0 +1,173 @@ +/* + * 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 void +dl_private_init() +{ + int dlderr; + dl_generic_private_init(); +#ifdef __linux__ + dlderr = dld_init("/proc/self/exe"); + if (dlderr) { +#endif + dlderr = dld_init(dld_find_executable(origargv[0])); + if (dlderr) { + char *msg = dld_strerror(dlderr); + SaveError("dld_init(%s) failed: %s", origargv[0], msg); + DLDEBUG(1,fprintf(stderr,"%s", LastError)); + } +#ifdef __linux__ + } +#endif +} + + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + + +char * +dl_load_file(filename) + char * filename + CODE: + int dlderr,x,max; + GV *gv; + AV *av; + RETVAL = filename; + DLDEBUG(1,fprintf(stderr,"dl_load_file(%s)\n", filename)); + gv = gv_fetchpv("DynaLoader::dl_require_symbols", FALSE, SVt_PVAV); + if (gv) { + av = GvAV(gv); + max = AvFILL(av); + for (x = 0; x <= max; x++) { + char *sym = SvPVX(*av_fetch(av, x, 0)); + DLDEBUG(1,fprintf(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,fprintf(stderr, "dld_link(%s)\n", filename)); + if (dlderr = dld_link(filename)) { + SaveError("dld_link(%s): %s", filename, dld_strerror(dlderr)); + goto haverror; + } + gv = gv_fetchpv("DynaLoader::dl_resolve_using", FALSE, SVt_PVAV); + if (gv) { + av = GvAV(gv); + max = AvFILL(av); + for (x = 0; x <= max; x++) { + char *sym = SvPVX(*av_fetch(av, x, 0)); + DLDEBUG(1,fprintf(stderr, "dld_link(%s)\n", sym)); + if (dlderr = dld_link(sym)) { + SaveError("dld_link(%s): %s", sym, dld_strerror(dlderr)); + goto haverror; + } + } + } + DLDEBUG(2,fprintf(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,fprintf(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,fprintf(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,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/ext/DynaLoader/dl_dlopen.xs b/ext/DynaLoader/dl_dlopen.xs new file mode 100644 index 0000000000..ffd3dbc422 --- /dev/null +++ b/ext/DynaLoader/dl_dlopen.xs @@ -0,0 +1,201 @@ +/* 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 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 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 HAS_DLERROR +#define dlerror() "Unknown error - dlerror() not implemented" +#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) + char * filename + CODE: + int mode = 1; /* Solaris 1 */ +#ifdef RTLD_LAZY + mode = RTLD_LAZY; /* Solaris 2 */ +#endif + DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); + RETVAL = dlopen(filename, mode) ; + DLDEBUG(2,fprintf(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: +#ifdef DLSYM_NEEDS_UNDERSCORE + char symbolname_buf[1024]; + symbolname = dl_add_underscore(symbolname, symbolname_buf); +#endif + DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", + libhandle, symbolname)); + RETVAL = dlsym(libhandle, symbolname); + DLDEBUG(2,fprintf(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,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/ext/DynaLoader/dl_hpux.xs b/ext/DynaLoader/dl_hpux.xs new file mode 100644 index 0000000000..0558e40eaa --- /dev/null +++ b/ext/DynaLoader/dl_hpux.xs @@ -0,0 +1,101 @@ +/* + * Author: Jeff Okamoto (okamoto@corp.hp.com) + */ + +#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 void +dl_private_init() +{ + (void)dl_generic_private_init(); +} + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + + +void * +dl_load_file(filename) + char * filename + CODE: + shl_t obj = NULL; + DLDEBUG(1,fprintf(stderr,"dl_load_file(%s): ", filename)); + obj = shl_load(filename, + BIND_IMMEDIATE | BIND_NONFATAL | BIND_NOSTART | BIND_VERBOSE, 0L); + DLDEBUG(2,fprintf(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: + shl_t obj = (shl_t) libhandle; + void *symaddr = NULL; + int status; +#ifdef __hp9000s300 + char symbolname_buf[MAXPATHLEN]; + symbolname = dl_add_underscore(symbolname, symbolname_buf); +#endif + DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", + libhandle, symbolname)); + status = shl_findsym(&obj, symbolname, TYPE_PROCEDURE, &symaddr); + DLDEBUG(2,fprintf(stderr," symbolref = %x\n", symaddr)); + ST(0) = sv_newmortal() ; + if (status == -1) + SaveError("%s",(errno) ? Strerror(errno) : "Symbol not found") ; + else + sv_setiv( ST(0), (IV)symaddr); + + +int +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/ext/DynaLoader/dl_next.xs b/ext/DynaLoader/dl_next.xs new file mode 100644 index 0000000000..9bc5cd81c2 --- /dev/null +++ b/ext/DynaLoader/dl_next.xs @@ -0,0 +1,213 @@ +/* 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 + +*/ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "dlutils.c" /* SaveError() etc */ + + +#include <mach-o/rld.h> +#include <streams/streams.h> + +static char * dl_last_error = (char *) 0; + +NXStream * +OpenError() +{ + return NXOpenMemory( (char *) 0, 0, NX_WRITEONLY); +} + +void +TransferError( s) +NXStream *s; +{ + char *buffer; + int len, maxlen; + + if ( dl_last_error ) { + safefree(dl_last_error); + } + NXGetMemoryBuffer(s, &buffer, &len, &maxlen); + dl_last_error = safemalloc(len); + strcpy(dl_last_error, buffer); +} + +void +CloseError( s) +NXStream *s; +{ + if ( s ) { + NXCloseMemory( s, NX_FREEBUFFER); + } +} + +char *dlerror() +{ + return dl_last_error; +} + +char * +dlopen(path, mode) +char * path; +int mode; /* mode is ignored */ +{ + int rld_success; + NXStream *nxerr = OpenError(); + AV * av_resolve; + I32 i, psize; + char *result; + char **p; + + av_resolve = GvAVn(gv_fetchpv( + "DynaLoader::dl_resolve_using", FALSE, SVt_PVAV)); + psize = AvFILL(av_resolve) + 3; + p = (char **) safemalloc(psize * sizeof(char*)); + p[0] = path; + for(i=1; i<psize-1; i++) { + p[i] = SvPVx(*av_fetch(av_resolve, i-1, TRUE), 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; + } else { + TransferError(nxerr); + result = (char*) 0; + } + CloseError(nxerr); + return result; +} + +int +dlclose(handle) /* stub only */ +void *handle; +{ + return 0; +} + +void * +dlsym(handle, symbol) +void *handle; +char *symbol; +{ + NXStream *nxerr = OpenError(); + char symbuf[1024]; + unsigned long symref = 0; + + sprintf(symbuf, "_%s", symbol); + if (!rld_lookup(nxerr, symbuf, &symref)) { + TransferError(nxerr); + } + CloseError(nxerr); + return (void*) symref; +} + + +/* ----- code from dl_dlopen.xs below here ----- */ + + +static void +dl_private_init() +{ + (void)dl_generic_private_init(); +} + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + + + +void * +dl_load_file(filename) + char * filename + CODE: + int mode = 1; + DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); + RETVAL = dlopen(filename, mode) ; + DLDEBUG(2,fprintf(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,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", + libhandle, symbolname)); + RETVAL = dlsym(libhandle, symbolname); + DLDEBUG(2,fprintf(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,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/ext/DynaLoader/dl_none.xs b/ext/DynaLoader/dl_none.xs new file mode 100644 index 0000000000..5a193e4346 --- /dev/null +++ b/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/ext/DynaLoader/dl_vms.xs b/ext/DynaLoader/dl_vms.xs new file mode 100644 index 0000000000..8486ae260c --- /dev/null +++ b/ext/DynaLoader/dl_vms.xs @@ -0,0 +1,324 @@ +/* dl_vms.xs + * + * Platform: OpenVMS, VAX or AXP + * Author: Charles Bailey bailey@genetics.upenn.edu + * Revised: 4-Sep-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 */ +/* 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> + +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)), + msg->dsc$a_pointer, msg->dsc$w_length); + else + strncpy((LastError = safemalloc(msg->dsc$w_length)), + msg->dsc$a_pointer, msg->dsc$w_length); + return 0; + } + else { /* continuation line */ + int errlen = strlen(LastError); + LastError = saferealloc(LastError, errlen + msg->dsc$w_length + 1); + LastError[errlen] = '\n'; LastError[errlen+1] = '\0'; + strncat(LastError, msg->dsc$a_pointer, msg->dsc$w_length); + } +} + +/* Use $PutMsg to retrieve error message for failure status code */ +static void +dl_set_error(sts,stv) + vmssts sts; + vmssts stv; +{ + vmssts vec[3],pmsts; + + vec[0] = stv ? 2 : 1; + vec[1] = sts; vec[2] = stv; + if (!(pmsts = sys$putmsg(vec,copy_errmsg,0,0)) & 1) + croak("Fatal $PUTMSG error: %d",pmsts); +} + +static void +dl_private_init() +{ + dl_generic_private_init(); + /* 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(); + +SV * +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,fprintf(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,fprintf(stderr,"\tSYNCHK sys$parse = %d\n",sts)); + if (!(sts & 1)) { + dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); + ST(0) = &sv_undef; + } + else { + /* Now set up a default spec - everything but the name */ + deflen = dlnam.nam$l_type - 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,fprintf(stderr,"\tsplit filespec: name = %.*s, default = %.*s\n", + dlnam.nam$b_name,vmsspec,defspec,deflen)); + /* . . . 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,fprintf(stderr,"\tname/default sys$parse = %d\n",sts)); + if (!(sts & 1)) { + dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); + ST(0) = &sv_undef; + } + else { + /* Now find the actual file */ + sts = sys$search(&dlfab); + DLDEBUG(2,fprintf(stderr,"\tsys$search = %d\n",sts)); + if (!(sts & 1) && sts != RMS$_FNF) { + dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); + ST(0) = &sv_undef; + } + else { + ST(0) = sv_2mortal(newSVpv(dlnam.nam$l_rsa,dlnam.nam$b_rsl)); + DLDEBUG(1,fprintf(stderr,"\tresult = \\%.*s\\\n", + dlnam.nam$b_rsl,dlnam.nam$l_rsa)); + } + } + } + +void * +dl_load_file(filespec) + char * filespec + CODE: + char vmsspec[NAM$C_MAXRSS]; + AV *reqAV; + 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; + + DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n",filespec)); + specdsc.dsc$a_pointer = tovmsspec(filespec,vmsspec); + specdsc.dsc$w_length = strlen(specdsc.dsc$a_pointer); + DLDEBUG(2,fprintf(stderr,"\tVMS-ified filespec is %s\n", + specdsc.dsc$a_pointer)); + dlptr = safemalloc(sizeof(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,fprintf(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; + dlptr->defspec.dsc$a_pointer = safemalloc(dlptr->defspec.dsc$w_length + 1); + 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,fprintf(stderr,"\tlibref = name: %s, defspec: %.*s\n", + dlptr->name.dsc$a_pointer, + dlptr->defspec.dsc$w_length, + dlptr->defspec.dsc$a_pointer)); + if (!(reqAV = GvAV(gv_fetchpv("DynaLoader::dl_require_symbols", + FALSE,SVt_PVAV))) + || !(reqSVhndl = av_fetch(reqAV,0,FALSE)) || !(reqSV = *reqSVhndl)) { + DLDEBUG(2,fprintf(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,fprintf(stderr,"\t$dl_require_symbols[0] = %.*s\n", + symdsc.dsc$w_length, symdsc.dsc$a_pointer)); + sts = lib$find_image_symbol(&(dlptr->name),&symdsc, + &entry,&(dlptr->defspec)); + DLDEBUG(2,fprintf(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) = &sv_undef; + } + else { + ST(0) = sv_2mortal(newSViv(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,fprintf(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 = lib$find_image_symbol(&(thislib.name),&symdsc, + &entry,&(thislib.defspec)); + DLDEBUG(2,fprintf(stderr,"\tlib$find_image_symbol returns %d\n",sts)); + DLDEBUG(2,fprintf(stderr,"\tentry point is %d\n", + (unsigned long int) entry)); + if (!(sts & 1)) { + dl_set_error(sts,0); + ST(0) = &sv_undef; + } + else ST(0) = sv_2mortal(newSViv(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,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/ext/DynaLoader/dlutils.c b/ext/DynaLoader/dlutils.c new file mode 100644 index 0000000000..0ce082182c --- /dev/null +++ b/ext/DynaLoader/dlutils.c @@ -0,0 +1,85 @@ +/* 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; + + + +#ifdef DEBUGGING +/* currently not connected to $DynaLoader::dl_error but should be */ +static int dl_debug = 0; +#define DLDEBUG(level,code) if(dl_debug>=level){ code; } +#else +#define DLDEBUG(level,code) +#endif + + +static void +dl_generic_private_init() /* called by dl_*.xs dl_private_init() */ +{ +#ifdef DEBUGGING + char *perl_dl_debug = getenv("PERL_DL_DEBUG"); + if (perl_dl_debug) + dl_debug = atoi(perl_dl_debug); +#endif +} + + +/* SaveError() takes printf style args and saves the result in LastError */ +#ifdef STANDARD_C +static void +SaveError(char* pat, ...) +#else +/*VARARGS0*/ +static void +SaveError(pat, va_alist) + char *pat; + va_dcl +#endif +{ + va_list args; + char *message; + int len; + + /* This code is based on croak/warn but I'm not sure where mess() */ + /* gets its buffer space from! */ + +#ifdef I_STDARG + va_start(args, pat); +#else + va_start(args); +#endif + 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 = safemalloc(len) ; + + /* Copy message into LastError (including terminating null char) */ + strncpy(LastError, message, len) ; + DLDEBUG(2,fprintf(stderr,"DynaLoader: stored error msg '%s'\n",LastError)); +} + + +/* prepend underscore to s. write into buf. return buf. */ +char * +dl_add_underscore(s, buf) +char *s; +char *buf; +{ + *buf = '_'; + (void)strcpy(buf + 1, s); + return buf; +} + |