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, seenspace = 0;
 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             } else if (*s == '\\' && !seenspace) {
 350                 continue;               /* Allow backslashes in names */
 351             }
 352           doshell:
 353             if (execf == EXECF_TRUEEXEC)
 354                 return execl(shell,shell,copt,cmd,(char*)0);
 355             else if (execf == EXECF_EXEC)
 356                 return spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
 357             else if (execf == EXECF_SPAWN_NOWAIT)
 358                 return spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
 359             /* In the ak code internal P_NOWAIT is P_WAIT ??? */
 360             rc = result(P_WAIT,
 361                         spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
 362             if (rc < 0 && dowarn)
 363                 warn("Can't %s \"%s\": %s",
 364                      (execf == EXECF_SPAWN ? "spawn" : "exec"),
 365                      shell, Strerror(errno));
 366             if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
 367             if (news) Safefree(news);
 368             return rc;
 369         } else if (*s == ' ' || *s == '\t') {
 370             seenspace = 1;
 371         }
 372     }
 373
 374     New(1303,Argv, (s - cmd) / 2 + 2, char*);
 375     Cmd = savepvn(cmd, s-cmd);
 376     a = Argv;
 377     for (s = Cmd; *s;) {
 378         while (*s && isSPACE(*s)) s++;
 379         if (*s)
 380             *(a++) = s;
 381         while (*s && !isSPACE(*s)) s++;
 382         if (*s)
 383             *s++ = '\0';
 384     }
 385     *a = Nullch;
 386     if (Argv[0]) {
 387         int err;
 388
 389         if (execf == EXECF_TRUEEXEC)
 390             rc = execvp(Argv[0],Argv);
 391         else if (execf == EXECF_EXEC)
 392             rc = spawnvp(P_OVERLAY,Argv[0],Argv);
 393         else if (execf == EXECF_SPAWN_NOWAIT)
 394             rc = spawnvp(P_NOWAIT,Argv[0],Argv);
 395         else
 396             rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv));
 397         if (rc < 0) {
 398             err = errno;
 399             if (err == ENOENT) {        /* No such file. */
 400                 /* One reason may be that EMX added .exe. We suppose
 401                    that .exe-less files are automatically shellable. */
 402                 char *no_dir;
 403                 (no_dir = strrchr(Argv[0], '/'))
 404                     || (no_dir = strrchr(Argv[0], '\\'))
 405                     || (no_dir = Argv[0]);
 406                 if (!strchr(no_dir, '.')) {
 407                     struct stat buffer;
 408                     if (stat(Argv[0], &buffer) != -1) { /* File exists. */
 409                         /* Maybe we need to specify the full name here? */
 410                         goto doshell;
 411                     }
 412                 }
 413             } else if (err == ENOEXEC) { /* Need to send to shell. */
 414                 goto doshell;
 415             }
 416         }
 417         if (rc < 0 && dowarn)
 418             warn("Can't %s \"%s\": %s",
 419                  ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
 420                   ? "spawn" : "exec"),
 421                  Argv[0], Strerror(err));
 422         if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
 423     } else
 424         rc = -1;
 425     if (news) Safefree(news);
 426     do_execfree();
 427     return rc;
 428 }
 429
 430 int
 431 do_spawn(cmd)
 432 char *cmd;
 433 {
 434     return do_spawn2(cmd, EXECF_SPAWN);
 435 }
 436
 437 int
 438 do_spawn_nowait(cmd)
 439 char *cmd;
 440 {
 441     return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
 442 }
 443
 444 bool
 445 do_exec(cmd)
 446 char *cmd;
 447 {
 448     return do_spawn2(cmd, EXECF_EXEC);
 449 }
 450
 451 bool
 452 os2exec(cmd)
 453 char *cmd;
 454 {
 455     return do_spawn2(cmd, EXECF_TRUEEXEC);
 456 }
 457
 458 PerlIO *
 459 my_syspopen(cmd,mode)
 460 char    *cmd;
 461 char    *mode;
 462 {
 463 #ifndef USE_POPEN
 464
 465     int p[2];
 466     register I32 this, that, newfd;
 467     register I32 pid, rc;
 468     PerlIO *res;
 469     SV *sv;
 470
 471     if (pipe(p) < 0)
 472         return Nullfp;
 473     /* `this' is what we use in the parent, `that' in the child. */
 474     this = (*mode == 'w');
 475     that = !this;
 476     if (tainting) {
 477         taint_env();
 478         taint_proper("Insecure %s%s", "EXEC");
 479     }
 480     /* Now we need to spawn the child. */
 481     newfd = dup(*mode == 'r');          /* Preserve std* */
 482     if (p[that] != (*mode == 'r')) {
 483         dup2(p[that], *mode == 'r');
 484         close(p[that]);
 485     }
 486     /* Where is `this' and newfd now? */
 487     fcntl(p[this], F_SETFD, FD_CLOEXEC);
 488     fcntl(newfd, F_SETFD, FD_CLOEXEC);
 489     pid = do_spawn_nowait(cmd);
 490     if (newfd != (*mode == 'r')) {
 491         dup2(newfd, *mode == 'r');      /* Return std* back. */
 492         close(newfd);
 493     }
 494     close(p[that]);
 495     if (pid == -1) {
 496         close(p[this]);
 497         return NULL;
 498     }
 499     if (p[that] < p[this]) {
 500         dup2(p[this], p[that]);
 501         close(p[this]);
 502         p[this] = p[that];
 503     }
 504     sv = *av_fetch(fdpid,p[this],TRUE);
 505     (void)SvUPGRADE(sv,SVt_IV);
 506     SvIVX(sv) = pid;
 507     forkprocess = pid;
 508     return PerlIO_fdopen(p[this], mode);
 509
 510 #else  /* USE_POPEN */
 511
 512     PerlIO *res;
 513     SV *sv;
 514
 515 #  ifdef TRYSHELL
 516     res = popen(cmd, mode);
 517 #  else
 518     char *shell = getenv("EMXSHELL");
 519
 520     my_setenv("EMXSHELL", sh_path);
 521     res = popen(cmd, mode);
 522     my_setenv("EMXSHELL", shell);
 523 #  endif
 524     sv = *av_fetch(fdpid, PerlIO_fileno(res), TRUE);
 525     (void)SvUPGRADE(sv,SVt_IV);
 526     SvIVX(sv) = -1;                     /* A cooky. */
 527     return res;
 528
 529 #endif /* USE_POPEN */
 530
 531 }
 532
 533 /******************************************************************/
 534
 535 #ifndef HAS_FORK
 536 int
 537 fork(void)
 538 {
 539     die(no_func, "Unsupported function fork");
 540     errno = EINVAL;
 541     return -1;
 542 }
 543 #endif
 544
 545 /*******************************************************************/
 546 /* not implemented in EMX 0.9a */
 547
 548 void *  ctermid(x)      { return 0; }
 549
 550 #ifdef MYTTYNAME /* was not in emx0.9a */
 551 void *  ttyname(x)      { return 0; }
 552 #endif
 553
 554 /******************************************************************/
 555 /* my socket forwarders - EMX lib only provides static forwarders */
 556
 557 static HMODULE htcp = 0;
 558
 559 static void *
 560 tcp0(char *name)
 561 {
 562     static BYTE buf[20];
 563     PFN fcn;
 564
 565     if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
 566     if (!htcp)
 567         DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
 568     if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
 569         return (void *) ((void * (*)(void)) fcn) ();
 570     return 0;
 571 }
 572
 573 static void
 574 tcp1(char *name, int arg)
 575 {
 576     static BYTE buf[20];
 577     PFN fcn;
 578
 579     if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
 580     if (!htcp)
 581         DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
 582     if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
 583         ((void (*)(int)) fcn) (arg);
 584 }
 585
 586 void *  gethostent()    { return tcp0("GETHOSTENT");  }
 587 void *  getnetent()     { return tcp0("GETNETENT");   }
 588 void *  getprotoent()   { return tcp0("GETPROTOENT"); }
 589 void *  getservent()    { return tcp0("GETSERVENT");  }
 590 void    sethostent(x)   { tcp1("SETHOSTENT",  x); }
 591 void    setnetent(x)    { tcp1("SETNETENT",   x); }
 592 void    setprotoent(x)  { tcp1("SETPROTOENT", x); }
 593 void    setservent(x)   { tcp1("SETSERVENT",  x); }
 594 void    endhostent()    { tcp0("ENDHOSTENT");  }
 595 void    endnetent()     { tcp0("ENDNETENT");   }
 596 void    endprotoent()   { tcp0("ENDPROTOENT"); }
 597 void    endservent()    { tcp0("ENDSERVENT");  }
 598
 599 /*****************************************************************************/
 600 /* not implemented in C Set++ */
 601
 602 #ifndef __EMX__
 603 int     setuid(x)       { errno = EINVAL; return -1; }
 604 int     setgid(x)       { errno = EINVAL; return -1; }
 605 #endif
 606
 607 /*****************************************************************************/
 608 /* stat() hack for char/block device */
 609
 610 #if OS2_STAT_HACK
 611
 612     /* First attempt used DosQueryFSAttach which crashed the system when
 613        used with 5.001. Now just look for /dev/. */
 614
 615 int
 616 os2_stat(char *name, struct stat *st)
 617 {
 618     static int ino = SHRT_MAX;
 619
 620     if (stricmp(name, "/dev/con") != 0
 621      && stricmp(name, "/dev/tty") != 0)
 622         return stat(name, st);
 623
 624     memset(st, 0, sizeof *st);
 625     st->st_mode = S_IFCHR|0666;
 626     st->st_ino = (ino-- & 0x7FFF);
 627     st->st_nlink = 1;
 628     return 0;
 629 }
 630
 631 #endif
 632
 633 #ifdef USE_PERL_SBRK
 634
 635 /* SBRK() emulation, mostly moved to malloc.c. */
 636
 637 void *
 638 sys_alloc(int size) {
 639     void *got;
 640     APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
 641
 642     if (rc == ERROR_NOT_ENOUGH_MEMORY) {
 643         return (void *) -1;
 644     } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
 645     return got;
 646 }
 647
 648 #endif /* USE_PERL_SBRK */
 649
 650 /* tmp path */
 651
 652 char *tmppath = TMPPATH1;
 653
 654 void
 655 settmppath()
 656 {
 657     char *p = getenv("TMP"), *tpath;
 658     int len;
 659
 660     if (!p) p = getenv("TEMP");
 661     if (!p) return;
 662     len = strlen(p);
 663     tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
 664     strcpy(tpath, p);
 665     tpath[len] = '/';
 666     strcpy(tpath + len + 1, TMPPATH1);
 667     tmppath = tpath;
 668 }
 669
 670 #include "XSUB.h"
 671
 672 XS(XS_File__Copy_syscopy)
 673 {
 674     dXSARGS;
 675     if (items < 2 || items > 3)
 676         croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
 677     {
 678         char *  src = (char *)SvPV(ST(0),na);
 679         char *  dst = (char *)SvPV(ST(1),na);
 680         U32     flag;
 681         int     RETVAL, rc;
 682
 683         if (items < 3)
 684             flag = 0;
 685         else {
 686             flag = (unsigned long)SvIV(ST(2));
 687         }
 688
 689         RETVAL = !CheckOSError(DosCopy(src, dst, flag));
 690         ST(0) = sv_newmortal();
 691         sv_setiv(ST(0), (IV)RETVAL);
 692     }
 693     XSRETURN(1);
 694 }
 695
 696 char *
 697 mod2fname(sv)
 698      SV   *sv;
 699 {
 700     static char fname[9];
 701     int pos = 6, len, avlen;
 702     unsigned int sum = 0;
 703     AV  *av;
 704     SV  *svp;
 705     char *s;
 706
 707     if (!SvROK(sv)) croak("Not a reference given to mod2fname");
 708     sv = SvRV(sv);
 709     if (SvTYPE(sv) != SVt_PVAV)
 710       croak("Not array reference given to mod2fname");
 711
 712     avlen = av_len((AV*)sv);
 713     if (avlen < 0)
 714       croak("Empty array reference given to mod2fname");
 715
 716     s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
 717     strncpy(fname, s, 8);
 718     len = strlen(s);
 719     if (len < 6) pos = len;
 720     while (*s) {
 721         sum = 33 * sum + *(s++);        /* Checksumming first chars to
 722                                          * get the capitalization into c.s. */
 723     }
 724     avlen --;
 725     while (avlen >= 0) {
 726         s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
 727         while (*s) {
 728             sum = 33 * sum + *(s++);    /* 7 is primitive mod 13. */
 729         }
 730         avlen --;
 731     }
 732     fname[pos] = 'A' + (sum % 26);
 733     fname[pos + 1] = 'A' + (sum / 26 % 26);
 734     fname[pos + 2] = '\0';
 735     return (char *)fname;
 736 }
 737
 738 XS(XS_DynaLoader_mod2fname)
 739 {
 740     dXSARGS;
 741     if (items != 1)
 742         croak("Usage: DynaLoader::mod2fname(sv)");
 743     {
 744         SV *    sv = ST(0);
 745         char *  RETVAL;
 746
 747         RETVAL = mod2fname(sv);
 748         ST(0) = sv_newmortal();
 749         sv_setpv((SV*)ST(0), RETVAL);
 750     }
 751     XSRETURN(1);
 752 }
 753
 754 char *
 755 os2error(int rc)
 756 {
 757         static char buf[300];
 758         ULONG len;
 759
 760         if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
 761         if (rc == 0)
 762                 return NULL;
 763         if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
 764                 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
 765         else
 766                 buf[len] = '\0';
 767         return buf;
 768 }
 769
 770 char *
 771 perllib_mangle(char *s, unsigned int l)
 772 {
 773     static char *newp, *oldp;
 774     static int newl, oldl, notfound;
 775     static char ret[STATIC_FILE_LENGTH+1];
 776
 777     if (!newp && !notfound) {
 778         newp = getenv("PERLLIB_PREFIX");
 779         if (newp) {
 780             char *s;
 781
 782             oldp = newp;
 783             while (*newp && !isSPACE(*newp) && *newp != ';') {
 784                 newp++; oldl++;         /* Skip digits. */
 785             }
 786             while (*newp && (isSPACE(*newp) || *newp == ';')) {
 787                 newp++;                 /* Skip whitespace. */
 788             }
 789             newl = strlen(newp);
 790             if (newl == 0 || oldl == 0) {
 791                 die("Malformed PERLLIB_PREFIX");
 792             }
 793             strcpy(ret, newp);
 794             s = ret;
 795             while (*s) {
 796                 if (*s == '\\') *s = '/';
 797                 s++;
 798             }
 799         } else {
 800             notfound = 1;
 801         }
 802     }
 803     if (!newp) {
 804         return s;
 805     }
 806     if (l == 0) {
 807         l = strlen(s);
 808     }
 809     if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
 810         return s;
 811     }
 812     if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
 813         die("Malformed PERLLIB_PREFIX");
 814     }
 815     strcpy(ret + newl, s + oldl);
 816     return ret;
 817 }
 818
 819 extern void dlopen();
 820 void *fakedl = &dlopen;         /* Pull in dynaloading part. */
 821
 822 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
 823                                 && ((path)[2] == '/' || (path)[2] == '\\'))
 824 #define sys_is_rooted _fnisabs
 825 #define sys_is_relative _fnisrel
 826 #define current_drive _getdrive
 827
 828 #undef chdir                            /* Was _chdir2. */
 829 #define sys_chdir(p) (chdir(p) == 0)
 830 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
 831
 832 XS(XS_Cwd_current_drive)
 833 {
 834     dXSARGS;
 835     if (items != 0)
 836         croak("Usage: Cwd::current_drive()");
 837     {
 838         char    RETVAL;
 839
 840         RETVAL = current_drive();
 841         ST(0) = sv_newmortal();
 842         sv_setpvn(ST(0), (char *)&RETVAL, 1);
 843     }
 844     XSRETURN(1);
 845 }
 846
 847 XS(XS_Cwd_sys_chdir)
 848 {
 849     dXSARGS;
 850     if (items != 1)
 851         croak("Usage: Cwd::sys_chdir(path)");
 852     {
 853         char *  path = (char *)SvPV(ST(0),na);
 854         bool    RETVAL;
 855
 856         RETVAL = sys_chdir(path);
 857         ST(0) = boolSV(RETVAL);
 858         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
 859     }
 860     XSRETURN(1);
 861 }
 862
 863 XS(XS_Cwd_change_drive)
 864 {
 865     dXSARGS;
 866     if (items != 1)
 867         croak("Usage: Cwd::change_drive(d)");
 868     {
 869         char    d = (char)*SvPV(ST(0),na);
 870         bool    RETVAL;
 871
 872         RETVAL = change_drive(d);
 873         ST(0) = boolSV(RETVAL);
 874         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
 875     }
 876     XSRETURN(1);
 877 }
 878
 879 XS(XS_Cwd_sys_is_absolute)
 880 {
 881     dXSARGS;
 882     if (items != 1)
 883         croak("Usage: Cwd::sys_is_absolute(path)");
 884     {
 885         char *  path = (char *)SvPV(ST(0),na);
 886         bool    RETVAL;
 887
 888         RETVAL = sys_is_absolute(path);
 889         ST(0) = boolSV(RETVAL);
 890         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
 891     }
 892     XSRETURN(1);
 893 }
 894
 895 XS(XS_Cwd_sys_is_rooted)
 896 {
 897     dXSARGS;
 898     if (items != 1)
 899         croak("Usage: Cwd::sys_is_rooted(path)");
 900     {
 901         char *  path = (char *)SvPV(ST(0),na);
 902         bool    RETVAL;
 903
 904         RETVAL = sys_is_rooted(path);
 905         ST(0) = boolSV(RETVAL);
 906         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
 907     }
 908     XSRETURN(1);
 909 }
 910
 911 XS(XS_Cwd_sys_is_relative)
 912 {
 913     dXSARGS;
 914     if (items != 1)
 915         croak("Usage: Cwd::sys_is_relative(path)");
 916     {
 917         char *  path = (char *)SvPV(ST(0),na);
 918         bool    RETVAL;
 919
 920         RETVAL = sys_is_relative(path);
 921         ST(0) = boolSV(RETVAL);
 922         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
 923     }
 924     XSRETURN(1);
 925 }
 926
 927 XS(XS_Cwd_sys_cwd)
 928 {
 929     dXSARGS;
 930     if (items != 0)
 931         croak("Usage: Cwd::sys_cwd()");
 932     {
 933         char p[MAXPATHLEN];
 934         char *  RETVAL;
 935         RETVAL = _getcwd2(p, MAXPATHLEN);
 936         ST(0) = sv_newmortal();
 937         sv_setpv((SV*)ST(0), RETVAL);
 938     }
 939     XSRETURN(1);
 940 }
 941
 942 XS(XS_Cwd_sys_abspath)
 943 {
 944     dXSARGS;
 945     if (items < 1 || items > 2)
 946         croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
 947     {
 948         char *  path = (char *)SvPV(ST(0),na);
 949         char *  dir;
 950         char p[MAXPATHLEN];
 951         char *  RETVAL;
 952
 953         if (items < 2)
 954             dir = NULL;
 955         else {
 956             dir = (char *)SvPV(ST(1),na);
 957         }
 958         if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
 959             path += 2;
 960         }
 961         if (dir == NULL) {
 962             if (_abspath(p, path, MAXPATHLEN) == 0) {
 963                 RETVAL = p;
 964             } else {
 965                 RETVAL = NULL;
 966             }
 967         } else {
 968             /* Absolute with drive: */
 969             if ( sys_is_absolute(path) ) {
 970                 if (_abspath(p, path, MAXPATHLEN) == 0) {
 971                     RETVAL = p;
 972                 } else {
 973                     RETVAL = NULL;
 974                 }
 975             } else if (path[0] == '/' || path[0] == '\\') {
 976                 /* Rooted, but maybe on different drive. */
 977                 if (isALPHA(dir[0]) && dir[1] == ':' ) {
 978                     char p1[MAXPATHLEN];
 979
 980                     /* Need to prepend the drive. */
 981                     p1[0] = dir[0];
 982                     p1[1] = dir[1];
 983                     Copy(path, p1 + 2, strlen(path) + 1, char);
 984                     RETVAL = p;
 985                     if (_abspath(p, p1, MAXPATHLEN) == 0) {
 986                         RETVAL = p;
 987                     } else {
 988                         RETVAL = NULL;
 989                     }
 990                 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
 991                     RETVAL = p;
 992                 } else {
 993                     RETVAL = NULL;
 994                 }
 995             } else {
 996                 /* Either path is relative, or starts with a drive letter. */
 997                 /* If the path starts with a drive letter, then dir is
 998                    relevant only if
 999                    a/b) it is absolute/x:relative on the same drive.
1000                    c)   path is on current drive, and dir is rooted
1001                    In all the cases it is safe to drop the drive part
1002                    of the path. */
1003                 if ( !sys_is_relative(path) ) {
1004                     int is_drived;
1005
1006                     if ( ( ( sys_is_absolute(dir)
1007                              || (isALPHA(dir[0]) && dir[1] == ':'
1008                                  && strnicmp(dir, path,1) == 0))
1009                            && strnicmp(dir, path,1) == 0)
1010                          || ( !(isALPHA(dir[0]) && dir[1] == ':')
1011                               && toupper(path[0]) == current_drive())) {
1012                         path += 2;
1013                     } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1014                         RETVAL = p; goto done;
1015                     } else {
1016                         RETVAL = NULL; goto done;
1017                     }
1018                 }
1019                 {
1020                     /* Need to prepend the absolute path of dir. */
1021                     char p1[MAXPATHLEN];
1022
1023                     if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1024                         int l = strlen(p1);
1025
1026                         if (p1[ l - 1 ] != '/') {
1027                             p1[ l ] = '/';
1028                             l++;
1029                         }
1030                         Copy(path, p1 + l, strlen(path) + 1, char);
1031                         if (_abspath(p, p1, MAXPATHLEN) == 0) {
1032                             RETVAL = p;
1033                         } else {
1034                             RETVAL = NULL;
1035                         }
1036                     } else {
1037                         RETVAL = NULL;
1038                     }
1039                 }
1040               done:
1041             }
1042         }
1043         ST(0) = sv_newmortal();
1044         sv_setpv((SV*)ST(0), RETVAL);
1045     }
1046     XSRETURN(1);
1047 }
1048 typedef APIRET (*PELP)(PSZ path, ULONG type);
1049
1050 APIRET
1051 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1052 {
1053     loadByOrd(ord);                     /* Guarantied to load or die! */
1054     return (*(PELP)ExtFCN[ord])(path, type);
1055 }
1056
1057 #define extLibpath(type)                                                \
1058     (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH   \
1059                                                  : BEGIN_LIBPATH)))     \
1060      ? NULL : to )
1061
1062 #define extLibpath_set(p,type)                                  \
1063     (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH   \
1064                                                  : BEGIN_LIBPATH))))
1065
1066 XS(XS_Cwd_extLibpath)
1067 {
1068     dXSARGS;
1069     if (items < 0 || items > 1)
1070         croak("Usage: Cwd::extLibpath(type = 0)");
1071     {
1072         bool    type;
1073         char    to[1024];
1074         U32     rc;
1075         char *  RETVAL;
1076
1077         if (items < 1)
1078             type = 0;
1079         else {
1080             type = (int)SvIV(ST(0));
1081         }
1082
1083         RETVAL = extLibpath(type);
1084         ST(0) = sv_newmortal();
1085         sv_setpv((SV*)ST(0), RETVAL);
1086     }
1087     XSRETURN(1);
1088 }
1089
1090 XS(XS_Cwd_extLibpath_set)
1091 {
1092     dXSARGS;
1093     if (items < 1 || items > 2)
1094         croak("Usage: Cwd::extLibpath_set(s, type = 0)");
1095     {
1096         char *  s = (char *)SvPV(ST(0),na);
1097         bool    type;
1098         U32     rc;
1099         bool    RETVAL;
1100
1101         if (items < 2)
1102             type = 0;
1103         else {
1104             type = (int)SvIV(ST(1));
1105         }
1106
1107         RETVAL = extLibpath_set(s, type);
1108         ST(0) = boolSV(RETVAL);
1109         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1110     }
1111     XSRETURN(1);
1112 }
1113
1114 int
1115 Xs_OS2_init()
1116 {
1117     char *file = __FILE__;
1118     {
1119         GV *gv;
1120
1121         if (_emx_env & 0x200) { /* OS/2 */
1122             newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
1123             newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
1124             newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
1125         }
1126         newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
1127         newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
1128         newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
1129         newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
1130         newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
1131         newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
1132         newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
1133         newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
1134         newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
1135         gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
1136         GvMULTI_on(gv);
1137 #ifdef PERL_IS_AOUT
1138         sv_setiv(GvSV(gv), 1);
1139 #endif
1140     }
1141 }
1142
1143 OS2_Perl_data_t OS2_Perl_data;
1144
1145 void
1146 Perl_OS2_init(char **env)
1147 {
1148     char *shell;
1149
1150     MALLOC_INIT;
1151     settmppath();
1152     OS2_Perl_data.xs_init = &Xs_OS2_init;
1153     if (environ == NULL) {
1154         environ = env;
1155     }
1156     if ( (shell = getenv("PERL_SH_DRIVE")) ) {
1157         New(1304, sh_path, strlen(SH_PATH) + 1, char);
1158         strcpy(sh_path, SH_PATH);
1159         sh_path[0] = shell[0];
1160     } else if ( (shell = getenv("PERL_SH_DIR")) ) {
1161         int l = strlen(shell), i;
1162         if (shell[l-1] == '/' || shell[l-1] == '\\') {
1163             l--;
1164         }
1165         New(1304, sh_path, l + 8, char);
1166         strncpy(sh_path, shell, l);
1167         strcpy(sh_path + l, "/sh.exe");
1168         for (i = 0; i < l; i++) {
1169             if (sh_path[i] == '\\') sh_path[i] = '/';
1170         }
1171     }
1172 }
1173
1174 #undef tmpnam
1175 #undef tmpfile
1176
1177 char *
1178 my_tmpnam (char *str)
1179 {
1180     char *p = getenv("TMP"), *tpath;
1181     int len;
1182
1183     if (!p) p = getenv("TEMP");
1184     tpath = tempnam(p, "pltmp");
1185     if (str && tpath) {
1186         strcpy(str, tpath);
1187         return str;
1188     }
1189     return tpath;
1190 }
1191
1192 FILE *
1193 my_tmpfile ()
1194 {
1195     struct stat s;
1196
1197     stat(".", &s);
1198     if (s.st_mode & S_IWOTH) {
1199         return tmpfile();
1200     }
1201     return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
1202                                              grants TMP. */
1203 }
1204
1205 #undef flock
1206
1207 /* This code was contributed by Rocco Caputo. */
1208 int
1209 my_flock(int handle, int op)
1210 {
1211   FILELOCK      rNull, rFull;
1212   ULONG         timeout, handle_type, flag_word;
1213   APIRET        rc;
1214   int           blocking, shared;
1215   static int    use_my = -1;
1216
1217   if (use_my == -1) {
1218     char *s = getenv("USE_PERL_FLOCK");
1219     if (s)
1220         use_my = atoi(s);
1221     else
1222         use_my = 1;
1223   }
1224   if (!(_emx_env & 0x200) || !use_my)
1225     return flock(handle, op);   /* Delegate to EMX. */
1226
1227                                         // is this a file?
1228   if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
1229       (handle_type & 0xFF))
1230   {
1231     errno = EBADF;
1232     return -1;
1233   }
1234                                         // set lock/unlock ranges
1235   rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
1236   rFull.lRange = 0x7FFFFFFF;
1237                                         // set timeout for blocking
1238   timeout = ((blocking = !(op & LOCK_NB))) ? 100 : 1;
1239                                         // shared or exclusive?
1240   shared = (op & LOCK_SH) ? 1 : 0;
1241                                         // do not block the unlock
1242   if (op & (LOCK_UN | LOCK_SH | LOCK_EX)) {
1243     rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
1244     switch (rc) {
1245       case 0:
1246         errno = 0;
1247         return 0;
1248       case ERROR_INVALID_HANDLE:
1249         errno = EBADF;
1250         return -1;
1251       case ERROR_SHARING_BUFFER_EXCEEDED:
1252         errno = ENOLCK;
1253         return -1;
1254       case ERROR_LOCK_VIOLATION:
1255         break;                          // not an error
1256       case ERROR_INVALID_PARAMETER:
1257       case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1258       case ERROR_READ_LOCKS_NOT_SUPPORTED:
1259         errno = EINVAL;
1260         return -1;
1261       case ERROR_INTERRUPT:
1262         errno = EINTR;
1263         return -1;
1264       default:
1265         errno = EINVAL;
1266         return -1;
1267     }
1268   }
1269                                         // lock may block
1270   if (op & (LOCK_SH | LOCK_EX)) {
1271                                         // for blocking operations
1272     for (;;) {
1273       rc =
1274         DosSetFileLocks(
1275                 handle,
1276                 &rNull,
1277                 &rFull,
1278                 timeout,
1279                 shared
1280         );
1281       switch (rc) {
1282         case 0:
1283           errno = 0;
1284           return 0;
1285         case ERROR_INVALID_HANDLE:
1286           errno = EBADF;
1287           return -1;
1288         case ERROR_SHARING_BUFFER_EXCEEDED:
1289           errno = ENOLCK;
1290           return -1;
1291         case ERROR_LOCK_VIOLATION:
1292           if (!blocking) {
1293             errno = EWOULDBLOCK;
1294             return -1;
1295           }
1296           break;
1297         case ERROR_INVALID_PARAMETER:
1298         case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1299         case ERROR_READ_LOCKS_NOT_SUPPORTED:
1300           errno = EINVAL;
1301           return -1;
1302         case ERROR_INTERRUPT:
1303           errno = EINTR;
1304           return -1;
1305         default:
1306           errno = EINVAL;
1307           return -1;
1308       }
1309                                         // give away timeslice
1310       DosSleep(1);
1311     }
1312   }
1313
1314   errno = 0;
1315   return 0;
1316 }