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 #ifdef USE_THREADS
  22
  23 typedef void (*emx_startroutine)(void *);
  24 typedef void* (*pthreads_startroutine)(void *);
  25
  26 enum pthreads_state {
  27     pthreads_st_none = 0,
  28     pthreads_st_run,
  29     pthreads_st_exited,
  30     pthreads_st_detached,
  31     pthreads_st_waited,
  32 };
  33 const char *pthreads_states[] = {
  34     "uninit",
  35     "running",
  36     "exited",
  37     "detached",
  38     "waited for",
  39 };
  40
  41 typedef struct {
  42     void *status;
  43     perl_cond cond;
  44     enum pthreads_state state;
  45 } thread_join_t;
  46
  47 thread_join_t *thread_join_data;
  48 int thread_join_count;
  49 perl_mutex start_thread_mutex;
  50
  51 int
  52 pthread_join(perl_os_thread tid, void **status)
  53 {
  54     MUTEX_LOCK(&start_thread_mutex);
  55     switch (thread_join_data[tid].state) {
  56     case pthreads_st_exited:
  57         thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
  58         MUTEX_UNLOCK(&start_thread_mutex);
  59         *status = thread_join_data[tid].status;
  60         break;
  61     case pthreads_st_waited:
  62         MUTEX_UNLOCK(&start_thread_mutex);
  63         croak("join with a thread with a waiter");
  64         break;
  65     case pthreads_st_run:
  66         thread_join_data[tid].state = pthreads_st_waited;
  67         COND_INIT(&thread_join_data[tid].cond);
  68         MUTEX_UNLOCK(&start_thread_mutex);
  69         COND_WAIT(&thread_join_data[tid].cond, NULL);
  70         COND_DESTROY(&thread_join_data[tid].cond);
  71         thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
  72         *status = thread_join_data[tid].status;
  73         break;
  74     default:
  75         MUTEX_UNLOCK(&start_thread_mutex);
  76         croak("join: unknown thread state: '%s'",
  77               pthreads_states[thread_join_data[tid].state]);
  78         break;
  79     }
  80     return 0;
  81 }
  82
  83 void
  84 pthread_startit(void *arg)
  85 {
  86     /* Thread is already started, we need to transfer control only */
  87     pthreads_startroutine start_routine = *((pthreads_startroutine*)arg);
  88     int tid = pthread_self();
  89     void *retval;
  90
  91     arg = ((void**)arg)[1];
  92     if (tid >= thread_join_count) {
  93         int oc = thread_join_count;
  94
  95         thread_join_count = tid + 5 + tid/5;
  96         if (thread_join_data) {
  97             Renew(thread_join_data, thread_join_count, thread_join_t);
  98             Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
  99         } else {
 100             Newz(1323, thread_join_data, thread_join_count, thread_join_t);
 101         }
 102     }
 103     if (thread_join_data[tid].state != pthreads_st_none)
 104         croak("attempt to reuse thread id %i", tid);
 105     thread_join_data[tid].state = pthreads_st_run;
 106     /* Now that we copied/updated the guys, we may release the caller... */
 107     MUTEX_UNLOCK(&start_thread_mutex);
 108     thread_join_data[tid].status = (*start_routine)(arg);
 109     switch (thread_join_data[tid].state) {
 110     case pthreads_st_waited:
 111         COND_SIGNAL(&thread_join_data[tid].cond);
 112         break;
 113     default:
 114         thread_join_data[tid].state = pthreads_st_exited;
 115         break;
 116     }
 117 }
 118
 119 int
 120 pthread_create(perl_os_thread *tid, const pthread_attr_t *attr,
 121                void *(*start_routine)(void*), void *arg)
 122 {
 123     void *args[2];
 124
 125     args[0] = (void*)start_routine;
 126     args[1] = arg;
 127
 128     MUTEX_LOCK(&start_thread_mutex);
 129     *tid = _beginthread(pthread_startit, /*stack*/ NULL,
 130                         /*stacksize*/ 10*1024*1024, (void*)args);
 131     MUTEX_LOCK(&start_thread_mutex);
 132     MUTEX_UNLOCK(&start_thread_mutex);
 133     return *tid ? 0 : EINVAL;
 134 }
 135
 136 int
 137 pthread_detach(perl_os_thread tid)
 138 {
 139     MUTEX_LOCK(&start_thread_mutex);
 140     switch (thread_join_data[tid].state) {
 141     case pthreads_st_waited:
 142         MUTEX_UNLOCK(&start_thread_mutex);
 143         croak("detach on a thread with a waiter");
 144         break;
 145     case pthreads_st_run:
 146         thread_join_data[tid].state = pthreads_st_detached;
 147         MUTEX_UNLOCK(&start_thread_mutex);
 148         break;
 149     default:
 150         MUTEX_UNLOCK(&start_thread_mutex);
 151         croak("detach: unknown thread state: '%s'",
 152               pthreads_states[thread_join_data[tid].state]);
 153         break;
 154     }
 155     return 0;
 156 }
 157
 158 /* This is a very bastardized version: */
 159 int
 160 os2_cond_wait(perl_cond *c, perl_mutex *m)
 161 {
 162     int rc;
 163     if ((rc = DosResetEventSem(*c,&na)) && (rc != ERROR_ALREADY_RESET))
 164         croak("panic: COND_WAIT-reset: rc=%i", rc);
 165     if (m) MUTEX_UNLOCK(m);
 166     if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT)))
 167         croak("panic: COND_WAIT: rc=%i", rc);
 168     if (m) MUTEX_LOCK(m);
 169 }
 170 #endif
 171
 172 /*****************************************************************************/
 173 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
 174 static PFN ExtFCN[2];                   /* Labeled by ord below. */
 175 static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
 176 #define ORD_QUERY_ELP   0
 177 #define ORD_SET_ELP     1
 178
 179 APIRET
 180 loadByOrd(ULONG ord)
 181 {
 182     if (ExtFCN[ord] == NULL) {
 183         static HMODULE hdosc = 0;
 184         BYTE buf[20];
 185         PFN fcn;
 186         APIRET rc;
 187
 188         if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf,
 189                                                   "doscalls", &hdosc)))
 190             || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
 191             die("This version of OS/2 does not support doscalls.%i",
 192                 loadOrd[ord]);
 193         ExtFCN[ord] = fcn;
 194     }
 195     if ((long)ExtFCN[ord] == -1) die("panic queryaddr");
 196 }
 197
 198 /* priorities */
 199 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
 200                                                self inverse. */
 201 #define QSS_INI_BUFFER 1024
 202
 203 PQTOPLEVEL
 204 get_sysinfo(ULONG pid, ULONG flags)
 205 {
 206     char *pbuffer;
 207     ULONG rc, buf_len = QSS_INI_BUFFER;
 208
 209     New(1322, pbuffer, buf_len, char);
 210     /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
 211     rc = QuerySysState(flags, pid, pbuffer, buf_len);
 212     while (rc == ERROR_BUFFER_OVERFLOW) {
 213         Renew(pbuffer, buf_len *= 2, char);
 214         rc = QuerySysState(flags, pid, pbuffer, buf_len);
 215     }
 216     if (rc) {
 217         FillOSError(rc);
 218         Safefree(pbuffer);
 219         return 0;
 220     }
 221     return (PQTOPLEVEL)pbuffer;
 222 }
 223
 224 #define PRIO_ERR 0x1111
 225
 226 static ULONG
 227 sys_prio(pid)
 228 {
 229   ULONG prio;
 230   PQTOPLEVEL psi;
 231
 232   psi = get_sysinfo(pid, QSS_PROCESS);
 233   if (!psi) {
 234       return PRIO_ERR;
 235   }
 236   if (pid != psi->procdata->pid) {
 237       Safefree(psi);
 238       croak("panic: wrong pid in sysinfo");
 239   }
 240   prio = psi->procdata->threads->priority;
 241   Safefree(psi);
 242   return prio;
 243 }
 244
 245 int
 246 setpriority(int which, int pid, int val)
 247 {
 248   ULONG rc, prio;
 249   PQTOPLEVEL psi;
 250
 251   prio = sys_prio(pid);
 252
 253   if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
 254   if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
 255       /* Do not change class. */
 256       return CheckOSError(DosSetPriority((pid < 0)
 257                                          ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
 258                                          0,
 259                                          (32 - val) % 32 - (prio & 0xFF),
 260                                          abs(pid)))
 261       ? -1 : 0;
 262   } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
 263       /* Documentation claims one can change both class and basevalue,
 264        * but I find it wrong. */
 265       /* Change class, but since delta == 0 denotes absolute 0, correct. */
 266       if (CheckOSError(DosSetPriority((pid < 0)
 267                                       ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
 268                                       priors[(32 - val) >> 5] + 1,
 269                                       0,
 270                                       abs(pid))))
 271           return -1;
 272       if ( ((32 - val) % 32) == 0 ) return 0;
 273       return CheckOSError(DosSetPriority((pid < 0)
 274                                          ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
 275                                          0,
 276                                          (32 - val) % 32,
 277                                          abs(pid)))
 278           ? -1 : 0;
 279   }
 280 /*   else return CheckOSError(DosSetPriority((pid < 0)  */
 281 /*                                        ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
 282 /*                                        priors[(32 - val) >> 5] + 1,  */
 283 /*                                        (32 - val) % 32 - (prio & 0xFF),  */
 284 /*                                        abs(pid))) */
 285 /*       ? -1 : 0; */
 286 }
 287
 288 int
 289 getpriority(int which /* ignored */, int pid)
 290 {
 291   TIB *tib;
 292   PIB *pib;
 293   ULONG rc, ret;
 294
 295   if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
 296   /* DosGetInfoBlocks has old priority! */
 297 /*   if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
 298 /*   if (pid != pib->pib_ulpid) { */
 299   ret = sys_prio(pid);
 300   if (ret == PRIO_ERR) {
 301       return -1;
 302   }
 303 /*   } else */
 304 /*       ret = tib->tib_ptib2->tib2_ulpri; */
 305   return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
 306 }
 307
 308 /*****************************************************************************/
 309 /* spawn */
 310 typedef void (*Sigfunc) _((int));
 311
 312 static int
 313 result(int flag, int pid)
 314 {
 315         int r, status;
 316         Signal_t (*ihand)();     /* place to save signal during system() */
 317         Signal_t (*qhand)();     /* place to save signal during system() */
 318 #ifndef __EMX__
 319         RESULTCODES res;
 320         int rpid;
 321 #endif
 322
 323         if (pid < 0 || flag != 0)
 324                 return pid;
 325
 326 #ifdef __EMX__
 327         ihand = rsignal(SIGINT, SIG_IGN);
 328         qhand = rsignal(SIGQUIT, SIG_IGN);
 329         do {
 330             r = wait4pid(pid, &status, 0);
 331         } while (r == -1 && errno == EINTR);
 332         rsignal(SIGINT, ihand);
 333         rsignal(SIGQUIT, qhand);
 334
 335         statusvalue = (U16)status;
 336         if (r < 0)
 337                 return -1;
 338         return status & 0xFFFF;
 339 #else
 340         ihand = rsignal(SIGINT, SIG_IGN);
 341         r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
 342         rsignal(SIGINT, ihand);
 343         statusvalue = res.codeResult << 8 | res.codeTerminate;
 344         if (r)
 345                 return -1;
 346         return statusvalue;
 347 #endif
 348 }
 349
 350 #define EXECF_SPAWN 0
 351 #define EXECF_EXEC 1
 352 #define EXECF_TRUEEXEC 2
 353 #define EXECF_SPAWN_NOWAIT 3
 354
 355 /* Spawn/exec a program, revert to shell if needed. */
 356 /* global Argv[] contains arguments. */
 357
 358 int
 359 do_aspawn(really, flag, execf)
 360 SV *really;
 361 U32 flag;
 362 U32 execf;
 363 {
 364     dTHR;
 365         int trueflag = flag;
 366         int rc, secondtry = 0, err;
 367         char *tmps;
 368         char buf[256], *s = 0;
 369         char *args[4];
 370         static char * fargs[4]
 371             = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
 372         char **argsp = fargs;
 373         char nargs = 4;
 374
 375         if (flag == P_WAIT)
 376                 flag = P_NOWAIT;
 377
 378       retry:
 379         if (strEQ(Argv[0],"/bin/sh"))
 380             Argv[0] = sh_path;
 381
 382         if (Argv[0][0] != '/' && Argv[0][0] != '\\'
 383             && !(Argv[0][0] && Argv[0][1] == ':'
 384                  && (Argv[0][2] == '/' || Argv[0][2] != '\\'))
 385             ) /* will swawnvp use PATH? */
 386             TAINT_ENV();        /* testing IFS here is overkill, probably */
 387         /* We should check PERL_SH* and PERLLIB_* as well? */
 388         if (!really || !*(tmps = SvPV(really, na)))
 389             tmps = Argv[0];
 390 #if 0
 391         rc = result(trueflag, spawnvp(flag,tmps,Argv));
 392 #else
 393         if (execf == EXECF_TRUEEXEC)
 394             rc = execvp(tmps,Argv);
 395         else if (execf == EXECF_EXEC)
 396             rc = spawnvp(trueflag | P_OVERLAY,tmps,Argv);
 397         else if (execf == EXECF_SPAWN_NOWAIT)
 398             rc = spawnvp(trueflag | P_NOWAIT,tmps,Argv);
 399         else                            /* EXECF_SPAWN */
 400             rc = result(trueflag,
 401                         spawnvp(trueflag | P_NOWAIT,tmps,Argv));
 402 #endif
 403         if (rc < 0 && secondtry == 0
 404             && (tmps == Argv[0])) { /* Cannot transfer `really' via shell. */
 405             err = errno;
 406             if (err == ENOENT) {        /* No such file. */
 407                 /* One reason may be that EMX added .exe. We suppose
 408                    that .exe-less files are automatically shellable.
 409                    It might have also been .cmd file without
 410                    extension. */
 411                 char *no_dir;
 412                 (no_dir = strrchr(Argv[0], '/'))
 413                     || (no_dir = strrchr(Argv[0], '\\'))
 414                     || (no_dir = Argv[0]);
 415                 if (!strchr(no_dir, '.')) {
 416                     struct stat buffer;
 417                     if (stat(Argv[0], &buffer) != -1) { /* File exists. */
 418                         /* Maybe we need to specify the full name here? */
 419                         goto doshell;
 420                     } else {
 421                         /* Try adding script extensions to the file name */
 422                         char *scr;
 423                         if ((scr = find_script(Argv[0], TRUE, NULL, 0))) {
 424                             FILE *file = fopen(scr, "r");
 425                             char *s = 0, *s1;
 426
 427                             Argv[0] = scr;
 428                             if (!file)
 429                                 goto panic_file;
 430                             if (!fgets(buf, sizeof buf, file)) {
 431                                 fclose(file);
 432                                 goto panic_file;
 433                             }
 434                             if (fclose(file) != 0) { /* Failure */
 435                               panic_file:
 436                                 warn("Error reading \"%s\": %s",
 437                                      scr, Strerror(errno));
 438                                 goto doshell;
 439                             }
 440                             if (buf[0] == '#') {
 441                                 if (buf[1] == '!')
 442                                     s = buf + 2;
 443                             } else if (buf[0] == 'e') {
 444                                 if (strnEQ(buf, "extproc", 7)
 445                                     && isSPACE(buf[7]))
 446                                     s = buf + 8;
 447                             } else if (buf[0] == 'E') {
 448                                 if (strnEQ(buf, "EXTPROC", 7)
 449                                     && isSPACE(buf[7]))
 450                                     s = buf + 8;
 451                             }
 452                             if (!s)
 453                                 goto doshell;
 454                             s1 = s;
 455                             nargs = 0;
 456                             argsp = args;
 457                             while (1) {
 458                                 while (isSPACE(*s))
 459                                     s++;
 460                                 if (*s == 0)
 461                                     break;
 462                                 if (nargs == 4) {
 463                                     nargs = -1;
 464                                     break;
 465                                 }
 466                                 args[nargs++] = s;
 467                                 while (*s && !isSPACE(*s))
 468                                     s++;
 469                                 if (*s == 0)
 470                                     break;
 471                                 *s++ = 0;
 472                             }
 473                             if (nargs == -1) {
 474                                 warn("Too many args on %.*s line of \"%s\"",
 475                                      s1 - buf, buf, scr);
 476                                 nargs = 4;
 477                                 argsp = fargs;
 478                             }
 479                             goto doshell;
 480                         }
 481                     }
 482                 }
 483                 /* Restore errno */
 484                 errno = err;
 485             } else if (err == ENOEXEC) { /* Need to send to shell. */
 486               doshell:
 487                 {
 488                 char **a = Argv;
 489
 490                 while (a[1])            /* Get to the end */
 491                     a++;
 492                 while (a >= Argv) {
 493                     *(a + nargs) = *a;  /* Argv was preallocated to be
 494                                            long enough. */
 495                     a--;
 496                 }
 497                 while (nargs-- >= 0)
 498                     Argv[nargs] = argsp[nargs];
 499                 secondtry = 1;
 500                 goto retry;
 501                 }
 502             }
 503         }
 504         if (rc < 0 && dowarn)
 505             warn("Can't %s \"%s\": %s\n",
 506                  ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
 507                   ? "spawn" : "exec"),
 508                  Argv[0], Strerror(err));
 509         if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
 510             && ((trueflag & 0xFF) == P_WAIT))
 511             rc = 255 << 8; /* Emulate the fork(). */
 512
 513     return rc;
 514 }
 515
 516 int
 517 do_aspawn(really,mark,sp)
 518 SV *really;
 519 register SV **mark;
 520 register SV **sp;
 521 {
 522     dTHR;
 523     register char **a;
 524     char *tmps = NULL;
 525     int rc;
 526     int flag = P_WAIT, trueflag, err, secondtry = 0;
 527
 528     if (sp > mark) {
 529         New(1301,Argv, sp - mark + 3, char*);
 530         a = Argv;
 531
 532         if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
 533                 ++mark;
 534                 flag = SvIVx(*mark);
 535         }
 536
 537         while (++mark <= sp) {
 538             if (*mark)
 539                 *a++ = SvPVx(*mark, na);
 540             else
 541                 *a++ = "";
 542         }
 543         *a = Nullch;
 544
 545         rc = do_spawn_ve(really, flag, EXECF_SPAWN);
 546     } else
 547         rc = -1;
 548     do_execfree();
 549     return rc;
 550 }
 551
 552 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
 553 int
 554 do_spawn2(cmd, execf)
 555 char *cmd;
 556 int execf;
 557 {
 558     register char **a;
 559     register char *s;
 560     char flags[10];
 561     char *shell, *copt, *news = NULL;
 562     int rc, added_shell = 0, err, seenspace = 0;
 563     char fullcmd[MAXNAMLEN + 1];
 564
 565 #ifdef TRYSHELL
 566     if ((shell = getenv("EMXSHELL")) != NULL)
 567         copt = "-c";
 568     else if ((shell = getenv("SHELL")) != NULL)
 569         copt = "-c";
 570     else if ((shell = getenv("COMSPEC")) != NULL)
 571         copt = "/C";
 572     else
 573         shell = "cmd.exe";
 574 #else
 575     /* Consensus on perl5-porters is that it is _very_ important to
 576        have a shell which will not change between computers with the
 577        same architecture, to avoid "action on a distance".
 578        And to have simple build, this shell should be sh. */
 579     shell = sh_path;
 580     copt = "-c";
 581 #endif
 582
 583     while (*cmd && isSPACE(*cmd))
 584         cmd++;
 585
 586     if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
 587         STRLEN l = strlen(sh_path);
 588
 589         New(1302, news, strlen(cmd) - 7 + l + 1, char);
 590         strcpy(news, sh_path);
 591         strcpy(news + l, cmd + 7);
 592         cmd = news;
 593         added_shell = 1;
 594     }
 595
 596     /* save an extra exec if possible */
 597     /* see if there are shell metacharacters in it */
 598
 599     if (*cmd == '.' && isSPACE(cmd[1]))
 600         goto doshell;
 601
 602     if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
 603         goto doshell;
 604
 605     for (s = cmd; *s && isALPHA(*s); s++) ;     /* catch VAR=val gizmo */
 606     if (*s == '=')
 607         goto doshell;
 608
 609     for (s = cmd; *s; s++) {
 610         if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
 611             if (*s == '\n' && s[1] == '\0') {
 612                 *s = '\0';
 613                 break;
 614             } else if (*s == '\\' && !seenspace) {
 615                 continue;               /* Allow backslashes in names */
 616             }
 617             /* We do not convert this to do_spawn_ve since shell
 618                should be smart enough to start itself gloriously. */
 619           doshell:
 620             if (execf == EXECF_TRUEEXEC)
 621                 return execl(shell,shell,copt,cmd,(char*)0);
 622             else if (execf == EXECF_EXEC)
 623                 return spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
 624             else if (execf == EXECF_SPAWN_NOWAIT)
 625                 return spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
 626             /* In the ak code internal P_NOWAIT is P_WAIT ??? */
 627             rc = result(P_WAIT,
 628                         spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
 629             if (rc < 0 && dowarn)
 630                 warn("Can't %s \"%s\": %s",
 631                      (execf == EXECF_SPAWN ? "spawn" : "exec"),
 632                      shell, Strerror(errno));
 633             if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
 634             if (news) Safefree(news);
 635             return rc;
 636         } else if (*s == ' ' || *s == '\t') {
 637             seenspace = 1;
 638         }
 639     }
 640
 641     /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
 642     New(1303,Argv, (s - cmd + 11) / 2, char*);
 643     Cmd = savepvn(cmd, s-cmd);
 644     a = Argv;
 645     for (s = Cmd; *s;) {
 646         while (*s && isSPACE(*s)) s++;
 647         if (*s)
 648             *(a++) = s;
 649         while (*s && !isSPACE(*s)) s++;
 650         if (*s)
 651             *s++ = '\0';
 652     }
 653     *a = Nullch;
 654     if (Argv[0])
 655         rc = do_spawn_ve(NULL, 0, execf);
 656     else
 657         rc = -1;
 658     if (news) Safefree(news);
 659     do_execfree();
 660     return rc;
 661 }
 662
 663 int
 664 do_spawn(cmd)
 665 char *cmd;
 666 {
 667     return do_spawn2(cmd, EXECF_SPAWN);
 668 }
 669
 670 int
 671 do_spawn_nowait(cmd)
 672 char *cmd;
 673 {
 674     return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
 675 }
 676
 677 bool
 678 do_exec(cmd)
 679 char *cmd;
 680 {
 681     return do_spawn2(cmd, EXECF_EXEC);
 682 }
 683
 684 bool
 685 os2exec(cmd)
 686 char *cmd;
 687 {
 688     return do_spawn2(cmd, EXECF_TRUEEXEC);
 689 }
 690
 691 PerlIO *
 692 my_syspopen(cmd,mode)
 693 char    *cmd;
 694 char    *mode;
 695 {
 696 #ifndef USE_POPEN
 697
 698     int p[2];
 699     register I32 this, that, newfd;
 700     register I32 pid, rc;
 701     PerlIO *res;
 702     SV *sv;
 703
 704     /* `this' is what we use in the parent, `that' in the child. */
 705     this = (*mode == 'w');
 706     that = !this;
 707     if (tainting) {
 708         taint_env();
 709         taint_proper("Insecure %s%s", "EXEC");
 710     }
 711     if (pipe(p) < 0)
 712         return Nullfp;
 713     /* Now we need to spawn the child. */
 714     newfd = dup(*mode == 'r');          /* Preserve std* */
 715     if (p[that] != (*mode == 'r')) {
 716         dup2(p[that], *mode == 'r');
 717         close(p[that]);
 718     }
 719     /* Where is `this' and newfd now? */
 720     fcntl(p[this], F_SETFD, FD_CLOEXEC);
 721     fcntl(newfd, F_SETFD, FD_CLOEXEC);
 722     pid = do_spawn_nowait(cmd);
 723     if (newfd != (*mode == 'r')) {
 724         dup2(newfd, *mode == 'r');      /* Return std* back. */
 725         close(newfd);
 726     }
 727     if (p[that] == (*mode == 'r'))
 728         close(p[that]);
 729     if (pid == -1) {
 730         close(p[this]);
 731         return NULL;
 732     }
 733     if (p[that] < p[this]) {
 734         dup2(p[this], p[that]);
 735         close(p[this]);
 736         p[this] = p[that];
 737     }
 738     sv = *av_fetch(fdpid,p[this],TRUE);
 739     (void)SvUPGRADE(sv,SVt_IV);
 740     SvIVX(sv) = pid;
 741     forkprocess = pid;
 742     return PerlIO_fdopen(p[this], mode);
 743
 744 #else  /* USE_POPEN */
 745
 746     PerlIO *res;
 747     SV *sv;
 748
 749 #  ifdef TRYSHELL
 750     res = popen(cmd, mode);
 751 #  else
 752     char *shell = getenv("EMXSHELL");
 753
 754     my_setenv("EMXSHELL", sh_path);
 755     res = popen(cmd, mode);
 756     my_setenv("EMXSHELL", shell);
 757 #  endif
 758     sv = *av_fetch(fdpid, PerlIO_fileno(res), TRUE);
 759     (void)SvUPGRADE(sv,SVt_IV);
 760     SvIVX(sv) = -1;                     /* A cooky. */
 761     return res;
 762
 763 #endif /* USE_POPEN */
 764
 765 }
 766
 767 /******************************************************************/
 768
 769 #ifndef HAS_FORK
 770 int
 771 fork(void)
 772 {
 773     die(no_func, "Unsupported function fork");
 774     errno = EINVAL;
 775     return -1;
 776 }
 777 #endif
 778
 779 /*******************************************************************/
 780 /* not implemented in EMX 0.9a */
 781
 782 void *  ctermid(x)      { return 0; }
 783
 784 #ifdef MYTTYNAME /* was not in emx0.9a */
 785 void *  ttyname(x)      { return 0; }
 786 #endif
 787
 788 /******************************************************************/
 789 /* my socket forwarders - EMX lib only provides static forwarders */
 790
 791 static HMODULE htcp = 0;
 792
 793 static void *
 794 tcp0(char *name)
 795 {
 796     static BYTE buf[20];
 797     PFN fcn;
 798
 799     if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
 800     if (!htcp)
 801         DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
 802     if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
 803         return (void *) ((void * (*)(void)) fcn) ();
 804     return 0;
 805 }
 806
 807 static void
 808 tcp1(char *name, int arg)
 809 {
 810     static BYTE buf[20];
 811     PFN fcn;
 812
 813     if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
 814     if (!htcp)
 815         DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
 816     if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
 817         ((void (*)(int)) fcn) (arg);
 818 }
 819
 820 void *  gethostent()    { return tcp0("GETHOSTENT");  }
 821 void *  getnetent()     { return tcp0("GETNETENT");   }
 822 void *  getprotoent()   { return tcp0("GETPROTOENT"); }
 823 void *  getservent()    { return tcp0("GETSERVENT");  }
 824 void    sethostent(x)   { tcp1("SETHOSTENT",  x); }
 825 void    setnetent(x)    { tcp1("SETNETENT",   x); }
 826 void    setprotoent(x)  { tcp1("SETPROTOENT", x); }
 827 void    setservent(x)   { tcp1("SETSERVENT",  x); }
 828 void    endhostent()    { tcp0("ENDHOSTENT");  }
 829 void    endnetent()     { tcp0("ENDNETENT");   }
 830 void    endprotoent()   { tcp0("ENDPROTOENT"); }
 831 void    endservent()    { tcp0("ENDSERVENT");  }
 832
 833 /*****************************************************************************/
 834 /* not implemented in C Set++ */
 835
 836 #ifndef __EMX__
 837 int     setuid(x)       { errno = EINVAL; return -1; }
 838 int     setgid(x)       { errno = EINVAL; return -1; }
 839 #endif
 840
 841 /*****************************************************************************/
 842 /* stat() hack for char/block device */
 843
 844 #if OS2_STAT_HACK
 845
 846     /* First attempt used DosQueryFSAttach which crashed the system when
 847        used with 5.001. Now just look for /dev/. */
 848
 849 int
 850 os2_stat(char *name, struct stat *st)
 851 {
 852     static int ino = SHRT_MAX;
 853
 854     if (stricmp(name, "/dev/con") != 0
 855      && stricmp(name, "/dev/tty") != 0)
 856         return stat(name, st);
 857
 858     memset(st, 0, sizeof *st);
 859     st->st_mode = S_IFCHR|0666;
 860     st->st_ino = (ino-- & 0x7FFF);
 861     st->st_nlink = 1;
 862     return 0;
 863 }
 864
 865 #endif
 866
 867 #ifdef USE_PERL_SBRK
 868
 869 /* SBRK() emulation, mostly moved to malloc.c. */
 870
 871 void *
 872 sys_alloc(int size) {
 873     void *got;
 874     APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
 875
 876     if (rc == ERROR_NOT_ENOUGH_MEMORY) {
 877         return (void *) -1;
 878     } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
 879     return got;
 880 }
 881
 882 #endif /* USE_PERL_SBRK */
 883
 884 /* tmp path */
 885
 886 char *tmppath = TMPPATH1;
 887
 888 void
 889 settmppath()
 890 {
 891     char *p = getenv("TMP"), *tpath;
 892     int len;
 893
 894     if (!p) p = getenv("TEMP");
 895     if (!p) return;
 896     len = strlen(p);
 897     tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
 898     strcpy(tpath, p);
 899     tpath[len] = '/';
 900     strcpy(tpath + len + 1, TMPPATH1);
 901     tmppath = tpath;
 902 }
 903
 904 #include "XSUB.h"
 905
 906 XS(XS_File__Copy_syscopy)
 907 {
 908     dXSARGS;
 909     if (items < 2 || items > 3)
 910         croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
 911     {
 912         char *  src = (char *)SvPV(ST(0),na);
 913         char *  dst = (char *)SvPV(ST(1),na);
 914         U32     flag;
 915         int     RETVAL, rc;
 916
 917         if (items < 3)
 918             flag = 0;
 919         else {
 920             flag = (unsigned long)SvIV(ST(2));
 921         }
 922
 923         RETVAL = !CheckOSError(DosCopy(src, dst, flag));
 924         ST(0) = sv_newmortal();
 925         sv_setiv(ST(0), (IV)RETVAL);
 926     }
 927     XSRETURN(1);
 928 }
 929
 930 char *
 931 mod2fname(sv)
 932      SV   *sv;
 933 {
 934     static char fname[9];
 935     int pos = 6, len, avlen;
 936     unsigned int sum = 0;
 937     AV  *av;
 938     SV  *svp;
 939     char *s;
 940
 941     if (!SvROK(sv)) croak("Not a reference given to mod2fname");
 942     sv = SvRV(sv);
 943     if (SvTYPE(sv) != SVt_PVAV)
 944       croak("Not array reference given to mod2fname");
 945
 946     avlen = av_len((AV*)sv);
 947     if (avlen < 0)
 948       croak("Empty array reference given to mod2fname");
 949
 950     s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
 951     strncpy(fname, s, 8);
 952     len = strlen(s);
 953     if (len < 6) pos = len;
 954     while (*s) {
 955         sum = 33 * sum + *(s++);        /* Checksumming first chars to
 956                                          * get the capitalization into c.s. */
 957     }
 958     avlen --;
 959     while (avlen >= 0) {
 960         s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
 961         while (*s) {
 962             sum = 33 * sum + *(s++);    /* 7 is primitive mod 13. */
 963         }
 964         avlen --;
 965     }
 966 #ifdef USE_THREADS
 967     sum++;                              /* Avoid conflict of DLLs in memory. */
 968 #endif
 969     fname[pos] = 'A' + (sum % 26);
 970     fname[pos + 1] = 'A' + (sum / 26 % 26);
 971     fname[pos + 2] = '\0';
 972     return (char *)fname;
 973 }
 974
 975 XS(XS_DynaLoader_mod2fname)
 976 {
 977     dXSARGS;
 978     if (items != 1)
 979         croak("Usage: DynaLoader::mod2fname(sv)");
 980     {
 981         SV *    sv = ST(0);
 982         char *  RETVAL;
 983
 984         RETVAL = mod2fname(sv);
 985         ST(0) = sv_newmortal();
 986         sv_setpv((SV*)ST(0), RETVAL);
 987     }
 988     XSRETURN(1);
 989 }
 990
 991 char *
 992 os2error(int rc)
 993 {
 994         static char buf[300];
 995         ULONG len;
 996
 997         if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
 998         if (rc == 0)
 999                 return NULL;
1000         if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1001                 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1002         else
1003                 buf[len] = '\0';
1004         return buf;
1005 }
1006
1007 char *
1008 perllib_mangle(char *s, unsigned int l)
1009 {
1010     static char *newp, *oldp;
1011     static int newl, oldl, notfound;
1012     static char ret[STATIC_FILE_LENGTH+1];
1013
1014     if (!newp && !notfound) {
1015         newp = getenv("PERLLIB_PREFIX");
1016         if (newp) {
1017             char *s;
1018
1019             oldp = newp;
1020             while (*newp && !isSPACE(*newp) && *newp != ';') {
1021                 newp++; oldl++;         /* Skip digits. */
1022             }
1023             while (*newp && (isSPACE(*newp) || *newp == ';')) {
1024                 newp++;                 /* Skip whitespace. */
1025             }
1026             newl = strlen(newp);
1027             if (newl == 0 || oldl == 0) {
1028                 die("Malformed PERLLIB_PREFIX");
1029             }
1030             strcpy(ret, newp);
1031             s = ret;
1032             while (*s) {
1033                 if (*s == '\\') *s = '/';
1034                 s++;
1035             }
1036         } else {
1037             notfound = 1;
1038         }
1039     }
1040     if (!newp) {
1041         return s;
1042     }
1043     if (l == 0) {
1044         l = strlen(s);
1045     }
1046     if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1047         return s;
1048     }
1049     if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1050         die("Malformed PERLLIB_PREFIX");
1051     }
1052     strcpy(ret + newl, s + oldl);
1053     return ret;
1054 }
1055
1056 extern void dlopen();
1057 void *fakedl = &dlopen;         /* Pull in dynaloading part. */
1058
1059 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1060                                 && ((path)[2] == '/' || (path)[2] == '\\'))
1061 #define sys_is_rooted _fnisabs
1062 #define sys_is_relative _fnisrel
1063 #define current_drive _getdrive
1064
1065 #undef chdir                            /* Was _chdir2. */
1066 #define sys_chdir(p) (chdir(p) == 0)
1067 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1068
1069 XS(XS_Cwd_current_drive)
1070 {
1071     dXSARGS;
1072     if (items != 0)
1073         croak("Usage: Cwd::current_drive()");
1074     {
1075         char    RETVAL;
1076
1077         RETVAL = current_drive();
1078         ST(0) = sv_newmortal();
1079         sv_setpvn(ST(0), (char *)&RETVAL, 1);
1080     }
1081     XSRETURN(1);
1082 }
1083
1084 XS(XS_Cwd_sys_chdir)
1085 {
1086     dXSARGS;
1087     if (items != 1)
1088         croak("Usage: Cwd::sys_chdir(path)");
1089     {
1090         char *  path = (char *)SvPV(ST(0),na);
1091         bool    RETVAL;
1092
1093         RETVAL = sys_chdir(path);
1094         ST(0) = boolSV(RETVAL);
1095         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1096     }
1097     XSRETURN(1);
1098 }
1099
1100 XS(XS_Cwd_change_drive)
1101 {
1102     dXSARGS;
1103     if (items != 1)
1104         croak("Usage: Cwd::change_drive(d)");
1105     {
1106         char    d = (char)*SvPV(ST(0),na);
1107         bool    RETVAL;
1108
1109         RETVAL = change_drive(d);
1110         ST(0) = boolSV(RETVAL);
1111         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1112     }
1113     XSRETURN(1);
1114 }
1115
1116 XS(XS_Cwd_sys_is_absolute)
1117 {
1118     dXSARGS;
1119     if (items != 1)
1120         croak("Usage: Cwd::sys_is_absolute(path)");
1121     {
1122         char *  path = (char *)SvPV(ST(0),na);
1123         bool    RETVAL;
1124
1125         RETVAL = sys_is_absolute(path);
1126         ST(0) = boolSV(RETVAL);
1127         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1128     }
1129     XSRETURN(1);
1130 }
1131
1132 XS(XS_Cwd_sys_is_rooted)
1133 {
1134     dXSARGS;
1135     if (items != 1)
1136         croak("Usage: Cwd::sys_is_rooted(path)");
1137     {
1138         char *  path = (char *)SvPV(ST(0),na);
1139         bool    RETVAL;
1140
1141         RETVAL = sys_is_rooted(path);
1142         ST(0) = boolSV(RETVAL);
1143         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1144     }
1145     XSRETURN(1);
1146 }
1147
1148 XS(XS_Cwd_sys_is_relative)
1149 {
1150     dXSARGS;
1151     if (items != 1)
1152         croak("Usage: Cwd::sys_is_relative(path)");
1153     {
1154         char *  path = (char *)SvPV(ST(0),na);
1155         bool    RETVAL;
1156
1157         RETVAL = sys_is_relative(path);
1158         ST(0) = boolSV(RETVAL);
1159         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1160     }
1161     XSRETURN(1);
1162 }
1163
1164 XS(XS_Cwd_sys_cwd)
1165 {
1166     dXSARGS;
1167     if (items != 0)
1168         croak("Usage: Cwd::sys_cwd()");
1169     {
1170         char p[MAXPATHLEN];
1171         char *  RETVAL;
1172         RETVAL = _getcwd2(p, MAXPATHLEN);
1173         ST(0) = sv_newmortal();
1174         sv_setpv((SV*)ST(0), RETVAL);
1175     }
1176     XSRETURN(1);
1177 }
1178
1179 XS(XS_Cwd_sys_abspath)
1180 {
1181     dXSARGS;
1182     if (items < 1 || items > 2)
1183         croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
1184     {
1185         char *  path = (char *)SvPV(ST(0),na);
1186         char *  dir;
1187         char p[MAXPATHLEN];
1188         char *  RETVAL;
1189
1190         if (items < 2)
1191             dir = NULL;
1192         else {
1193             dir = (char *)SvPV(ST(1),na);
1194         }
1195         if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1196             path += 2;
1197         }
1198         if (dir == NULL) {
1199             if (_abspath(p, path, MAXPATHLEN) == 0) {
1200                 RETVAL = p;
1201             } else {
1202                 RETVAL = NULL;
1203             }
1204         } else {
1205             /* Absolute with drive: */
1206             if ( sys_is_absolute(path) ) {
1207                 if (_abspath(p, path, MAXPATHLEN) == 0) {
1208                     RETVAL = p;
1209                 } else {
1210                     RETVAL = NULL;
1211                 }
1212             } else if (path[0] == '/' || path[0] == '\\') {
1213                 /* Rooted, but maybe on different drive. */
1214                 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1215                     char p1[MAXPATHLEN];
1216
1217                     /* Need to prepend the drive. */
1218                     p1[0] = dir[0];
1219                     p1[1] = dir[1];
1220                     Copy(path, p1 + 2, strlen(path) + 1, char);
1221                     RETVAL = p;
1222                     if (_abspath(p, p1, MAXPATHLEN) == 0) {
1223                         RETVAL = p;
1224                     } else {
1225                         RETVAL = NULL;
1226                     }
1227                 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1228                     RETVAL = p;
1229                 } else {
1230                     RETVAL = NULL;
1231                 }
1232             } else {
1233                 /* Either path is relative, or starts with a drive letter. */
1234                 /* If the path starts with a drive letter, then dir is
1235                    relevant only if
1236                    a/b) it is absolute/x:relative on the same drive.
1237                    c)   path is on current drive, and dir is rooted
1238                    In all the cases it is safe to drop the drive part
1239                    of the path. */
1240                 if ( !sys_is_relative(path) ) {
1241                     int is_drived;
1242
1243                     if ( ( ( sys_is_absolute(dir)
1244                              || (isALPHA(dir[0]) && dir[1] == ':'
1245                                  && strnicmp(dir, path,1) == 0))
1246                            && strnicmp(dir, path,1) == 0)
1247                          || ( !(isALPHA(dir[0]) && dir[1] == ':')
1248                               && toupper(path[0]) == current_drive())) {
1249                         path += 2;
1250                     } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1251                         RETVAL = p; goto done;
1252                     } else {
1253                         RETVAL = NULL; goto done;
1254                     }
1255                 }
1256                 {
1257                     /* Need to prepend the absolute path of dir. */
1258                     char p1[MAXPATHLEN];
1259
1260                     if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1261                         int l = strlen(p1);
1262
1263                         if (p1[ l - 1 ] != '/') {
1264                             p1[ l ] = '/';
1265                             l++;
1266                         }
1267                         Copy(path, p1 + l, strlen(path) + 1, char);
1268                         if (_abspath(p, p1, MAXPATHLEN) == 0) {
1269                             RETVAL = p;
1270                         } else {
1271                             RETVAL = NULL;
1272                         }
1273                     } else {
1274                         RETVAL = NULL;
1275                     }
1276                 }
1277               done:
1278             }
1279         }
1280         ST(0) = sv_newmortal();
1281         sv_setpv((SV*)ST(0), RETVAL);
1282     }
1283     XSRETURN(1);
1284 }
1285 typedef APIRET (*PELP)(PSZ path, ULONG type);
1286
1287 APIRET
1288 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1289 {
1290     loadByOrd(ord);                     /* Guarantied to load or die! */
1291     return (*(PELP)ExtFCN[ord])(path, type);
1292 }
1293
1294 #define extLibpath(type)                                                \
1295     (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH   \
1296                                                  : BEGIN_LIBPATH)))     \
1297      ? NULL : to )
1298
1299 #define extLibpath_set(p,type)                                  \
1300     (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH   \
1301                                                  : BEGIN_LIBPATH))))
1302
1303 XS(XS_Cwd_extLibpath)
1304 {
1305     dXSARGS;
1306     if (items < 0 || items > 1)
1307         croak("Usage: Cwd::extLibpath(type = 0)");
1308     {
1309         bool    type;
1310         char    to[1024];
1311         U32     rc;
1312         char *  RETVAL;
1313
1314         if (items < 1)
1315             type = 0;
1316         else {
1317             type = (int)SvIV(ST(0));
1318         }
1319
1320         RETVAL = extLibpath(type);
1321         ST(0) = sv_newmortal();
1322         sv_setpv((SV*)ST(0), RETVAL);
1323     }
1324     XSRETURN(1);
1325 }
1326
1327 XS(XS_Cwd_extLibpath_set)
1328 {
1329     dXSARGS;
1330     if (items < 1 || items > 2)
1331         croak("Usage: Cwd::extLibpath_set(s, type = 0)");
1332     {
1333         char *  s = (char *)SvPV(ST(0),na);
1334         bool    type;
1335         U32     rc;
1336         bool    RETVAL;
1337
1338         if (items < 2)
1339             type = 0;
1340         else {
1341             type = (int)SvIV(ST(1));
1342         }
1343
1344         RETVAL = extLibpath_set(s, type);
1345         ST(0) = boolSV(RETVAL);
1346         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1347     }
1348     XSRETURN(1);
1349 }
1350
1351 int
1352 Xs_OS2_init()
1353 {
1354     char *file = __FILE__;
1355     {
1356         GV *gv;
1357
1358         if (_emx_env & 0x200) { /* OS/2 */
1359             newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
1360             newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
1361             newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
1362         }
1363         newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
1364         newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
1365         newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
1366         newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
1367         newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
1368         newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
1369         newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
1370         newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
1371         newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
1372         gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
1373         GvMULTI_on(gv);
1374 #ifdef PERL_IS_AOUT
1375         sv_setiv(GvSV(gv), 1);
1376 #endif
1377     }
1378 }
1379
1380 OS2_Perl_data_t OS2_Perl_data;
1381
1382 void
1383 Perl_OS2_init(char **env)
1384 {
1385     char *shell;
1386
1387     MALLOC_INIT;
1388     settmppath();
1389     OS2_Perl_data.xs_init = &Xs_OS2_init;
1390     if (environ == NULL) {
1391         environ = env;
1392     }
1393     if ( (shell = getenv("PERL_SH_DRIVE")) ) {
1394         New(1304, sh_path, strlen(SH_PATH) + 1, char);
1395         strcpy(sh_path, SH_PATH);
1396         sh_path[0] = shell[0];
1397     } else if ( (shell = getenv("PERL_SH_DIR")) ) {
1398         int l = strlen(shell), i;
1399         if (shell[l-1] == '/' || shell[l-1] == '\\') {
1400             l--;
1401         }
1402         New(1304, sh_path, l + 8, char);
1403         strncpy(sh_path, shell, l);
1404         strcpy(sh_path + l, "/sh.exe");
1405         for (i = 0; i < l; i++) {
1406             if (sh_path[i] == '\\') sh_path[i] = '/';
1407         }
1408     }
1409     MUTEX_INIT(&start_thread_mutex);
1410 }
1411
1412 #undef tmpnam
1413 #undef tmpfile
1414
1415 char *
1416 my_tmpnam (char *str)
1417 {
1418     char *p = getenv("TMP"), *tpath;
1419     int len;
1420
1421     if (!p) p = getenv("TEMP");
1422     tpath = tempnam(p, "pltmp");
1423     if (str && tpath) {
1424         strcpy(str, tpath);
1425         return str;
1426     }
1427     return tpath;
1428 }
1429
1430 FILE *
1431 my_tmpfile ()
1432 {
1433     struct stat s;
1434
1435     stat(".", &s);
1436     if (s.st_mode & S_IWOTH) {
1437         return tmpfile();
1438     }
1439     return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
1440                                              grants TMP. */
1441 }
1442
1443 #undef flock
1444
1445 /* This code was contributed by Rocco Caputo. */
1446 int
1447 my_flock(int handle, int o)
1448 {
1449   FILELOCK      rNull, rFull;
1450   ULONG         timeout, handle_type, flag_word;
1451   APIRET        rc;
1452   int           blocking, shared;
1453   static int    use_my = -1;
1454
1455   if (use_my == -1) {
1456     char *s = getenv("USE_PERL_FLOCK");
1457     if (s)
1458         use_my = atoi(s);
1459     else
1460         use_my = 1;
1461   }
1462   if (!(_emx_env & 0x200) || !use_my)
1463     return flock(handle, o);    /* Delegate to EMX. */
1464
1465                                         // is this a file?
1466   if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
1467       (handle_type & 0xFF))
1468   {
1469     errno = EBADF;
1470     return -1;
1471   }
1472                                         // set lock/unlock ranges
1473   rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
1474   rFull.lRange = 0x7FFFFFFF;
1475                                         // set timeout for blocking
1476   timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
1477                                         // shared or exclusive?
1478   shared = (o & LOCK_SH) ? 1 : 0;
1479                                         // do not block the unlock
1480   if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
1481     rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
1482     switch (rc) {
1483       case 0:
1484         errno = 0;
1485         return 0;
1486       case ERROR_INVALID_HANDLE:
1487         errno = EBADF;
1488         return -1;
1489       case ERROR_SHARING_BUFFER_EXCEEDED:
1490         errno = ENOLCK;
1491         return -1;
1492       case ERROR_LOCK_VIOLATION:
1493         break;                          // not an error
1494       case ERROR_INVALID_PARAMETER:
1495       case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1496       case ERROR_READ_LOCKS_NOT_SUPPORTED:
1497         errno = EINVAL;
1498         return -1;
1499       case ERROR_INTERRUPT:
1500         errno = EINTR;
1501         return -1;
1502       default:
1503         errno = EINVAL;
1504         return -1;
1505     }
1506   }
1507                                         // lock may block
1508   if (o & (LOCK_SH | LOCK_EX)) {
1509                                         // for blocking operations
1510     for (;;) {
1511       rc =
1512         DosSetFileLocks(
1513                 handle,
1514                 &rNull,
1515                 &rFull,
1516                 timeout,
1517                 shared
1518         );
1519       switch (rc) {
1520         case 0:
1521           errno = 0;
1522           return 0;
1523         case ERROR_INVALID_HANDLE:
1524           errno = EBADF;
1525           return -1;
1526         case ERROR_SHARING_BUFFER_EXCEEDED:
1527           errno = ENOLCK;
1528           return -1;
1529         case ERROR_LOCK_VIOLATION:
1530           if (!blocking) {
1531             errno = EWOULDBLOCK;
1532             return -1;
1533           }
1534           break;
1535         case ERROR_INVALID_PARAMETER:
1536         case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1537         case ERROR_READ_LOCKS_NOT_SUPPORTED:
1538           errno = EINVAL;
1539           return -1;
1540         case ERROR_INTERRUPT:
1541           errno = EINTR;
1542           return -1;
1543         default:
1544           errno = EINVAL;
1545           return -1;
1546       }
1547                                         // give away timeslice
1548       DosSleep(1);
1549     }
1550   }
1551
1552   errno = 0;
1553   return 0;
1554 }