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