os2/os2.c

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