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(flags, 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 *
 728 perllib_mangle(char *s, unsigned int l)
 729 {
 730     static char *newp, *oldp;
 731     static int newl, oldl, notfound;
 732     static char ret[STATIC_FILE_LENGTH+1];
 733
 734     if (!newp && !notfound) {
 735         newp = getenv("PERLLIB_PREFIX");
 736         if (newp) {
 737             char *s;
 738
 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             strcpy(ret, newp);
 751             s = ret;
 752             while (*s) {
 753                 if (*s == '\\') *s = '/';
 754                 s++;
 755             }
 756         } else {
 757             notfound = 1;
 758         }
 759     }
 760     if (!newp) {
 761         return s;
 762     }
 763     if (l == 0) {
 764         l = strlen(s);
 765     }
 766     if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
 767         return s;
 768     }
 769     if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
 770         die("Malformed PERLLIB_PREFIX");
 771     }
 772     strcpy(ret + newl, s + oldl);
 773     return ret;
 774 }
 775
 776 extern void dlopen();
 777 void *fakedl = &dlopen;         /* Pull in dynaloading part. */
 778
 779 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
 780                                 && ((path)[2] == '/' || (path)[2] == '\\'))
 781 #define sys_is_rooted _fnisabs
 782 #define sys_is_relative _fnisrel
 783 #define current_drive _getdrive
 784
 785 #undef chdir                            /* Was _chdir2. */
 786 #define sys_chdir(p) (chdir(p) == 0)
 787 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
 788
 789 XS(XS_Cwd_current_drive)
 790 {
 791     dXSARGS;
 792     if (items != 0)
 793         croak("Usage: Cwd::current_drive()");
 794     {
 795         char    RETVAL;
 796
 797         RETVAL = current_drive();
 798         ST(0) = sv_newmortal();
 799         sv_setpvn(ST(0), (char *)&RETVAL, 1);
 800     }
 801     XSRETURN(1);
 802 }
 803
 804 XS(XS_Cwd_sys_chdir)
 805 {
 806     dXSARGS;
 807     if (items != 1)
 808         croak("Usage: Cwd::sys_chdir(path)");
 809     {
 810         char *  path = (char *)SvPV(ST(0),na);
 811         bool    RETVAL;
 812
 813         RETVAL = sys_chdir(path);
 814         ST(0) = RETVAL ? &sv_yes : &sv_no;
 815         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
 816     }
 817     XSRETURN(1);
 818 }
 819
 820 XS(XS_Cwd_change_drive)
 821 {
 822     dXSARGS;
 823     if (items != 1)
 824         croak("Usage: Cwd::change_drive(d)");
 825     {
 826         char    d = (char)*SvPV(ST(0),na);
 827         bool    RETVAL;
 828
 829         RETVAL = change_drive(d);
 830         ST(0) = RETVAL ? &sv_yes : &sv_no;
 831         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
 832     }
 833     XSRETURN(1);
 834 }
 835
 836 XS(XS_Cwd_sys_is_absolute)
 837 {
 838     dXSARGS;
 839     if (items != 1)
 840         croak("Usage: Cwd::sys_is_absolute(path)");
 841     {
 842         char *  path = (char *)SvPV(ST(0),na);
 843         bool    RETVAL;
 844
 845         RETVAL = sys_is_absolute(path);
 846         ST(0) = RETVAL ? &sv_yes : &sv_no;
 847         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
 848     }
 849     XSRETURN(1);
 850 }
 851
 852 XS(XS_Cwd_sys_is_rooted)
 853 {
 854     dXSARGS;
 855     if (items != 1)
 856         croak("Usage: Cwd::sys_is_rooted(path)");
 857     {
 858         char *  path = (char *)SvPV(ST(0),na);
 859         bool    RETVAL;
 860
 861         RETVAL = sys_is_rooted(path);
 862         ST(0) = RETVAL ? &sv_yes : &sv_no;
 863         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
 864     }
 865     XSRETURN(1);
 866 }
 867
 868 XS(XS_Cwd_sys_is_relative)
 869 {
 870     dXSARGS;
 871     if (items != 1)
 872         croak("Usage: Cwd::sys_is_relative(path)");
 873     {
 874         char *  path = (char *)SvPV(ST(0),na);
 875         bool    RETVAL;
 876
 877         RETVAL = sys_is_relative(path);
 878         ST(0) = RETVAL ? &sv_yes : &sv_no;
 879         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
 880     }
 881     XSRETURN(1);
 882 }
 883
 884 XS(XS_Cwd_sys_cwd)
 885 {
 886     dXSARGS;
 887     if (items != 0)
 888         croak("Usage: Cwd::sys_cwd()");
 889     {
 890         char p[MAXPATHLEN];
 891         char *  RETVAL;
 892         RETVAL = _getcwd2(p, MAXPATHLEN);
 893         ST(0) = sv_newmortal();
 894         sv_setpv((SV*)ST(0), RETVAL);
 895     }
 896     XSRETURN(1);
 897 }
 898
 899 XS(XS_Cwd_sys_abspath)
 900 {
 901     dXSARGS;
 902     if (items < 1 || items > 2)
 903         croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
 904     {
 905         char *  path = (char *)SvPV(ST(0),na);
 906         char *  dir;
 907         char p[MAXPATHLEN];
 908         char *  RETVAL;
 909
 910         if (items < 2)
 911             dir = NULL;
 912         else {
 913             dir = (char *)SvPV(ST(1),na);
 914         }
 915         if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
 916             path += 2;
 917         }
 918         if (dir == NULL) {
 919             if (_abspath(p, path, MAXPATHLEN) == 0) {
 920                 RETVAL = p;
 921             } else {
 922                 RETVAL = NULL;
 923             }
 924         } else {
 925             /* Absolute with drive: */
 926             if ( sys_is_absolute(path) ) {
 927                 if (_abspath(p, path, MAXPATHLEN) == 0) {
 928                     RETVAL = p;
 929                 } else {
 930                     RETVAL = NULL;
 931                 }
 932             } else if (path[0] == '/' || path[0] == '\\') {
 933                 /* Rooted, but maybe on different drive. */
 934                 if (isALPHA(dir[0]) && dir[1] == ':' ) {
 935                     char p1[MAXPATHLEN];
 936
 937                     /* Need to prepend the drive. */
 938                     p1[0] = dir[0];
 939                     p1[1] = dir[1];
 940                     Copy(path, p1 + 2, strlen(path) + 1, char);
 941                     RETVAL = p;
 942                     if (_abspath(p, p1, MAXPATHLEN) == 0) {
 943                         RETVAL = p;
 944                     } else {
 945                         RETVAL = NULL;
 946                     }
 947                 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
 948                     RETVAL = p;
 949                 } else {
 950                     RETVAL = NULL;
 951                 }
 952             } else {
 953                 /* Either path is relative, or starts with a drive letter. */
 954                 /* If the path starts with a drive letter, then dir is
 955                    relevant only if
 956                    a/b) it is absolute/x:relative on the same drive.
 957                    c)   path is on current drive, and dir is rooted
 958                    In all the cases it is safe to drop the drive part
 959                    of the path. */
 960                 if ( !sys_is_relative(path) ) {
 961                     int is_drived;
 962
 963                     if ( ( ( sys_is_absolute(dir)
 964                              || (isALPHA(dir[0]) && dir[1] == ':'
 965                                  && strnicmp(dir, path,1) == 0))
 966                            && strnicmp(dir, path,1) == 0)
 967                          || ( !(isALPHA(dir[0]) && dir[1] == ':')
 968                               && toupper(path[0]) == current_drive())) {
 969                         path += 2;
 970                     } else if (_abspath(p, path, MAXPATHLEN) == 0) {
 971                         RETVAL = p; goto done;
 972                     } else {
 973                         RETVAL = NULL; goto done;
 974                     }
 975                 }
 976                 {
 977                     /* Need to prepend the absolute path of dir. */
 978                     char p1[MAXPATHLEN];
 979
 980                     if (_abspath(p1, dir, MAXPATHLEN) == 0) {
 981                         int l = strlen(p1);
 982
 983                         if (p1[ l - 1 ] != '/') {
 984                             p1[ l ] = '/';
 985                             l++;
 986                         }
 987                         Copy(path, p1 + l, strlen(path) + 1, char);
 988                         if (_abspath(p, p1, MAXPATHLEN) == 0) {
 989                             RETVAL = p;
 990                         } else {
 991                             RETVAL = NULL;
 992                         }
 993                     } else {
 994                         RETVAL = NULL;
 995                     }
 996                 }
 997               done:
 998             }
 999         }
1000         ST(0) = sv_newmortal();
1001         sv_setpv((SV*)ST(0), RETVAL);
1002     }
1003     XSRETURN(1);
1004 }
1005 typedef APIRET (*PELP)(PSZ path, ULONG type);
1006
1007 APIRET
1008 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1009 {
1010     loadByOrd(ord);                     /* Guarantied to load or die! */
1011     return (*(PELP)ExtFCN[ord])(path, type);
1012 }
1013
1014 #define extLibpath(type)                                                \
1015     (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH   \
1016                                                  : BEGIN_LIBPATH)))     \
1017      ? NULL : to )
1018
1019 #define extLibpath_set(p,type)                                  \
1020     (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH   \
1021                                                  : BEGIN_LIBPATH))))
1022
1023 XS(XS_Cwd_extLibpath)
1024 {
1025     dXSARGS;
1026     if (items < 0 || items > 1)
1027         croak("Usage: Cwd::extLibpath(type = 0)");
1028     {
1029         bool    type;
1030         char    to[1024];
1031         U32     rc;
1032         char *  RETVAL;
1033
1034         if (items < 1)
1035             type = 0;
1036         else {
1037             type = (int)SvIV(ST(0));
1038         }
1039
1040         RETVAL = extLibpath(type);
1041         ST(0) = sv_newmortal();
1042         sv_setpv((SV*)ST(0), RETVAL);
1043     }
1044     XSRETURN(1);
1045 }
1046
1047 XS(XS_Cwd_extLibpath_set)
1048 {
1049     dXSARGS;
1050     if (items < 1 || items > 2)
1051         croak("Usage: Cwd::extLibpath_set(s, type = 0)");
1052     {
1053         char *  s = (char *)SvPV(ST(0),na);
1054         bool    type;
1055         U32     rc;
1056         bool    RETVAL;
1057
1058         if (items < 2)
1059             type = 0;
1060         else {
1061             type = (int)SvIV(ST(1));
1062         }
1063
1064         RETVAL = extLibpath_set(s, type);
1065         ST(0) = RETVAL ? &sv_yes : &sv_no;
1066         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1067     }
1068     XSRETURN(1);
1069 }
1070
1071 int
1072 Xs_OS2_init()
1073 {
1074     char *file = __FILE__;
1075     {
1076         GV *gv;
1077
1078         if (_emx_env & 0x200) { /* OS/2 */
1079             newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
1080             newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
1081             newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
1082         }
1083         newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
1084         newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
1085         newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
1086         newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
1087         newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
1088         newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
1089         newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
1090         newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
1091         newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
1092         gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
1093         GvMULTI_on(gv);
1094 #ifdef PERL_IS_AOUT
1095         sv_setiv(GvSV(gv), 1);
1096 #endif
1097     }
1098 }
1099
1100 OS2_Perl_data_t OS2_Perl_data;
1101
1102 void
1103 Perl_OS2_init()
1104 {
1105     char *shell;
1106
1107     settmppath();
1108     OS2_Perl_data.xs_init = &Xs_OS2_init;
1109     if ( (shell = getenv("PERL_SH_DRIVE")) ) {
1110         New(404, sh_path, strlen(SH_PATH) + 1, char);
1111         strcpy(sh_path, SH_PATH);
1112         sh_path[0] = shell[0];
1113     } else if ( (shell = getenv("PERL_SH_DIR")) ) {
1114         int l = strlen(shell), i;
1115         if (shell[l-1] == '/' || shell[l-1] == '\\') {
1116             l--;
1117         }
1118         New(404, sh_path, l + 8, char);
1119         strncpy(sh_path, shell, l);
1120         strcpy(sh_path + l, "/sh.exe");
1121         for (i = 0; i < l; i++) {
1122             if (sh_path[i] == '\\') sh_path[i] = '/';
1123         }
1124     }
1125 }
1126
1127 #undef tmpnam
1128 #undef tmpfile
1129
1130 char *
1131 my_tmpnam (char *str)
1132 {
1133     char *p = getenv("TMP"), *tpath;
1134     int len;
1135
1136     if (!p) p = getenv("TEMP");
1137     tpath = tempnam(p, "pltmp");
1138     if (str && tpath) {
1139         strcpy(str, tpath);
1140         return str;
1141     }
1142     return tpath;
1143 }
1144
1145 FILE *
1146 my_tmpfile ()
1147 {
1148     struct stat s;
1149
1150     stat(".", &s);
1151     if (s.st_mode & S_IWOTH) {
1152         return tmpfile();
1153     }
1154     return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
1155                                              grants TMP. */
1156 }