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