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 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     /* `this' is what we use in the parent, `that' in the child. */
 624     this = (*mode == 'w');
 625     that = !this;
 626     if (tainting) {
 627         taint_env();
 628         taint_proper("Insecure %s%s", "EXEC");
 629     }
 630     if (pipe(p) < 0)
 631         return Nullfp;
 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 #ifdef USE_THREADS
 885     sum++;                              /* Avoid conflict of DLLs in memory. */
 886 #endif
 887     fname[pos] = 'A' + (sum % 26);
 888     fname[pos + 1] = 'A' + (sum / 26 % 26);
 889     fname[pos + 2] = '\0';
 890     return (char *)fname;
 891 }
 892
 893 XS(XS_DynaLoader_mod2fname)
 894 {
 895     dXSARGS;
 896     if (items != 1)
 897         croak("Usage: DynaLoader::mod2fname(sv)");
 898     {
 899         SV *    sv = ST(0);
 900         char *  RETVAL;
 901
 902         RETVAL = mod2fname(sv);
 903         ST(0) = sv_newmortal();
 904         sv_setpv((SV*)ST(0), RETVAL);
 905     }
 906     XSRETURN(1);
 907 }
 908
 909 char *
 910 os2error(int rc)
 911 {
 912         static char buf[300];
 913         ULONG len;
 914
 915         if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
 916         if (rc == 0)
 917                 return NULL;
 918         if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
 919                 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
 920         else
 921                 buf[len] = '\0';
 922         return buf;
 923 }
 924
 925 char *
 926 perllib_mangle(char *s, unsigned int l)
 927 {
 928     static char *newp, *oldp;
 929     static int newl, oldl, notfound;
 930     static char ret[STATIC_FILE_LENGTH+1];
 931
 932     if (!newp && !notfound) {
 933         newp = getenv("PERLLIB_PREFIX");
 934         if (newp) {
 935             char *s;
 936
 937             oldp = newp;
 938             while (*newp && !isSPACE(*newp) && *newp != ';') {
 939                 newp++; oldl++;         /* Skip digits. */
 940             }
 941             while (*newp && (isSPACE(*newp) || *newp == ';')) {
 942                 newp++;                 /* Skip whitespace. */
 943             }
 944             newl = strlen(newp);
 945             if (newl == 0 || oldl == 0) {
 946                 die("Malformed PERLLIB_PREFIX");
 947             }
 948             strcpy(ret, newp);
 949             s = ret;
 950             while (*s) {
 951                 if (*s == '\\') *s = '/';
 952                 s++;
 953             }
 954         } else {
 955             notfound = 1;
 956         }
 957     }
 958     if (!newp) {
 959         return s;
 960     }
 961     if (l == 0) {
 962         l = strlen(s);
 963     }
 964     if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
 965         return s;
 966     }
 967     if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
 968         die("Malformed PERLLIB_PREFIX");
 969     }
 970     strcpy(ret + newl, s + oldl);
 971     return ret;
 972 }
 973
 974 extern void dlopen();
 975 void *fakedl = &dlopen;         /* Pull in dynaloading part. */
 976
 977 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
 978                                 && ((path)[2] == '/' || (path)[2] == '\\'))
 979 #define sys_is_rooted _fnisabs
 980 #define sys_is_relative _fnisrel
 981 #define current_drive _getdrive
 982
 983 #undef chdir                            /* Was _chdir2. */
 984 #define sys_chdir(p) (chdir(p) == 0)
 985 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
 986
 987 XS(XS_Cwd_current_drive)
 988 {
 989     dXSARGS;
 990     if (items != 0)
 991         croak("Usage: Cwd::current_drive()");
 992     {
 993         char    RETVAL;
 994
 995         RETVAL = current_drive();
 996         ST(0) = sv_newmortal();
 997         sv_setpvn(ST(0), (char *)&RETVAL, 1);
 998     }
 999     XSRETURN(1);
1000 }
1001
1002 XS(XS_Cwd_sys_chdir)
1003 {
1004     dXSARGS;
1005     if (items != 1)
1006         croak("Usage: Cwd::sys_chdir(path)");
1007     {
1008         char *  path = (char *)SvPV(ST(0),na);
1009         bool    RETVAL;
1010
1011         RETVAL = sys_chdir(path);
1012         ST(0) = boolSV(RETVAL);
1013         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1014     }
1015     XSRETURN(1);
1016 }
1017
1018 XS(XS_Cwd_change_drive)
1019 {
1020     dXSARGS;
1021     if (items != 1)
1022         croak("Usage: Cwd::change_drive(d)");
1023     {
1024         char    d = (char)*SvPV(ST(0),na);
1025         bool    RETVAL;
1026
1027         RETVAL = change_drive(d);
1028         ST(0) = boolSV(RETVAL);
1029         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1030     }
1031     XSRETURN(1);
1032 }
1033
1034 XS(XS_Cwd_sys_is_absolute)
1035 {
1036     dXSARGS;
1037     if (items != 1)
1038         croak("Usage: Cwd::sys_is_absolute(path)");
1039     {
1040         char *  path = (char *)SvPV(ST(0),na);
1041         bool    RETVAL;
1042
1043         RETVAL = sys_is_absolute(path);
1044         ST(0) = boolSV(RETVAL);
1045         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1046     }
1047     XSRETURN(1);
1048 }
1049
1050 XS(XS_Cwd_sys_is_rooted)
1051 {
1052     dXSARGS;
1053     if (items != 1)
1054         croak("Usage: Cwd::sys_is_rooted(path)");
1055     {
1056         char *  path = (char *)SvPV(ST(0),na);
1057         bool    RETVAL;
1058
1059         RETVAL = sys_is_rooted(path);
1060         ST(0) = boolSV(RETVAL);
1061         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1062     }
1063     XSRETURN(1);
1064 }
1065
1066 XS(XS_Cwd_sys_is_relative)
1067 {
1068     dXSARGS;
1069     if (items != 1)
1070         croak("Usage: Cwd::sys_is_relative(path)");
1071     {
1072         char *  path = (char *)SvPV(ST(0),na);
1073         bool    RETVAL;
1074
1075         RETVAL = sys_is_relative(path);
1076         ST(0) = boolSV(RETVAL);
1077         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1078     }
1079     XSRETURN(1);
1080 }
1081
1082 XS(XS_Cwd_sys_cwd)
1083 {
1084     dXSARGS;
1085     if (items != 0)
1086         croak("Usage: Cwd::sys_cwd()");
1087     {
1088         char p[MAXPATHLEN];
1089         char *  RETVAL;
1090         RETVAL = _getcwd2(p, MAXPATHLEN);
1091         ST(0) = sv_newmortal();
1092         sv_setpv((SV*)ST(0), RETVAL);
1093     }
1094     XSRETURN(1);
1095 }
1096
1097 XS(XS_Cwd_sys_abspath)
1098 {
1099     dXSARGS;
1100     if (items < 1 || items > 2)
1101         croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
1102     {
1103         char *  path = (char *)SvPV(ST(0),na);
1104         char *  dir;
1105         char p[MAXPATHLEN];
1106         char *  RETVAL;
1107
1108         if (items < 2)
1109             dir = NULL;
1110         else {
1111             dir = (char *)SvPV(ST(1),na);
1112         }
1113         if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1114             path += 2;
1115         }
1116         if (dir == NULL) {
1117             if (_abspath(p, path, MAXPATHLEN) == 0) {
1118                 RETVAL = p;
1119             } else {
1120                 RETVAL = NULL;
1121             }
1122         } else {
1123             /* Absolute with drive: */
1124             if ( sys_is_absolute(path) ) {
1125                 if (_abspath(p, path, MAXPATHLEN) == 0) {
1126                     RETVAL = p;
1127                 } else {
1128                     RETVAL = NULL;
1129                 }
1130             } else if (path[0] == '/' || path[0] == '\\') {
1131                 /* Rooted, but maybe on different drive. */
1132                 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1133                     char p1[MAXPATHLEN];
1134
1135                     /* Need to prepend the drive. */
1136                     p1[0] = dir[0];
1137                     p1[1] = dir[1];
1138                     Copy(path, p1 + 2, strlen(path) + 1, char);
1139                     RETVAL = p;
1140                     if (_abspath(p, p1, MAXPATHLEN) == 0) {
1141                         RETVAL = p;
1142                     } else {
1143                         RETVAL = NULL;
1144                     }
1145                 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1146                     RETVAL = p;
1147                 } else {
1148                     RETVAL = NULL;
1149                 }
1150             } else {
1151                 /* Either path is relative, or starts with a drive letter. */
1152                 /* If the path starts with a drive letter, then dir is
1153                    relevant only if
1154                    a/b) it is absolute/x:relative on the same drive.
1155                    c)   path is on current drive, and dir is rooted
1156                    In all the cases it is safe to drop the drive part
1157                    of the path. */
1158                 if ( !sys_is_relative(path) ) {
1159                     int is_drived;
1160
1161                     if ( ( ( sys_is_absolute(dir)
1162                              || (isALPHA(dir[0]) && dir[1] == ':'
1163                                  && strnicmp(dir, path,1) == 0))
1164                            && strnicmp(dir, path,1) == 0)
1165                          || ( !(isALPHA(dir[0]) && dir[1] == ':')
1166                               && toupper(path[0]) == current_drive())) {
1167                         path += 2;
1168                     } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1169                         RETVAL = p; goto done;
1170                     } else {
1171                         RETVAL = NULL; goto done;
1172                     }
1173                 }
1174                 {
1175                     /* Need to prepend the absolute path of dir. */
1176                     char p1[MAXPATHLEN];
1177
1178                     if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1179                         int l = strlen(p1);
1180
1181                         if (p1[ l - 1 ] != '/') {
1182                             p1[ l ] = '/';
1183                             l++;
1184                         }
1185                         Copy(path, p1 + l, strlen(path) + 1, char);
1186                         if (_abspath(p, p1, MAXPATHLEN) == 0) {
1187                             RETVAL = p;
1188                         } else {
1189                             RETVAL = NULL;
1190                         }
1191                     } else {
1192                         RETVAL = NULL;
1193                     }
1194                 }
1195               done:
1196             }
1197         }
1198         ST(0) = sv_newmortal();
1199         sv_setpv((SV*)ST(0), RETVAL);
1200     }
1201     XSRETURN(1);
1202 }
1203 typedef APIRET (*PELP)(PSZ path, ULONG type);
1204
1205 APIRET
1206 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1207 {
1208     loadByOrd(ord);                     /* Guarantied to load or die! */
1209     return (*(PELP)ExtFCN[ord])(path, type);
1210 }
1211
1212 #define extLibpath(type)                                                \
1213     (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH   \
1214                                                  : BEGIN_LIBPATH)))     \
1215      ? NULL : to )
1216
1217 #define extLibpath_set(p,type)                                  \
1218     (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH   \
1219                                                  : BEGIN_LIBPATH))))
1220
1221 XS(XS_Cwd_extLibpath)
1222 {
1223     dXSARGS;
1224     if (items < 0 || items > 1)
1225         croak("Usage: Cwd::extLibpath(type = 0)");
1226     {
1227         bool    type;
1228         char    to[1024];
1229         U32     rc;
1230         char *  RETVAL;
1231
1232         if (items < 1)
1233             type = 0;
1234         else {
1235             type = (int)SvIV(ST(0));
1236         }
1237
1238         RETVAL = extLibpath(type);
1239         ST(0) = sv_newmortal();
1240         sv_setpv((SV*)ST(0), RETVAL);
1241     }
1242     XSRETURN(1);
1243 }
1244
1245 XS(XS_Cwd_extLibpath_set)
1246 {
1247     dXSARGS;
1248     if (items < 1 || items > 2)
1249         croak("Usage: Cwd::extLibpath_set(s, type = 0)");
1250     {
1251         char *  s = (char *)SvPV(ST(0),na);
1252         bool    type;
1253         U32     rc;
1254         bool    RETVAL;
1255
1256         if (items < 2)
1257             type = 0;
1258         else {
1259             type = (int)SvIV(ST(1));
1260         }
1261
1262         RETVAL = extLibpath_set(s, type);
1263         ST(0) = boolSV(RETVAL);
1264         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1265     }
1266     XSRETURN(1);
1267 }
1268
1269 int
1270 Xs_OS2_init()
1271 {
1272     char *file = __FILE__;
1273     {
1274         GV *gv;
1275
1276         if (_emx_env & 0x200) { /* OS/2 */
1277             newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
1278             newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
1279             newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
1280         }
1281         newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
1282         newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
1283         newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
1284         newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
1285         newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
1286         newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
1287         newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
1288         newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
1289         newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
1290         gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
1291         GvMULTI_on(gv);
1292 #ifdef PERL_IS_AOUT
1293         sv_setiv(GvSV(gv), 1);
1294 #endif
1295     }
1296 }
1297
1298 OS2_Perl_data_t OS2_Perl_data;
1299
1300 void
1301 Perl_OS2_init(char **env)
1302 {
1303     char *shell;
1304
1305     MALLOC_INIT;
1306     settmppath();
1307     OS2_Perl_data.xs_init = &Xs_OS2_init;
1308     if (environ == NULL) {
1309         environ = env;
1310     }
1311     if ( (shell = getenv("PERL_SH_DRIVE")) ) {
1312         New(1304, sh_path, strlen(SH_PATH) + 1, char);
1313         strcpy(sh_path, SH_PATH);
1314         sh_path[0] = shell[0];
1315     } else if ( (shell = getenv("PERL_SH_DIR")) ) {
1316         int l = strlen(shell), i;
1317         if (shell[l-1] == '/' || shell[l-1] == '\\') {
1318             l--;
1319         }
1320         New(1304, sh_path, l + 8, char);
1321         strncpy(sh_path, shell, l);
1322         strcpy(sh_path + l, "/sh.exe");
1323         for (i = 0; i < l; i++) {
1324             if (sh_path[i] == '\\') sh_path[i] = '/';
1325         }
1326     }
1327     MUTEX_INIT(&start_thread_mutex);
1328 }
1329
1330 #undef tmpnam
1331 #undef tmpfile
1332
1333 char *
1334 my_tmpnam (char *str)
1335 {
1336     char *p = getenv("TMP"), *tpath;
1337     int len;
1338
1339     if (!p) p = getenv("TEMP");
1340     tpath = tempnam(p, "pltmp");
1341     if (str && tpath) {
1342         strcpy(str, tpath);
1343         return str;
1344     }
1345     return tpath;
1346 }
1347
1348 FILE *
1349 my_tmpfile ()
1350 {
1351     struct stat s;
1352
1353     stat(".", &s);
1354     if (s.st_mode & S_IWOTH) {
1355         return tmpfile();
1356     }
1357     return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
1358                                              grants TMP. */
1359 }
1360
1361 #undef flock
1362
1363 /* This code was contributed by Rocco Caputo. */
1364 int
1365 my_flock(int handle, int o)
1366 {
1367   FILELOCK      rNull, rFull;
1368   ULONG         timeout, handle_type, flag_word;
1369   APIRET        rc;
1370   int           blocking, shared;
1371   static int    use_my = -1;
1372
1373   if (use_my == -1) {
1374     char *s = getenv("USE_PERL_FLOCK");
1375     if (s)
1376         use_my = atoi(s);
1377     else
1378         use_my = 1;
1379   }
1380   if (!(_emx_env & 0x200) || !use_my)
1381     return flock(handle, o);    /* Delegate to EMX. */
1382
1383                                         // is this a file?
1384   if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
1385       (handle_type & 0xFF))
1386   {
1387     errno = EBADF;
1388     return -1;
1389   }
1390                                         // set lock/unlock ranges
1391   rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
1392   rFull.lRange = 0x7FFFFFFF;
1393                                         // set timeout for blocking
1394   timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
1395                                         // shared or exclusive?
1396   shared = (o & LOCK_SH) ? 1 : 0;
1397                                         // do not block the unlock
1398   if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
1399     rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
1400     switch (rc) {
1401       case 0:
1402         errno = 0;
1403         return 0;
1404       case ERROR_INVALID_HANDLE:
1405         errno = EBADF;
1406         return -1;
1407       case ERROR_SHARING_BUFFER_EXCEEDED:
1408         errno = ENOLCK;
1409         return -1;
1410       case ERROR_LOCK_VIOLATION:
1411         break;                          // not an error
1412       case ERROR_INVALID_PARAMETER:
1413       case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1414       case ERROR_READ_LOCKS_NOT_SUPPORTED:
1415         errno = EINVAL;
1416         return -1;
1417       case ERROR_INTERRUPT:
1418         errno = EINTR;
1419         return -1;
1420       default:
1421         errno = EINVAL;
1422         return -1;
1423     }
1424   }
1425                                         // lock may block
1426   if (o & (LOCK_SH | LOCK_EX)) {
1427                                         // for blocking operations
1428     for (;;) {
1429       rc =
1430         DosSetFileLocks(
1431                 handle,
1432                 &rNull,
1433                 &rFull,
1434                 timeout,
1435                 shared
1436         );
1437       switch (rc) {
1438         case 0:
1439           errno = 0;
1440           return 0;
1441         case ERROR_INVALID_HANDLE:
1442           errno = EBADF;
1443           return -1;
1444         case ERROR_SHARING_BUFFER_EXCEEDED:
1445           errno = ENOLCK;
1446           return -1;
1447         case ERROR_LOCK_VIOLATION:
1448           if (!blocking) {
1449             errno = EWOULDBLOCK;
1450             return -1;
1451           }
1452           break;
1453         case ERROR_INVALID_PARAMETER:
1454         case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1455         case ERROR_READ_LOCKS_NOT_SUPPORTED:
1456           errno = EINVAL;
1457           return -1;
1458         case ERROR_INTERRUPT:
1459           errno = EINTR;
1460           return -1;
1461         default:
1462           errno = EINVAL;
1463           return -1;
1464       }
1465                                         // give away timeslice
1466       DosSleep(1);
1467     }
1468   }
1469
1470   errno = 0;
1471   return 0;
1472 }