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_mpeix.xs
1 /*
2  * Author:  Mark Klein (mklein@dis.com)
3  * Version: 2.1, 1996/07/25
4  * Version: 2.2, 1997/09/25 Mark Bixby (markb@cccd.edu)
5  * Version: 2.3, 1998/11/19 Mark Bixby (markb@cccd.edu)
6  */
7
8 #include "EXTERN.h"
9 #include "perl.h"
10 #include "XSUB.h"
11
12 #ifdef __GNUC__
13 extern void HPGETPROCPLABEL(    int    parms,
14                                 char * procname,
15                                 int  * plabel,
16                                 int  * status,
17                                 char * firstfile,
18                                 int    casesensitive,
19                                 int    symboltype,
20                                 int  * datasize,
21                                 int    position,
22                                 int    searchpath,
23                                 int    binding);
24 #else
25 #pragma intrinsic HPGETPROCPLABEL
26 #endif
27 #include "dlutils.c"    /* for SaveError() etc */
28
29 typedef struct {
30   char  filename[PATH_MAX + 3];
31   } t_mpe_dld, *p_mpe_dld;
32
33 static AV *dl_resolve_using = Nullav;
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 void *
48 dl_load_file(filename, flags=0)
49     char *      filename
50     int         flags
51     PREINIT:
52     char                buf[PATH_MAX + 3];
53     p_mpe_dld           obj = NULL;
54     int                 i;
55     CODE:
56     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,
57 flags));
58     if (flags & 0x01)
59         Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s
60 ",filename);
61     obj = (p_mpe_dld) safemalloc(sizeof(t_mpe_dld));
62     memzero(obj, sizeof(t_mpe_dld));
63     if (filename[0] != '/')
64         {
65         getcwd(buf,sizeof(buf));
66         sprintf(obj->filename," %s/%s ",buf,filename);
67         }
68     else
69         sprintf(obj->filename," %s ",filename);
70
71     DLDEBUG(2,PerlIO_printf(Perl_debug_log," libref=%x\n", obj));
72
73     ST(0) = sv_newmortal() ;
74     if (obj == NULL)
75         SaveError(aTHX_"%s",Strerror(errno));
76     else
77         sv_setiv( ST(0), PTR2IV(obj) );
78
79 void *
80 dl_find_symbol(libhandle, symbolname)
81     void *      libhandle
82     char *      symbolname
83     CODE:
84     int       datalen;
85     p_mpe_dld obj = (p_mpe_dld) libhandle;
86     char      symname[PATH_MAX + 3];
87     void *    symaddr = NULL;
88     int       status;
89     DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_find_symbol(handle=%x, symbol=%s)\n",
90                 libhandle, symbolname));
91     ST(0) = sv_newmortal() ;
92     errno = 0;
93
94     sprintf(symname, " %s ", symbolname);
95     HPGETPROCPLABEL(8, symname, &symaddr, &status, obj->filename, 1,
96                     0, &datalen, 1, 0, 0);
97
98     DLDEBUG(2,PerlIO_printf(Perl_debug_log,"  symbolref(PROCEDURE) = %x, status=%x\n", symaddr, status));
99
100     if (status != 0) {
101         SaveError(aTHX_"%s",(errno) ? Strerror(errno) : "Symbol not found") ;
102     } else {
103         sv_setiv( ST(0), PTR2IV(symaddr) );
104     }
105
106 void
107 dl_undef_symbols()
108     PPCODE:
109
110 # These functions should not need changing on any platform:
111
112 void
113 dl_install_xsub(perl_name, symref, filename="$Package")
114     char *      perl_name
115     void *      symref
116     char *      filename
117     CODE:
118     DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_install_xsub(name=%s, symref=%x)\n",
119             perl_name, symref));
120     ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
121                                         (void(*)(pTHX_ CV *))symref,
122                                         filename)));
123
124 char *
125 dl_error()
126     CODE:
127     RETVAL = LastError ;
128     OUTPUT:
129     RETVAL
130
131 # end.