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