This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
make die/warn and other diagnostics go to wherever STDERR happens
[perl5.git] / ext / DynaLoader / dl_dld.xs
CommitLineData
a0d0e21e
LW
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
8e07c86e
AD
47static AV *dl_resolve_using = Nullav;
48static AV *dl_require_symbols = Nullav;
49
a0d0e21e 50static void
cea2e8a9 51dl_private_init(pTHX)
a0d0e21e
LW
52{
53 int dlderr;
cea2e8a9
GS
54 dl_generic_private_init(aTHX);
55 dl_resolve_using = get_av("DynaLoader::dl_resolve_using", 0x4);
56 dl_require_symbols = get_av("DynaLoader::dl_require_symbols", 0x4);
a0d0e21e
LW
57#ifdef __linux__
58 dlderr = dld_init("/proc/self/exe");
59 if (dlderr) {
60#endif
6b88bc9c 61 dlderr = dld_init(dld_find_executable(PL_origargv[0]));
a0d0e21e
LW
62 if (dlderr) {
63 char *msg = dld_strerror(dlderr);
cea2e8a9 64 SaveError(aTHX_ "dld_init(%s) failed: %s", PL_origargv[0], msg);
bf49b057 65 DLDEBUG(1,PerlIO_printf(Perl_debug_log, "%s", LastError));
a0d0e21e
LW
66 }
67#ifdef __linux__
68 }
69#endif
70}
71
72
73MODULE = DynaLoader PACKAGE = DynaLoader
74
75BOOT:
76 (void)dl_private_init();
77
78
79char *
ff7f3c60 80dl_load_file(filename, flags=0)
a0d0e21e 81 char * filename
ff7f3c60
NIS
82 int flags
83 PREINIT:
a0d0e21e
LW
84 int dlderr,x,max;
85 GV *gv;
ff7f3c60 86 CODE:
a0d0e21e 87 RETVAL = filename;
bf49b057 88 DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
ff7f3c60 89 if (flags & 0x01)
cea2e8a9 90 Perl_croak(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
8e07c86e
AD
91 max = AvFILL(dl_require_symbols);
92 for (x = 0; x <= max; x++) {
93 char *sym = SvPVX(*av_fetch(dl_require_symbols, x, 0));
bf49b057 94 DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dld_create_ref(%s)\n", sym));
8e07c86e 95 if (dlderr = dld_create_reference(sym)) {
cea2e8a9 96 SaveError(aTHX_ "dld_create_reference(%s): %s", sym,
8e07c86e
AD
97 dld_strerror(dlderr));
98 goto haverror;
a0d0e21e
LW
99 }
100 }
8e07c86e 101
bf49b057 102 DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dld_link(%s)\n", filename));
a0d0e21e 103 if (dlderr = dld_link(filename)) {
cea2e8a9 104 SaveError(aTHX_ "dld_link(%s): %s", filename, dld_strerror(dlderr));
a0d0e21e
LW
105 goto haverror;
106 }
8e07c86e
AD
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));
bf49b057 111 DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dld_link(%s)\n", sym));
8e07c86e 112 if (dlderr = dld_link(sym)) {
cea2e8a9 113 SaveError(aTHX_ "dld_link(%s): %s", sym, dld_strerror(dlderr));
8e07c86e 114 goto haverror;
a0d0e21e
LW
115 }
116 }
bf49b057 117 DLDEBUG(2,PerlIO_printf(Perl_debug_log, "libref=%s\n", RETVAL));
a0d0e21e
LW
118haverror:
119 ST(0) = sv_newmortal() ;
120 if (dlderr == 0)
f66f545a 121 sv_setiv(ST(0), PTR2IV(RETVAL));
a0d0e21e
LW
122
123
124void *
125dl_find_symbol(libhandle, symbolname)
126 void * libhandle
127 char * symbolname
128 CODE:
bf49b057 129 DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%x, symbol=%s)\n",
a0d0e21e
LW
130 libhandle, symbolname));
131 RETVAL = (void *)dld_get_func(symbolname);
132 /* if RETVAL==NULL we should try looking for a non-function symbol */
bf49b057 133 DLDEBUG(2,PerlIO_printf(Perl_debug_log, " symbolref = %x\n", RETVAL));
a0d0e21e
LW
134 ST(0) = sv_newmortal() ;
135 if (RETVAL == NULL)
cea2e8a9 136 SaveError(aTHX_ "dl_find_symbol: Unable to find '%s' symbol", symbolname) ;
a0d0e21e 137 else
f66f545a 138 sv_setiv(ST(0), PTR2IV(RETVAL));
a0d0e21e
LW
139
140
141void
142dl_undef_symbols()
143 PPCODE:
144 if (dld_undefined_sym_count) {
145 int x;
146 char **undef_syms = dld_list_undefined_sym();
924508f0 147 EXTEND(SP, dld_undefined_sym_count);
a0d0e21e
LW
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
157void
158dl_install_xsub(perl_name, symref, filename="$Package")
159 char * perl_name
160 void * symref
161 char * filename
162 CODE:
bf49b057 163 DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
a0d0e21e 164 perl_name, symref));
cea2e8a9
GS
165 ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
166 (void(*)(pTHX_ CV *))symref,
167 filename)));
a0d0e21e
LW
168
169
170char *
171dl_error()
172 CODE:
173 RETVAL = LastError ;
174 OUTPUT:
175 RETVAL
176
177# end.