ext/DynaLoader/dl_freemint.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  * Adapted for use with FreeMINT after dld support was removed from perl.
  16  *
  17  * $Log: dld_dl.c,v $
  18  * Removed implicit link against libc.  1994/09/14 William Setzer.
  19  *
  20  * Integrated other DynaLoader changes. 1994/06/08 Tim Bunce.
  21  *
  22  * rewrote dl_load_file, misc updates.  1994/09/03 William Setzer.
  23  *
  24  * Revision 1.4  1994/03/07  00:21:43  rsanders
  25  * added min symbol count for load_libs and switched order so system libs
  26  * are loaded after app-specified libs.
  27  *
  28  * Revision 1.3  1994/03/05  01:17:26  rsanders
  29  * added path searching.
  30  *
  31  * Revision 1.2  1994/03/05  00:52:39  rsanders
  32  * added package-specified libraries.
  33  *
  34  * Revision 1.1  1994/03/05  00:33:40  rsanders
  35  * Initial revision
  36  *
  37  *
  38  */
  39
  40 #define PERL_EXT
  41 #include "EXTERN.h"
  42 #define PERL_IN_DL_FREEMINT_XS
  43 #include "perl.h"
  44 #include "XSUB.h"
  45
  46 #include <dld.h>        /* GNU DLD header file */
  47 #include <unistd.h>
  48
  49 typedef struct {
  50     AV *        x_resolve_using;
  51     AV *        x_require_symbols;
  52 } my_cxtx_t;            /* this *must* be named my_cxtx_t */
  53
  54 #define DL_CXT_EXTRA    /* ask for dl_cxtx to be defined in dlutils.c */
  55 #include "dlutils.c"    /* for SaveError() etc */
  56
  57 #define dl_resolve_using        (dl_cxtx.x_resolve_using)
  58 #define dl_require_symbols      (dl_cxtx.x_require_symbols)
  59
  60 static void
  61 dl_private_init(pTHX)
  62 {
  63     dl_generic_private_init(aTHX);
  64     {
  65         int dlderr;
  66         dMY_CXT;
  67
  68         dl_resolve_using   = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI);
  69         dl_require_symbols = get_av("DynaLoader::dl_require_symbols", GV_ADDMULTI);
  70         dlderr = dld_init("/kern/self/exe");
  71         if (dlderr) {
  72             dlderr = dld_init(dld_find_executable(PL_origargv[0]));
  73             if (dlderr) {
  74                 char *msg = dld_strerror(dlderr);
  75                 SaveError(aTHX_ "dld_init(%s) failed: %s", dld_find_executable(PL_origargv[0]), msg);
  76                 DLDEBUG(1,PerlIO_printf(Perl_debug_log, "%s", dl_last_error));
  77             }
  78         }
  79     }
  80 }
  81
  82
  83 MODULE = DynaLoader     PACKAGE = DynaLoader
  84
  85 BOOT:
  86     (void)dl_private_init();
  87
  88
  89 void
  90 dl_load_file(filename, flags=0)
  91     char *      filename
  92     int         flags
  93     PREINIT:
  94     int dlderr,x,max;
  95     GV *gv;
  96     dMY_CXT;
  97     CODE:
  98     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
  99     if (flags & 0x01)
 100         Perl_croak(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
 101     max = AvFILL(dl_require_symbols);
 102     for (x = 0; x <= max; x++) {
 103         char *sym = SvPVX(*av_fetch(dl_require_symbols, x, 0));
 104         DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dld_create_ref(%s)\n", sym));
 105         if (dlderr = dld_create_reference(sym)) {
 106             SaveError(aTHX_ "dld_create_reference(%s): %s", sym,
 107                       dld_strerror(dlderr));
 108             goto haverror;
 109         }
 110     }
 111
 112     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dld_link(%s)\n", filename));
 113     if (dlderr = dld_link(filename)) {
 114         SaveError(aTHX_ "dld_link(%s): %s", filename, dld_strerror(dlderr));
 115         goto haverror;
 116     }
 117
 118     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dld_link(libm.a)\n"));
 119     if (dlderr = dld_link("/usr/lib/libm.a")) {
 120         SaveError(aTHX_ "dld_link(libm.a): %s", dld_strerror(dlderr));
 121         goto haverror;
 122     }
 123
 124     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dld_link(libc.a)\n"));
 125     if (dlderr = dld_link("/usr/lib/libc.a")) {
 126         SaveError(aTHX_ "dld_link(libc.a): %s", dld_strerror(dlderr));
 127         goto haverror;
 128     }
 129
 130     max = AvFILL(dl_resolve_using);
 131     for (x = 0; x <= max; x++) {
 132         char *sym = SvPVX(*av_fetch(dl_resolve_using, x, 0));
 133         DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dld_link(%s)\n", sym));
 134         if (dlderr = dld_link(sym)) {
 135             SaveError(aTHX_ "dld_link(%s): %s", sym, dld_strerror(dlderr));
 136             goto haverror;
 137         }
 138     }
 139     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "libref=%s\n", filename));
 140 haverror:
 141     ST(0) = sv_newmortal() ;
 142     if (dlderr == 0)
 143         sv_setiv(ST(0), PTR2IV(filename));
 144     XSRETURN(1);
 145
 146
 147 void
 148 dl_find_symbol(libhandle, symbolname, ign_err=0)
 149     void *      libhandle
 150     char *      symbolname
 151     int         ign_err
 152     PREINIT:
 153     void *retv;
 154     CODE:
 155     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%x, symbol=%s)\n",
 156             libhandle, symbolname));
 157     retv = (void *)dld_get_func(symbolname);
 158     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "  symbolref = %x\n", (unsigned int)retv));
 159     ST(0) = sv_newmortal() ;
 160     if (retv == NULL) {
 161         if (!ign_err)
 162             SaveError(aTHX_ "dl_find_symbol: Unable to find '%s' symbol", symbolname) ;
 163     } else
 164         sv_setiv(ST(0), PTR2IV(retv));
 165     XSRETURN(1);
 166
 167
 168 void
 169 dl_undef_symbols()
 170     PPCODE:
 171     if (dld_undefined_sym_count) {
 172         int x;
 173         char **undef_syms = dld_list_undefined_sym();
 174         EXTEND(SP, dld_undefined_sym_count);
 175         for (x=0; x < dld_undefined_sym_count; x++)
 176             PUSHs(sv_2mortal(newSVpv(undef_syms[x]+1, 0)));
 177         free(undef_syms);
 178     }
 179
 180
 181
 182 # These functions should not need changing on any platform:
 183
 184 void
 185 dl_install_xsub(perl_name, symref, filename="$Package")
 186     char *      perl_name
 187     void *      symref
 188     const char *        filename
 189     CODE:
 190     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
 191             perl_name, symref));
 192     ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
 193                                               (void(*)(pTHX_ CV *))symref,
 194                                               filename, NULL,
 195                                               XS_DYNAMIC_FILENAME)));
 196     XSRETURN(1);
 197
 198 SV *
 199 dl_error()
 200     CODE:
 201     dMY_CXT;
 202     RETVAL = newSVsv(MY_CXT.x_dl_last_error);
 203     OUTPUT:
 204     RETVAL
 205
 206 #if defined(USE_ITHREADS)
 207
 208 void
 209 CLONE(...)
 210     CODE:
 211     MY_CXT_CLONE;
 212
 213     /* MY_CXT_CLONE just does a memcpy on the whole structure, so to avoid
 214      * using Perl variables that belong to another thread, we create our
 215      * own for this thread.
 216      */
 217     MY_CXT.x_dl_last_error = newSVpvs("");
 218     dl_resolve_using   = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI);
 219     dl_require_symbols = get_av("DynaLoader::dl_require_symbols", GV_ADDMULTI);
 220
 221 #endif
 222
 223 # end.