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
  17 #include "EXTERN.h"
  18 #include "perl.h"
  19
  20 /*****************************************************************************/
  21 /* priorities */
  22 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
  23                                                self inverse. */
  24 #define QSS_INI_BUFFER 1024
  25
  26 PQTOPLEVEL
  27 get_sysinfo(ULONG pid, ULONG flags)
  28 {
  29     char *pbuffer;
  30     ULONG rc, buf_len = QSS_INI_BUFFER;
  31
  32     New(1022, pbuffer, buf_len, char);
  33     /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
  34     rc = QuerySysState(flags, pid, pbuffer, buf_len);
  35     while (rc == ERROR_BUFFER_OVERFLOW) {
  36         Renew(pbuffer, buf_len *= 2, char);
  37         rc = QuerySysState(QSS_PROCESS, pid, pbuffer, buf_len);
  38     }
  39     if (rc) {
  40         FillOSError(rc);
  41         Safefree(pbuffer);
  42         return 0;
  43     }
  44     return (PQTOPLEVEL)pbuffer;
  45 }
  46
  47 #define PRIO_ERR 0x1111
  48
  49 static ULONG
  50 sys_prio(pid)
  51 {
  52   ULONG prio;
  53   PQTOPLEVEL psi;
  54
  55   psi = get_sysinfo(pid, QSS_PROCESS);
  56   if (!psi) {
  57       return PRIO_ERR;
  58   }
  59   if (pid != psi->procdata->pid) {
  60       Safefree(psi);
  61       croak("panic: wrong pid in sysinfo");
  62   }
  63   prio = psi->procdata->threads->priority;
  64   Safefree(psi);
  65   return prio;
  66 }
  67
  68 int
  69 setpriority(int which, int pid, int val)
  70 {
  71   ULONG rc, prio;
  72   PQTOPLEVEL psi;
  73
  74   prio = sys_prio(pid);
  75
  76   if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
  77       /* Do not change class. */
  78       return CheckOSError(DosSetPriority((pid < 0)
  79                                          ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
  80                                          0,
  81                                          (32 - val) % 32 - (prio & 0xFF),
  82                                          abs(pid)))
  83       ? -1 : 0;
  84   } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
  85       /* Documentation claims one can change both class and basevalue,
  86        * but I find it wrong. */
  87       /* Change class, but since delta == 0 denotes absolute 0, correct. */
  88       if (CheckOSError(DosSetPriority((pid < 0)
  89                                       ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
  90                                       priors[(32 - val) >> 5] + 1,
  91                                       0,
  92                                       abs(pid))))
  93           return -1;
  94       if ( ((32 - val) % 32) == 0 ) return 0;
  95       return CheckOSError(DosSetPriority((pid < 0)
  96                                          ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
  97                                          0,
  98                                          (32 - val) % 32,
  99                                          abs(pid)))
 100           ? -1 : 0;
 101   }
 102 /*   else return CheckOSError(DosSetPriority((pid < 0)  */
 103 /*                                        ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
 104 /*                                        priors[(32 - val) >> 5] + 1,  */
 105 /*                                        (32 - val) % 32 - (prio & 0xFF),  */
 106 /*                                        abs(pid))) */
 107 /*       ? -1 : 0; */
 108 }
 109
 110 int
 111 getpriority(int which /* ignored */, int pid)
 112 {
 113   TIB *tib;
 114   PIB *pib;
 115   ULONG rc, ret;
 116
 117   /* DosGetInfoBlocks has old priority! */
 118 /*   if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
 119 /*   if (pid != pib->pib_ulpid) { */
 120   ret = sys_prio(pid);
 121   if (ret == PRIO_ERR) {
 122       return -1;
 123   }
 124 /*   } else */
 125 /*       ret = tib->tib_ptib2->tib2_ulpri; */
 126   return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
 127 }
 128
 129 /*****************************************************************************/
 130 /* spawn */
 131
 132 static int
 133 result(int flag, int pid)
 134 {
 135         int r, status;
 136         Signal_t (*ihand)();     /* place to save signal during system() */
 137         Signal_t (*qhand)();     /* place to save signal during system() */
 138 #ifndef __EMX__
 139         RESULTCODES res;
 140         int rpid;
 141 #endif
 142
 143         if (pid < 0 || flag != 0)
 144                 return pid;
 145
 146 #ifdef __EMX__
 147         ihand = signal(SIGINT, SIG_IGN);
 148         qhand = signal(SIGQUIT, SIG_IGN);
 149         do {
 150             r = wait4pid(pid, &status, 0);
 151         } while (r == -1 && errno == EINTR);
 152         signal(SIGINT, ihand);
 153         signal(SIGQUIT, qhand);
 154
 155         statusvalue = (U16)status;
 156         if (r < 0)
 157                 return -1;
 158         return status & 0xFFFF;
 159 #else
 160         ihand = signal(SIGINT, SIG_IGN);
 161         r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
 162         signal(SIGINT, ihand);
 163         statusvalue = res.codeResult << 8 | res.codeTerminate;
 164         if (r)
 165                 return -1;
 166         return statusvalue;
 167 #endif
 168 }
 169
 170 int
 171 do_aspawn(really,mark,sp)
 172 SV *really;
 173 register SV **mark;
 174 register SV **sp;
 175 {
 176     register char **a;
 177     char *tmps;
 178     int rc;
 179     int flag = P_WAIT, trueflag;
 180
 181     if (sp > mark) {
 182         New(401,Argv, sp - mark + 1, char*);
 183         a = Argv;
 184
 185         if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
 186                 ++mark;
 187                 flag = SvIVx(*mark);
 188         }
 189
 190         while (++mark <= sp) {
 191             if (*mark)
 192                 *a++ = SvPVx(*mark, na);
 193             else
 194                 *a++ = "";
 195         }
 196         *a = Nullch;
 197
 198         trueflag = flag;
 199         if (flag == P_WAIT)
 200                 flag = P_NOWAIT;
 201
 202         if (*Argv[0] != '/' && *Argv[0] != '\\'
 203             && !(*Argv[0] && *Argv[1] == ':'
 204                  && (*Argv[2] == '/' || *Argv[2] != '\\'))
 205             ) /* will swawnvp use PATH? */
 206             TAINT_ENV();        /* testing IFS here is overkill, probably */
 207         /* We should check PERL_SH* and PERLLIB_* as well? */
 208         if (really && *(tmps = SvPV(really, na)))
 209             rc = result(trueflag, spawnvp(flag,tmps,Argv));
 210         else
 211             rc = result(trueflag, spawnvp(flag,Argv[0],Argv));
 212
 213         if (rc < 0 && dowarn)
 214             warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
 215         if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
 216     } else
 217         rc = -1;
 218     do_execfree();
 219     return rc;
 220 }
 221
 222 #define EXECF_SPAWN 0
 223 #define EXECF_EXEC 1
 224 #define EXECF_TRUEEXEC 2
 225
 226 int
 227 do_spawn2(cmd, execf)
 228 char *cmd;
 229 int execf;
 230 {
 231     register char **a;
 232     register char *s;
 233     char flags[10];
 234     char *shell, *copt;
 235     int rc;
 236
 237 #ifdef TRYSHELL
 238     if ((shell = getenv("EMXSHELL")) != NULL)
 239         copt = "-c";
 240     else if ((shell = getenv("SHELL")) != NULL)
 241         copt = "-c";
 242     else if ((shell = getenv("COMSPEC")) != NULL)
 243         copt = "/C";
 244     else
 245         shell = "cmd.exe";
 246 #else
 247     /* Consensus on perl5-porters is that it is _very_ important to
 248        have a shell which will not change between computers with the
 249        same architecture, to avoid "action on a distance".
 250        And to have simple build, this shell should be sh. */
 251     shell = SH_PATH;
 252     copt = "-c";
 253 #endif
 254
 255     while (*cmd && isSPACE(*cmd))
 256         cmd++;
 257
 258     /* save an extra exec if possible */
 259     /* see if there are shell metacharacters in it */
 260
 261     if (*cmd == '.' && isSPACE(cmd[1]))
 262         goto doshell;
 263
 264     if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
 265         goto doshell;
 266
 267     for (s = cmd; *s && isALPHA(*s); s++) ;     /* catch VAR=val gizmo */
 268     if (*s == '=')
 269         goto doshell;
 270
 271     for (s = cmd; *s; s++) {
 272         if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
 273             if (*s == '\n' && !s[1]) {
 274                 *s = '\0';
 275                 break;
 276             }
 277           doshell:
 278             if (execf == EXECF_TRUEEXEC)
 279                 return execl(shell,shell,copt,cmd,(char*)0);
 280             else if (execf == EXECF_EXEC)
 281                 return spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
 282             /* In the ak code internal P_NOWAIT is P_WAIT ??? */
 283             rc = result(P_WAIT,
 284                         spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
 285             if (rc < 0 && dowarn)
 286                 warn("Can't %s \"%s\": %s",
 287                      (execf == EXECF_SPAWN ? "spawn" : "exec"),
 288                      shell, Strerror(errno));
 289             if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
 290             return rc;
 291         }
 292     }
 293
 294     New(402,Argv, (s - cmd) / 2 + 2, char*);
 295     Cmd = savepvn(cmd, s-cmd);
 296     a = Argv;
 297     for (s = Cmd; *s;) {
 298         while (*s && isSPACE(*s)) s++;
 299         if (*s)
 300             *(a++) = s;
 301         while (*s && !isSPACE(*s)) s++;
 302         if (*s)
 303             *s++ = '\0';
 304     }
 305     *a = Nullch;
 306     if (Argv[0]) {
 307         if (execf == EXECF_TRUEEXEC)
 308             rc = execvp(Argv[0],Argv);
 309         else if (execf == EXECF_EXEC)
 310             rc = spawnvp(P_OVERLAY,Argv[0],Argv);
 311         else
 312             rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv));
 313         if (rc < 0 && dowarn)
 314             warn("Can't %s \"%s\": %s",
 315                  (execf == EXECF_SPAWN ? "spawn" : "exec"),
 316                  Argv[0], Strerror(errno));
 317         if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
 318     } else
 319         rc = -1;
 320     do_execfree();
 321     return rc;
 322 }
 323
 324 int
 325 do_spawn(cmd)
 326 char *cmd;
 327 {
 328     return do_spawn2(cmd, EXECF_SPAWN);
 329 }
 330
 331 bool
 332 do_exec(cmd)
 333 char *cmd;
 334 {
 335     return do_spawn2(cmd, EXECF_EXEC);
 336 }
 337
 338 bool
 339 os2exec(cmd)
 340 char *cmd;
 341 {
 342     return do_spawn2(cmd, EXECF_TRUEEXEC);
 343 }
 344
 345 #ifndef HAS_FORK
 346 FILE *
 347 my_popen(cmd,mode)
 348 char    *cmd;
 349 char    *mode;
 350 {
 351 #ifdef TRYSHELL
 352     return popen(cmd, mode);
 353 #else
 354     char *shell = getenv("EMXSHELL");
 355     FILE *res;
 356
 357     my_setenv("EMXSHELL", SH_PATH);
 358     res = popen(cmd, mode);
 359     my_setenv("EMXSHELL", shell);
 360     return res;
 361 #endif
 362 }
 363 #endif
 364
 365 /*****************************************************************************/
 366
 367 #ifndef HAS_FORK
 368 int
 369 fork(void)
 370 {
 371     die(no_func, "Unsupported function fork");
 372     errno = EINVAL;
 373     return -1;
 374 }
 375 #endif
 376
 377 /*****************************************************************************/
 378 /* not implemented in EMX 0.9a */
 379
 380 void *  ctermid(x)      { return 0; }
 381
 382 #ifdef MYTTYNAME /* was not in emx0.9a */
 383 void *  ttyname(x)      { return 0; }
 384 #endif
 385
 386 /*****************************************************************************/
 387 /* my socket forwarders - EMX lib only provides static forwarders */
 388
 389 static HMODULE htcp = 0;
 390
 391 static void *
 392 tcp0(char *name)
 393 {
 394     static BYTE buf[20];
 395     PFN fcn;
 396     if (!htcp)
 397         DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
 398     if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
 399         return (void *) ((void * (*)(void)) fcn) ();
 400     return 0;
 401 }
 402
 403 static void
 404 tcp1(char *name, int arg)
 405 {
 406     static BYTE buf[20];
 407     PFN fcn;
 408     if (!htcp)
 409         DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
 410     if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
 411         ((void (*)(int)) fcn) (arg);
 412 }
 413
 414 void *  gethostent()    { return tcp0("GETHOSTENT");  }
 415 void *  getnetent()     { return tcp0("GETNETENT");   }
 416 void *  getprotoent()   { return tcp0("GETPROTOENT"); }
 417 void *  getservent()    { return tcp0("GETSERVENT");  }
 418 void    sethostent(x)   { tcp1("SETHOSTENT",  x); }
 419 void    setnetent(x)    { tcp1("SETNETENT",   x); }
 420 void    setprotoent(x)  { tcp1("SETPROTOENT", x); }
 421 void    setservent(x)   { tcp1("SETSERVENT",  x); }
 422 void    endhostent()    { tcp0("ENDHOSTENT");  }
 423 void    endnetent()     { tcp0("ENDNETENT");   }
 424 void    endprotoent()   { tcp0("ENDPROTOENT"); }
 425 void    endservent()    { tcp0("ENDSERVENT");  }
 426
 427 /*****************************************************************************/
 428 /* not implemented in C Set++ */
 429
 430 #ifndef __EMX__
 431 int     setuid(x)       { errno = EINVAL; return -1; }
 432 int     setgid(x)       { errno = EINVAL; return -1; }
 433 #endif
 434
 435 /*****************************************************************************/
 436 /* stat() hack for char/block device */
 437
 438 #if OS2_STAT_HACK
 439
 440     /* First attempt used DosQueryFSAttach which crashed the system when
 441        used with 5.001. Now just look for /dev/. */
 442
 443 int
 444 os2_stat(char *name, struct stat *st)
 445 {
 446     static int ino = SHRT_MAX;
 447
 448     if (stricmp(name, "/dev/con") != 0
 449      && stricmp(name, "/dev/tty") != 0)
 450         return stat(name, st);
 451
 452     memset(st, 0, sizeof *st);
 453     st->st_mode = S_IFCHR|0666;
 454     st->st_ino = (ino-- & 0x7FFF);
 455     st->st_nlink = 1;
 456     return 0;
 457 }
 458
 459 #endif
 460
 461 #ifdef USE_PERL_SBRK
 462
 463 /* SBRK() emulation, mostly moved to malloc.c. */
 464
 465 void *
 466 sys_alloc(int size) {
 467     void *got;
 468     APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
 469
 470     if (rc == ERROR_NOT_ENOUGH_MEMORY) {
 471         return (void *) -1;
 472     } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
 473     return got;
 474 }
 475
 476 #endif /* USE_PERL_SBRK */
 477
 478 /* tmp path */
 479
 480 char *tmppath = TMPPATH1;
 481
 482 void
 483 settmppath()
 484 {
 485     char *p = getenv("TMP"), *tpath;
 486     int len;
 487
 488     if (!p) p = getenv("TEMP");
 489     if (!p) return;
 490     len = strlen(p);
 491     tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
 492     strcpy(tpath, p);
 493     tpath[len] = '/';
 494     strcpy(tpath + len + 1, TMPPATH1);
 495     tmppath = tpath;
 496 }
 497
 498 #include "XSUB.h"
 499
 500 XS(XS_File__Copy_syscopy)
 501 {
 502     dXSARGS;
 503     if (items < 2 || items > 3)
 504         croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
 505     {
 506         char *  src = (char *)SvPV(ST(0),na);
 507         char *  dst = (char *)SvPV(ST(1),na);
 508         U32     flag;
 509         int     RETVAL, rc;
 510
 511         if (items < 3)
 512             flag = 0;
 513         else {
 514             flag = (unsigned long)SvIV(ST(2));
 515         }
 516
 517         RETVAL = !CheckOSError(DosCopy(src, dst, flag));
 518         ST(0) = sv_newmortal();
 519         sv_setiv(ST(0), (IV)RETVAL);
 520     }
 521     XSRETURN(1);
 522 }
 523
 524 char *
 525 mod2fname(sv)
 526      SV   *sv;
 527 {
 528     static char fname[9];
 529     int pos = 6, len, avlen;
 530     unsigned int sum = 0;
 531     AV  *av;
 532     SV  *svp;
 533     char *s;
 534
 535     if (!SvROK(sv)) croak("Not a reference given to mod2fname");
 536     sv = SvRV(sv);
 537     if (SvTYPE(sv) != SVt_PVAV)
 538       croak("Not array reference given to mod2fname");
 539
 540     avlen = av_len((AV*)sv);
 541     if (avlen < 0)
 542       croak("Empty array reference given to mod2fname");
 543
 544     s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
 545     strncpy(fname, s, 8);
 546     len = strlen(s);
 547     if (len < 6) pos = len;
 548     while (*s) {
 549         sum = 33 * sum + *(s++);        /* Checksumming first chars to
 550                                          * get the capitalization into c.s. */
 551     }
 552     avlen --;
 553     while (avlen >= 0) {
 554         s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
 555         while (*s) {
 556             sum = 33 * sum + *(s++);    /* 7 is primitive mod 13. */
 557         }
 558         avlen --;
 559     }
 560     fname[pos] = 'A' + (sum % 26);
 561     fname[pos + 1] = 'A' + (sum / 26 % 26);
 562     fname[pos + 2] = '\0';
 563     return (char *)fname;
 564 }
 565
 566 XS(XS_DynaLoader_mod2fname)
 567 {
 568     dXSARGS;
 569     if (items != 1)
 570         croak("Usage: DynaLoader::mod2fname(sv)");
 571     {
 572         SV *    sv = ST(0);
 573         char *  RETVAL;
 574
 575         RETVAL = mod2fname(sv);
 576         ST(0) = sv_newmortal();
 577         sv_setpv((SV*)ST(0), RETVAL);
 578     }
 579     XSRETURN(1);
 580 }
 581
 582 char *
 583 os2error(int rc)
 584 {
 585         static char buf[300];
 586         ULONG len;
 587
 588         if (rc == 0)
 589                 return NULL;
 590         if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
 591                 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
 592         else
 593                 buf[len] = '\0';
 594         return buf;
 595 }
 596
 597 OS2_Perl_data_t OS2_Perl_data;
 598
 599 int
 600 Xs_OS2_init()
 601 {
 602     char *file = __FILE__;
 603     {
 604         GV *gv;
 605
 606         newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
 607         newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
 608         gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
 609         GvMULTI_on(gv);
 610 #ifdef PERL_IS_AOUT
 611         sv_setiv(GvSV(gv), 1);
 612 #endif
 613     }
 614 }
 615
 616 void
 617 Perl_OS2_init()
 618 {
 619     char *shell;
 620
 621     settmppath();
 622     OS2_Perl_data.xs_init = &Xs_OS2_init;
 623     if ( (shell = getenv("PERL_SH_DRIVE")) ) {
 624         sh_path[0] = shell[0];
 625     } else if ( (shell = getenv("PERL_SH_DIR")) ) {
 626         int l = strlen(shell);
 627         if (shell[l-1] == '/' || shell[l-1] == '\\') {
 628             l--;
 629         }
 630         if (l > STATIC_FILE_LENGTH - 7) {
 631             die("PERL_SH_DIR too long");
 632         }
 633         strncpy(sh_path, shell, l);
 634         strcpy(sh_path + l, "/sh.exe");
 635     }
 636 }
 637
 638 char sh_path[STATIC_FILE_LENGTH+1] = SH_PATH_INI;
 639
 640 char *
 641 perllib_mangle(char *s, unsigned int l)
 642 {
 643     static char *newp, *oldp;
 644     static int newl, oldl, notfound;
 645     static char ret[STATIC_FILE_LENGTH+1];
 646
 647     if (!newp && !notfound) {
 648         newp = getenv("PERLLIB_PREFIX");
 649         if (newp) {
 650             oldp = newp;
 651             while (*newp && !isSPACE(*newp) && *newp != ';') {
 652                 newp++; oldl++;         /* Skip digits. */
 653             }
 654             while (*newp && (isSPACE(*newp) || *newp == ';')) {
 655                 newp++;                 /* Skip whitespace. */
 656             }
 657             newl = strlen(newp);
 658             if (newl == 0 || oldl == 0) {
 659                 die("Malformed PERLLIB_PREFIX");
 660             }
 661         } else {
 662             notfound = 1;
 663         }
 664     }
 665     if (!newp) {
 666         return s;
 667     }
 668     if (l == 0) {
 669         l = strlen(s);
 670     }
 671     if (l <= oldl || strnicmp(oldp, s, oldl) != 0) {
 672         return s;
 673     }
 674     if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
 675         die("Malformed PERLLIB_PREFIX");
 676     }
 677     strncpy(ret, newp, newl);
 678     strcpy(ret + newl, s + oldl);
 679     return ret;
 680 }
 681
 682 extern void dlopen();
 683 void *fakedl = &dlopen;         /* Pull in dynaloading part. */