5.003_08: OS/2-specific bugs/enhancements
[perl.git] / os2 / os2.c
1 #define INCL_DOS
2 #define INCL_NOPM
3 #define INCL_DOSFILEMGR
4 #define INCL_DOSMEMMGR
5 #define INCL_DOSERRORS
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 #include <fcntl.h>
17
18 #include "EXTERN.h"
19 #include "perl.h"
20
21 /*****************************************************************************/
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
47 /* priorities */
48 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
49                                                self inverse. */
50 #define QSS_INI_BUFFER 1024
51
52 PQTOPLEVEL
53 get_sysinfo(ULONG pid, ULONG flags)
54 {
55     char *pbuffer;
56     ULONG rc, buf_len = QSS_INI_BUFFER;
57
58     New(1022, pbuffer, buf_len, char);
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);
63         rc = QuerySysState(QSS_PROCESS, pid, pbuffer, buf_len);
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
102   if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
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; */
135 }
136
137 int 
138 getpriority(int which /* ignored */, int pid)
139 {
140   TIB *tib;
141   PIB *pib;
142   ULONG rc, ret;
143
144   if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
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);
155 }
156
157 /*****************************************************************************/
158 /* spawn */
159 typedef void (*Sigfunc) _((int));
160
161 static
162 Sigfunc rsignal(signo,handler)
163 int signo;
164 Sigfunc handler;
165 {
166     struct sigaction act,oact;
167     
168     act.sa_handler = handler;
169     sigemptyset(&act.sa_mask);
170     act.sa_flags = 0;
171     if (sigaction(signo, &act, &oact) < 0)
172         return(SIG_ERR);
173     else
174         return(oact.sa_handler);
175 }
176
177 static int
178 result(int flag, int pid)
179 {
180         int r, status;
181         Signal_t (*ihand)();     /* place to save signal during system() */
182         Signal_t (*qhand)();     /* place to save signal during system() */
183 #ifndef __EMX__
184         RESULTCODES res;
185         int rpid;
186 #endif
187
188         if (pid < 0 || flag != 0)
189                 return pid;
190
191 #ifdef __EMX__
192         ihand = rsignal(SIGINT, SIG_IGN);
193         qhand = rsignal(SIGQUIT, SIG_IGN);
194         do {
195             r = wait4pid(pid, &status, 0);
196         } while (r == -1 && errno == EINTR);
197         rsignal(SIGINT, ihand);
198         rsignal(SIGQUIT, qhand);
199
200         statusvalue = (U16)status;
201         if (r < 0)
202                 return -1;
203         return status & 0xFFFF;
204 #else
205         ihand = rsignal(SIGINT, SIG_IGN);
206         r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
207         rsignal(SIGINT, ihand);
208         statusvalue = res.codeResult << 8 | res.codeTerminate;
209         if (r)
210                 return -1;
211         return statusvalue;
212 #endif
213 }
214
215 int
216 do_aspawn(really,mark,sp)
217 SV *really;
218 register SV **mark;
219 register SV **sp;
220 {
221     register char **a;
222     char *tmps;
223     int rc;
224     int flag = P_WAIT, trueflag;
225
226     if (sp > mark) {
227         New(401,Argv, sp - mark + 1, char*);
228         a = Argv;
229
230         if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
231                 ++mark;
232                 flag = SvIVx(*mark);
233         }
234
235         while (++mark <= sp) {
236             if (*mark)
237                 *a++ = SvPVx(*mark, na);
238             else
239                 *a++ = "";
240         }
241         *a = Nullch;
242
243         trueflag = flag;
244         if (flag == P_WAIT)
245                 flag = P_NOWAIT;
246
247         if (strEQ(Argv[0],"/bin/sh")) Argv[0] = SH_PATH;
248
249         if (Argv[0][0] != '/' && Argv[0][0] != '\\'
250             && !(Argv[0][0] && Argv[0][1] == ':' 
251                  && (Argv[0][2] == '/' || Argv[0][2] != '\\'))
252             ) /* will swawnvp use PATH? */
253             TAINT_ENV();        /* testing IFS here is overkill, probably */
254         /* We should check PERL_SH* and PERLLIB_* as well? */
255         if (really && *(tmps = SvPV(really, na)))
256             rc = result(trueflag, spawnvp(flag,tmps,Argv));
257         else
258             rc = result(trueflag, spawnvp(flag,Argv[0],Argv));
259
260         if (rc < 0 && dowarn)
261             warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
262         if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
263     } else
264         rc = -1;
265     do_execfree();
266     return rc;
267 }
268
269 #define EXECF_SPAWN 0
270 #define EXECF_EXEC 1
271 #define EXECF_TRUEEXEC 2
272 #define EXECF_SPAWN_NOWAIT 3
273
274 int
275 do_spawn2(cmd, execf)
276 char *cmd;
277 int execf;
278 {
279     register char **a;
280     register char *s;
281     char flags[10];
282     char *shell, *copt, *news = NULL;
283     int rc;
284
285 #ifdef TRYSHELL
286     if ((shell = getenv("EMXSHELL")) != NULL)
287         copt = "-c";
288     else if ((shell = getenv("SHELL")) != NULL)
289         copt = "-c";
290     else if ((shell = getenv("COMSPEC")) != NULL)
291         copt = "/C";
292     else
293         shell = "cmd.exe";
294 #else
295     /* Consensus on perl5-porters is that it is _very_ important to
296        have a shell which will not change between computers with the
297        same architecture, to avoid "action on a distance". 
298        And to have simple build, this shell should be sh. */
299     shell = SH_PATH;
300     copt = "-c";
301 #endif 
302
303     while (*cmd && isSPACE(*cmd))
304         cmd++;
305
306     if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
307         STRLEN l = strlen(SH_PATH);
308         
309         New(4545, news, strlen(cmd) - 7 + l, char);
310         strcpy(news, SH_PATH);
311         strcpy(news + l, cmd + 7);
312         cmd = news;
313     }
314
315     /* save an extra exec if possible */
316     /* see if there are shell metacharacters in it */
317
318     if (*cmd == '.' && isSPACE(cmd[1]))
319         goto doshell;
320
321     if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
322         goto doshell;
323
324     for (s = cmd; *s && isALPHA(*s); s++) ;     /* catch VAR=val gizmo */
325     if (*s == '=')
326         goto doshell;
327
328     for (s = cmd; *s; s++) {
329         if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
330             if (*s == '\n' && s[1] == '\0') {
331                 *s = '\0';
332                 break;
333             }
334           doshell:
335             if (execf == EXECF_TRUEEXEC)
336                 return execl(shell,shell,copt,cmd,(char*)0);
337             else if (execf == EXECF_EXEC)
338                 return spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
339             else if (execf == EXECF_SPAWN_NOWAIT)
340                 return spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
341             /* In the ak code internal P_NOWAIT is P_WAIT ??? */
342             rc = result(P_WAIT,
343                         spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
344             if (rc < 0 && dowarn)
345                 warn("Can't %s \"%s\": %s", 
346                      (execf == EXECF_SPAWN ? "spawn" : "exec"),
347                      shell, Strerror(errno));
348             if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
349             if (news) Safefree(news);
350             return rc;
351         }
352     }
353
354     New(402,Argv, (s - cmd) / 2 + 2, char*);
355     Cmd = savepvn(cmd, s-cmd);
356     a = Argv;
357     for (s = Cmd; *s;) {
358         while (*s && isSPACE(*s)) s++;
359         if (*s)
360             *(a++) = s;
361         while (*s && !isSPACE(*s)) s++;
362         if (*s)
363             *s++ = '\0';
364     }
365     *a = Nullch;
366     if (Argv[0]) {
367         if (execf == EXECF_TRUEEXEC)
368             rc = execvp(Argv[0],Argv);
369         else if (execf == EXECF_EXEC)
370             rc = spawnvp(P_OVERLAY,Argv[0],Argv);
371         else if (execf == EXECF_SPAWN_NOWAIT)
372             rc = spawnvp(P_NOWAIT,Argv[0],Argv);
373         else
374             rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv));
375         if (rc < 0 && dowarn)
376             warn("Can't %s \"%s\": %s", 
377                  (execf == EXECF_SPAWN ? "spawn" : "exec"),
378                  Argv[0], Strerror(errno));
379         if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
380     } else
381         rc = -1;
382     if (news) Safefree(news);
383     do_execfree();
384     return rc;
385 }
386
387 int
388 do_spawn(cmd)
389 char *cmd;
390 {
391     return do_spawn2(cmd, EXECF_SPAWN);
392 }
393
394 int
395 do_spawn_nowait(cmd)
396 char *cmd;
397 {
398     return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
399 }
400
401 bool
402 do_exec(cmd)
403 char *cmd;
404 {
405     return do_spawn2(cmd, EXECF_EXEC);
406 }
407
408 bool
409 os2exec(cmd)
410 char *cmd;
411 {
412     return do_spawn2(cmd, EXECF_TRUEEXEC);
413 }
414
415 PerlIO *
416 my_syspopen(cmd,mode)
417 char    *cmd;
418 char    *mode;
419 {
420 #ifndef USE_POPEN
421
422     int p[2];
423     register I32 this, that, newfd;
424     register I32 pid, rc;
425     PerlIO *res;
426     SV *sv;
427     
428     if (pipe(p) < 0)
429         return Nullfp;
430     /* `this' is what we use in the parent, `that' in the child. */
431     this = (*mode == 'w');
432     that = !this;
433     if (tainting) {
434         taint_env();
435         taint_proper("Insecure %s%s", "EXEC");
436     }
437     /* Now we need to spawn the child. */
438     newfd = dup(*mode == 'r');          /* Preserve std* */
439     if (p[that] != (*mode == 'r')) {
440         dup2(p[that], *mode == 'r');
441         close(p[that]);
442     }
443     /* Where is `this' and newfd now? */
444     fcntl(p[this], F_SETFD, FD_CLOEXEC);
445     fcntl(newfd, F_SETFD, FD_CLOEXEC);
446     pid = do_spawn_nowait(cmd);
447     if (newfd != (*mode == 'r')) {
448         dup2(newfd, *mode == 'r');      /* Return std* back. */
449         close(newfd);
450     }
451     close(p[that]);
452     if (pid == -1) {
453         close(p[this]);
454         return NULL;
455     }
456     if (p[that] < p[this]) {
457         dup2(p[this], p[that]);
458         close(p[this]);
459         p[this] = p[that];
460     }
461     sv = *av_fetch(fdpid,p[this],TRUE);
462     (void)SvUPGRADE(sv,SVt_IV);
463     SvIVX(sv) = pid;
464     forkprocess = pid;
465     return PerlIO_fdopen(p[this], mode);
466
467 #else  /* USE_POPEN */
468
469     PerlIO *res;
470     SV *sv;
471
472 #  ifdef TRYSHELL
473     res = popen(cmd, mode);
474 #  else
475     char *shell = getenv("EMXSHELL");
476
477     my_setenv("EMXSHELL", SH_PATH);
478     res = popen(cmd, mode);
479     my_setenv("EMXSHELL", shell);
480 #  endif 
481     sv = *av_fetch(fdpid, PerlIO_fileno(res), TRUE);
482     (void)SvUPGRADE(sv,SVt_IV);
483     SvIVX(sv) = -1;                     /* A cooky. */
484     return res;
485
486 #endif /* USE_POPEN */
487
488 }
489
490 /******************************************************************/
491
492 #ifndef HAS_FORK
493 int
494 fork(void)
495 {
496     die(no_func, "Unsupported function fork");
497     errno = EINVAL;
498     return -1;
499 }
500 #endif
501
502 /*******************************************************************/
503 /* not implemented in EMX 0.9a */
504
505 void *  ctermid(x)      { return 0; }
506
507 #ifdef MYTTYNAME /* was not in emx0.9a */
508 void *  ttyname(x)      { return 0; }
509 #endif
510
511 /******************************************************************/
512 /* my socket forwarders - EMX lib only provides static forwarders */
513
514 static HMODULE htcp = 0;
515
516 static void *
517 tcp0(char *name)
518 {
519     static BYTE buf[20];
520     PFN fcn;
521
522     if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
523     if (!htcp)
524         DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
525     if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
526         return (void *) ((void * (*)(void)) fcn) ();
527     return 0;
528 }
529
530 static void
531 tcp1(char *name, int arg)
532 {
533     static BYTE buf[20];
534     PFN fcn;
535
536     if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
537     if (!htcp)
538         DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
539     if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
540         ((void (*)(int)) fcn) (arg);
541 }
542
543 void *  gethostent()    { return tcp0("GETHOSTENT");  }
544 void *  getnetent()     { return tcp0("GETNETENT");   }
545 void *  getprotoent()   { return tcp0("GETPROTOENT"); }
546 void *  getservent()    { return tcp0("GETSERVENT");  }
547 void    sethostent(x)   { tcp1("SETHOSTENT",  x); }
548 void    setnetent(x)    { tcp1("SETNETENT",   x); }
549 void    setprotoent(x)  { tcp1("SETPROTOENT", x); }
550 void    setservent(x)   { tcp1("SETSERVENT",  x); }
551 void    endhostent()    { tcp0("ENDHOSTENT");  }
552 void    endnetent()     { tcp0("ENDNETENT");   }
553 void    endprotoent()   { tcp0("ENDPROTOENT"); }
554 void    endservent()    { tcp0("ENDSERVENT");  }
555
556 /*****************************************************************************/
557 /* not implemented in C Set++ */
558
559 #ifndef __EMX__
560 int     setuid(x)       { errno = EINVAL; return -1; }
561 int     setgid(x)       { errno = EINVAL; return -1; }
562 #endif
563
564 /*****************************************************************************/
565 /* stat() hack for char/block device */
566
567 #if OS2_STAT_HACK
568
569     /* First attempt used DosQueryFSAttach which crashed the system when
570        used with 5.001. Now just look for /dev/. */
571
572 int
573 os2_stat(char *name, struct stat *st)
574 {
575     static int ino = SHRT_MAX;
576
577     if (stricmp(name, "/dev/con") != 0
578      && stricmp(name, "/dev/tty") != 0)
579         return stat(name, st);
580
581     memset(st, 0, sizeof *st);
582     st->st_mode = S_IFCHR|0666;
583     st->st_ino = (ino-- & 0x7FFF);
584     st->st_nlink = 1;
585     return 0;
586 }
587
588 #endif
589
590 #ifdef USE_PERL_SBRK
591
592 /* SBRK() emulation, mostly moved to malloc.c. */
593
594 void *
595 sys_alloc(int size) {
596     void *got;
597     APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
598
599     if (rc == ERROR_NOT_ENOUGH_MEMORY) {
600         return (void *) -1;
601     } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
602     return got;
603 }
604
605 #endif /* USE_PERL_SBRK */
606
607 /* tmp path */
608
609 char *tmppath = TMPPATH1;
610
611 void
612 settmppath()
613 {
614     char *p = getenv("TMP"), *tpath;
615     int len;
616
617     if (!p) p = getenv("TEMP");
618     if (!p) return;
619     len = strlen(p);
620     tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
621     strcpy(tpath, p);
622     tpath[len] = '/';
623     strcpy(tpath + len + 1, TMPPATH1);
624     tmppath = tpath;
625 }
626
627 #include "XSUB.h"
628
629 XS(XS_File__Copy_syscopy)
630 {
631     dXSARGS;
632     if (items < 2 || items > 3)
633         croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
634     {
635         char *  src = (char *)SvPV(ST(0),na);
636         char *  dst = (char *)SvPV(ST(1),na);
637         U32     flag;
638         int     RETVAL, rc;
639
640         if (items < 3)
641             flag = 0;
642         else {
643             flag = (unsigned long)SvIV(ST(2));
644         }
645
646         RETVAL = !CheckOSError(DosCopy(src, dst, flag));
647         ST(0) = sv_newmortal();
648         sv_setiv(ST(0), (IV)RETVAL);
649     }
650     XSRETURN(1);
651 }
652
653 char *
654 mod2fname(sv)
655      SV   *sv;
656 {
657     static char fname[9];
658     int pos = 6, len, avlen;
659     unsigned int sum = 0;
660     AV  *av;
661     SV  *svp;
662     char *s;
663
664     if (!SvROK(sv)) croak("Not a reference given to mod2fname");
665     sv = SvRV(sv);
666     if (SvTYPE(sv) != SVt_PVAV) 
667       croak("Not array reference given to mod2fname");
668
669     avlen = av_len((AV*)sv);
670     if (avlen < 0) 
671       croak("Empty array reference given to mod2fname");
672
673     s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
674     strncpy(fname, s, 8);
675     len = strlen(s);
676     if (len < 6) pos = len;
677     while (*s) {
678         sum = 33 * sum + *(s++);        /* Checksumming first chars to
679                                          * get the capitalization into c.s. */
680     }
681     avlen --;
682     while (avlen >= 0) {
683         s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
684         while (*s) {
685             sum = 33 * sum + *(s++);    /* 7 is primitive mod 13. */
686         }
687         avlen --;
688     }
689     fname[pos] = 'A' + (sum % 26);
690     fname[pos + 1] = 'A' + (sum / 26 % 26);
691     fname[pos + 2] = '\0';
692     return (char *)fname;
693 }
694
695 XS(XS_DynaLoader_mod2fname)
696 {
697     dXSARGS;
698     if (items != 1)
699         croak("Usage: DynaLoader::mod2fname(sv)");
700     {
701         SV *    sv = ST(0);
702         char *  RETVAL;
703
704         RETVAL = mod2fname(sv);
705         ST(0) = sv_newmortal();
706         sv_setpv((SV*)ST(0), RETVAL);
707     }
708     XSRETURN(1);
709 }
710
711 char *
712 os2error(int rc)
713 {
714         static char buf[300];
715         ULONG len;
716
717         if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
718         if (rc == 0)
719                 return NULL;
720         if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
721                 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
722         else
723                 buf[len] = '\0';
724         return buf;
725 }
726
727 char sh_path[STATIC_FILE_LENGTH+1] = SH_PATH_INI;
728
729 char *
730 perllib_mangle(char *s, unsigned int l)
731 {
732     static char *newp, *oldp;
733     static int newl, oldl, notfound;
734     static char ret[STATIC_FILE_LENGTH+1];
735     
736     if (!newp && !notfound) {
737         newp = getenv("PERLLIB_PREFIX");
738         if (newp) {
739             oldp = newp;
740             while (*newp && !isSPACE(*newp) && *newp != ';') {
741                 newp++; oldl++;         /* Skip digits. */
742             }
743             while (*newp && (isSPACE(*newp) || *newp == ';')) {
744                 newp++;                 /* Skip whitespace. */
745             }
746             newl = strlen(newp);
747             if (newl == 0 || oldl == 0) {
748                 die("Malformed PERLLIB_PREFIX");
749             }
750         } else {
751             notfound = 1;
752         }
753     }
754     if (!newp) {
755         return s;
756     }
757     if (l == 0) {
758         l = strlen(s);
759     }
760     if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
761         return s;
762     }
763     if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
764         die("Malformed PERLLIB_PREFIX");
765     }
766     strncpy(ret, newp, newl);
767     strcpy(ret + newl, s + oldl);
768     return ret;
769 }
770
771 extern void dlopen();
772 void *fakedl = &dlopen;         /* Pull in dynaloading part. */
773
774 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
775                                 && ((path)[2] == '/' || (path)[2] == '\\'))
776 #define sys_is_rooted _fnisabs
777 #define sys_is_relative _fnisrel
778 #define current_drive _getdrive
779
780 #undef chdir                            /* Was _chdir2. */
781 #define sys_chdir(p) (chdir(p) == 0)
782 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
783
784 XS(XS_Cwd_current_drive)
785 {
786     dXSARGS;
787     if (items != 0)
788         croak("Usage: Cwd::current_drive()");
789     {
790         char    RETVAL;
791
792         RETVAL = current_drive();
793         ST(0) = sv_newmortal();
794         sv_setpvn(ST(0), (char *)&RETVAL, 1);
795     }
796     XSRETURN(1);
797 }
798
799 XS(XS_Cwd_sys_chdir)
800 {
801     dXSARGS;
802     if (items != 1)
803         croak("Usage: Cwd::sys_chdir(path)");
804     {
805         char *  path = (char *)SvPV(ST(0),na);
806         bool    RETVAL;
807
808         RETVAL = sys_chdir(path);
809         ST(0) = RETVAL ? &sv_yes : &sv_no;
810         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
811     }
812     XSRETURN(1);
813 }
814
815 XS(XS_Cwd_change_drive)
816 {
817     dXSARGS;
818     if (items != 1)
819         croak("Usage: Cwd::change_drive(d)");
820     {
821         char    d = (char)*SvPV(ST(0),na);
822         bool    RETVAL;
823
824         RETVAL = change_drive(d);
825         ST(0) = RETVAL ? &sv_yes : &sv_no;
826         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
827     }
828     XSRETURN(1);
829 }
830
831 XS(XS_Cwd_sys_is_absolute)
832 {
833     dXSARGS;
834     if (items != 1)
835         croak("Usage: Cwd::sys_is_absolute(path)");
836     {
837         char *  path = (char *)SvPV(ST(0),na);
838         bool    RETVAL;
839
840         RETVAL = sys_is_absolute(path);
841         ST(0) = RETVAL ? &sv_yes : &sv_no;
842         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
843     }
844     XSRETURN(1);
845 }
846
847 XS(XS_Cwd_sys_is_rooted)
848 {
849     dXSARGS;
850     if (items != 1)
851         croak("Usage: Cwd::sys_is_rooted(path)");
852     {
853         char *  path = (char *)SvPV(ST(0),na);
854         bool    RETVAL;
855
856         RETVAL = sys_is_rooted(path);
857         ST(0) = RETVAL ? &sv_yes : &sv_no;
858         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
859     }
860     XSRETURN(1);
861 }
862
863 XS(XS_Cwd_sys_is_relative)
864 {
865     dXSARGS;
866     if (items != 1)
867         croak("Usage: Cwd::sys_is_relative(path)");
868     {
869         char *  path = (char *)SvPV(ST(0),na);
870         bool    RETVAL;
871
872         RETVAL = sys_is_relative(path);
873         ST(0) = RETVAL ? &sv_yes : &sv_no;
874         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
875     }
876     XSRETURN(1);
877 }
878
879 XS(XS_Cwd_sys_cwd)
880 {
881     dXSARGS;
882     if (items != 0)
883         croak("Usage: Cwd::sys_cwd()");
884     {
885         char p[MAXPATHLEN];
886         char *  RETVAL;
887         RETVAL = _getcwd2(p, MAXPATHLEN);
888         ST(0) = sv_newmortal();
889         sv_setpv((SV*)ST(0), RETVAL);
890     }
891     XSRETURN(1);
892 }
893
894 XS(XS_Cwd_sys_abspath)
895 {
896     dXSARGS;
897     if (items < 1 || items > 2)
898         croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
899     {
900         char *  path = (char *)SvPV(ST(0),na);
901         char *  dir;
902         char p[MAXPATHLEN];
903         char *  RETVAL;
904
905         if (items < 2)
906             dir = NULL;
907         else {
908             dir = (char *)SvPV(ST(1),na);
909         }
910         if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
911             path += 2;
912         }
913         if (dir == NULL) {
914             if (_abspath(p, path, MAXPATHLEN) == 0) {
915                 RETVAL = p;
916             } else {
917                 RETVAL = NULL;
918             }
919         } else {
920             /* Absolute with drive: */
921             if ( sys_is_absolute(path) ) {
922                 if (_abspath(p, path, MAXPATHLEN) == 0) {
923                     RETVAL = p;
924                 } else {
925                     RETVAL = NULL;
926                 }
927             } else if (path[0] == '/' || path[0] == '\\') {
928                 /* Rooted, but maybe on different drive. */
929                 if (isALPHA(dir[0]) && dir[1] == ':' ) {
930                     char p1[MAXPATHLEN];
931
932                     /* Need to prepend the drive. */
933                     p1[0] = dir[0];
934                     p1[1] = dir[1];
935                     Copy(path, p1 + 2, strlen(path) + 1, char);
936                     RETVAL = p;
937                     if (_abspath(p, p1, MAXPATHLEN) == 0) {
938                         RETVAL = p;
939                     } else {
940                         RETVAL = NULL;
941                     }
942                 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
943                     RETVAL = p;
944                 } else {
945                     RETVAL = NULL;
946                 }
947             } else {
948                 /* Either path is relative, or starts with a drive letter. */
949                 /* If the path starts with a drive letter, then dir is
950                    relevant only if 
951                    a/b) it is absolute/x:relative on the same drive.  
952                    c)   path is on current drive, and dir is rooted
953                    In all the cases it is safe to drop the drive part
954                    of the path. */
955                 if ( !sys_is_relative(path) ) {
956                     int is_drived;
957
958                     if ( ( ( sys_is_absolute(dir)
959                              || (isALPHA(dir[0]) && dir[1] == ':' 
960                                  && strnicmp(dir, path,1) == 0)) 
961                            && strnicmp(dir, path,1) == 0)
962                          || ( !(isALPHA(dir[0]) && dir[1] == ':')
963                               && toupper(path[0]) == current_drive())) {
964                         path += 2;
965                     } else if (_abspath(p, path, MAXPATHLEN) == 0) {
966                         RETVAL = p; goto done;
967                     } else {
968                         RETVAL = NULL; goto done;
969                     }
970                 }
971                 {
972                     /* Need to prepend the absolute path of dir. */
973                     char p1[MAXPATHLEN];
974
975                     if (_abspath(p1, dir, MAXPATHLEN) == 0) {
976                         int l = strlen(p1);
977
978                         if (p1[ l - 1 ] != '/') {
979                             p1[ l ] = '/';
980                             l++;
981                         }
982                         Copy(path, p1 + l, strlen(path) + 1, char);
983                         if (_abspath(p, p1, MAXPATHLEN) == 0) {
984                             RETVAL = p;
985                         } else {
986                             RETVAL = NULL;
987                         }
988                     } else {
989                         RETVAL = NULL;
990                     }
991                 }
992               done:
993             }
994         }
995         ST(0) = sv_newmortal();
996         sv_setpv((SV*)ST(0), RETVAL);
997     }
998     XSRETURN(1);
999 }
1000 typedef APIRET (*PELP)(PSZ path, ULONG type);
1001
1002 APIRET
1003 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1004 {
1005     loadByOrd(ord);                     /* Guarantied to load or die! */
1006     return (*(PELP)ExtFCN[ord])(path, type);
1007 }
1008
1009 #define extLibpath(type)                                                \
1010     (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH   \
1011                                                  : BEGIN_LIBPATH)))     \
1012      ? NULL : to )
1013
1014 #define extLibpath_set(p,type)                                  \
1015     (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH   \
1016                                                  : BEGIN_LIBPATH))))
1017
1018 XS(XS_Cwd_extLibpath)
1019 {
1020     dXSARGS;
1021     if (items < 0 || items > 1)
1022         croak("Usage: Cwd::extLibpath(type = 0)");
1023     {
1024         bool    type;
1025         char    to[1024];
1026         U32     rc;
1027         char *  RETVAL;
1028
1029         if (items < 1)
1030             type = 0;
1031         else {
1032             type = (int)SvIV(ST(0));
1033         }
1034
1035         RETVAL = extLibpath(type);
1036         ST(0) = sv_newmortal();
1037         sv_setpv((SV*)ST(0), RETVAL);
1038     }
1039     XSRETURN(1);
1040 }
1041
1042 XS(XS_Cwd_extLibpath_set)
1043 {
1044     dXSARGS;
1045     if (items < 1 || items > 2)
1046         croak("Usage: Cwd::extLibpath_set(s, type = 0)");
1047     {
1048         char *  s = (char *)SvPV(ST(0),na);
1049         bool    type;
1050         U32     rc;
1051         bool    RETVAL;
1052
1053         if (items < 2)
1054             type = 0;
1055         else {
1056             type = (int)SvIV(ST(1));
1057         }
1058
1059         RETVAL = extLibpath_set(s, type);
1060         ST(0) = RETVAL ? &sv_yes : &sv_no;
1061         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1062     }
1063     XSRETURN(1);
1064 }
1065
1066 int
1067 Xs_OS2_init()
1068 {
1069     char *file = __FILE__;
1070     {
1071         GV *gv;
1072
1073         if (_emx_env & 0x200) { /* OS/2 */
1074             newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
1075             newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
1076             newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
1077         }
1078         newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
1079         newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
1080         newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
1081         newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
1082         newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
1083         newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
1084         newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
1085         newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
1086         newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
1087         gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
1088         GvMULTI_on(gv);
1089 #ifdef PERL_IS_AOUT
1090         sv_setiv(GvSV(gv), 1);
1091 #endif 
1092     }
1093 }
1094
1095 OS2_Perl_data_t OS2_Perl_data;
1096
1097 void
1098 Perl_OS2_init()
1099 {
1100     char *shell;
1101
1102     settmppath();
1103     OS2_Perl_data.xs_init = &Xs_OS2_init;
1104     if ( (shell = getenv("PERL_SH_DRIVE")) ) {
1105         sh_path[0] = shell[0];
1106     } else if ( (shell = getenv("PERL_SH_DIR")) ) {
1107         int l = strlen(shell);
1108         if (shell[l-1] == '/' || shell[l-1] == '\\') {
1109             l--;
1110         }
1111         if (l > STATIC_FILE_LENGTH - 7) {
1112             die("PERL_SH_DIR too long");
1113         }
1114         strncpy(sh_path, shell, l);
1115         strcpy(sh_path + l, "/sh.exe");
1116     }
1117 }
1118
1119 #undef tmpnam
1120 #undef tmpfile
1121
1122 char *
1123 my_tmpnam (char *str)
1124 {
1125     char *p = getenv("TMP"), *tpath;
1126     int len;
1127
1128     if (!p) p = getenv("TEMP");
1129     tpath = tempnam(p, "pltmp");
1130     if (str && tpath) {
1131         strcpy(str, tpath);
1132         return str;
1133     }
1134     return tpath;
1135 }
1136
1137 FILE *
1138 my_tmpfile ()
1139 {
1140     struct stat s;
1141
1142     stat(".", &s);
1143     if (s.st_mode & S_IWOTH) {
1144         return tmpfile();
1145     }
1146     return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
1147                                              grants TMP. */
1148 }