Commit | Line | Data |
---|---|---|
4633a7c4 LW |
1 | #define INCL_DOS |
2 | #define INCL_NOPM | |
7a2f0d5b | 3 | #define INCL_DOSFILEMGR |
760ac839 LW |
4 | #define INCL_DOSMEMMGR |
5 | #define INCL_DOSERRORS | |
4633a7c4 LW |
6 | #include <os2.h> |
7 | ||
8 | /* | |
9 | * Various Unix compatibility functions for OS/2 | |
10 | */ | |
11 | ||
12 | #include <stdio.h> | |
13 | #include <errno.h> | |
14 | #include <limits.h> | |
15 | #include <process.h> | |
72ea3524 | 16 | #include <fcntl.h> |
4633a7c4 LW |
17 | |
18 | #include "EXTERN.h" | |
19 | #include "perl.h" | |
20 | ||
21 | /*****************************************************************************/ | |
72ea3524 IZ |
22 | /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */ |
23 | static PFN ExtFCN[2]; /* Labeled by ord below. */ | |
24 | static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */ | |
25 | #define ORD_QUERY_ELP 0 | |
26 | #define ORD_SET_ELP 1 | |
27 | ||
28 | APIRET | |
29 | loadByOrd(ULONG ord) | |
30 | { | |
31 | if (ExtFCN[ord] == NULL) { | |
32 | static HMODULE hdosc = 0; | |
33 | BYTE buf[20]; | |
34 | PFN fcn; | |
35 | APIRET rc; | |
36 | ||
37 | if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf, | |
38 | "doscalls", &hdosc))) | |
39 | || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn))) | |
40 | die("This version of OS/2 does not support doscalls.%i", | |
41 | loadOrd[ord]); | |
42 | ExtFCN[ord] = fcn; | |
43 | } | |
44 | if ((long)ExtFCN[ord] == -1) die("panic queryaddr"); | |
45 | } | |
46 | ||
4633a7c4 | 47 | /* priorities */ |
6f064249 | 48 | static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged, |
49 | self inverse. */ | |
50 | #define QSS_INI_BUFFER 1024 | |
4633a7c4 | 51 | |
6f064249 | 52 | PQTOPLEVEL |
53 | get_sysinfo(ULONG pid, ULONG flags) | |
4633a7c4 | 54 | { |
6f064249 | 55 | char *pbuffer; |
56 | ULONG rc, buf_len = QSS_INI_BUFFER; | |
57 | ||
fc36a67e | 58 | New(1322, pbuffer, buf_len, char); |
6f064249 | 59 | /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */ |
60 | rc = QuerySysState(flags, pid, pbuffer, buf_len); | |
61 | while (rc == ERROR_BUFFER_OVERFLOW) { | |
62 | Renew(pbuffer, buf_len *= 2, char); | |
df3ef7a9 | 63 | rc = QuerySysState(flags, pid, pbuffer, buf_len); |
6f064249 | 64 | } |
65 | if (rc) { | |
66 | FillOSError(rc); | |
67 | Safefree(pbuffer); | |
68 | return 0; | |
69 | } | |
70 | return (PQTOPLEVEL)pbuffer; | |
71 | } | |
72 | ||
73 | #define PRIO_ERR 0x1111 | |
74 | ||
75 | static ULONG | |
76 | sys_prio(pid) | |
77 | { | |
78 | ULONG prio; | |
79 | PQTOPLEVEL psi; | |
80 | ||
81 | psi = get_sysinfo(pid, QSS_PROCESS); | |
82 | if (!psi) { | |
83 | return PRIO_ERR; | |
84 | } | |
85 | if (pid != psi->procdata->pid) { | |
86 | Safefree(psi); | |
87 | croak("panic: wrong pid in sysinfo"); | |
88 | } | |
89 | prio = psi->procdata->threads->priority; | |
90 | Safefree(psi); | |
91 | return prio; | |
92 | } | |
93 | ||
94 | int | |
95 | setpriority(int which, int pid, int val) | |
96 | { | |
97 | ULONG rc, prio; | |
98 | PQTOPLEVEL psi; | |
99 | ||
100 | prio = sys_prio(pid); | |
101 | ||
55497cff | 102 | if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */ |
6f064249 | 103 | if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) { |
104 | /* Do not change class. */ | |
105 | return CheckOSError(DosSetPriority((pid < 0) | |
106 | ? PRTYS_PROCESSTREE : PRTYS_PROCESS, | |
107 | 0, | |
108 | (32 - val) % 32 - (prio & 0xFF), | |
109 | abs(pid))) | |
110 | ? -1 : 0; | |
111 | } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ { | |
112 | /* Documentation claims one can change both class and basevalue, | |
113 | * but I find it wrong. */ | |
114 | /* Change class, but since delta == 0 denotes absolute 0, correct. */ | |
115 | if (CheckOSError(DosSetPriority((pid < 0) | |
116 | ? PRTYS_PROCESSTREE : PRTYS_PROCESS, | |
117 | priors[(32 - val) >> 5] + 1, | |
118 | 0, | |
119 | abs(pid)))) | |
120 | return -1; | |
121 | if ( ((32 - val) % 32) == 0 ) return 0; | |
122 | return CheckOSError(DosSetPriority((pid < 0) | |
123 | ? PRTYS_PROCESSTREE : PRTYS_PROCESS, | |
124 | 0, | |
125 | (32 - val) % 32, | |
126 | abs(pid))) | |
127 | ? -1 : 0; | |
128 | } | |
129 | /* else return CheckOSError(DosSetPriority((pid < 0) */ | |
130 | /* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */ | |
131 | /* priors[(32 - val) >> 5] + 1, */ | |
132 | /* (32 - val) % 32 - (prio & 0xFF), */ | |
133 | /* abs(pid))) */ | |
134 | /* ? -1 : 0; */ | |
4633a7c4 LW |
135 | } |
136 | ||
6f064249 | 137 | int |
138 | getpriority(int which /* ignored */, int pid) | |
4633a7c4 LW |
139 | { |
140 | TIB *tib; | |
141 | PIB *pib; | |
6f064249 | 142 | ULONG rc, ret; |
143 | ||
55497cff | 144 | if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */ |
6f064249 | 145 | /* DosGetInfoBlocks has old priority! */ |
146 | /* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */ | |
147 | /* if (pid != pib->pib_ulpid) { */ | |
148 | ret = sys_prio(pid); | |
149 | if (ret == PRIO_ERR) { | |
150 | return -1; | |
151 | } | |
152 | /* } else */ | |
153 | /* ret = tib->tib_ptib2->tib2_ulpri; */ | |
154 | return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF); | |
4633a7c4 LW |
155 | } |
156 | ||
157 | /*****************************************************************************/ | |
158 | /* spawn */ | |
72ea3524 IZ |
159 | typedef void (*Sigfunc) _((int)); |
160 | ||
4633a7c4 LW |
161 | static int |
162 | result(int flag, int pid) | |
163 | { | |
164 | int r, status; | |
165 | Signal_t (*ihand)(); /* place to save signal during system() */ | |
166 | Signal_t (*qhand)(); /* place to save signal during system() */ | |
760ac839 LW |
167 | #ifndef __EMX__ |
168 | RESULTCODES res; | |
169 | int rpid; | |
170 | #endif | |
4633a7c4 | 171 | |
760ac839 | 172 | if (pid < 0 || flag != 0) |
4633a7c4 LW |
173 | return pid; |
174 | ||
760ac839 | 175 | #ifdef __EMX__ |
72ea3524 IZ |
176 | ihand = rsignal(SIGINT, SIG_IGN); |
177 | qhand = rsignal(SIGQUIT, SIG_IGN); | |
c0c09dfd | 178 | do { |
179 | r = wait4pid(pid, &status, 0); | |
180 | } while (r == -1 && errno == EINTR); | |
72ea3524 IZ |
181 | rsignal(SIGINT, ihand); |
182 | rsignal(SIGQUIT, qhand); | |
4633a7c4 LW |
183 | |
184 | statusvalue = (U16)status; | |
185 | if (r < 0) | |
186 | return -1; | |
187 | return status & 0xFFFF; | |
760ac839 | 188 | #else |
72ea3524 | 189 | ihand = rsignal(SIGINT, SIG_IGN); |
760ac839 | 190 | r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid); |
72ea3524 | 191 | rsignal(SIGINT, ihand); |
760ac839 LW |
192 | statusvalue = res.codeResult << 8 | res.codeTerminate; |
193 | if (r) | |
194 | return -1; | |
195 | return statusvalue; | |
196 | #endif | |
4633a7c4 LW |
197 | } |
198 | ||
199 | int | |
200 | do_aspawn(really,mark,sp) | |
201 | SV *really; | |
202 | register SV **mark; | |
203 | register SV **sp; | |
204 | { | |
205 | register char **a; | |
e29f6e02 | 206 | char *tmps = NULL; |
4633a7c4 | 207 | int rc; |
e29f6e02 | 208 | int flag = P_WAIT, trueflag, err, secondtry = 0; |
4633a7c4 LW |
209 | |
210 | if (sp > mark) { | |
fc36a67e | 211 | New(1301,Argv, sp - mark + 3, char*); |
4633a7c4 LW |
212 | a = Argv; |
213 | ||
760ac839 | 214 | if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { |
4633a7c4 LW |
215 | ++mark; |
216 | flag = SvIVx(*mark); | |
217 | } | |
218 | ||
219 | while (++mark <= sp) { | |
220 | if (*mark) | |
221 | *a++ = SvPVx(*mark, na); | |
222 | else | |
223 | *a++ = ""; | |
224 | } | |
225 | *a = Nullch; | |
226 | ||
227 | trueflag = flag; | |
228 | if (flag == P_WAIT) | |
229 | flag = P_NOWAIT; | |
230 | ||
ff68c719 | 231 | if (strEQ(Argv[0],"/bin/sh")) Argv[0] = sh_path; |
3bbf9c2b IZ |
232 | |
233 | if (Argv[0][0] != '/' && Argv[0][0] != '\\' | |
234 | && !(Argv[0][0] && Argv[0][1] == ':' | |
235 | && (Argv[0][2] == '/' || Argv[0][2] != '\\')) | |
760ac839 | 236 | ) /* will swawnvp use PATH? */ |
c0c09dfd | 237 | TAINT_ENV(); /* testing IFS here is overkill, probably */ |
760ac839 | 238 | /* We should check PERL_SH* and PERLLIB_* as well? */ |
e29f6e02 | 239 | retry: |
4633a7c4 LW |
240 | if (really && *(tmps = SvPV(really, na))) |
241 | rc = result(trueflag, spawnvp(flag,tmps,Argv)); | |
242 | else | |
243 | rc = result(trueflag, spawnvp(flag,Argv[0],Argv)); | |
244 | ||
e29f6e02 IZ |
245 | if (rc < 0 && secondtry == 0 |
246 | && (!tmps || !*tmps)) { /* Cannot transfer `really' via shell. */ | |
247 | err = errno; | |
248 | if (err == ENOENT) { /* No such file. */ | |
249 | /* One reason may be that EMX added .exe. We suppose | |
250 | that .exe-less files are automatically shellable. */ | |
251 | char *no_dir; | |
252 | (no_dir = strrchr(Argv[0], '/')) | |
253 | || (no_dir = strrchr(Argv[0], '\\')) | |
254 | || (no_dir = Argv[0]); | |
255 | if (!strchr(no_dir, '.')) { | |
256 | struct stat buffer; | |
257 | if (stat(Argv[0], &buffer) != -1) { /* File exists. */ | |
258 | /* Maybe we need to specify the full name here? */ | |
259 | goto doshell; | |
260 | } | |
261 | } | |
262 | } else if (err == ENOEXEC) { /* Need to send to shell. */ | |
263 | doshell: | |
264 | while (a >= Argv) { | |
265 | *(a + 2) = *a; | |
266 | a--; | |
267 | } | |
268 | *Argv = sh_path; | |
269 | *(Argv + 1) = "-c"; | |
270 | secondtry = 1; | |
271 | goto retry; | |
272 | } | |
273 | } | |
4633a7c4 LW |
274 | if (rc < 0 && dowarn) |
275 | warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno)); | |
c0c09dfd | 276 | if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ |
4633a7c4 LW |
277 | } else |
278 | rc = -1; | |
279 | do_execfree(); | |
280 | return rc; | |
281 | } | |
282 | ||
760ac839 LW |
283 | #define EXECF_SPAWN 0 |
284 | #define EXECF_EXEC 1 | |
285 | #define EXECF_TRUEEXEC 2 | |
72ea3524 | 286 | #define EXECF_SPAWN_NOWAIT 3 |
760ac839 | 287 | |
4633a7c4 | 288 | int |
760ac839 | 289 | do_spawn2(cmd, execf) |
4633a7c4 | 290 | char *cmd; |
760ac839 | 291 | int execf; |
4633a7c4 LW |
292 | { |
293 | register char **a; | |
294 | register char *s; | |
295 | char flags[10]; | |
3bbf9c2b | 296 | char *shell, *copt, *news = NULL; |
e29f6e02 IZ |
297 | int rc, added_shell = 0, err; |
298 | char fullcmd[MAXNAMLEN + 1]; | |
4633a7c4 | 299 | |
c0c09dfd | 300 | #ifdef TRYSHELL |
301 | if ((shell = getenv("EMXSHELL")) != NULL) | |
302 | copt = "-c"; | |
303 | else if ((shell = getenv("SHELL")) != NULL) | |
4633a7c4 LW |
304 | copt = "-c"; |
305 | else if ((shell = getenv("COMSPEC")) != NULL) | |
306 | copt = "/C"; | |
307 | else | |
308 | shell = "cmd.exe"; | |
c0c09dfd | 309 | #else |
310 | /* Consensus on perl5-porters is that it is _very_ important to | |
311 | have a shell which will not change between computers with the | |
312 | same architecture, to avoid "action on a distance". | |
313 | And to have simple build, this shell should be sh. */ | |
ff68c719 | 314 | shell = sh_path; |
c0c09dfd | 315 | copt = "-c"; |
316 | #endif | |
317 | ||
318 | while (*cmd && isSPACE(*cmd)) | |
319 | cmd++; | |
4633a7c4 | 320 | |
3bbf9c2b | 321 | if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) { |
ff68c719 | 322 | STRLEN l = strlen(sh_path); |
3bbf9c2b | 323 | |
2cc2f81f | 324 | New(1302, news, strlen(cmd) - 7 + l + 1, char); |
ff68c719 | 325 | strcpy(news, sh_path); |
3bbf9c2b IZ |
326 | strcpy(news + l, cmd + 7); |
327 | cmd = news; | |
e29f6e02 | 328 | added_shell = 1; |
3bbf9c2b IZ |
329 | } |
330 | ||
4633a7c4 LW |
331 | /* save an extra exec if possible */ |
332 | /* see if there are shell metacharacters in it */ | |
333 | ||
c0c09dfd | 334 | if (*cmd == '.' && isSPACE(cmd[1])) |
335 | goto doshell; | |
336 | ||
337 | if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4])) | |
338 | goto doshell; | |
339 | ||
340 | for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */ | |
341 | if (*s == '=') | |
342 | goto doshell; | |
343 | ||
4633a7c4 | 344 | for (s = cmd; *s; s++) { |
c0c09dfd | 345 | if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) { |
3bbf9c2b | 346 | if (*s == '\n' && s[1] == '\0') { |
4633a7c4 LW |
347 | *s = '\0'; |
348 | break; | |
349 | } | |
c0c09dfd | 350 | doshell: |
760ac839 LW |
351 | if (execf == EXECF_TRUEEXEC) |
352 | return execl(shell,shell,copt,cmd,(char*)0); | |
353 | else if (execf == EXECF_EXEC) | |
354 | return spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0); | |
72ea3524 IZ |
355 | else if (execf == EXECF_SPAWN_NOWAIT) |
356 | return spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0); | |
760ac839 | 357 | /* In the ak code internal P_NOWAIT is P_WAIT ??? */ |
c0c09dfd | 358 | rc = result(P_WAIT, |
760ac839 | 359 | spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0)); |
c0c09dfd | 360 | if (rc < 0 && dowarn) |
760ac839 LW |
361 | warn("Can't %s \"%s\": %s", |
362 | (execf == EXECF_SPAWN ? "spawn" : "exec"), | |
363 | shell, Strerror(errno)); | |
c0c09dfd | 364 | if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ |
3bbf9c2b | 365 | if (news) Safefree(news); |
c0c09dfd | 366 | return rc; |
4633a7c4 LW |
367 | } |
368 | } | |
c0c09dfd | 369 | |
fc36a67e | 370 | New(1303,Argv, (s - cmd) / 2 + 2, char*); |
4633a7c4 LW |
371 | Cmd = savepvn(cmd, s-cmd); |
372 | a = Argv; | |
373 | for (s = Cmd; *s;) { | |
374 | while (*s && isSPACE(*s)) s++; | |
375 | if (*s) | |
376 | *(a++) = s; | |
377 | while (*s && !isSPACE(*s)) s++; | |
378 | if (*s) | |
379 | *s++ = '\0'; | |
380 | } | |
381 | *a = Nullch; | |
382 | if (Argv[0]) { | |
e29f6e02 IZ |
383 | int err; |
384 | ||
760ac839 LW |
385 | if (execf == EXECF_TRUEEXEC) |
386 | rc = execvp(Argv[0],Argv); | |
387 | else if (execf == EXECF_EXEC) | |
388 | rc = spawnvp(P_OVERLAY,Argv[0],Argv); | |
72ea3524 IZ |
389 | else if (execf == EXECF_SPAWN_NOWAIT) |
390 | rc = spawnvp(P_NOWAIT,Argv[0],Argv); | |
760ac839 LW |
391 | else |
392 | rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv)); | |
e29f6e02 IZ |
393 | if (rc < 0) { |
394 | err = errno; | |
395 | if (err == ENOENT) { /* No such file. */ | |
396 | /* One reason may be that EMX added .exe. We suppose | |
397 | that .exe-less files are automatically shellable. */ | |
398 | char *no_dir; | |
399 | (no_dir = strrchr(Argv[0], '/')) | |
400 | || (no_dir = strrchr(Argv[0], '\\')) | |
401 | || (no_dir = Argv[0]); | |
402 | if (!strchr(no_dir, '.')) { | |
403 | struct stat buffer; | |
404 | if (stat(Argv[0], &buffer) != -1) { /* File exists. */ | |
405 | /* Maybe we need to specify the full name here? */ | |
406 | goto doshell; | |
407 | } | |
408 | } | |
409 | } else if (err == ENOEXEC) { /* Need to send to shell. */ | |
410 | goto doshell; | |
411 | } | |
412 | } | |
4633a7c4 | 413 | if (rc < 0 && dowarn) |
760ac839 | 414 | warn("Can't %s \"%s\": %s", |
e29f6e02 IZ |
415 | ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) |
416 | ? "spawn" : "exec"), | |
417 | Argv[0], Strerror(err)); | |
c0c09dfd | 418 | if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ |
4633a7c4 LW |
419 | } else |
420 | rc = -1; | |
3bbf9c2b | 421 | if (news) Safefree(news); |
4633a7c4 LW |
422 | do_execfree(); |
423 | return rc; | |
424 | } | |
425 | ||
760ac839 LW |
426 | int |
427 | do_spawn(cmd) | |
428 | char *cmd; | |
429 | { | |
430 | return do_spawn2(cmd, EXECF_SPAWN); | |
431 | } | |
432 | ||
72ea3524 IZ |
433 | int |
434 | do_spawn_nowait(cmd) | |
435 | char *cmd; | |
436 | { | |
437 | return do_spawn2(cmd, EXECF_SPAWN_NOWAIT); | |
438 | } | |
439 | ||
760ac839 LW |
440 | bool |
441 | do_exec(cmd) | |
442 | char *cmd; | |
443 | { | |
444 | return do_spawn2(cmd, EXECF_EXEC); | |
445 | } | |
446 | ||
447 | bool | |
448 | os2exec(cmd) | |
449 | char *cmd; | |
450 | { | |
451 | return do_spawn2(cmd, EXECF_TRUEEXEC); | |
452 | } | |
453 | ||
3bbf9c2b IZ |
454 | PerlIO * |
455 | my_syspopen(cmd,mode) | |
c0c09dfd | 456 | char *cmd; |
457 | char *mode; | |
458 | { | |
72ea3524 IZ |
459 | #ifndef USE_POPEN |
460 | ||
461 | int p[2]; | |
462 | register I32 this, that, newfd; | |
463 | register I32 pid, rc; | |
3bbf9c2b IZ |
464 | PerlIO *res; |
465 | SV *sv; | |
72ea3524 IZ |
466 | |
467 | if (pipe(p) < 0) | |
468 | return Nullfp; | |
469 | /* `this' is what we use in the parent, `that' in the child. */ | |
470 | this = (*mode == 'w'); | |
471 | that = !this; | |
472 | if (tainting) { | |
473 | taint_env(); | |
474 | taint_proper("Insecure %s%s", "EXEC"); | |
475 | } | |
476 | /* Now we need to spawn the child. */ | |
477 | newfd = dup(*mode == 'r'); /* Preserve std* */ | |
478 | if (p[that] != (*mode == 'r')) { | |
479 | dup2(p[that], *mode == 'r'); | |
480 | close(p[that]); | |
481 | } | |
482 | /* Where is `this' and newfd now? */ | |
483 | fcntl(p[this], F_SETFD, FD_CLOEXEC); | |
484 | fcntl(newfd, F_SETFD, FD_CLOEXEC); | |
485 | pid = do_spawn_nowait(cmd); | |
486 | if (newfd != (*mode == 'r')) { | |
487 | dup2(newfd, *mode == 'r'); /* Return std* back. */ | |
488 | close(newfd); | |
489 | } | |
490 | close(p[that]); | |
491 | if (pid == -1) { | |
492 | close(p[this]); | |
493 | return NULL; | |
494 | } | |
495 | if (p[that] < p[this]) { | |
496 | dup2(p[this], p[that]); | |
497 | close(p[this]); | |
498 | p[this] = p[that]; | |
499 | } | |
500 | sv = *av_fetch(fdpid,p[this],TRUE); | |
501 | (void)SvUPGRADE(sv,SVt_IV); | |
502 | SvIVX(sv) = pid; | |
503 | forkprocess = pid; | |
504 | return PerlIO_fdopen(p[this], mode); | |
3bbf9c2b | 505 | |
72ea3524 IZ |
506 | #else /* USE_POPEN */ |
507 | ||
508 | PerlIO *res; | |
509 | SV *sv; | |
510 | ||
511 | # ifdef TRYSHELL | |
3bbf9c2b | 512 | res = popen(cmd, mode); |
72ea3524 | 513 | # else |
c0c09dfd | 514 | char *shell = getenv("EMXSHELL"); |
3bbf9c2b | 515 | |
ff68c719 | 516 | my_setenv("EMXSHELL", sh_path); |
c0c09dfd | 517 | res = popen(cmd, mode); |
518 | my_setenv("EMXSHELL", shell); | |
72ea3524 | 519 | # endif |
3bbf9c2b IZ |
520 | sv = *av_fetch(fdpid, PerlIO_fileno(res), TRUE); |
521 | (void)SvUPGRADE(sv,SVt_IV); | |
522 | SvIVX(sv) = -1; /* A cooky. */ | |
523 | return res; | |
72ea3524 IZ |
524 | |
525 | #endif /* USE_POPEN */ | |
526 | ||
c0c09dfd | 527 | } |
528 | ||
3bbf9c2b | 529 | /******************************************************************/ |
4633a7c4 LW |
530 | |
531 | #ifndef HAS_FORK | |
532 | int | |
533 | fork(void) | |
534 | { | |
535 | die(no_func, "Unsupported function fork"); | |
536 | errno = EINVAL; | |
537 | return -1; | |
538 | } | |
539 | #endif | |
540 | ||
3bbf9c2b | 541 | /*******************************************************************/ |
4633a7c4 LW |
542 | /* not implemented in EMX 0.9a */ |
543 | ||
544 | void * ctermid(x) { return 0; } | |
eacfb5f1 | 545 | |
546 | #ifdef MYTTYNAME /* was not in emx0.9a */ | |
4633a7c4 | 547 | void * ttyname(x) { return 0; } |
eacfb5f1 | 548 | #endif |
4633a7c4 | 549 | |
3bbf9c2b | 550 | /******************************************************************/ |
760ac839 LW |
551 | /* my socket forwarders - EMX lib only provides static forwarders */ |
552 | ||
553 | static HMODULE htcp = 0; | |
554 | ||
555 | static void * | |
556 | tcp0(char *name) | |
557 | { | |
558 | static BYTE buf[20]; | |
559 | PFN fcn; | |
55497cff | 560 | |
561 | if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */ | |
760ac839 LW |
562 | if (!htcp) |
563 | DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp); | |
564 | if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) | |
565 | return (void *) ((void * (*)(void)) fcn) (); | |
566 | return 0; | |
567 | } | |
568 | ||
569 | static void | |
570 | tcp1(char *name, int arg) | |
571 | { | |
572 | static BYTE buf[20]; | |
573 | PFN fcn; | |
55497cff | 574 | |
575 | if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */ | |
760ac839 LW |
576 | if (!htcp) |
577 | DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp); | |
578 | if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) | |
579 | ((void (*)(int)) fcn) (arg); | |
580 | } | |
581 | ||
582 | void * gethostent() { return tcp0("GETHOSTENT"); } | |
583 | void * getnetent() { return tcp0("GETNETENT"); } | |
584 | void * getprotoent() { return tcp0("GETPROTOENT"); } | |
585 | void * getservent() { return tcp0("GETSERVENT"); } | |
586 | void sethostent(x) { tcp1("SETHOSTENT", x); } | |
587 | void setnetent(x) { tcp1("SETNETENT", x); } | |
588 | void setprotoent(x) { tcp1("SETPROTOENT", x); } | |
589 | void setservent(x) { tcp1("SETSERVENT", x); } | |
590 | void endhostent() { tcp0("ENDHOSTENT"); } | |
591 | void endnetent() { tcp0("ENDNETENT"); } | |
592 | void endprotoent() { tcp0("ENDPROTOENT"); } | |
593 | void endservent() { tcp0("ENDSERVENT"); } | |
594 | ||
595 | /*****************************************************************************/ | |
596 | /* not implemented in C Set++ */ | |
597 | ||
598 | #ifndef __EMX__ | |
599 | int setuid(x) { errno = EINVAL; return -1; } | |
600 | int setgid(x) { errno = EINVAL; return -1; } | |
601 | #endif | |
4633a7c4 LW |
602 | |
603 | /*****************************************************************************/ | |
604 | /* stat() hack for char/block device */ | |
605 | ||
606 | #if OS2_STAT_HACK | |
607 | ||
608 | /* First attempt used DosQueryFSAttach which crashed the system when | |
609 | used with 5.001. Now just look for /dev/. */ | |
610 | ||
611 | int | |
612 | os2_stat(char *name, struct stat *st) | |
613 | { | |
614 | static int ino = SHRT_MAX; | |
615 | ||
616 | if (stricmp(name, "/dev/con") != 0 | |
617 | && stricmp(name, "/dev/tty") != 0) | |
618 | return stat(name, st); | |
619 | ||
620 | memset(st, 0, sizeof *st); | |
621 | st->st_mode = S_IFCHR|0666; | |
622 | st->st_ino = (ino-- & 0x7FFF); | |
623 | st->st_nlink = 1; | |
624 | return 0; | |
625 | } | |
626 | ||
627 | #endif | |
c0c09dfd | 628 | |
760ac839 | 629 | #ifdef USE_PERL_SBRK |
c0c09dfd | 630 | |
760ac839 | 631 | /* SBRK() emulation, mostly moved to malloc.c. */ |
c0c09dfd | 632 | |
633 | void * | |
760ac839 LW |
634 | sys_alloc(int size) { |
635 | void *got; | |
636 | APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE); | |
637 | ||
c0c09dfd | 638 | if (rc == ERROR_NOT_ENOUGH_MEMORY) { |
639 | return (void *) -1; | |
640 | } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc); | |
760ac839 | 641 | return got; |
c0c09dfd | 642 | } |
760ac839 LW |
643 | |
644 | #endif /* USE_PERL_SBRK */ | |
c0c09dfd | 645 | |
646 | /* tmp path */ | |
647 | ||
648 | char *tmppath = TMPPATH1; | |
649 | ||
650 | void | |
651 | settmppath() | |
652 | { | |
653 | char *p = getenv("TMP"), *tpath; | |
654 | int len; | |
655 | ||
656 | if (!p) p = getenv("TEMP"); | |
657 | if (!p) return; | |
658 | len = strlen(p); | |
659 | tpath = (char *)malloc(len + strlen(TMPPATH1) + 2); | |
660 | strcpy(tpath, p); | |
661 | tpath[len] = '/'; | |
662 | strcpy(tpath + len + 1, TMPPATH1); | |
663 | tmppath = tpath; | |
664 | } | |
7a2f0d5b | 665 | |
666 | #include "XSUB.h" | |
667 | ||
668 | XS(XS_File__Copy_syscopy) | |
669 | { | |
670 | dXSARGS; | |
671 | if (items < 2 || items > 3) | |
672 | croak("Usage: File::Copy::syscopy(src,dst,flag=0)"); | |
673 | { | |
674 | char * src = (char *)SvPV(ST(0),na); | |
675 | char * dst = (char *)SvPV(ST(1),na); | |
676 | U32 flag; | |
677 | int RETVAL, rc; | |
678 | ||
679 | if (items < 3) | |
680 | flag = 0; | |
681 | else { | |
682 | flag = (unsigned long)SvIV(ST(2)); | |
683 | } | |
684 | ||
6f064249 | 685 | RETVAL = !CheckOSError(DosCopy(src, dst, flag)); |
7a2f0d5b | 686 | ST(0) = sv_newmortal(); |
687 | sv_setiv(ST(0), (IV)RETVAL); | |
688 | } | |
689 | XSRETURN(1); | |
690 | } | |
691 | ||
6f064249 | 692 | char * |
693 | mod2fname(sv) | |
694 | SV *sv; | |
695 | { | |
696 | static char fname[9]; | |
760ac839 LW |
697 | int pos = 6, len, avlen; |
698 | unsigned int sum = 0; | |
6f064249 | 699 | AV *av; |
700 | SV *svp; | |
701 | char *s; | |
702 | ||
703 | if (!SvROK(sv)) croak("Not a reference given to mod2fname"); | |
704 | sv = SvRV(sv); | |
705 | if (SvTYPE(sv) != SVt_PVAV) | |
706 | croak("Not array reference given to mod2fname"); | |
760ac839 LW |
707 | |
708 | avlen = av_len((AV*)sv); | |
709 | if (avlen < 0) | |
6f064249 | 710 | croak("Empty array reference given to mod2fname"); |
760ac839 LW |
711 | |
712 | s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na); | |
6f064249 | 713 | strncpy(fname, s, 8); |
760ac839 LW |
714 | len = strlen(s); |
715 | if (len < 6) pos = len; | |
716 | while (*s) { | |
717 | sum = 33 * sum + *(s++); /* Checksumming first chars to | |
718 | * get the capitalization into c.s. */ | |
719 | } | |
720 | avlen --; | |
721 | while (avlen >= 0) { | |
722 | s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na); | |
723 | while (*s) { | |
724 | sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */ | |
725 | } | |
726 | avlen --; | |
727 | } | |
728 | fname[pos] = 'A' + (sum % 26); | |
729 | fname[pos + 1] = 'A' + (sum / 26 % 26); | |
730 | fname[pos + 2] = '\0'; | |
6f064249 | 731 | return (char *)fname; |
732 | } | |
733 | ||
734 | XS(XS_DynaLoader_mod2fname) | |
735 | { | |
736 | dXSARGS; | |
737 | if (items != 1) | |
738 | croak("Usage: DynaLoader::mod2fname(sv)"); | |
739 | { | |
740 | SV * sv = ST(0); | |
741 | char * RETVAL; | |
742 | ||
743 | RETVAL = mod2fname(sv); | |
744 | ST(0) = sv_newmortal(); | |
745 | sv_setpv((SV*)ST(0), RETVAL); | |
746 | } | |
747 | XSRETURN(1); | |
748 | } | |
749 | ||
750 | char * | |
751 | os2error(int rc) | |
752 | { | |
753 | static char buf[300]; | |
754 | ULONG len; | |
755 | ||
55497cff | 756 | if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */ |
6f064249 | 757 | if (rc == 0) |
758 | return NULL; | |
759 | if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len)) | |
760 | sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc); | |
761 | else | |
762 | buf[len] = '\0'; | |
763 | return buf; | |
764 | } | |
765 | ||
760ac839 LW |
766 | char * |
767 | perllib_mangle(char *s, unsigned int l) | |
768 | { | |
769 | static char *newp, *oldp; | |
770 | static int newl, oldl, notfound; | |
771 | static char ret[STATIC_FILE_LENGTH+1]; | |
772 | ||
773 | if (!newp && !notfound) { | |
774 | newp = getenv("PERLLIB_PREFIX"); | |
775 | if (newp) { | |
ff68c719 | 776 | char *s; |
777 | ||
760ac839 | 778 | oldp = newp; |
89078e0f | 779 | while (*newp && !isSPACE(*newp) && *newp != ';') { |
760ac839 LW |
780 | newp++; oldl++; /* Skip digits. */ |
781 | } | |
782 | while (*newp && (isSPACE(*newp) || *newp == ';')) { | |
783 | newp++; /* Skip whitespace. */ | |
784 | } | |
785 | newl = strlen(newp); | |
786 | if (newl == 0 || oldl == 0) { | |
787 | die("Malformed PERLLIB_PREFIX"); | |
788 | } | |
ff68c719 | 789 | strcpy(ret, newp); |
790 | s = ret; | |
791 | while (*s) { | |
792 | if (*s == '\\') *s = '/'; | |
793 | s++; | |
794 | } | |
760ac839 LW |
795 | } else { |
796 | notfound = 1; | |
797 | } | |
798 | } | |
799 | if (!newp) { | |
800 | return s; | |
801 | } | |
802 | if (l == 0) { | |
803 | l = strlen(s); | |
804 | } | |
3bbf9c2b | 805 | if (l < oldl || strnicmp(oldp, s, oldl) != 0) { |
760ac839 LW |
806 | return s; |
807 | } | |
808 | if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) { | |
809 | die("Malformed PERLLIB_PREFIX"); | |
810 | } | |
89078e0f | 811 | strcpy(ret + newl, s + oldl); |
760ac839 LW |
812 | return ret; |
813 | } | |
6f064249 | 814 | |
815 | extern void dlopen(); | |
816 | void *fakedl = &dlopen; /* Pull in dynaloading part. */ | |
3bbf9c2b IZ |
817 | |
818 | #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \ | |
819 | && ((path)[2] == '/' || (path)[2] == '\\')) | |
820 | #define sys_is_rooted _fnisabs | |
821 | #define sys_is_relative _fnisrel | |
822 | #define current_drive _getdrive | |
823 | ||
824 | #undef chdir /* Was _chdir2. */ | |
825 | #define sys_chdir(p) (chdir(p) == 0) | |
826 | #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d))) | |
827 | ||
828 | XS(XS_Cwd_current_drive) | |
829 | { | |
830 | dXSARGS; | |
831 | if (items != 0) | |
832 | croak("Usage: Cwd::current_drive()"); | |
833 | { | |
834 | char RETVAL; | |
835 | ||
836 | RETVAL = current_drive(); | |
837 | ST(0) = sv_newmortal(); | |
838 | sv_setpvn(ST(0), (char *)&RETVAL, 1); | |
839 | } | |
840 | XSRETURN(1); | |
841 | } | |
842 | ||
843 | XS(XS_Cwd_sys_chdir) | |
844 | { | |
845 | dXSARGS; | |
846 | if (items != 1) | |
847 | croak("Usage: Cwd::sys_chdir(path)"); | |
848 | { | |
849 | char * path = (char *)SvPV(ST(0),na); | |
850 | bool RETVAL; | |
851 | ||
852 | RETVAL = sys_chdir(path); | |
54310121 | 853 | ST(0) = boolSV(RETVAL); |
3bbf9c2b IZ |
854 | if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); |
855 | } | |
856 | XSRETURN(1); | |
857 | } | |
858 | ||
859 | XS(XS_Cwd_change_drive) | |
860 | { | |
861 | dXSARGS; | |
862 | if (items != 1) | |
863 | croak("Usage: Cwd::change_drive(d)"); | |
864 | { | |
865 | char d = (char)*SvPV(ST(0),na); | |
866 | bool RETVAL; | |
867 | ||
868 | RETVAL = change_drive(d); | |
54310121 | 869 | ST(0) = boolSV(RETVAL); |
3bbf9c2b IZ |
870 | if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); |
871 | } | |
872 | XSRETURN(1); | |
873 | } | |
874 | ||
875 | XS(XS_Cwd_sys_is_absolute) | |
876 | { | |
877 | dXSARGS; | |
878 | if (items != 1) | |
879 | croak("Usage: Cwd::sys_is_absolute(path)"); | |
880 | { | |
881 | char * path = (char *)SvPV(ST(0),na); | |
882 | bool RETVAL; | |
883 | ||
884 | RETVAL = sys_is_absolute(path); | |
54310121 | 885 | ST(0) = boolSV(RETVAL); |
3bbf9c2b IZ |
886 | if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); |
887 | } | |
888 | XSRETURN(1); | |
889 | } | |
890 | ||
891 | XS(XS_Cwd_sys_is_rooted) | |
892 | { | |
893 | dXSARGS; | |
894 | if (items != 1) | |
895 | croak("Usage: Cwd::sys_is_rooted(path)"); | |
896 | { | |
897 | char * path = (char *)SvPV(ST(0),na); | |
898 | bool RETVAL; | |
899 | ||
900 | RETVAL = sys_is_rooted(path); | |
54310121 | 901 | ST(0) = boolSV(RETVAL); |
3bbf9c2b IZ |
902 | if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); |
903 | } | |
904 | XSRETURN(1); | |
905 | } | |
906 | ||
907 | XS(XS_Cwd_sys_is_relative) | |
908 | { | |
909 | dXSARGS; | |
910 | if (items != 1) | |
911 | croak("Usage: Cwd::sys_is_relative(path)"); | |
912 | { | |
913 | char * path = (char *)SvPV(ST(0),na); | |
914 | bool RETVAL; | |
915 | ||
916 | RETVAL = sys_is_relative(path); | |
54310121 | 917 | ST(0) = boolSV(RETVAL); |
3bbf9c2b IZ |
918 | if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); |
919 | } | |
920 | XSRETURN(1); | |
921 | } | |
922 | ||
923 | XS(XS_Cwd_sys_cwd) | |
924 | { | |
925 | dXSARGS; | |
926 | if (items != 0) | |
927 | croak("Usage: Cwd::sys_cwd()"); | |
928 | { | |
929 | char p[MAXPATHLEN]; | |
930 | char * RETVAL; | |
931 | RETVAL = _getcwd2(p, MAXPATHLEN); | |
932 | ST(0) = sv_newmortal(); | |
933 | sv_setpv((SV*)ST(0), RETVAL); | |
934 | } | |
935 | XSRETURN(1); | |
936 | } | |
937 | ||
938 | XS(XS_Cwd_sys_abspath) | |
939 | { | |
940 | dXSARGS; | |
941 | if (items < 1 || items > 2) | |
942 | croak("Usage: Cwd::sys_abspath(path, dir = NULL)"); | |
943 | { | |
944 | char * path = (char *)SvPV(ST(0),na); | |
945 | char * dir; | |
946 | char p[MAXPATHLEN]; | |
947 | char * RETVAL; | |
948 | ||
949 | if (items < 2) | |
950 | dir = NULL; | |
951 | else { | |
952 | dir = (char *)SvPV(ST(1),na); | |
953 | } | |
954 | if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) { | |
955 | path += 2; | |
956 | } | |
957 | if (dir == NULL) { | |
958 | if (_abspath(p, path, MAXPATHLEN) == 0) { | |
959 | RETVAL = p; | |
960 | } else { | |
961 | RETVAL = NULL; | |
962 | } | |
963 | } else { | |
964 | /* Absolute with drive: */ | |
965 | if ( sys_is_absolute(path) ) { | |
966 | if (_abspath(p, path, MAXPATHLEN) == 0) { | |
967 | RETVAL = p; | |
968 | } else { | |
969 | RETVAL = NULL; | |
970 | } | |
971 | } else if (path[0] == '/' || path[0] == '\\') { | |
972 | /* Rooted, but maybe on different drive. */ | |
973 | if (isALPHA(dir[0]) && dir[1] == ':' ) { | |
974 | char p1[MAXPATHLEN]; | |
975 | ||
976 | /* Need to prepend the drive. */ | |
977 | p1[0] = dir[0]; | |
978 | p1[1] = dir[1]; | |
979 | Copy(path, p1 + 2, strlen(path) + 1, char); | |
980 | RETVAL = p; | |
981 | if (_abspath(p, p1, MAXPATHLEN) == 0) { | |
982 | RETVAL = p; | |
983 | } else { | |
984 | RETVAL = NULL; | |
985 | } | |
986 | } else if (_abspath(p, path, MAXPATHLEN) == 0) { | |
987 | RETVAL = p; | |
988 | } else { | |
989 | RETVAL = NULL; | |
990 | } | |
991 | } else { | |
992 | /* Either path is relative, or starts with a drive letter. */ | |
993 | /* If the path starts with a drive letter, then dir is | |
994 | relevant only if | |
995 | a/b) it is absolute/x:relative on the same drive. | |
996 | c) path is on current drive, and dir is rooted | |
997 | In all the cases it is safe to drop the drive part | |
998 | of the path. */ | |
999 | if ( !sys_is_relative(path) ) { | |
1000 | int is_drived; | |
1001 | ||
1002 | if ( ( ( sys_is_absolute(dir) | |
1003 | || (isALPHA(dir[0]) && dir[1] == ':' | |
1004 | && strnicmp(dir, path,1) == 0)) | |
1005 | && strnicmp(dir, path,1) == 0) | |
1006 | || ( !(isALPHA(dir[0]) && dir[1] == ':') | |
1007 | && toupper(path[0]) == current_drive())) { | |
1008 | path += 2; | |
1009 | } else if (_abspath(p, path, MAXPATHLEN) == 0) { | |
1010 | RETVAL = p; goto done; | |
1011 | } else { | |
1012 | RETVAL = NULL; goto done; | |
1013 | } | |
1014 | } | |
1015 | { | |
1016 | /* Need to prepend the absolute path of dir. */ | |
1017 | char p1[MAXPATHLEN]; | |
1018 | ||
1019 | if (_abspath(p1, dir, MAXPATHLEN) == 0) { | |
1020 | int l = strlen(p1); | |
1021 | ||
1022 | if (p1[ l - 1 ] != '/') { | |
1023 | p1[ l ] = '/'; | |
1024 | l++; | |
1025 | } | |
1026 | Copy(path, p1 + l, strlen(path) + 1, char); | |
1027 | if (_abspath(p, p1, MAXPATHLEN) == 0) { | |
1028 | RETVAL = p; | |
1029 | } else { | |
1030 | RETVAL = NULL; | |
1031 | } | |
1032 | } else { | |
1033 | RETVAL = NULL; | |
1034 | } | |
1035 | } | |
1036 | done: | |
1037 | } | |
1038 | } | |
1039 | ST(0) = sv_newmortal(); | |
1040 | sv_setpv((SV*)ST(0), RETVAL); | |
1041 | } | |
1042 | XSRETURN(1); | |
1043 | } | |
72ea3524 IZ |
1044 | typedef APIRET (*PELP)(PSZ path, ULONG type); |
1045 | ||
1046 | APIRET | |
1047 | ExtLIBPATH(ULONG ord, PSZ path, ULONG type) | |
1048 | { | |
1049 | loadByOrd(ord); /* Guarantied to load or die! */ | |
1050 | return (*(PELP)ExtFCN[ord])(path, type); | |
1051 | } | |
3bbf9c2b | 1052 | |
72ea3524 IZ |
1053 | #define extLibpath(type) \ |
1054 | (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \ | |
1055 | : BEGIN_LIBPATH))) \ | |
3bbf9c2b IZ |
1056 | ? NULL : to ) |
1057 | ||
1058 | #define extLibpath_set(p,type) \ | |
72ea3524 IZ |
1059 | (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \ |
1060 | : BEGIN_LIBPATH)))) | |
3bbf9c2b IZ |
1061 | |
1062 | XS(XS_Cwd_extLibpath) | |
1063 | { | |
1064 | dXSARGS; | |
1065 | if (items < 0 || items > 1) | |
1066 | croak("Usage: Cwd::extLibpath(type = 0)"); | |
1067 | { | |
1068 | bool type; | |
1069 | char to[1024]; | |
1070 | U32 rc; | |
1071 | char * RETVAL; | |
1072 | ||
1073 | if (items < 1) | |
1074 | type = 0; | |
1075 | else { | |
1076 | type = (int)SvIV(ST(0)); | |
1077 | } | |
1078 | ||
1079 | RETVAL = extLibpath(type); | |
1080 | ST(0) = sv_newmortal(); | |
1081 | sv_setpv((SV*)ST(0), RETVAL); | |
1082 | } | |
1083 | XSRETURN(1); | |
1084 | } | |
1085 | ||
1086 | XS(XS_Cwd_extLibpath_set) | |
1087 | { | |
1088 | dXSARGS; | |
1089 | if (items < 1 || items > 2) | |
1090 | croak("Usage: Cwd::extLibpath_set(s, type = 0)"); | |
1091 | { | |
1092 | char * s = (char *)SvPV(ST(0),na); | |
1093 | bool type; | |
1094 | U32 rc; | |
1095 | bool RETVAL; | |
1096 | ||
1097 | if (items < 2) | |
1098 | type = 0; | |
1099 | else { | |
1100 | type = (int)SvIV(ST(1)); | |
1101 | } | |
1102 | ||
1103 | RETVAL = extLibpath_set(s, type); | |
54310121 | 1104 | ST(0) = boolSV(RETVAL); |
3bbf9c2b IZ |
1105 | if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); |
1106 | } | |
1107 | XSRETURN(1); | |
1108 | } | |
1109 | ||
1110 | int | |
1111 | Xs_OS2_init() | |
1112 | { | |
1113 | char *file = __FILE__; | |
1114 | { | |
1115 | GV *gv; | |
55497cff | 1116 | |
1117 | if (_emx_env & 0x200) { /* OS/2 */ | |
1118 | newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file); | |
1119 | newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file); | |
1120 | newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file); | |
1121 | } | |
3bbf9c2b IZ |
1122 | newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file); |
1123 | newXS("Cwd::current_drive", XS_Cwd_current_drive, file); | |
1124 | newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file); | |
1125 | newXS("Cwd::change_drive", XS_Cwd_change_drive, file); | |
1126 | newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file); | |
1127 | newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file); | |
1128 | newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file); | |
1129 | newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file); | |
1130 | newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file); | |
3bbf9c2b IZ |
1131 | gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV); |
1132 | GvMULTI_on(gv); | |
1133 | #ifdef PERL_IS_AOUT | |
1134 | sv_setiv(GvSV(gv), 1); | |
1135 | #endif | |
1136 | } | |
1137 | } | |
1138 | ||
1139 | OS2_Perl_data_t OS2_Perl_data; | |
1140 | ||
1141 | void | |
aa689395 | 1142 | Perl_OS2_init(char **env) |
3bbf9c2b IZ |
1143 | { |
1144 | char *shell; | |
1145 | ||
1146 | settmppath(); | |
1147 | OS2_Perl_data.xs_init = &Xs_OS2_init; | |
aa689395 | 1148 | if (environ == NULL) { |
1149 | environ = env; | |
1150 | } | |
3bbf9c2b | 1151 | if ( (shell = getenv("PERL_SH_DRIVE")) ) { |
fc36a67e | 1152 | New(1304, sh_path, strlen(SH_PATH) + 1, char); |
ff68c719 | 1153 | strcpy(sh_path, SH_PATH); |
3bbf9c2b IZ |
1154 | sh_path[0] = shell[0]; |
1155 | } else if ( (shell = getenv("PERL_SH_DIR")) ) { | |
ff68c719 | 1156 | int l = strlen(shell), i; |
3bbf9c2b IZ |
1157 | if (shell[l-1] == '/' || shell[l-1] == '\\') { |
1158 | l--; | |
1159 | } | |
fc36a67e | 1160 | New(1304, sh_path, l + 8, char); |
3bbf9c2b IZ |
1161 | strncpy(sh_path, shell, l); |
1162 | strcpy(sh_path + l, "/sh.exe"); | |
ff68c719 | 1163 | for (i = 0; i < l; i++) { |
1164 | if (sh_path[i] == '\\') sh_path[i] = '/'; | |
1165 | } | |
3bbf9c2b IZ |
1166 | } |
1167 | } | |
1168 | ||
55497cff | 1169 | #undef tmpnam |
1170 | #undef tmpfile | |
1171 | ||
1172 | char * | |
1173 | my_tmpnam (char *str) | |
1174 | { | |
1175 | char *p = getenv("TMP"), *tpath; | |
1176 | int len; | |
1177 | ||
1178 | if (!p) p = getenv("TEMP"); | |
1179 | tpath = tempnam(p, "pltmp"); | |
1180 | if (str && tpath) { | |
1181 | strcpy(str, tpath); | |
1182 | return str; | |
1183 | } | |
1184 | return tpath; | |
1185 | } | |
1186 | ||
1187 | FILE * | |
1188 | my_tmpfile () | |
1189 | { | |
1190 | struct stat s; | |
1191 | ||
1192 | stat(".", &s); | |
1193 | if (s.st_mode & S_IWOTH) { | |
1194 | return tmpfile(); | |
1195 | } | |
1196 | return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but | |
1197 | grants TMP. */ | |
1198 | } | |
367f3c24 IZ |
1199 | |
1200 | #undef flock | |
1201 | ||
1202 | /* This code was contributed by Rocco Caputo. */ | |
1203 | int | |
1204 | my_flock(int handle, int op) | |
1205 | { | |
1206 | FILELOCK rNull, rFull; | |
1207 | ULONG timeout, handle_type, flag_word; | |
1208 | APIRET rc; | |
1209 | int blocking, shared; | |
1210 | static int use_my = -1; | |
1211 | ||
1212 | if (use_my == -1) { | |
1213 | char *s = getenv("USE_PERL_FLOCK"); | |
1214 | if (s) | |
1215 | use_my = atoi(s); | |
1216 | else | |
1217 | use_my = 1; | |
1218 | } | |
1219 | if (!(_emx_env & 0x200) || !use_my) | |
1220 | return flock(handle, op); /* Delegate to EMX. */ | |
1221 | ||
1222 | // is this a file? | |
1223 | if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) || | |
1224 | (handle_type & 0xFF)) | |
1225 | { | |
1226 | errno = EBADF; | |
1227 | return -1; | |
1228 | } | |
1229 | // set lock/unlock ranges | |
1230 | rNull.lOffset = rNull.lRange = rFull.lOffset = 0; | |
1231 | rFull.lRange = 0x7FFFFFFF; | |
1232 | // set timeout for blocking | |
1233 | timeout = ((blocking = !(op & LOCK_NB))) ? 100 : 1; | |
1234 | // shared or exclusive? | |
1235 | shared = (op & LOCK_SH) ? 1 : 0; | |
1236 | // do not block the unlock | |
1237 | if (op & (LOCK_UN | LOCK_SH | LOCK_EX)) { | |
1238 | rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared); | |
1239 | switch (rc) { | |
1240 | case 0: | |
1241 | errno = 0; | |
1242 | return 0; | |
1243 | case ERROR_INVALID_HANDLE: | |
1244 | errno = EBADF; | |
1245 | return -1; | |
1246 | case ERROR_SHARING_BUFFER_EXCEEDED: | |
1247 | errno = ENOLCK; | |
1248 | return -1; | |
1249 | case ERROR_LOCK_VIOLATION: | |
1250 | break; // not an error | |
1251 | case ERROR_INVALID_PARAMETER: | |
1252 | case ERROR_ATOMIC_LOCK_NOT_SUPPORTED: | |
1253 | case ERROR_READ_LOCKS_NOT_SUPPORTED: | |
1254 | errno = EINVAL; | |
1255 | return -1; | |
1256 | case ERROR_INTERRUPT: | |
1257 | errno = EINTR; | |
1258 | return -1; | |
1259 | default: | |
1260 | errno = EINVAL; | |
1261 | return -1; | |
1262 | } | |
1263 | } | |
1264 | // lock may block | |
1265 | if (op & (LOCK_SH | LOCK_EX)) { | |
1266 | // for blocking operations | |
1267 | for (;;) { | |
1268 | rc = | |
1269 | DosSetFileLocks( | |
1270 | handle, | |
1271 | &rNull, | |
1272 | &rFull, | |
1273 | timeout, | |
1274 | shared | |
1275 | ); | |
1276 | switch (rc) { | |
1277 | case 0: | |
1278 | errno = 0; | |
1279 | return 0; | |
1280 | case ERROR_INVALID_HANDLE: | |
1281 | errno = EBADF; | |
1282 | return -1; | |
1283 | case ERROR_SHARING_BUFFER_EXCEEDED: | |
1284 | errno = ENOLCK; | |
1285 | return -1; | |
1286 | case ERROR_LOCK_VIOLATION: | |
1287 | if (!blocking) { | |
1288 | errno = EWOULDBLOCK; | |
1289 | return -1; | |
1290 | } | |
1291 | break; | |
1292 | case ERROR_INVALID_PARAMETER: | |
1293 | case ERROR_ATOMIC_LOCK_NOT_SUPPORTED: | |
1294 | case ERROR_READ_LOCKS_NOT_SUPPORTED: | |
1295 | errno = EINVAL; | |
1296 | return -1; | |
1297 | case ERROR_INTERRUPT: | |
1298 | errno = EINTR; | |
1299 | return -1; | |
1300 | default: | |
1301 | errno = EINVAL; | |
1302 | return -1; | |
1303 | } | |
1304 | // give away timeslice | |
1305 | DosSleep(1); | |
1306 | } | |
1307 | } | |
1308 | ||
1309 | errno = 0; | |
1310 | return 0; | |
1311 | } |