source: trunk/essentials/dev-lang/perl/NetWare/dl_netware.xs@ 3310

Last change on this file since 3310 was 3181, checked in by bird, 19 years ago

perl 5.8.8
File size: 4.5 KB
Line 
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
14NetWare 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
28typedef void (*PFUCSINITIALIZE) ();
29
30#include "dlutils.c" /* SaveError() etc */
31
32static void
33dl_private_init(pTHX)
34{
35 (void)dl_generic_private_init(aTHX);
36}
37
38
39MODULE = DynaLoader PACKAGE = DynaLoader
40
41BOOT:
42 (void)dl_private_init(aTHX);
43
44
45void *
46dl_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
141void *
142dl_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
161void
162dl_undef_symbols()
163 PPCODE:
164
165
166# These functions should not need changing on any platform:
167
168void
169dl_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
181char *
182dl_error()
183 CODE:
184 dMY_CXT;
185 RETVAL = dl_last_error ;
186 OUTPUT:
187 RETVAL
188
189# end.
190
191
Note: See TracBrowser for help on using the repository browser.