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