perl 5.003_07: os2/os2.c
[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
17 #include "EXTERN.h"
18 #include "perl.h"
19
20 /*****************************************************************************/
21 /* priorities */
22 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
23                                                self inverse. */
24 #define QSS_INI_BUFFER 1024
25
26 PQTOPLEVEL
27 get_sysinfo(ULONG pid, ULONG flags)
28 {
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; */
108 }
109
110 int 
111 getpriority(int which /* ignored */, int pid)
112 {
113   TIB *tib;
114   PIB *pib;
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);
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() */
138 #ifndef __EMX__
139         RESULTCODES res;
140         int rpid;
141 #endif
142
143         if (pid < 0 || flag != 0)
144                 return pid;
145
146 #ifdef __EMX__
147         ihand = signal(SIGINT, SIG_IGN);
148         qhand = signal(SIGQUIT, SIG_IGN);
149         do {
150             r = wait4pid(pid, &status, 0);
151         } while (r == -1 && errno == EINTR);
152         signal(SIGINT, ihand);
153         signal(SIGQUIT, qhand);
154
155         statusvalue = (U16)status;
156         if (r < 0)
157                 return -1;
158         return status & 0xFFFF;
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
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
185         if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
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
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] != '\\'))
207             ) /* will swawnvp use PATH? */
208             TAINT_ENV();        /* testing IFS here is overkill, probably */
209         /* We should check PERL_SH* and PERLLIB_* as well? */
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));
217         if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
218     } else
219         rc = -1;
220     do_execfree();
221     return rc;
222 }
223
224 #define EXECF_SPAWN 0
225 #define EXECF_EXEC 1
226 #define EXECF_TRUEEXEC 2
227
228 int
229 do_spawn2(cmd, execf)
230 char *cmd;
231 int execf;
232 {
233     register char **a;
234     register char *s;
235     char flags[10];
236     char *shell, *copt, *news = NULL;
237     int rc;
238
239 #ifdef TRYSHELL
240     if ((shell = getenv("EMXSHELL")) != NULL)
241         copt = "-c";
242     else if ((shell = getenv("SHELL")) != NULL)
243         copt = "-c";
244     else if ((shell = getenv("COMSPEC")) != NULL)
245         copt = "/C";
246     else
247         shell = "cmd.exe";
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. */
253     shell = SH_PATH;
254     copt = "-c";
255 #endif 
256
257     while (*cmd && isSPACE(*cmd))
258         cmd++;
259
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
269     /* save an extra exec if possible */
270     /* see if there are shell metacharacters in it */
271
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
282     for (s = cmd; *s; s++) {
283         if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
284             if (*s == '\n' && s[1] == '\0') {
285                 *s = '\0';
286                 break;
287             }
288           doshell:
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 ??? */
294             rc = result(P_WAIT,
295                         spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
296             if (rc < 0 && dowarn)
297                 warn("Can't %s \"%s\": %s", 
298                      (execf == EXECF_SPAWN ? "spawn" : "exec"),
299                      shell, Strerror(errno));
300             if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
301             if (news) Safefree(news);
302             return rc;
303         }
304     }
305
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]) {
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));
325         if (rc < 0 && dowarn)
326             warn("Can't %s \"%s\": %s", 
327                  (execf == EXECF_SPAWN ? "spawn" : "exec"),
328                  Argv[0], Strerror(errno));
329         if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
330     } else
331         rc = -1;
332     if (news) Safefree(news);
333     do_execfree();
334     return rc;
335 }
336
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
358 PerlIO *
359 my_syspopen(cmd,mode)
360 char    *cmd;
361 char    *mode;
362 {
363     PerlIO *res;
364     SV *sv;
365
366 #ifdef TRYSHELL
367     res = popen(cmd, mode);
368 #else
369     char *shell = getenv("EMXSHELL");
370
371     my_setenv("EMXSHELL", SH_PATH);
372     res = popen(cmd, mode);
373     my_setenv("EMXSHELL", shell);
374 #endif 
375     sv = *av_fetch(fdpid, PerlIO_fileno(res), TRUE);
376     (void)SvUPGRADE(sv,SVt_IV);
377     SvIVX(sv) = -1;                     /* A cooky. */
378     return res;
379 }
380
381 /******************************************************************/
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
393 /*******************************************************************/
394 /* not implemented in EMX 0.9a */
395
396 void *  ctermid(x)      { return 0; }
397
398 #ifdef MYTTYNAME /* was not in emx0.9a */
399 void *  ttyname(x)      { return 0; }
400 #endif
401
402 /******************************************************************/
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
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
476
477 #ifdef USE_PERL_SBRK
478
479 /* SBRK() emulation, mostly moved to malloc.c. */
480
481 void *
482 sys_alloc(int size) {
483     void *got;
484     APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
485
486     if (rc == ERROR_NOT_ENOUGH_MEMORY) {
487         return (void *) -1;
488     } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
489     return got;
490 }
491
492 #endif /* USE_PERL_SBRK */
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 }
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
533         RETVAL = !CheckOSError(DosCopy(src, dst, flag));
534         ST(0) = sv_newmortal();
535         sv_setiv(ST(0), (IV)RETVAL);
536     }
537     XSRETURN(1);
538 }
539
540 char *
541 mod2fname(sv)
542      SV   *sv;
543 {
544     static char fname[9];
545     int pos = 6, len, avlen;
546     unsigned int sum = 0;
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");
555
556     avlen = av_len((AV*)sv);
557     if (avlen < 0) 
558       croak("Empty array reference given to mod2fname");
559
560     s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
561     strncpy(fname, s, 8);
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';
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
613 char sh_path[STATIC_FILE_LENGTH+1] = SH_PATH_INI;
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;
626             while (*newp && !isSPACE(*newp) && *newp != ';') {
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     }
646     if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
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);
653     strcpy(ret + newl, s + oldl);
654     return ret;
655 }
656
657 extern void dlopen();
658 void *fakedl = &dlopen;         /* Pull in dynaloading part. */
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