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