This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
180679fb71f69c0577d3606bb2b77fe5b031095b
[perl5.git] / ext / DynaLoader / dl_hpux.xs
1 /*
2  * Author: Jeff Okamoto (okamoto@corp.hp.com)
3  * Version: 2.1, 1995/1/25
4  */
5
6 /* o Added BIND_VERBOSE to dl_nonlazy condition to add names of missing
7  *   symbols to stderr message on fatal error.
8  *
9  * o Added BIND_NONFATAL comment to default condition.
10  *
11  * Chuck Phillips (cdp@fc.hp.com)
12  * Version: 2.2, 1997/5/4 */
13
14 #ifdef __hp9000s300
15 #define magic hpux_magic
16 #define MAGIC HPUX_MAGIC
17 #endif
18
19 #include <dl.h>
20 #ifdef __hp9000s300
21 #undef magic
22 #undef MAGIC
23 #endif
24
25 #include "EXTERN.h"
26 #include "perl.h"
27 #include "XSUB.h"
28
29
30 #include "dlutils.c"    /* for SaveError() etc */
31
32 static AV *dl_resolve_using = Nullav;
33
34
35 static void
36 dl_private_init(pTHX)
37 {
38     (void)dl_generic_private_init(aTHX);
39     dl_resolve_using = get_av("DynaLoader::dl_resolve_using", 0x4);
40 }
41
42 MODULE = DynaLoader     PACKAGE = DynaLoader
43
44 BOOT:
45     (void)dl_private_init(aTHX);
46
47
48 void *
49 dl_load_file(filename, flags=0)
50     char *      filename
51     int         flags
52     PREINIT:
53     shl_t obj = NULL;
54     int i, max, bind_type;
55     CODE:
56     DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags));
57     if (flags & 0x01)
58         Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
59     if (dl_nonlazy) {
60       bind_type = BIND_IMMEDIATE|BIND_VERBOSE;
61     } else {
62       bind_type = BIND_DEFERRED;
63       /* For certain libraries, like DCE, deferred binding often causes run
64        * time problems.  Adding BIND_NONFATAL to BIND_IMMEDIATE still allows
65        * unresolved references in situations like this.  */
66       /* bind_type = BIND_IMMEDIATE|BIND_NONFATAL; */
67     }
68     /* BIND_NOSTART removed from bind_type because it causes the shared library's       */
69     /* initialisers not to be run.  This causes problems with all of the static objects */
70     /* in the library.     */
71 #ifdef DEBUGGING
72     if (dl_debug)
73         bind_type |= BIND_VERBOSE;
74 #endif /* DEBUGGING */
75
76     max = AvFILL(dl_resolve_using);
77     for (i = 0; i <= max; i++) {
78         char *sym = SvPVX(*av_fetch(dl_resolve_using, i, 0));
79         DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s) (dependent)\n", sym));
80         obj = shl_load(sym, bind_type, 0L);
81         if (obj == NULL) {
82             goto end;
83         }
84     }
85
86     DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s): ", filename));
87     obj = shl_load(filename, bind_type, 0L);
88
89     DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", obj));
90 end:
91     ST(0) = sv_newmortal() ;
92     if (obj == NULL)
93         SaveError(aTHX_ "%s",Strerror(errno));
94     else
95         sv_setiv( ST(0), PTR2IV(obj) );
96
97
98 void *
99 dl_find_symbol(libhandle, symbolname)
100     void *      libhandle
101     char *      symbolname
102     CODE:
103     shl_t obj = (shl_t) libhandle;
104     void *symaddr = NULL;
105     int status;
106 #ifdef __hp9000s300
107     symbolname = form("_%s", symbolname);
108 #endif
109     DLDEBUG(2, PerlIO_printf(PerlIO_stderr(),
110                              "dl_find_symbol(handle=%lx, symbol=%s)\n",
111                              (unsigned long) libhandle, symbolname));
112
113     ST(0) = sv_newmortal() ;
114     errno = 0;
115
116     status = shl_findsym(&obj, symbolname, TYPE_PROCEDURE, &symaddr);
117     DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "  symbolref(PROCEDURE) = %x\n", symaddr));
118
119     if (status == -1 && errno == 0) {   /* try TYPE_DATA instead */
120         status = shl_findsym(&obj, symbolname, TYPE_DATA, &symaddr);
121         DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "  symbolref(DATA) = %x\n", symaddr));
122     }
123
124     if (status == -1) {
125         SaveError(aTHX_ "%s",(errno) ? Strerror(errno) : "Symbol not found") ;
126     } else {
127         sv_setiv( ST(0), PTR2IV(symaddr) );
128     }
129
130
131 void
132 dl_undef_symbols()
133     PPCODE:
134
135
136
137 # These functions should not need changing on any platform:
138
139 void
140 dl_install_xsub(perl_name, symref, filename="$Package")
141     char *      perl_name
142     void *      symref 
143     char *      filename
144     CODE:
145     DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n",
146             perl_name, symref));
147     ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
148                                         (void(*)(pTHX_ CV *))symref,
149                                         filename)));
150
151
152 char *
153 dl_error()
154     CODE:
155     RETVAL = LastError ;
156     OUTPUT:
157     RETVAL
158
159 # end.