This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix bug in DynaLoader, which has been passing a filename in dynamic
[perl5.git] / 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 typedef struct {
46     AV *        x_resolve_using;
47     AV *        x_require_symbols;
48 } my_cxtx_t;            /* this *must* be named my_cxtx_t */
49
50 #define DL_CXT_EXTRA    /* ask for dl_cxtx to be defined in dlutils.c */
51 #include "dlutils.c"    /* for SaveError() etc */
52
53 #define dl_resolve_using        (dl_cxtx.x_resolve_using)
54 #define dl_require_symbols      (dl_cxtx.x_require_symbols)
55
56 static void
57 dl_private_init(pTHX)
58 {
59     dl_generic_private_init(aTHX);
60     {
61         int dlderr;
62         dMY_CXT;
63
64         dl_resolve_using   = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI);
65         dl_require_symbols = get_av("DynaLoader::dl_require_symbols", GV_ADDMULTI);
66 #ifdef __linux__
67         dlderr = dld_init("/proc/self/exe");
68         if (dlderr) {
69 #endif
70             dlderr = dld_init(dld_find_executable(PL_origargv[0]));
71             if (dlderr) {
72                 char *msg = dld_strerror(dlderr);
73                 SaveError(aTHX_ "dld_init(%s) failed: %s", PL_origargv[0], msg);
74                 DLDEBUG(1,PerlIO_printf(Perl_debug_log, "%s", dl_last_error));
75             }
76 #ifdef __linux__
77         }
78 #endif
79     }
80 }
81
82
83 MODULE = DynaLoader     PACKAGE = DynaLoader
84
85 BOOT:
86     (void)dl_private_init();
87
88
89 char *
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     RETVAL = filename;
99     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
100     if (flags & 0x01)
101         Perl_croak(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
102     max = AvFILL(dl_require_symbols);
103     for (x = 0; x <= max; x++) {
104         char *sym = SvPVX(*av_fetch(dl_require_symbols, x, 0));
105         DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dld_create_ref(%s)\n", sym));
106         if (dlderr = dld_create_reference(sym)) {
107             SaveError(aTHX_ "dld_create_reference(%s): %s", sym,
108                       dld_strerror(dlderr));
109             goto haverror;
110         }
111     }
112
113     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dld_link(%s)\n", filename));
114     if (dlderr = dld_link(filename)) {
115         SaveError(aTHX_ "dld_link(%s): %s", filename, dld_strerror(dlderr));
116         goto haverror;
117     }
118
119     max = AvFILL(dl_resolve_using);
120     for (x = 0; x <= max; x++) {
121         char *sym = SvPVX(*av_fetch(dl_resolve_using, x, 0));
122         DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dld_link(%s)\n", sym));
123         if (dlderr = dld_link(sym)) {
124             SaveError(aTHX_ "dld_link(%s): %s", sym, dld_strerror(dlderr));
125             goto haverror;
126         }
127     }
128     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "libref=%s\n", RETVAL));
129 haverror:
130     ST(0) = sv_newmortal() ;
131     if (dlderr == 0)
132         sv_setiv(ST(0), PTR2IV(RETVAL));
133
134
135 void *
136 dl_find_symbol(libhandle, symbolname)
137     void *      libhandle
138     char *      symbolname
139     CODE:
140     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%x, symbol=%s)\n",
141             libhandle, symbolname));
142     RETVAL = (void *)dld_get_func(symbolname);
143     /* if RETVAL==NULL we should try looking for a non-function symbol */
144     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "  symbolref = %x\n", RETVAL));
145     ST(0) = sv_newmortal() ;
146     if (RETVAL == NULL)
147         SaveError(aTHX_ "dl_find_symbol: Unable to find '%s' symbol", symbolname) ;
148     else
149         sv_setiv(ST(0), PTR2IV(RETVAL));
150
151
152 void
153 dl_undef_symbols()
154     PPCODE:
155     if (dld_undefined_sym_count) {
156         int x;
157         char **undef_syms = dld_list_undefined_sym();
158         EXTEND(SP, dld_undefined_sym_count);
159         for (x=0; x < dld_undefined_sym_count; x++)
160             PUSHs(sv_2mortal(newSVpv(undef_syms[x]+1, 0)));
161         free(undef_syms);
162     }
163
164
165
166 # These functions should not need changing on any platform:
167
168 void
169 dl_install_xsub(perl_name, symref, filename="$Package")
170     char *      perl_name
171     void *      symref 
172     char *      filename
173     CODE:
174     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
175             perl_name, symref));
176     ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
177                                               (void(*)(pTHX_ CV *))symref,
178                                               filename, NULL,
179                                               XS_DYNAMIC_FILENAME)));
180
181 char *
182 dl_error()
183     PREINIT:
184     dMY_CXT;
185     CODE:
186     RETVAL = dl_last_error ;
187     OUTPUT:
188     RETVAL
189
190 # end.