ext/DynaLoader/dl_dld.xs

   1 /*
   2  *    Written 3/1/94, Robert Sanders <Robert.Sanders@linux.org>
   3  *
   4  * based upon the file "dl.c", which is
   5  *    Copyright (c) 1994, Larry Wall
   6  *
   7  *    You may distribute under the terms of either the GNU General Public
   8  *    License or the Artistic License, as specified in the README file.
   9  *
  10  * $Date: 1994/03/07 00:21:43 $
  11  * $Source: /home/rsanders/src/perl5alpha6/RCS/dld_dl.c,v $
  12  * $Revision: 1.4 $
  13  * $State: Exp $
  14  *
  15  * $Log: dld_dl.c,v $
  16  * Removed implicit link against libc.  1994/09/14 William Setzer.
  17  *
  18  * Integrated other DynaLoader changes. 1994/06/08 Tim Bunce.
  19  *
  20  * rewrote dl_load_file, misc updates.  1994/09/03 William Setzer.
  21  *
  22  * Revision 1.4  1994/03/07  00:21:43  rsanders
  23  * added min symbol count for load_libs and switched order so system libs
  24  * are loaded after app-specified libs.
  25  *
  26  * Revision 1.3  1994/03/05  01:17:26  rsanders
  27  * added path searching.
  28  *
  29  * Revision 1.2  1994/03/05  00:52:39  rsanders
  30  * added package-specified libraries.
  31  *
  32  * Revision 1.1  1994/03/05  00:33:40  rsanders
  33  * Initial revision
  34  *
  35  *
  36  */
  37
  38 #include "EXTERN.h"
  39 #include "perl.h"
  40 #include "XSUB.h"
  41
  42 #include <dld.h>        /* GNU DLD header file */
  43 #include <unistd.h>
  44
  45 #include "dlutils.c"    /* for SaveError() etc */
  46
  47 static AV *dl_resolve_using   = Nullav;
  48 static AV *dl_require_symbols = Nullav;
  49
  50 static void
  51 dl_private_init(pTHX)
  52 {
  53     int dlderr;
  54     dl_generic_private_init(aTHX);
  55     dl_resolve_using   = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI);
  56     dl_require_symbols = get_av("DynaLoader::dl_require_symbols", GV_ADDMULTI);
  57 #ifdef __linux__
  58     dlderr = dld_init("/proc/self/exe");
  59     if (dlderr) {
  60 #endif
  61         dlderr = dld_init(dld_find_executable(PL_origargv[0]));
  62         if (dlderr) {
  63             char *msg = dld_strerror(dlderr);
  64             SaveError(aTHX_ "dld_init(%s) failed: %s", PL_origargv[0], msg);
  65             DLDEBUG(1,PerlIO_printf(Perl_debug_log, "%s", LastError));
  66         }
  67 #ifdef __linux__
  68     }
  69 #endif
  70 }
  71
  72
  73 MODULE = DynaLoader     PACKAGE = DynaLoader
  74
  75 BOOT:
  76     (void)dl_private_init();
  77
  78
  79 char *
  80 dl_load_file(filename, flags=0)
  81     char *      filename
  82     int         flags
  83     PREINIT:
  84     int dlderr,x,max;
  85     GV *gv;
  86     CODE:
  87     RETVAL = filename;
  88     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
  89     if (flags & 0x01)
  90         Perl_croak(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
  91     max = AvFILL(dl_require_symbols);
  92     for (x = 0; x <= max; x++) {
  93         char *sym = SvPVX(*av_fetch(dl_require_symbols, x, 0));
  94         DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dld_create_ref(%s)\n", sym));
  95         if (dlderr = dld_create_reference(sym)) {
  96             SaveError(aTHX_ "dld_create_reference(%s): %s", sym,
  97                       dld_strerror(dlderr));
  98             goto haverror;
  99         }
 100     }
 101
 102     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dld_link(%s)\n", filename));
 103     if (dlderr = dld_link(filename)) {
 104         SaveError(aTHX_ "dld_link(%s): %s", filename, dld_strerror(dlderr));
 105         goto haverror;
 106     }
 107
 108     max = AvFILL(dl_resolve_using);
 109     for (x = 0; x <= max; x++) {
 110         char *sym = SvPVX(*av_fetch(dl_resolve_using, x, 0));
 111         DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dld_link(%s)\n", sym));
 112         if (dlderr = dld_link(sym)) {
 113             SaveError(aTHX_ "dld_link(%s): %s", sym, dld_strerror(dlderr));
 114             goto haverror;
 115         }
 116     }
 117     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "libref=%s\n", RETVAL));
 118 haverror:
 119     ST(0) = sv_newmortal() ;
 120     if (dlderr == 0)
 121         sv_setiv(ST(0), PTR2IV(RETVAL));
 122
 123
 124 void *
 125 dl_find_symbol(libhandle, symbolname)
 126     void *      libhandle
 127     char *      symbolname
 128     CODE:
 129     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%x, symbol=%s)\n",
 130             libhandle, symbolname));
 131     RETVAL = (void *)dld_get_func(symbolname);
 132     /* if RETVAL==NULL we should try looking for a non-function symbol */
 133     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "  symbolref = %x\n", RETVAL));
 134     ST(0) = sv_newmortal() ;
 135     if (RETVAL == NULL)
 136         SaveError(aTHX_ "dl_find_symbol: Unable to find '%s' symbol", symbolname) ;
 137     else
 138         sv_setiv(ST(0), PTR2IV(RETVAL));
 139
 140
 141 void
 142 dl_undef_symbols()
 143     PPCODE:
 144     if (dld_undefined_sym_count) {
 145         int x;
 146         char **undef_syms = dld_list_undefined_sym();
 147         EXTEND(SP, dld_undefined_sym_count);
 148         for (x=0; x < dld_undefined_sym_count; x++)
 149             PUSHs(sv_2mortal(newSVpv(undef_syms[x]+1, 0)));
 150         free(undef_syms);
 151     }
 152
 153
 154
 155 # These functions should not need changing on any platform:
 156
 157 void
 158 dl_install_xsub(perl_name, symref, filename="$Package")
 159     char *      perl_name
 160     void *      symref
 161     char *      filename
 162     CODE:
 163     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
 164             perl_name, symref));
 165     ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
 166                                         (void(*)(pTHX_ CV *))symref,
 167                                         filename)));
 168
 169
 170 char *
 171 dl_error()
 172     CODE:
 173     RETVAL = LastError ;
 174     OUTPUT:
 175     RETVAL
 176
 177 # end.