Commit | Line | Data |
4633a7c4 |
1 | #define INCL_DOS |
2 | #define INCL_NOPM |
7a2f0d5b |
3 | #define INCL_DOSFILEMGR |
760ac839 |
4 | #define INCL_DOSMEMMGR |
5 | #define INCL_DOSERRORS |
4633a7c4 |
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> |
16 | |
17 | #include "EXTERN.h" |
18 | #include "perl.h" |
19 | |
20 | /*****************************************************************************/ |
21 | /* priorities */ |
6f064249 |
22 | static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged, |
23 | self inverse. */ |
24 | #define QSS_INI_BUFFER 1024 |
4633a7c4 |
25 | |
6f064249 |
26 | PQTOPLEVEL |
27 | get_sysinfo(ULONG pid, ULONG flags) |
4633a7c4 |
28 | { |
6f064249 |
29 | char *pbuffer; |
30 | ULONG rc, buf_len = QSS_INI_BUFFER; |
31 | |
32 | New(1022, pbuffer, buf_len, char); |
33 | /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */ |
34 | rc = QuerySysState(flags, pid, pbuffer, buf_len); |
35 | while (rc == ERROR_BUFFER_OVERFLOW) { |
36 | Renew(pbuffer, buf_len *= 2, char); |
37 | rc = QuerySysState(QSS_PROCESS, pid, pbuffer, buf_len); |
38 | } |
39 | if (rc) { |
40 | FillOSError(rc); |
41 | Safefree(pbuffer); |
42 | return 0; |
43 | } |
44 | return (PQTOPLEVEL)pbuffer; |
45 | } |
46 | |
47 | #define PRIO_ERR 0x1111 |
48 | |
49 | static ULONG |
50 | sys_prio(pid) |
51 | { |
52 | ULONG prio; |
53 | PQTOPLEVEL psi; |
54 | |
55 | psi = get_sysinfo(pid, QSS_PROCESS); |
56 | if (!psi) { |
57 | return PRIO_ERR; |
58 | } |
59 | if (pid != psi->procdata->pid) { |
60 | Safefree(psi); |
61 | croak("panic: wrong pid in sysinfo"); |
62 | } |
63 | prio = psi->procdata->threads->priority; |
64 | Safefree(psi); |
65 | return prio; |
66 | } |
67 | |
68 | int |
69 | setpriority(int which, int pid, int val) |
70 | { |
71 | ULONG rc, prio; |
72 | PQTOPLEVEL psi; |
73 | |
74 | prio = sys_prio(pid); |
75 | |
76 | if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) { |
77 | /* Do not change class. */ |
78 | return CheckOSError(DosSetPriority((pid < 0) |
79 | ? PRTYS_PROCESSTREE : PRTYS_PROCESS, |
80 | 0, |
81 | (32 - val) % 32 - (prio & 0xFF), |
82 | abs(pid))) |
83 | ? -1 : 0; |
84 | } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ { |
85 | /* Documentation claims one can change both class and basevalue, |
86 | * but I find it wrong. */ |
87 | /* Change class, but since delta == 0 denotes absolute 0, correct. */ |
88 | if (CheckOSError(DosSetPriority((pid < 0) |
89 | ? PRTYS_PROCESSTREE : PRTYS_PROCESS, |
90 | priors[(32 - val) >> 5] + 1, |
91 | 0, |
92 | abs(pid)))) |
93 | return -1; |
94 | if ( ((32 - val) % 32) == 0 ) return 0; |
95 | return CheckOSError(DosSetPriority((pid < 0) |
96 | ? PRTYS_PROCESSTREE : PRTYS_PROCESS, |
97 | 0, |
98 | (32 - val) % 32, |
99 | abs(pid))) |
100 | ? -1 : 0; |
101 | } |
102 | /* else return CheckOSError(DosSetPriority((pid < 0) */ |
103 | /* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */ |
104 | /* priors[(32 - val) >> 5] + 1, */ |
105 | /* (32 - val) % 32 - (prio & 0xFF), */ |
106 | /* abs(pid))) */ |
107 | /* ? -1 : 0; */ |
4633a7c4 |
108 | } |
109 | |
6f064249 |
110 | int |
111 | getpriority(int which /* ignored */, int pid) |
4633a7c4 |
112 | { |
113 | TIB *tib; |
114 | PIB *pib; |
6f064249 |
115 | ULONG rc, ret; |
116 | |
117 | /* DosGetInfoBlocks has old priority! */ |
118 | /* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */ |
119 | /* if (pid != pib->pib_ulpid) { */ |
120 | ret = sys_prio(pid); |
121 | if (ret == PRIO_ERR) { |
122 | return -1; |
123 | } |
124 | /* } else */ |
125 | /* ret = tib->tib_ptib2->tib2_ulpri; */ |
126 | return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF); |
4633a7c4 |
127 | } |
128 | |
129 | /*****************************************************************************/ |
130 | /* spawn */ |
131 | |
132 | static int |
133 | result(int flag, int pid) |
134 | { |
135 | int r, status; |
136 | Signal_t (*ihand)(); /* place to save signal during system() */ |
137 | Signal_t (*qhand)(); /* place to save signal during system() */ |
760ac839 |
138 | #ifndef __EMX__ |
139 | RESULTCODES res; |
140 | int rpid; |
141 | #endif |
4633a7c4 |
142 | |
760ac839 |
143 | if (pid < 0 || flag != 0) |
4633a7c4 |
144 | return pid; |
145 | |
760ac839 |
146 | #ifdef __EMX__ |
4633a7c4 |
147 | ihand = signal(SIGINT, SIG_IGN); |
148 | qhand = signal(SIGQUIT, SIG_IGN); |
c0c09dfd |
149 | do { |
150 | r = wait4pid(pid, &status, 0); |
151 | } while (r == -1 && errno == EINTR); |
4633a7c4 |
152 | signal(SIGINT, ihand); |
153 | signal(SIGQUIT, qhand); |
154 | |
155 | statusvalue = (U16)status; |
156 | if (r < 0) |
157 | return -1; |
158 | return status & 0xFFFF; |
760ac839 |
159 | #else |
160 | ihand = signal(SIGINT, SIG_IGN); |
161 | r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid); |
162 | signal(SIGINT, ihand); |
163 | statusvalue = res.codeResult << 8 | res.codeTerminate; |
164 | if (r) |
165 | return -1; |
166 | return statusvalue; |
167 | #endif |
4633a7c4 |
168 | } |
169 | |
170 | int |
171 | do_aspawn(really,mark,sp) |
172 | SV *really; |
173 | register SV **mark; |
174 | register SV **sp; |
175 | { |
176 | register char **a; |
177 | char *tmps; |
178 | int rc; |
179 | int flag = P_WAIT, trueflag; |
180 | |
181 | if (sp > mark) { |
182 | New(401,Argv, sp - mark + 1, char*); |
183 | a = Argv; |
184 | |
760ac839 |
185 | if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { |
4633a7c4 |
186 | ++mark; |
187 | flag = SvIVx(*mark); |
188 | } |
189 | |
190 | while (++mark <= sp) { |
191 | if (*mark) |
192 | *a++ = SvPVx(*mark, na); |
193 | else |
194 | *a++ = ""; |
195 | } |
196 | *a = Nullch; |
197 | |
198 | trueflag = flag; |
199 | if (flag == P_WAIT) |
200 | flag = P_NOWAIT; |
201 | |
3bbf9c2b |
202 | if (strEQ(Argv[0],"/bin/sh")) Argv[0] = SH_PATH; |
203 | |
204 | if (Argv[0][0] != '/' && Argv[0][0] != '\\' |
205 | && !(Argv[0][0] && Argv[0][1] == ':' |
206 | && (Argv[0][2] == '/' || Argv[0][2] != '\\')) |
760ac839 |
207 | ) /* will swawnvp use PATH? */ |
c0c09dfd |
208 | TAINT_ENV(); /* testing IFS here is overkill, probably */ |
760ac839 |
209 | /* We should check PERL_SH* and PERLLIB_* as well? */ |
4633a7c4 |
210 | if (really && *(tmps = SvPV(really, na))) |
211 | rc = result(trueflag, spawnvp(flag,tmps,Argv)); |
212 | else |
213 | rc = result(trueflag, spawnvp(flag,Argv[0],Argv)); |
214 | |
215 | if (rc < 0 && dowarn) |
216 | warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno)); |
c0c09dfd |
217 | if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ |
4633a7c4 |
218 | } else |
219 | rc = -1; |
220 | do_execfree(); |
221 | return rc; |
222 | } |
223 | |
760ac839 |
224 | #define EXECF_SPAWN 0 |
225 | #define EXECF_EXEC 1 |
226 | #define EXECF_TRUEEXEC 2 |
227 | |
4633a7c4 |
228 | int |
760ac839 |
229 | do_spawn2(cmd, execf) |
4633a7c4 |
230 | char *cmd; |
760ac839 |
231 | int execf; |
4633a7c4 |
232 | { |
233 | register char **a; |
234 | register char *s; |
235 | char flags[10]; |
3bbf9c2b |
236 | char *shell, *copt, *news = NULL; |
4633a7c4 |
237 | int rc; |
238 | |
c0c09dfd |
239 | #ifdef TRYSHELL |
240 | if ((shell = getenv("EMXSHELL")) != NULL) |
241 | copt = "-c"; |
242 | else if ((shell = getenv("SHELL")) != NULL) |
4633a7c4 |
243 | copt = "-c"; |
244 | else if ((shell = getenv("COMSPEC")) != NULL) |
245 | copt = "/C"; |
246 | else |
247 | shell = "cmd.exe"; |
c0c09dfd |
248 | #else |
249 | /* Consensus on perl5-porters is that it is _very_ important to |
250 | have a shell which will not change between computers with the |
251 | same architecture, to avoid "action on a distance". |
252 | And to have simple build, this shell should be sh. */ |
6f064249 |
253 | shell = SH_PATH; |
c0c09dfd |
254 | copt = "-c"; |
255 | #endif |
256 | |
257 | while (*cmd && isSPACE(*cmd)) |
258 | cmd++; |
4633a7c4 |
259 | |
3bbf9c2b |
260 | if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) { |
261 | STRLEN l = strlen(SH_PATH); |
262 | |
263 | New(4545, news, strlen(cmd) - 7 + l, char); |
264 | strcpy(news, SH_PATH); |
265 | strcpy(news + l, cmd + 7); |
266 | cmd = news; |
267 | } |
268 | |
4633a7c4 |
269 | /* save an extra exec if possible */ |
270 | /* see if there are shell metacharacters in it */ |
271 | |
c0c09dfd |
272 | if (*cmd == '.' && isSPACE(cmd[1])) |
273 | goto doshell; |
274 | |
275 | if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4])) |
276 | goto doshell; |
277 | |
278 | for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */ |
279 | if (*s == '=') |
280 | goto doshell; |
281 | |
4633a7c4 |
282 | for (s = cmd; *s; s++) { |
c0c09dfd |
283 | if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) { |
3bbf9c2b |
284 | if (*s == '\n' && s[1] == '\0') { |
4633a7c4 |
285 | *s = '\0'; |
286 | break; |
287 | } |
c0c09dfd |
288 | doshell: |
760ac839 |
289 | if (execf == EXECF_TRUEEXEC) |
290 | return execl(shell,shell,copt,cmd,(char*)0); |
291 | else if (execf == EXECF_EXEC) |
292 | return spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0); |
293 | /* In the ak code internal P_NOWAIT is P_WAIT ??? */ |
c0c09dfd |
294 | rc = result(P_WAIT, |
760ac839 |
295 | spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0)); |
c0c09dfd |
296 | if (rc < 0 && dowarn) |
760ac839 |
297 | warn("Can't %s \"%s\": %s", |
298 | (execf == EXECF_SPAWN ? "spawn" : "exec"), |
299 | shell, Strerror(errno)); |
c0c09dfd |
300 | if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ |
3bbf9c2b |
301 | if (news) Safefree(news); |
c0c09dfd |
302 | return rc; |
4633a7c4 |
303 | } |
304 | } |
c0c09dfd |
305 | |
4633a7c4 |
306 | New(402,Argv, (s - cmd) / 2 + 2, char*); |
307 | Cmd = savepvn(cmd, s-cmd); |
308 | a = Argv; |
309 | for (s = Cmd; *s;) { |
310 | while (*s && isSPACE(*s)) s++; |
311 | if (*s) |
312 | *(a++) = s; |
313 | while (*s && !isSPACE(*s)) s++; |
314 | if (*s) |
315 | *s++ = '\0'; |
316 | } |
317 | *a = Nullch; |
318 | if (Argv[0]) { |
760ac839 |
319 | if (execf == EXECF_TRUEEXEC) |
320 | rc = execvp(Argv[0],Argv); |
321 | else if (execf == EXECF_EXEC) |
322 | rc = spawnvp(P_OVERLAY,Argv[0],Argv); |
323 | else |
324 | rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv)); |
4633a7c4 |
325 | if (rc < 0 && dowarn) |
760ac839 |
326 | warn("Can't %s \"%s\": %s", |
327 | (execf == EXECF_SPAWN ? "spawn" : "exec"), |
328 | Argv[0], Strerror(errno)); |
c0c09dfd |
329 | if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ |
4633a7c4 |
330 | } else |
331 | rc = -1; |
3bbf9c2b |
332 | if (news) Safefree(news); |
4633a7c4 |
333 | do_execfree(); |
334 | return rc; |
335 | } |
336 | |
760ac839 |
337 | int |
338 | do_spawn(cmd) |
339 | char *cmd; |
340 | { |
341 | return do_spawn2(cmd, EXECF_SPAWN); |
342 | } |
343 | |
344 | bool |
345 | do_exec(cmd) |
346 | char *cmd; |
347 | { |
348 | return do_spawn2(cmd, EXECF_EXEC); |
349 | } |
350 | |
351 | bool |
352 | os2exec(cmd) |
353 | char *cmd; |
354 | { |
355 | return do_spawn2(cmd, EXECF_TRUEEXEC); |
356 | } |
357 | |
3bbf9c2b |
358 | PerlIO * |
359 | my_syspopen(cmd,mode) |
c0c09dfd |
360 | char *cmd; |
361 | char *mode; |
362 | { |
3bbf9c2b |
363 | PerlIO *res; |
364 | SV *sv; |
365 | |
760ac839 |
366 | #ifdef TRYSHELL |
3bbf9c2b |
367 | res = popen(cmd, mode); |
760ac839 |
368 | #else |
c0c09dfd |
369 | char *shell = getenv("EMXSHELL"); |
3bbf9c2b |
370 | |
6f064249 |
371 | my_setenv("EMXSHELL", SH_PATH); |
c0c09dfd |
372 | res = popen(cmd, mode); |
373 | my_setenv("EMXSHELL", shell); |
760ac839 |
374 | #endif |
3bbf9c2b |
375 | sv = *av_fetch(fdpid, PerlIO_fileno(res), TRUE); |
376 | (void)SvUPGRADE(sv,SVt_IV); |
377 | SvIVX(sv) = -1; /* A cooky. */ |
378 | return res; |
c0c09dfd |
379 | } |
380 | |
3bbf9c2b |
381 | /******************************************************************/ |
4633a7c4 |
382 | |
383 | #ifndef HAS_FORK |
384 | int |
385 | fork(void) |
386 | { |
387 | die(no_func, "Unsupported function fork"); |
388 | errno = EINVAL; |
389 | return -1; |
390 | } |
391 | #endif |
392 | |
3bbf9c2b |
393 | /*******************************************************************/ |
4633a7c4 |
394 | /* not implemented in EMX 0.9a */ |
395 | |
396 | void * ctermid(x) { return 0; } |
eacfb5f1 |
397 | |
398 | #ifdef MYTTYNAME /* was not in emx0.9a */ |
4633a7c4 |
399 | void * ttyname(x) { return 0; } |
eacfb5f1 |
400 | #endif |
4633a7c4 |
401 | |
3bbf9c2b |
402 | /******************************************************************/ |
760ac839 |
403 | /* my socket forwarders - EMX lib only provides static forwarders */ |
404 | |
405 | static HMODULE htcp = 0; |
406 | |
407 | static void * |
408 | tcp0(char *name) |
409 | { |
410 | static BYTE buf[20]; |
411 | PFN fcn; |
412 | if (!htcp) |
413 | DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp); |
414 | if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) |
415 | return (void *) ((void * (*)(void)) fcn) (); |
416 | return 0; |
417 | } |
418 | |
419 | static void |
420 | tcp1(char *name, int arg) |
421 | { |
422 | static BYTE buf[20]; |
423 | PFN fcn; |
424 | if (!htcp) |
425 | DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp); |
426 | if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) |
427 | ((void (*)(int)) fcn) (arg); |
428 | } |
429 | |
430 | void * gethostent() { return tcp0("GETHOSTENT"); } |
431 | void * getnetent() { return tcp0("GETNETENT"); } |
432 | void * getprotoent() { return tcp0("GETPROTOENT"); } |
433 | void * getservent() { return tcp0("GETSERVENT"); } |
434 | void sethostent(x) { tcp1("SETHOSTENT", x); } |
435 | void setnetent(x) { tcp1("SETNETENT", x); } |
436 | void setprotoent(x) { tcp1("SETPROTOENT", x); } |
437 | void setservent(x) { tcp1("SETSERVENT", x); } |
438 | void endhostent() { tcp0("ENDHOSTENT"); } |
439 | void endnetent() { tcp0("ENDNETENT"); } |
440 | void endprotoent() { tcp0("ENDPROTOENT"); } |
441 | void endservent() { tcp0("ENDSERVENT"); } |
442 | |
443 | /*****************************************************************************/ |
444 | /* not implemented in C Set++ */ |
445 | |
446 | #ifndef __EMX__ |
447 | int setuid(x) { errno = EINVAL; return -1; } |
448 | int setgid(x) { errno = EINVAL; return -1; } |
449 | #endif |
4633a7c4 |
450 | |
451 | /*****************************************************************************/ |
452 | /* stat() hack for char/block device */ |
453 | |
454 | #if OS2_STAT_HACK |
455 | |
456 | /* First attempt used DosQueryFSAttach which crashed the system when |
457 | used with 5.001. Now just look for /dev/. */ |
458 | |
459 | int |
460 | os2_stat(char *name, struct stat *st) |
461 | { |
462 | static int ino = SHRT_MAX; |
463 | |
464 | if (stricmp(name, "/dev/con") != 0 |
465 | && stricmp(name, "/dev/tty") != 0) |
466 | return stat(name, st); |
467 | |
468 | memset(st, 0, sizeof *st); |
469 | st->st_mode = S_IFCHR|0666; |
470 | st->st_ino = (ino-- & 0x7FFF); |
471 | st->st_nlink = 1; |
472 | return 0; |
473 | } |
474 | |
475 | #endif |
c0c09dfd |
476 | |
760ac839 |
477 | #ifdef USE_PERL_SBRK |
c0c09dfd |
478 | |
760ac839 |
479 | /* SBRK() emulation, mostly moved to malloc.c. */ |
c0c09dfd |
480 | |
481 | void * |
760ac839 |
482 | sys_alloc(int size) { |
483 | void *got; |
484 | APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE); |
485 | |
c0c09dfd |
486 | if (rc == ERROR_NOT_ENOUGH_MEMORY) { |
487 | return (void *) -1; |
488 | } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc); |
760ac839 |
489 | return got; |
c0c09dfd |
490 | } |
760ac839 |
491 | |
492 | #endif /* USE_PERL_SBRK */ |
c0c09dfd |
493 | |
494 | /* tmp path */ |
495 | |
496 | char *tmppath = TMPPATH1; |
497 | |
498 | void |
499 | settmppath() |
500 | { |
501 | char *p = getenv("TMP"), *tpath; |
502 | int len; |
503 | |
504 | if (!p) p = getenv("TEMP"); |
505 | if (!p) return; |
506 | len = strlen(p); |
507 | tpath = (char *)malloc(len + strlen(TMPPATH1) + 2); |
508 | strcpy(tpath, p); |
509 | tpath[len] = '/'; |
510 | strcpy(tpath + len + 1, TMPPATH1); |
511 | tmppath = tpath; |
512 | } |
7a2f0d5b |
513 | |
514 | #include "XSUB.h" |
515 | |
516 | XS(XS_File__Copy_syscopy) |
517 | { |
518 | dXSARGS; |
519 | if (items < 2 || items > 3) |
520 | croak("Usage: File::Copy::syscopy(src,dst,flag=0)"); |
521 | { |
522 | char * src = (char *)SvPV(ST(0),na); |
523 | char * dst = (char *)SvPV(ST(1),na); |
524 | U32 flag; |
525 | int RETVAL, rc; |
526 | |
527 | if (items < 3) |
528 | flag = 0; |
529 | else { |
530 | flag = (unsigned long)SvIV(ST(2)); |
531 | } |
532 | |
6f064249 |
533 | RETVAL = !CheckOSError(DosCopy(src, dst, flag)); |
7a2f0d5b |
534 | ST(0) = sv_newmortal(); |
535 | sv_setiv(ST(0), (IV)RETVAL); |
536 | } |
537 | XSRETURN(1); |
538 | } |
539 | |
6f064249 |
540 | char * |
541 | mod2fname(sv) |
542 | SV *sv; |
543 | { |
544 | static char fname[9]; |
760ac839 |
545 | int pos = 6, len, avlen; |
546 | unsigned int sum = 0; |
6f064249 |
547 | AV *av; |
548 | SV *svp; |
549 | char *s; |
550 | |
551 | if (!SvROK(sv)) croak("Not a reference given to mod2fname"); |
552 | sv = SvRV(sv); |
553 | if (SvTYPE(sv) != SVt_PVAV) |
554 | croak("Not array reference given to mod2fname"); |
760ac839 |
555 | |
556 | avlen = av_len((AV*)sv); |
557 | if (avlen < 0) |
6f064249 |
558 | croak("Empty array reference given to mod2fname"); |
760ac839 |
559 | |
560 | s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na); |
6f064249 |
561 | strncpy(fname, s, 8); |
760ac839 |
562 | len = strlen(s); |
563 | if (len < 6) pos = len; |
564 | while (*s) { |
565 | sum = 33 * sum + *(s++); /* Checksumming first chars to |
566 | * get the capitalization into c.s. */ |
567 | } |
568 | avlen --; |
569 | while (avlen >= 0) { |
570 | s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na); |
571 | while (*s) { |
572 | sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */ |
573 | } |
574 | avlen --; |
575 | } |
576 | fname[pos] = 'A' + (sum % 26); |
577 | fname[pos + 1] = 'A' + (sum / 26 % 26); |
578 | fname[pos + 2] = '\0'; |
6f064249 |
579 | return (char *)fname; |
580 | } |
581 | |
582 | XS(XS_DynaLoader_mod2fname) |
583 | { |
584 | dXSARGS; |
585 | if (items != 1) |
586 | croak("Usage: DynaLoader::mod2fname(sv)"); |
587 | { |
588 | SV * sv = ST(0); |
589 | char * RETVAL; |
590 | |
591 | RETVAL = mod2fname(sv); |
592 | ST(0) = sv_newmortal(); |
593 | sv_setpv((SV*)ST(0), RETVAL); |
594 | } |
595 | XSRETURN(1); |
596 | } |
597 | |
598 | char * |
599 | os2error(int rc) |
600 | { |
601 | static char buf[300]; |
602 | ULONG len; |
603 | |
604 | if (rc == 0) |
605 | return NULL; |
606 | if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len)) |
607 | sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc); |
608 | else |
609 | buf[len] = '\0'; |
610 | return buf; |
611 | } |
612 | |
89078e0f |
613 | char sh_path[STATIC_FILE_LENGTH+1] = SH_PATH_INI; |
760ac839 |
614 | |
615 | char * |
616 | perllib_mangle(char *s, unsigned int l) |
617 | { |
618 | static char *newp, *oldp; |
619 | static int newl, oldl, notfound; |
620 | static char ret[STATIC_FILE_LENGTH+1]; |
621 | |
622 | if (!newp && !notfound) { |
623 | newp = getenv("PERLLIB_PREFIX"); |
624 | if (newp) { |
625 | oldp = newp; |
89078e0f |
626 | while (*newp && !isSPACE(*newp) && *newp != ';') { |
760ac839 |
627 | newp++; oldl++; /* Skip digits. */ |
628 | } |
629 | while (*newp && (isSPACE(*newp) || *newp == ';')) { |
630 | newp++; /* Skip whitespace. */ |
631 | } |
632 | newl = strlen(newp); |
633 | if (newl == 0 || oldl == 0) { |
634 | die("Malformed PERLLIB_PREFIX"); |
635 | } |
636 | } else { |
637 | notfound = 1; |
638 | } |
639 | } |
640 | if (!newp) { |
641 | return s; |
642 | } |
643 | if (l == 0) { |
644 | l = strlen(s); |
645 | } |
3bbf9c2b |
646 | if (l < oldl || strnicmp(oldp, s, oldl) != 0) { |
760ac839 |
647 | return s; |
648 | } |
649 | if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) { |
650 | die("Malformed PERLLIB_PREFIX"); |
651 | } |
652 | strncpy(ret, newp, newl); |
89078e0f |
653 | strcpy(ret + newl, s + oldl); |
760ac839 |
654 | return ret; |
655 | } |
6f064249 |
656 | |
657 | extern void dlopen(); |
658 | void *fakedl = &dlopen; /* Pull in dynaloading part. */ |
3bbf9c2b |
659 | |
660 | #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \ |
661 | && ((path)[2] == '/' || (path)[2] == '\\')) |
662 | #define sys_is_rooted _fnisabs |
663 | #define sys_is_relative _fnisrel |
664 | #define current_drive _getdrive |
665 | |
666 | #undef chdir /* Was _chdir2. */ |
667 | #define sys_chdir(p) (chdir(p) == 0) |
668 | #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d))) |
669 | |
670 | XS(XS_Cwd_current_drive) |
671 | { |
672 | dXSARGS; |
673 | if (items != 0) |
674 | croak("Usage: Cwd::current_drive()"); |
675 | { |
676 | char RETVAL; |
677 | |
678 | RETVAL = current_drive(); |
679 | ST(0) = sv_newmortal(); |
680 | sv_setpvn(ST(0), (char *)&RETVAL, 1); |
681 | } |
682 | XSRETURN(1); |
683 | } |
684 | |
685 | XS(XS_Cwd_sys_chdir) |
686 | { |
687 | dXSARGS; |
688 | if (items != 1) |
689 | croak("Usage: Cwd::sys_chdir(path)"); |
690 | { |
691 | char * path = (char *)SvPV(ST(0),na); |
692 | bool RETVAL; |
693 | |
694 | RETVAL = sys_chdir(path); |
695 | ST(0) = RETVAL ? &sv_yes : &sv_no; |
696 | if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); |
697 | } |
698 | XSRETURN(1); |
699 | } |
700 | |
701 | XS(XS_Cwd_change_drive) |
702 | { |
703 | dXSARGS; |
704 | if (items != 1) |
705 | croak("Usage: Cwd::change_drive(d)"); |
706 | { |
707 | char d = (char)*SvPV(ST(0),na); |
708 | bool RETVAL; |
709 | |
710 | RETVAL = change_drive(d); |
711 | ST(0) = RETVAL ? &sv_yes : &sv_no; |
712 | if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); |
713 | } |
714 | XSRETURN(1); |
715 | } |
716 | |
717 | XS(XS_Cwd_sys_is_absolute) |
718 | { |
719 | dXSARGS; |
720 | if (items != 1) |
721 | croak("Usage: Cwd::sys_is_absolute(path)"); |
722 | { |
723 | char * path = (char *)SvPV(ST(0),na); |
724 | bool RETVAL; |
725 | |
726 | RETVAL = sys_is_absolute(path); |
727 | ST(0) = RETVAL ? &sv_yes : &sv_no; |
728 | if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); |
729 | } |
730 | XSRETURN(1); |
731 | } |
732 | |
733 | XS(XS_Cwd_sys_is_rooted) |
734 | { |
735 | dXSARGS; |
736 | if (items != 1) |
737 | croak("Usage: Cwd::sys_is_rooted(path)"); |
738 | { |
739 | char * path = (char *)SvPV(ST(0),na); |
740 | bool RETVAL; |
741 | |
742 | RETVAL = sys_is_rooted(path); |
743 | ST(0) = RETVAL ? &sv_yes : &sv_no; |
744 | if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); |
745 | } |
746 | XSRETURN(1); |
747 | } |
748 | |
749 | XS(XS_Cwd_sys_is_relative) |
750 | { |
751 | dXSARGS; |
752 | if (items != 1) |
753 | croak("Usage: Cwd::sys_is_relative(path)"); |
754 | { |
755 | char * path = (char *)SvPV(ST(0),na); |
756 | bool RETVAL; |
757 | |
758 | RETVAL = sys_is_relative(path); |
759 | ST(0) = RETVAL ? &sv_yes : &sv_no; |
760 | if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); |
761 | } |
762 | XSRETURN(1); |
763 | } |
764 | |
765 | XS(XS_Cwd_sys_cwd) |
766 | { |
767 | dXSARGS; |
768 | if (items != 0) |
769 | croak("Usage: Cwd::sys_cwd()"); |
770 | { |
771 | char p[MAXPATHLEN]; |
772 | char * RETVAL; |
773 | RETVAL = _getcwd2(p, MAXPATHLEN); |
774 | ST(0) = sv_newmortal(); |
775 | sv_setpv((SV*)ST(0), RETVAL); |
776 | } |
777 | XSRETURN(1); |
778 | } |
779 | |
780 | XS(XS_Cwd_sys_abspath) |
781 | { |
782 | dXSARGS; |
783 | if (items < 1 || items > 2) |
784 | croak("Usage: Cwd::sys_abspath(path, dir = NULL)"); |
785 | { |
786 | char * path = (char *)SvPV(ST(0),na); |
787 | char * dir; |
788 | char p[MAXPATHLEN]; |
789 | char * RETVAL; |
790 | |
791 | if (items < 2) |
792 | dir = NULL; |
793 | else { |
794 | dir = (char *)SvPV(ST(1),na); |
795 | } |
796 | if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) { |
797 | path += 2; |
798 | } |
799 | if (dir == NULL) { |
800 | if (_abspath(p, path, MAXPATHLEN) == 0) { |
801 | RETVAL = p; |
802 | } else { |
803 | RETVAL = NULL; |
804 | } |
805 | } else { |
806 | /* Absolute with drive: */ |
807 | if ( sys_is_absolute(path) ) { |
808 | if (_abspath(p, path, MAXPATHLEN) == 0) { |
809 | RETVAL = p; |
810 | } else { |
811 | RETVAL = NULL; |
812 | } |
813 | } else if (path[0] == '/' || path[0] == '\\') { |
814 | /* Rooted, but maybe on different drive. */ |
815 | if (isALPHA(dir[0]) && dir[1] == ':' ) { |
816 | char p1[MAXPATHLEN]; |
817 | |
818 | /* Need to prepend the drive. */ |
819 | p1[0] = dir[0]; |
820 | p1[1] = dir[1]; |
821 | Copy(path, p1 + 2, strlen(path) + 1, char); |
822 | RETVAL = p; |
823 | if (_abspath(p, p1, MAXPATHLEN) == 0) { |
824 | RETVAL = p; |
825 | } else { |
826 | RETVAL = NULL; |
827 | } |
828 | } else if (_abspath(p, path, MAXPATHLEN) == 0) { |
829 | RETVAL = p; |
830 | } else { |
831 | RETVAL = NULL; |
832 | } |
833 | } else { |
834 | /* Either path is relative, or starts with a drive letter. */ |
835 | /* If the path starts with a drive letter, then dir is |
836 | relevant only if |
837 | a/b) it is absolute/x:relative on the same drive. |
838 | c) path is on current drive, and dir is rooted |
839 | In all the cases it is safe to drop the drive part |
840 | of the path. */ |
841 | if ( !sys_is_relative(path) ) { |
842 | int is_drived; |
843 | |
844 | if ( ( ( sys_is_absolute(dir) |
845 | || (isALPHA(dir[0]) && dir[1] == ':' |
846 | && strnicmp(dir, path,1) == 0)) |
847 | && strnicmp(dir, path,1) == 0) |
848 | || ( !(isALPHA(dir[0]) && dir[1] == ':') |
849 | && toupper(path[0]) == current_drive())) { |
850 | path += 2; |
851 | } else if (_abspath(p, path, MAXPATHLEN) == 0) { |
852 | RETVAL = p; goto done; |
853 | } else { |
854 | RETVAL = NULL; goto done; |
855 | } |
856 | } |
857 | { |
858 | /* Need to prepend the absolute path of dir. */ |
859 | char p1[MAXPATHLEN]; |
860 | |
861 | if (_abspath(p1, dir, MAXPATHLEN) == 0) { |
862 | int l = strlen(p1); |
863 | |
864 | if (p1[ l - 1 ] != '/') { |
865 | p1[ l ] = '/'; |
866 | l++; |
867 | } |
868 | Copy(path, p1 + l, strlen(path) + 1, char); |
869 | if (_abspath(p, p1, MAXPATHLEN) == 0) { |
870 | RETVAL = p; |
871 | } else { |
872 | RETVAL = NULL; |
873 | } |
874 | } else { |
875 | RETVAL = NULL; |
876 | } |
877 | } |
878 | done: |
879 | } |
880 | } |
881 | ST(0) = sv_newmortal(); |
882 | sv_setpv((SV*)ST(0), RETVAL); |
883 | } |
884 | XSRETURN(1); |
885 | } |
886 | |
887 | #define extLibpath(type) \ |
888 | (CheckOSError(DosQueryExtLIBPATH(to, ((type) ? END_LIBPATH \ |
889 | : BEGIN_LIBPATH))) \ |
890 | ? NULL : to ) |
891 | |
892 | #define extLibpath_set(p,type) \ |
893 | (!CheckOSError(DosSetExtLIBPATH((p), ((type) ? END_LIBPATH \ |
894 | : BEGIN_LIBPATH)))) |
895 | |
896 | XS(XS_Cwd_extLibpath) |
897 | { |
898 | dXSARGS; |
899 | if (items < 0 || items > 1) |
900 | croak("Usage: Cwd::extLibpath(type = 0)"); |
901 | { |
902 | bool type; |
903 | char to[1024]; |
904 | U32 rc; |
905 | char * RETVAL; |
906 | |
907 | if (items < 1) |
908 | type = 0; |
909 | else { |
910 | type = (int)SvIV(ST(0)); |
911 | } |
912 | |
913 | RETVAL = extLibpath(type); |
914 | ST(0) = sv_newmortal(); |
915 | sv_setpv((SV*)ST(0), RETVAL); |
916 | } |
917 | XSRETURN(1); |
918 | } |
919 | |
920 | XS(XS_Cwd_extLibpath_set) |
921 | { |
922 | dXSARGS; |
923 | if (items < 1 || items > 2) |
924 | croak("Usage: Cwd::extLibpath_set(s, type = 0)"); |
925 | { |
926 | char * s = (char *)SvPV(ST(0),na); |
927 | bool type; |
928 | U32 rc; |
929 | bool RETVAL; |
930 | |
931 | if (items < 2) |
932 | type = 0; |
933 | else { |
934 | type = (int)SvIV(ST(1)); |
935 | } |
936 | |
937 | RETVAL = extLibpath_set(s, type); |
938 | ST(0) = RETVAL ? &sv_yes : &sv_no; |
939 | if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); |
940 | } |
941 | XSRETURN(1); |
942 | } |
943 | |
944 | int |
945 | Xs_OS2_init() |
946 | { |
947 | char *file = __FILE__; |
948 | { |
949 | GV *gv; |
950 | |
951 | newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file); |
952 | newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file); |
953 | newXS("Cwd::current_drive", XS_Cwd_current_drive, file); |
954 | newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file); |
955 | newXS("Cwd::change_drive", XS_Cwd_change_drive, file); |
956 | newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file); |
957 | newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file); |
958 | newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file); |
959 | newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file); |
960 | newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file); |
961 | newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file); |
962 | newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file); |
963 | gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV); |
964 | GvMULTI_on(gv); |
965 | #ifdef PERL_IS_AOUT |
966 | sv_setiv(GvSV(gv), 1); |
967 | #endif |
968 | } |
969 | } |
970 | |
971 | OS2_Perl_data_t OS2_Perl_data; |
972 | |
973 | void |
974 | Perl_OS2_init() |
975 | { |
976 | char *shell; |
977 | |
978 | settmppath(); |
979 | OS2_Perl_data.xs_init = &Xs_OS2_init; |
980 | if ( (shell = getenv("PERL_SH_DRIVE")) ) { |
981 | sh_path[0] = shell[0]; |
982 | } else if ( (shell = getenv("PERL_SH_DIR")) ) { |
983 | int l = strlen(shell); |
984 | if (shell[l-1] == '/' || shell[l-1] == '\\') { |
985 | l--; |
986 | } |
987 | if (l > STATIC_FILE_LENGTH - 7) { |
988 | die("PERL_SH_DIR too long"); |
989 | } |
990 | strncpy(sh_path, shell, l); |
991 | strcpy(sh_path + l, "/sh.exe"); |
992 | } |
993 | } |
994 | |