os2/os2.c

   1 #define INCL_DOS
   2 #define INCL_NOPM
   3 #define INCL_DOSFILEMGR
   4 #ifndef NO_SYS_ALLOC
   5 #  define INCL_DOSMEMMGR
   6 #  define INCL_DOSERRORS
   7 #endif /* ! defined NO_SYS_ALLOC */
   8 #include <os2.h>
   9
  10 /*
  11  * Various Unix compatibility functions for OS/2
  12  */
  13
  14 #include <stdio.h>
  15 #include <errno.h>
  16 #include <limits.h>
  17 #include <process.h>
  18
  19 #include "EXTERN.h"
  20 #include "perl.h"
  21
  22 /*****************************************************************************/
  23 /* priorities */
  24 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
  25                                                self inverse. */
  26 #define QSS_INI_BUFFER 1024
  27
  28 PQTOPLEVEL
  29 get_sysinfo(ULONG pid, ULONG flags)
  30 {
  31     char *pbuffer;
  32     ULONG rc, buf_len = QSS_INI_BUFFER;
  33
  34     New(1022, pbuffer, buf_len, char);
  35     /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
  36     rc = QuerySysState(flags, pid, pbuffer, buf_len);
  37     while (rc == ERROR_BUFFER_OVERFLOW) {
  38         Renew(pbuffer, buf_len *= 2, char);
  39         rc = QuerySysState(QSS_PROCESS, pid, pbuffer, buf_len);
  40     }
  41     if (rc) {
  42         FillOSError(rc);
  43         Safefree(pbuffer);
  44         return 0;
  45     }
  46     return (PQTOPLEVEL)pbuffer;
  47 }
  48
  49 #define PRIO_ERR 0x1111
  50
  51 static ULONG
  52 sys_prio(pid)
  53 {
  54   ULONG prio;
  55   PQTOPLEVEL psi;
  56
  57   psi = get_sysinfo(pid, QSS_PROCESS);
  58   if (!psi) {
  59       return PRIO_ERR;
  60   }
  61   if (pid != psi->procdata->pid) {
  62       Safefree(psi);
  63       croak("panic: wrong pid in sysinfo");
  64   }
  65   prio = psi->procdata->threads->priority;
  66   Safefree(psi);
  67   return prio;
  68 }
  69
  70 int
  71 setpriority(int which, int pid, int val)
  72 {
  73   ULONG rc, prio;
  74   PQTOPLEVEL psi;
  75
  76   prio = sys_prio(pid);
  77
  78   if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
  79       /* Do not change class. */
  80       return CheckOSError(DosSetPriority((pid < 0)
  81                                          ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
  82                                          0,
  83                                          (32 - val) % 32 - (prio & 0xFF),
  84                                          abs(pid)))
  85       ? -1 : 0;
  86   } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
  87       /* Documentation claims one can change both class and basevalue,
  88        * but I find it wrong. */
  89       /* Change class, but since delta == 0 denotes absolute 0, correct. */
  90       if (CheckOSError(DosSetPriority((pid < 0)
  91                                       ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
  92                                       priors[(32 - val) >> 5] + 1,
  93                                       0,
  94                                       abs(pid))))
  95           return -1;
  96       if ( ((32 - val) % 32) == 0 ) return 0;
  97       return CheckOSError(DosSetPriority((pid < 0)
  98                                          ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
  99                                          0,
 100                                          (32 - val) % 32,
 101                                          abs(pid)))
 102           ? -1 : 0;
 103   }
 104 /*   else return CheckOSError(DosSetPriority((pid < 0)  */
 105 /*                                        ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
 106 /*                                        priors[(32 - val) >> 5] + 1,  */
 107 /*                                        (32 - val) % 32 - (prio & 0xFF),  */
 108 /*                                        abs(pid))) */
 109 /*       ? -1 : 0; */
 110 }
 111
 112 int
 113 getpriority(int which /* ignored */, int pid)
 114 {
 115   TIB *tib;
 116   PIB *pib;
 117   ULONG rc, ret;
 118
 119   /* DosGetInfoBlocks has old priority! */
 120 /*   if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
 121 /*   if (pid != pib->pib_ulpid) { */
 122   ret = sys_prio(pid);
 123   if (ret == PRIO_ERR) {
 124       return -1;
 125   }
 126 /*   } else */
 127 /*       ret = tib->tib_ptib2->tib2_ulpri; */
 128   return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
 129 }
 130
 131 /*****************************************************************************/
 132 /* spawn */
 133
 134 static int
 135 result(int flag, int pid)
 136 {
 137         int r, status;
 138         Signal_t (*ihand)();     /* place to save signal during system() */
 139         Signal_t (*qhand)();     /* place to save signal during system() */
 140
 141         if (pid < 0 || flag != 0)
 142                 return pid;
 143
 144         ihand = signal(SIGINT, SIG_IGN);
 145         qhand = signal(SIGQUIT, SIG_IGN);
 146         do {
 147             r = wait4pid(pid, &status, 0);
 148         } while (r == -1 && errno == EINTR);
 149         signal(SIGINT, ihand);
 150         signal(SIGQUIT, qhand);
 151
 152         statusvalue = (U16)status;
 153         if (r < 0)
 154                 return -1;
 155         return status & 0xFFFF;
 156 }
 157
 158 int
 159 do_aspawn(really,mark,sp)
 160 SV *really;
 161 register SV **mark;
 162 register SV **sp;
 163 {
 164     register char **a;
 165     char *tmps;
 166     int rc;
 167     int flag = P_WAIT, trueflag;
 168
 169     if (sp > mark) {
 170         New(401,Argv, sp - mark + 1, char*);
 171         a = Argv;
 172
 173         if (mark < sp && SvIOKp(*(mark+1))) {
 174                 ++mark;
 175                 flag = SvIVx(*mark);
 176         }
 177
 178         while (++mark <= sp) {
 179             if (*mark)
 180                 *a++ = SvPVx(*mark, na);
 181             else
 182                 *a++ = "";
 183         }
 184         *a = Nullch;
 185
 186         trueflag = flag;
 187         if (flag == P_WAIT)
 188                 flag = P_NOWAIT;
 189
 190         if (*Argv[0] != '/' && *Argv[0] != '\\') /* will swawnvp use PATH? */
 191             TAINT_ENV();        /* testing IFS here is overkill, probably */
 192         if (really && *(tmps = SvPV(really, na)))
 193             rc = result(trueflag, spawnvp(flag,tmps,Argv));
 194         else
 195             rc = result(trueflag, spawnvp(flag,Argv[0],Argv));
 196
 197         if (rc < 0 && dowarn)
 198             warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
 199         if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
 200     } else
 201         rc = -1;
 202     do_execfree();
 203     return rc;
 204 }
 205
 206 int
 207 do_spawn(cmd)
 208 char *cmd;
 209 {
 210     register char **a;
 211     register char *s;
 212     char flags[10];
 213     char *shell, *copt;
 214     int rc;
 215
 216 #ifdef TRYSHELL
 217     if ((shell = getenv("EMXSHELL")) != NULL)
 218         copt = "-c";
 219     else if ((shell = getenv("SHELL")) != NULL)
 220         copt = "-c";
 221     else if ((shell = getenv("COMSPEC")) != NULL)
 222         copt = "/C";
 223     else
 224         shell = "cmd.exe";
 225 #else
 226     /* Consensus on perl5-porters is that it is _very_ important to
 227        have a shell which will not change between computers with the
 228        same architecture, to avoid "action on a distance".
 229        And to have simple build, this shell should be sh. */
 230     shell = SH_PATH;
 231     copt = "-c";
 232 #endif
 233
 234     while (*cmd && isSPACE(*cmd))
 235         cmd++;
 236
 237     /* save an extra exec if possible */
 238     /* see if there are shell metacharacters in it */
 239
 240     if (*cmd == '.' && isSPACE(cmd[1]))
 241         goto doshell;
 242
 243     if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
 244         goto doshell;
 245
 246     for (s = cmd; *s && isALPHA(*s); s++) ;     /* catch VAR=val gizmo */
 247     if (*s == '=')
 248         goto doshell;
 249
 250     for (s = cmd; *s; s++) {
 251         if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
 252             if (*s == '\n' && !s[1]) {
 253                 *s = '\0';
 254                 break;
 255             }
 256           doshell:
 257             rc = result(P_WAIT,
 258                           spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
 259             if (rc < 0 && dowarn)
 260                 warn("Can't spawn \"%s\": %s", shell, Strerror(errno));
 261             if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
 262             return rc;
 263         }
 264     }
 265
 266     New(402,Argv, (s - cmd) / 2 + 2, char*);
 267     Cmd = savepvn(cmd, s-cmd);
 268     a = Argv;
 269     for (s = Cmd; *s;) {
 270         while (*s && isSPACE(*s)) s++;
 271         if (*s)
 272             *(a++) = s;
 273         while (*s && !isSPACE(*s)) s++;
 274         if (*s)
 275             *s++ = '\0';
 276     }
 277     *a = Nullch;
 278     if (Argv[0]) {
 279         rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv));
 280         if (rc < 0 && dowarn)
 281             warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
 282         if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
 283     } else
 284         rc = -1;
 285     do_execfree();
 286     return rc;
 287 }
 288
 289 #ifndef HAS_FORK
 290 FILE *
 291 my_popen(cmd,mode)
 292 char    *cmd;
 293 char    *mode;
 294 {
 295     char *shell = getenv("EMXSHELL");
 296     FILE *res;
 297
 298     my_setenv("EMXSHELL", SH_PATH);
 299     res = popen(cmd, mode);
 300     my_setenv("EMXSHELL", shell);
 301     return res;
 302 }
 303 #endif
 304
 305 /*****************************************************************************/
 306
 307 #ifndef HAS_FORK
 308 int
 309 fork(void)
 310 {
 311     die(no_func, "Unsupported function fork");
 312     errno = EINVAL;
 313     return -1;
 314 }
 315 #endif
 316
 317 /*****************************************************************************/
 318 /* not implemented in EMX 0.9a */
 319
 320 void *  ctermid(x)      { return 0; }
 321
 322 #ifdef MYTTYNAME /* was not in emx0.9a */
 323 void *  ttyname(x)      { return 0; }
 324 #endif
 325
 326 void *  gethostent()    { return 0; }
 327 void *  getnetent()     { return 0; }
 328 void *  getprotoent()   { return 0; }
 329 void *  getservent()    { return 0; }
 330 void    sethostent(x)   {}
 331 void    setnetent(x)    {}
 332 void    setprotoent(x)  {}
 333 void    setservent(x)   {}
 334 void    endhostent(x)   {}
 335 void    endnetent(x)    {}
 336 void    endprotoent(x)  {}
 337 void    endservent(x)   {}
 338
 339 /*****************************************************************************/
 340 /* stat() hack for char/block device */
 341
 342 #if OS2_STAT_HACK
 343
 344     /* First attempt used DosQueryFSAttach which crashed the system when
 345        used with 5.001. Now just look for /dev/. */
 346
 347 int
 348 os2_stat(char *name, struct stat *st)
 349 {
 350     static int ino = SHRT_MAX;
 351
 352     if (stricmp(name, "/dev/con") != 0
 353      && stricmp(name, "/dev/tty") != 0)
 354         return stat(name, st);
 355
 356     memset(st, 0, sizeof *st);
 357     st->st_mode = S_IFCHR|0666;
 358     st->st_ino = (ino-- & 0x7FFF);
 359     st->st_nlink = 1;
 360     return 0;
 361 }
 362
 363 #endif
 364
 365 #ifndef NO_SYS_ALLOC
 366
 367 static char *oldchunk;
 368 static long oldsize;
 369
 370 #define _32_K (1<<15)
 371 #define _64_K (1<<16)
 372
 373 /* The real problem is that DosAllocMem will grant memory on 64K-chunks
 374  * boundaries only. Note that addressable space for application memory
 375  * is around 240M, thus we will run out of addressable space if we
 376  * allocate around 14M worth of 4K segments.
 377  * Thus we allocate memory in 64K chunks, and abandon the rest of the old
 378  * chunk if the new is bigger than that rest. Also, we just allocate
 379  * whatever is requested if the size is bigger that 32K. With this strategy
 380  * we cannot lose more than 1/2 of addressable space. */
 381
 382 void *
 383 sbrk(int size)
 384 {
 385     char *got;
 386     APIRET rc;
 387     int small, reqsize;
 388
 389     if (!size) return 0;
 390     else if (size <= oldsize) {
 391         got = oldchunk;
 392         oldchunk += size;
 393         oldsize -= size;
 394         return (void *)got;
 395     } else if (size >= _32_K) {
 396         small = 0;
 397     } else {
 398         reqsize = size;
 399         size = _64_K;
 400         small = 1;
 401     }
 402     rc = DosAllocMem((void **)&got, size, PAG_COMMIT | PAG_WRITE);
 403     if (rc == ERROR_NOT_ENOUGH_MEMORY) {
 404         return (void *) -1;
 405     } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
 406     if (small) {
 407         /* Chunk is small, register the rest for future allocs. */
 408         oldchunk = got + reqsize;
 409         oldsize = size - reqsize;
 410     }
 411     return (void *)got;
 412 }
 413 #endif /* ! defined NO_SYS_ALLOC */
 414
 415 /* tmp path */
 416
 417 char *tmppath = TMPPATH1;
 418
 419 void
 420 settmppath()
 421 {
 422     char *p = getenv("TMP"), *tpath;
 423     int len;
 424
 425     if (!p) p = getenv("TEMP");
 426     if (!p) return;
 427     len = strlen(p);
 428     tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
 429     strcpy(tpath, p);
 430     tpath[len] = '/';
 431     strcpy(tpath + len + 1, TMPPATH1);
 432     tmppath = tpath;
 433 }
 434
 435 #include "XSUB.h"
 436
 437 XS(XS_File__Copy_syscopy)
 438 {
 439     dXSARGS;
 440     if (items < 2 || items > 3)
 441         croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
 442     {
 443         char *  src = (char *)SvPV(ST(0),na);
 444         char *  dst = (char *)SvPV(ST(1),na);
 445         U32     flag;
 446         int     RETVAL, rc;
 447
 448         if (items < 3)
 449             flag = 0;
 450         else {
 451             flag = (unsigned long)SvIV(ST(2));
 452         }
 453
 454         RETVAL = !CheckOSError(DosCopy(src, dst, flag));
 455         ST(0) = sv_newmortal();
 456         sv_setiv(ST(0), (IV)RETVAL);
 457     }
 458     XSRETURN(1);
 459 }
 460
 461 char *
 462 mod2fname(sv)
 463      SV   *sv;
 464 {
 465     static char fname[9];
 466     int pos = 7;
 467     int len;
 468     AV  *av;
 469     SV  *svp;
 470     char *s;
 471
 472     if (!SvROK(sv)) croak("Not a reference given to mod2fname");
 473     sv = SvRV(sv);
 474     if (SvTYPE(sv) != SVt_PVAV)
 475       croak("Not array reference given to mod2fname");
 476     if (av_len((AV*)sv) < 0)
 477       croak("Empty array reference given to mod2fname");
 478     s = SvPV(*av_fetch((AV*)sv, av_len((AV*)sv), FALSE), na);
 479     strncpy(fname, s, 8);
 480     if ((len=strlen(s)) < 7) pos = len;
 481     fname[pos] = '_';
 482     fname[pos + 1] = '\0';
 483     return (char *)fname;
 484 }
 485
 486 XS(XS_DynaLoader_mod2fname)
 487 {
 488     dXSARGS;
 489     if (items != 1)
 490         croak("Usage: DynaLoader::mod2fname(sv)");
 491     {
 492         SV *    sv = ST(0);
 493         char *  RETVAL;
 494
 495         RETVAL = mod2fname(sv);
 496         ST(0) = sv_newmortal();
 497         sv_setpv((SV*)ST(0), RETVAL);
 498     }
 499     XSRETURN(1);
 500 }
 501
 502 char *
 503 os2error(int rc)
 504 {
 505         static char buf[300];
 506         ULONG len;
 507
 508         if (rc == 0)
 509                 return NULL;
 510         if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
 511                 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
 512         else
 513                 buf[len] = '\0';
 514         return buf;
 515 }
 516
 517 OS2_Perl_data_t OS2_Perl_data;
 518
 519 int
 520 Xs_OS2_init()
 521 {
 522     char *file = __FILE__;
 523     {
 524         GV *gv;
 525
 526         newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
 527         newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
 528 #ifdef PERL_IS_AOUT
 529         gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
 530         GvMULTI_on(gv);
 531         sv_setiv(GvSV(gv), 1);
 532 #endif
 533     }
 534 }
 535
 536 void
 537 Perl_OS2_init()
 538 {
 539     char *shell;
 540
 541     settmppath();
 542     OS2_Perl_data.xs_init = &Xs_OS2_init;
 543     if ( (shell = getenv("PERL_SH_DRIVE")) ) {
 544         sh_path[0] = shell[0];
 545     }
 546 }
 547
 548 char sh_path[33] = BIN_SH;
 549
 550 extern void dlopen();
 551 void *fakedl = &dlopen;         /* Pull in dynaloading part. */