Updated perlfaq to CPAN version 5.0150040
[perl.git] / NetWare / dl_netware.xs
1 /* dl_netware.xs
2  * 
3  * Platform:    NetWare 
4  * Author:      SGP
5  * Created:     21st July 2000
6  * Last Modified: 23rd Oct 2000
7  * Note: !!!Any modification to the xs file to be done to the one which is under netware directory!!!
8  * Modification History
9  * 23rd Oct - Failing to find nlms with long names fixed - sdbm_file
10  */
11
12 /* 
13
14 NetWare related modifications done on dl_win32.xs file created by Wei-Yuen Tan to get this file.
15
16 */
17
18
19 #include <nwthread.h> 
20 #include <nwerrno.h>
21
22 #include "EXTERN.h"
23 #include "perl.h"
24 #include "XSUB.h"
25
26
27 //function pointer for UCSInitialize
28 typedef void (*PFUCSINITIALIZE) ();
29
30 #include "dlutils.c"    /* SaveError() etc      */
31
32 static void
33 dl_private_init(pTHX)
34 {
35     (void)dl_generic_private_init(aTHX);
36 }
37
38
39 MODULE = DynaLoader     PACKAGE = DynaLoader
40
41 BOOT:
42     (void)dl_private_init(aTHX);
43
44
45 void *
46 dl_load_file(filename,flags=0)
47     char *              filename
48     int                 flags
49     PREINIT:
50     CODE:
51   {
52         char* mod_name = filename;
53
54         //Names with more than 8 chars can't be found with FindNLMHandle
55         //8 - Name, 1 - Period, 3 - Extension, 1 - String terminator
56         char mod_name8[13]={'\0'};
57         char *p=NULL;
58         char *buffer=NULL;
59         int nNameLength=0;
60         unsigned int nlmHandle=0;
61
62         while (*mod_name) mod_name++;
63         
64         //Get the module name with extension to see if it is already loaded
65         while (mod_name > filename && mod_name[-1] != '/' && mod_name[-1] != '\\') mod_name--;
66
67     DLDEBUG(1,PerlIO_printf(Perl_debug_log,"dl_load_file(%s):\n", filename));
68
69         buffer = strdup(mod_name);
70         p = strtok (buffer, "."); 
71         if (p) {
72                 nNameLength = (strlen(p)>8)?8:strlen(p);
73                 memcpy(mod_name8,p,nNameLength);
74                 *(mod_name8 + nNameLength) = '.';
75                 *(mod_name8 + nNameLength+1) ='\0';
76                 p = strtok (NULL, ".");
77                 if (p){
78                         strcat(mod_name8,p);
79
80                         if ( (nlmHandle = FindNLMHandle(mod_name8)) == NULL )
81                         {
82                                 //NLM/NLP not loaded, load it and get the handle
83                                 if(spawnlp(P_NOWAIT, filename, filename, NULL)!=0)
84                                 {
85                                         //failed to load the NLM/NLP, this unlikely
86                                         //If multiple scripts are executed for the first time before running any other
87                                         //ucs script, sometimes there used to be an abend.
88                                         switch(NetWareErrno)
89                                         {
90                                         case LOAD_CAN_NOT_LOAD_MULTIPLE_COPIES:
91                                                 nlmHandle = FindNLMHandle(mod_name8);
92                                                 break;
93                                         case LOAD_ALREADY_IN_PROGRESS:
94 #ifdef MPK_ON
95                                                         kYieldThread();
96 #else
97                                                         ThreadSwitch();
98 #endif  //MPK_ON
99                                                 nlmHandle = FindNLMHandle(mod_name8);
100                                                 break;
101                                         default:
102                                                 nlmHandle = 0;
103                                         }
104                                 }
105                                 else
106                                 {
107                                         nlmHandle = FindNLMHandle(mod_name8);
108                                 }
109                         }
110                         //use Perl2UCS or UCSExt encountered :
111                         //initialize UCS, this has to be terminated when the script finishes execution
112                         //Is the script intending to use UCS Extensions?
113                         //This should be done once per script execution
114                         if ((strcmp(mod_name,"Perl2UCS.nlm")==0) || (strcmp(mod_name,"UCSExt.nlm")==0))
115                         {
116                                 unsigned int moduleHandle = 0;
117                                 moduleHandle = FindNLMHandle("UCSCORE.NLM");
118                                 if (moduleHandle)
119                                 {
120                                         PFUCSINITIALIZE ucsinit = (PFUCSINITIALIZE)ImportSymbol(moduleHandle,"UCSInitialize");
121                                         if (ucsinit!=NULL)
122                                                 (*ucsinit)();
123                                 }
124                         }
125
126                         DLDEBUG(2,PerlIO_printf(Perl_debug_log," libref=%x\n", nlmHandle));
127                         ST(0) = sv_newmortal() ;
128                         if (nlmHandle == NULL)
129                         //SaveError(aTHX_ "load_file:%s",
130                         //        OS_Error_String(aTHX)) ;
131                         ConsolePrintf("load_file error :  %s\n", mod_name8);
132                         else
133                         sv_setiv( ST(0), (IV)nlmHandle);
134                 }
135         }
136         free(buffer);
137
138         
139   }
140
141 void *
142 dl_find_symbol(libhandle, symbolname)
143     void *      libhandle
144     char *      symbolname
145     CODE:
146     DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_find_symbol(handle=%x, symbol=%s)\n",
147                       libhandle, symbolname));
148
149         //import the symbol that the dynaloader is asking for.
150         RETVAL = (void *)ImportSymbol((int)libhandle, symbolname);
151
152     DLDEBUG(2,PerlIO_printf(Perl_debug_log,"  symbolref = %x\n", RETVAL));
153     ST(0) = sv_newmortal() ;
154     if (RETVAL == NULL)
155         //SaveError(aTHX_ "find_symbol:%s",
156         //        OS_Error_String(aTHX)) ;
157         ConsolePrintf("find_symbol error \n");
158     else
159         sv_setiv( ST(0), (IV)RETVAL);
160
161 void
162 dl_undef_symbols()
163     PPCODE:
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(perl_name,
177                                         (void(*)(pTHX_ CV *))symref,
178                                         filename)));
179
180
181 char *
182 dl_error()
183     CODE:
184     dMY_CXT;
185     RETVAL = dl_last_error ;
186     OUTPUT:
187     RETVAL
188
189 # end.
190
191