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