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