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 #include <sys/uflags.h>
   9
  10 /*
  11  * Various Unix compatibility functions for OS/2
  12  */
  13
  14 #include <stdio.h>
  15 #include <errno.h>
  16 #include <limits.h>
  17 #include <process.h>
  18 #include <fcntl.h>
  19
  20 #include "EXTERN.h"
  21 #include "perl.h"
  22
  23 #ifdef USE_THREADS
  24
  25 typedef void (*emx_startroutine)(void *);
  26 typedef void* (*pthreads_startroutine)(void *);
  27
  28 enum pthreads_state {
  29     pthreads_st_none = 0,
  30     pthreads_st_run,
  31     pthreads_st_exited,
  32     pthreads_st_detached,
  33     pthreads_st_waited,
  34 };
  35 const char *pthreads_states[] = {
  36     "uninit",
  37     "running",
  38     "exited",
  39     "detached",
  40     "waited for",
  41 };
  42
  43 typedef struct {
  44     void *status;
  45     perl_cond cond;
  46     enum pthreads_state state;
  47 } thread_join_t;
  48
  49 thread_join_t *thread_join_data;
  50 int thread_join_count;
  51 perl_mutex start_thread_mutex;
  52
  53 int
  54 pthread_join(perl_os_thread tid, void **status)
  55 {
  56     MUTEX_LOCK(&start_thread_mutex);
  57     switch (thread_join_data[tid].state) {
  58     case pthreads_st_exited:
  59         thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
  60         MUTEX_UNLOCK(&start_thread_mutex);
  61         *status = thread_join_data[tid].status;
  62         break;
  63     case pthreads_st_waited:
  64         MUTEX_UNLOCK(&start_thread_mutex);
  65         croak("join with a thread with a waiter");
  66         break;
  67     case pthreads_st_run:
  68         thread_join_data[tid].state = pthreads_st_waited;
  69         COND_INIT(&thread_join_data[tid].cond);
  70         MUTEX_UNLOCK(&start_thread_mutex);
  71         COND_WAIT(&thread_join_data[tid].cond, NULL);
  72         COND_DESTROY(&thread_join_data[tid].cond);
  73         thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
  74         *status = thread_join_data[tid].status;
  75         break;
  76     default:
  77         MUTEX_UNLOCK(&start_thread_mutex);
  78         croak("join: unknown thread state: '%s'",
  79               pthreads_states[thread_join_data[tid].state]);
  80         break;
  81     }
  82     return 0;
  83 }
  84
  85 void
  86 pthread_startit(void *arg)
  87 {
  88     /* Thread is already started, we need to transfer control only */
  89     pthreads_startroutine start_routine = *((pthreads_startroutine*)arg);
  90     int tid = pthread_self();
  91     void *retval;
  92
  93     arg = ((void**)arg)[1];
  94     if (tid >= thread_join_count) {
  95         int oc = thread_join_count;
  96
  97         thread_join_count = tid + 5 + tid/5;
  98         if (thread_join_data) {
  99             Renew(thread_join_data, thread_join_count, thread_join_t);
 100             Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
 101         } else {
 102             Newz(1323, thread_join_data, thread_join_count, thread_join_t);
 103         }
 104     }
 105     if (thread_join_data[tid].state != pthreads_st_none)
 106         croak("attempt to reuse thread id %i", tid);
 107     thread_join_data[tid].state = pthreads_st_run;
 108     /* Now that we copied/updated the guys, we may release the caller... */
 109     MUTEX_UNLOCK(&start_thread_mutex);
 110     thread_join_data[tid].status = (*start_routine)(arg);
 111     switch (thread_join_data[tid].state) {
 112     case pthreads_st_waited:
 113         COND_SIGNAL(&thread_join_data[tid].cond);
 114         break;
 115     default:
 116         thread_join_data[tid].state = pthreads_st_exited;
 117         break;
 118     }
 119 }
 120
 121 int
 122 pthread_create(perl_os_thread *tid, const pthread_attr_t *attr,
 123                void *(*start_routine)(void*), void *arg)
 124 {
 125     void *args[2];
 126
 127     args[0] = (void*)start_routine;
 128     args[1] = arg;
 129
 130     MUTEX_LOCK(&start_thread_mutex);
 131     *tid = _beginthread(pthread_startit, /*stack*/ NULL,
 132                         /*stacksize*/ 10*1024*1024, (void*)args);
 133     MUTEX_LOCK(&start_thread_mutex);
 134     MUTEX_UNLOCK(&start_thread_mutex);
 135     return *tid ? 0 : EINVAL;
 136 }
 137
 138 int
 139 pthread_detach(perl_os_thread tid)
 140 {
 141     MUTEX_LOCK(&start_thread_mutex);
 142     switch (thread_join_data[tid].state) {
 143     case pthreads_st_waited:
 144         MUTEX_UNLOCK(&start_thread_mutex);
 145         croak("detach on a thread with a waiter");
 146         break;
 147     case pthreads_st_run:
 148         thread_join_data[tid].state = pthreads_st_detached;
 149         MUTEX_UNLOCK(&start_thread_mutex);
 150         break;
 151     default:
 152         MUTEX_UNLOCK(&start_thread_mutex);
 153         croak("detach: unknown thread state: '%s'",
 154               pthreads_states[thread_join_data[tid].state]);
 155         break;
 156     }
 157     return 0;
 158 }
 159
 160 /* This is a very bastardized version: */
 161 int
 162 os2_cond_wait(perl_cond *c, perl_mutex *m)
 163 {
 164     int rc;
 165     if ((rc = DosResetEventSem(*c,&PL_na)) && (rc != ERROR_ALREADY_RESET))
 166         croak("panic: COND_WAIT-reset: rc=%i", rc);
 167     if (m) MUTEX_UNLOCK(m);
 168     if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
 169         && (rc != ERROR_INTERRUPT))
 170         croak("panic: COND_WAIT: rc=%i", rc);
 171     if (rc == ERROR_INTERRUPT)
 172         errno = EINTR;
 173     if (m) MUTEX_LOCK(m);
 174 }
 175 #endif
 176
 177 /*****************************************************************************/
 178 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
 179 static PFN ExtFCN[2];                   /* Labeled by ord below. */
 180 static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
 181 #define ORD_QUERY_ELP   0
 182 #define ORD_SET_ELP     1
 183 struct PMWIN_entries_t PMWIN_entries;
 184
 185 APIRET
 186 loadByOrd(char *modname, ULONG ord)
 187 {
 188     if (ExtFCN[ord] == NULL) {
 189         static HMODULE hdosc = 0;
 190         BYTE buf[20];
 191         PFN fcn;
 192         APIRET rc;
 193
 194         if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf,
 195                                                   modname, &hdosc)))
 196             || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
 197             croak("This version of OS/2 does not support %s.%i",
 198                   modname, loadOrd[ord]);
 199         ExtFCN[ord] = fcn;
 200     }
 201     if ((long)ExtFCN[ord] == -1)
 202         croak("panic queryaddr");
 203 }
 204
 205 void
 206 init_PMWIN_entries(void)
 207 {
 208     static HMODULE hpmwin = 0;
 209     static const int ords[] = {
 210         763,                            /* Initialize */
 211         716,                            /* CreateMsgQueue */
 212         726,                            /* DestroyMsgQueue */
 213         918,                            /* PeekMsg */
 214         915,                            /* GetMsg */
 215         912,                            /* DispatchMsg */
 216     };
 217     BYTE buf[20];
 218     int i = 0;
 219     unsigned long rc;
 220
 221     if (hpmwin)
 222         return;
 223
 224     if (CheckOSError(DosLoadModule(buf, sizeof buf, "pmwin", &hpmwin)))
 225         croak("This version of OS/2 does not support pmwin: error in %s", buf);
 226     while (i <= 5) {
 227         if (CheckOSError(DosQueryProcAddr(hpmwin, ords[i], NULL,
 228                                           ((PFN*)&PMWIN_entries)+i)))
 229             croak("This version of OS/2 does not support pmwin.%d", ords[i]);
 230         i++;
 231     }
 232 }
 233
 234
 235 /* priorities */
 236 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
 237                                                self inverse. */
 238 #define QSS_INI_BUFFER 1024
 239
 240 PQTOPLEVEL
 241 get_sysinfo(ULONG pid, ULONG flags)
 242 {
 243     char *pbuffer;
 244     ULONG rc, buf_len = QSS_INI_BUFFER;
 245
 246     New(1322, pbuffer, buf_len, char);
 247     /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
 248     rc = QuerySysState(flags, pid, pbuffer, buf_len);
 249     while (rc == ERROR_BUFFER_OVERFLOW) {
 250         Renew(pbuffer, buf_len *= 2, char);
 251         rc = QuerySysState(flags, pid, pbuffer, buf_len);
 252     }
 253     if (rc) {
 254         FillOSError(rc);
 255         Safefree(pbuffer);
 256         return 0;
 257     }
 258     return (PQTOPLEVEL)pbuffer;
 259 }
 260
 261 #define PRIO_ERR 0x1111
 262
 263 static ULONG
 264 sys_prio(pid)
 265 {
 266   ULONG prio;
 267   PQTOPLEVEL psi;
 268
 269   psi = get_sysinfo(pid, QSS_PROCESS);
 270   if (!psi) {
 271       return PRIO_ERR;
 272   }
 273   if (pid != psi->procdata->pid) {
 274       Safefree(psi);
 275       croak("panic: wrong pid in sysinfo");
 276   }
 277   prio = psi->procdata->threads->priority;
 278   Safefree(psi);
 279   return prio;
 280 }
 281
 282 int
 283 setpriority(int which, int pid, int val)
 284 {
 285   ULONG rc, prio;
 286   PQTOPLEVEL psi;
 287
 288   prio = sys_prio(pid);
 289
 290   if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
 291   if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
 292       /* Do not change class. */
 293       return CheckOSError(DosSetPriority((pid < 0)
 294                                          ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
 295                                          0,
 296                                          (32 - val) % 32 - (prio & 0xFF),
 297                                          abs(pid)))
 298       ? -1 : 0;
 299   } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
 300       /* Documentation claims one can change both class and basevalue,
 301        * but I find it wrong. */
 302       /* Change class, but since delta == 0 denotes absolute 0, correct. */
 303       if (CheckOSError(DosSetPriority((pid < 0)
 304                                       ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
 305                                       priors[(32 - val) >> 5] + 1,
 306                                       0,
 307                                       abs(pid))))
 308           return -1;
 309       if ( ((32 - val) % 32) == 0 ) return 0;
 310       return CheckOSError(DosSetPriority((pid < 0)
 311                                          ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
 312                                          0,
 313                                          (32 - val) % 32,
 314                                          abs(pid)))
 315           ? -1 : 0;
 316   }
 317 /*   else return CheckOSError(DosSetPriority((pid < 0)  */
 318 /*                                        ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
 319 /*                                        priors[(32 - val) >> 5] + 1,  */
 320 /*                                        (32 - val) % 32 - (prio & 0xFF),  */
 321 /*                                        abs(pid))) */
 322 /*       ? -1 : 0; */
 323 }
 324
 325 int
 326 getpriority(int which /* ignored */, int pid)
 327 {
 328   TIB *tib;
 329   PIB *pib;
 330   ULONG rc, ret;
 331
 332   if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
 333   /* DosGetInfoBlocks has old priority! */
 334 /*   if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
 335 /*   if (pid != pib->pib_ulpid) { */
 336   ret = sys_prio(pid);
 337   if (ret == PRIO_ERR) {
 338       return -1;
 339   }
 340 /*   } else */
 341 /*       ret = tib->tib_ptib2->tib2_ulpri; */
 342   return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
 343 }
 344
 345 /*****************************************************************************/
 346 /* spawn */
 347
 348 /* There is no big sense to make it thread-specific, since signals
 349    are delivered to thread 1 only.  XXXX Maybe make it into an array? */
 350 static int spawn_pid;
 351 static int spawn_killed;
 352
 353 static Signal_t
 354 spawn_sighandler(int sig)
 355 {
 356     /* Some programs do not arrange for the keyboard signals to be
 357        delivered to them.  We need to deliver the signal manually. */
 358     /* We may get a signal only if
 359        a) kid does not receive keyboard signal: deliver it;
 360        b) kid already died, and we get a signal.  We may only hope
 361           that the pid number was not reused.
 362      */
 363
 364     if (spawn_killed)
 365         sig = SIGKILL;                  /* Try harder. */
 366     kill(spawn_pid, sig);
 367     spawn_killed = 1;
 368 }
 369
 370 static int
 371 result(int flag, int pid)
 372 {
 373         int r, status;
 374         Signal_t (*ihand)();     /* place to save signal during system() */
 375         Signal_t (*qhand)();     /* place to save signal during system() */
 376 #ifndef __EMX__
 377         RESULTCODES res;
 378         int rpid;
 379 #endif
 380
 381         if (pid < 0 || flag != 0)
 382                 return pid;
 383
 384 #ifdef __EMX__
 385         spawn_pid = pid;
 386         spawn_killed = 0;
 387         ihand = rsignal(SIGINT, &spawn_sighandler);
 388         qhand = rsignal(SIGQUIT, &spawn_sighandler);
 389         do {
 390             r = wait4pid(pid, &status, 0);
 391         } while (r == -1 && errno == EINTR);
 392         rsignal(SIGINT, ihand);
 393         rsignal(SIGQUIT, qhand);
 394
 395         PL_statusvalue = (U16)status;
 396         if (r < 0)
 397                 return -1;
 398         return status & 0xFFFF;
 399 #else
 400         ihand = rsignal(SIGINT, SIG_IGN);
 401         r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
 402         rsignal(SIGINT, ihand);
 403         PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
 404         if (r)
 405                 return -1;
 406         return PL_statusvalue;
 407 #endif
 408 }
 409
 410 #define EXECF_SPAWN 0
 411 #define EXECF_EXEC 1
 412 #define EXECF_TRUEEXEC 2
 413 #define EXECF_SPAWN_NOWAIT 3
 414
 415 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
 416
 417 static int
 418 my_type()
 419 {
 420     int rc;
 421     TIB *tib;
 422     PIB *pib;
 423
 424     if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
 425     if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
 426         return -1;
 427
 428     return (pib->pib_ultype);
 429 }
 430
 431 static ULONG
 432 file_type(char *path)
 433 {
 434     int rc;
 435     ULONG apptype;
 436
 437     if (!(_emx_env & 0x200))
 438         croak("file_type not implemented on DOS"); /* not OS/2. */
 439     if (CheckOSError(DosQueryAppType(path, &apptype))) {
 440         switch (rc) {
 441         case ERROR_FILE_NOT_FOUND:
 442         case ERROR_PATH_NOT_FOUND:
 443             return -1;
 444         case ERROR_ACCESS_DENIED:       /* Directory with this name found? */
 445             return -3;
 446         default:                        /* Found, but not an
 447                                            executable, or some other
 448                                            read error. */
 449             return -2;
 450         }
 451     }
 452     return apptype;
 453 }
 454
 455 static ULONG os2_mytype;
 456
 457 /* Spawn/exec a program, revert to shell if needed. */
 458 /* global PL_Argv[] contains arguments. */
 459
 460 int
 461 do_spawn_ve(really, flag, execf, inicmd)
 462 SV *really;
 463 U32 flag;
 464 U32 execf;
 465 char *inicmd;
 466 {
 467     dTHR;
 468         int trueflag = flag;
 469         int rc, pass = 1;
 470         char *tmps;
 471         char buf[256], *s = 0, scrbuf[280];
 472         char *args[4];
 473         static char * fargs[4]
 474             = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
 475         char **argsp = fargs;
 476         char nargs = 4;
 477         int force_shell;
 478
 479         if (flag == P_WAIT)
 480                 flag = P_NOWAIT;
 481
 482       retry:
 483         if (strEQ(PL_Argv[0],"/bin/sh"))
 484             PL_Argv[0] = PL_sh_path;
 485
 486         if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\'
 487             && !(PL_Argv[0][0] && PL_Argv[0][1] == ':'
 488                  && (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\'))
 489             ) /* will spawnvp use PATH? */
 490             TAINT_ENV();        /* testing IFS here is overkill, probably */
 491         /* We should check PERL_SH* and PERLLIB_* as well? */
 492         if (!really || !*(tmps = SvPV(really, PL_na)))
 493             tmps = PL_Argv[0];
 494
 495       reread:
 496         force_shell = 0;
 497         if (_emx_env & 0x200) { /* OS/2. */
 498             int type = file_type(tmps);
 499           type_again:
 500             if (type == -1) {           /* Not found */
 501                 errno = ENOENT;
 502                 rc = -1;
 503                 goto do_script;
 504             }
 505             else if (type == -2) {              /* Not an EXE */
 506                 errno = ENOEXEC;
 507                 rc = -1;
 508                 goto do_script;
 509             }
 510             else if (type == -3) {              /* Is a directory? */
 511                 /* Special-case this */
 512                 char tbuf[512];
 513                 int l = strlen(tmps);
 514
 515                 if (l + 5 <= sizeof tbuf) {
 516                     strcpy(tbuf, tmps);
 517                     strcpy(tbuf + l, ".exe");
 518                     type = file_type(tbuf);
 519                     if (type >= -3)
 520                         goto type_again;
 521                 }
 522
 523                 errno = ENOEXEC;
 524                 rc = -1;
 525                 goto do_script;
 526             }
 527             switch (type & 7) {
 528                 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
 529             case FAPPTYP_WINDOWAPI:
 530             {
 531                 if (os2_mytype != 3) {  /* not PM */
 532                     if (flag == P_NOWAIT)
 533                         flag = P_PM;
 534                     else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION)
 535                         warn("Starting PM process with flag=%d, mytype=%d",
 536                              flag, os2_mytype);
 537                 }
 538             }
 539             break;
 540             case FAPPTYP_NOTWINDOWCOMPAT:
 541             {
 542                 if (os2_mytype != 0) {  /* not full screen */
 543                     if (flag == P_NOWAIT)
 544                         flag = P_SESSION;
 545                     else if ((flag & 7) != P_SESSION)
 546                         warn("Starting Full Screen process with flag=%d, mytype=%d",
 547                              flag, os2_mytype);
 548                 }
 549             }
 550             break;
 551             case FAPPTYP_NOTSPEC:
 552                 /* Let the shell handle this... */
 553                 force_shell = 1;
 554                 goto doshell_args;
 555                 break;
 556             }
 557         }
 558
 559 #if 0
 560         rc = result(trueflag, spawnvp(flag,tmps,PL_Argv));
 561 #else
 562         if (execf == EXECF_TRUEEXEC)
 563             rc = execvp(tmps,PL_Argv);
 564         else if (execf == EXECF_EXEC)
 565             rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
 566         else if (execf == EXECF_SPAWN_NOWAIT)
 567             rc = spawnvp(flag,tmps,PL_Argv);
 568         else                            /* EXECF_SPAWN */
 569             rc = result(trueflag,
 570                         spawnvp(flag,tmps,PL_Argv));
 571 #endif
 572         if (rc < 0 && pass == 1
 573             && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
 574               do_script:
 575             {
 576             int err = errno;
 577
 578             if (err == ENOENT || err == ENOEXEC) {
 579                 /* No such file, or is a script. */
 580                 /* Try adding script extensions to the file name, and
 581                    search on PATH. */
 582                 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
 583                 int l = strlen(scr);
 584
 585                 if (l >= sizeof scrbuf) {
 586                    Safefree(scr);
 587                  longbuf:
 588                    croak("Size of scriptname too big: %d", l);
 589                 }
 590                 strcpy(scrbuf, scr);
 591                 Safefree(scr);
 592                 scr = scrbuf;
 593
 594                 if (scr) {
 595                     FILE *file = fopen(scr, "r");
 596                     char *s = 0, *s1;
 597
 598                     PL_Argv[0] = scr;
 599                     if (!file)
 600                         goto panic_file;
 601                     if (!fgets(buf, sizeof buf, file)) { /* Empty... */
 602
 603                         buf[0] = 0;
 604                         fclose(file);
 605                         /* Special case: maybe from -Zexe build, so
 606                            there is an executable around (contrary to
 607                            documentation, DosQueryAppType sometimes (?)
 608                            does not append ".exe", so we could have
 609                            reached this place). */
 610                         if (l + 5 < sizeof scrbuf) {
 611                             strcpy(scrbuf + l, ".exe");
 612                             if (PerlLIO_stat(scrbuf,&PL_statbuf) >= 0
 613                                 && !S_ISDIR(PL_statbuf.st_mode)) {
 614                                 /* Found */
 615                                 tmps = scr;
 616                                 pass++;
 617                                 goto reread;
 618                             } else
 619                                 scrbuf[l] = 0;
 620                         } else
 621                             goto longbuf;
 622                     }
 623                     if (fclose(file) != 0) { /* Failure */
 624                       panic_file:
 625                         warn("Error reading \"%s\": %s",
 626                              scr, Strerror(errno));
 627                         buf[0] = 0;     /* Not #! */
 628                         goto doshell_args;
 629                     }
 630                     if (buf[0] == '#') {
 631                         if (buf[1] == '!')
 632                             s = buf + 2;
 633                     } else if (buf[0] == 'e') {
 634                         if (strnEQ(buf, "extproc", 7)
 635                             && isSPACE(buf[7]))
 636                             s = buf + 8;
 637                     } else if (buf[0] == 'E') {
 638                         if (strnEQ(buf, "EXTPROC", 7)
 639                             && isSPACE(buf[7]))
 640                             s = buf + 8;
 641                     }
 642                     if (!s) {
 643                         buf[0] = 0;     /* Not #! */
 644                         goto doshell_args;
 645                     }
 646
 647                     s1 = s;
 648                     nargs = 0;
 649                     argsp = args;
 650                     while (1) {
 651                         /* Do better than pdksh: allow a few args,
 652                            strip trailing whitespace.  */
 653                         while (isSPACE(*s))
 654                             s++;
 655                         if (*s == 0)
 656                             break;
 657                         if (nargs == 4) {
 658                             nargs = -1;
 659                             break;
 660                         }
 661                         args[nargs++] = s;
 662                         while (*s && !isSPACE(*s))
 663                             s++;
 664                         if (*s == 0)
 665                             break;
 666                         *s++ = 0;
 667                     }
 668                     if (nargs == -1) {
 669                         warn("Too many args on %.*s line of \"%s\"",
 670                              s1 - buf, buf, scr);
 671                         nargs = 4;
 672                         argsp = fargs;
 673                     }
 674                   doshell_args:
 675                     {
 676                         char **a = PL_Argv;
 677                         char *exec_args[2];
 678
 679                         if (force_shell
 680                             || (!buf[0] && file)) { /* File without magic */
 681                             /* In fact we tried all what pdksh would
 682                                try.  There is no point in calling
 683                                pdksh, we may just emulate its logic. */
 684                             char *shell = getenv("EXECSHELL");
 685                             char *shell_opt = NULL;
 686
 687                             if (!shell) {
 688                                 char *s;
 689
 690                                 shell_opt = "/c";
 691                                 shell = getenv("OS2_SHELL");
 692                                 if (inicmd) { /* No spaces at start! */
 693                                     s = inicmd;
 694                                     while (*s && !isSPACE(*s)) {
 695                                         if (*s++ = '/') {
 696                                             inicmd = NULL; /* Cannot use */
 697                                             break;
 698                                         }
 699                                     }
 700                                 }
 701                                 if (!inicmd) {
 702                                     s = PL_Argv[0];
 703                                     while (*s) {
 704                                         /* Dosish shells will choke on slashes
 705                                            in paths, fortunately, this is
 706                                            important for zeroth arg only. */
 707                                         if (*s == '/')
 708                                             *s = '\\';
 709                                         s++;
 710                                     }
 711                                 }
 712                             }
 713                             /* If EXECSHELL is set, we do not set */
 714
 715                             if (!shell)
 716                                 shell = ((_emx_env & 0x200)
 717                                          ? "c:/os2/cmd.exe"
 718                                          : "c:/command.com");
 719                             nargs = shell_opt ? 2 : 1;  /* shell file args */
 720                             exec_args[0] = shell;
 721                             exec_args[1] = shell_opt;
 722                             argsp = exec_args;
 723                             if (nargs == 2 && inicmd) {
 724                                 /* Use the original cmd line */
 725                                 /* XXXX This is good only until we refuse
 726                                         quoted arguments... */
 727                                 PL_Argv[0] = inicmd;
 728                                 PL_Argv[1] = Nullch;
 729                             }
 730                         } else if (!buf[0] && inicmd) { /* No file */
 731                             /* Start with the original cmdline. */
 732                             /* XXXX This is good only until we refuse
 733                                     quoted arguments... */
 734
 735                             PL_Argv[0] = inicmd;
 736                             PL_Argv[1] = Nullch;
 737                             nargs = 2;  /* shell -c */
 738                         }
 739
 740                         while (a[1])            /* Get to the end */
 741                             a++;
 742                         a++;                    /* Copy finil NULL too */
 743                         while (a >= PL_Argv) {
 744                             *(a + nargs) = *a;  /* PL_Argv was preallocated to be
 745                                                    long enough. */
 746                             a--;
 747                         }
 748                         while (nargs-- >= 0)
 749                             PL_Argv[nargs] = argsp[nargs];
 750                         /* Enable pathless exec if #! (as pdksh). */
 751                         pass = (buf[0] == '#' ? 2 : 3);
 752                         goto retry;
 753                     }
 754                 }
 755                 /* Not found: restore errno */
 756                 errno = err;
 757             }
 758           }
 759         } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
 760             char *no_dir = strrchr(PL_Argv[0], '/');
 761
 762             /* Do as pdksh port does: if not found with /, try without
 763                path. */
 764             if (no_dir) {
 765                 PL_Argv[0] = no_dir + 1;
 766                 pass++;
 767                 goto retry;
 768             }
 769         }
 770         if (rc < 0 && PL_dowarn)
 771             warn("Can't %s \"%s\": %s\n",
 772                  ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
 773                   ? "spawn" : "exec"),
 774                  PL_Argv[0], Strerror(errno));
 775         if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
 776             && ((trueflag & 0xFF) == P_WAIT))
 777             rc = 255 << 8; /* Emulate the fork(). */
 778
 779     return rc;
 780 }
 781
 782 /* Array spawn.  */
 783 int
 784 do_aspawn(really,mark,sp)
 785 SV *really;
 786 register SV **mark;
 787 register SV **sp;
 788 {
 789     dTHR;
 790     register char **a;
 791     char *tmps = NULL;
 792     int rc;
 793     int flag = P_WAIT, trueflag, err, secondtry = 0;
 794
 795     if (sp > mark) {
 796         New(1301,PL_Argv, sp - mark + 3, char*);
 797         a = PL_Argv;
 798
 799         if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
 800                 ++mark;
 801                 flag = SvIVx(*mark);
 802         }
 803
 804         while (++mark <= sp) {
 805             if (*mark)
 806                 *a++ = SvPVx(*mark, PL_na);
 807             else
 808                 *a++ = "";
 809         }
 810         *a = Nullch;
 811
 812         rc = do_spawn_ve(really, flag, EXECF_SPAWN, NULL);
 813     } else
 814         rc = -1;
 815     do_execfree();
 816     return rc;
 817 }
 818
 819 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
 820 int
 821 do_spawn2(cmd, execf)
 822 char *cmd;
 823 int execf;
 824 {
 825     register char **a;
 826     register char *s;
 827     char flags[10];
 828     char *shell, *copt, *news = NULL;
 829     int rc, err, seenspace = 0;
 830     char fullcmd[MAXNAMLEN + 1];
 831
 832 #ifdef TRYSHELL
 833     if ((shell = getenv("EMXSHELL")) != NULL)
 834         copt = "-c";
 835     else if ((shell = getenv("SHELL")) != NULL)
 836         copt = "-c";
 837     else if ((shell = getenv("COMSPEC")) != NULL)
 838         copt = "/C";
 839     else
 840         shell = "cmd.exe";
 841 #else
 842     /* Consensus on perl5-porters is that it is _very_ important to
 843        have a shell which will not change between computers with the
 844        same architecture, to avoid "action on a distance".
 845        And to have simple build, this shell should be sh. */
 846     shell = PL_sh_path;
 847     copt = "-c";
 848 #endif
 849
 850     while (*cmd && isSPACE(*cmd))
 851         cmd++;
 852
 853     if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
 854         STRLEN l = strlen(PL_sh_path);
 855
 856         New(1302, news, strlen(cmd) - 7 + l + 1, char);
 857         strcpy(news, PL_sh_path);
 858         strcpy(news + l, cmd + 7);
 859         cmd = news;
 860     }
 861
 862     /* save an extra exec if possible */
 863     /* see if there are shell metacharacters in it */
 864
 865     if (*cmd == '.' && isSPACE(cmd[1]))
 866         goto doshell;
 867
 868     if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
 869         goto doshell;
 870
 871     for (s = cmd; *s && isALPHA(*s); s++) ;     /* catch VAR=val gizmo */
 872     if (*s == '=')
 873         goto doshell;
 874
 875     for (s = cmd; *s; s++) {
 876         if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
 877             if (*s == '\n' && s[1] == '\0') {
 878                 *s = '\0';
 879                 break;
 880             } else if (*s == '\\' && !seenspace) {
 881                 continue;               /* Allow backslashes in names */
 882             }
 883             /* We do not convert this to do_spawn_ve since shell
 884                should be smart enough to start itself gloriously. */
 885           doshell:
 886             if (execf == EXECF_TRUEEXEC)
 887                 rc = execl(shell,shell,copt,cmd,(char*)0);
 888             else if (execf == EXECF_EXEC)
 889                 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
 890             else if (execf == EXECF_SPAWN_NOWAIT)
 891                 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
 892             else {
 893                 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
 894                 rc = result(P_WAIT,
 895                             spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
 896                 if (rc < 0 && PL_dowarn)
 897                     warn("Can't %s \"%s\": %s",
 898                          (execf == EXECF_SPAWN ? "spawn" : "exec"),
 899                          shell, Strerror(errno));
 900                 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
 901             }
 902             if (news)
 903                 Safefree(news);
 904             return rc;
 905         } else if (*s == ' ' || *s == '\t') {
 906             seenspace = 1;
 907         }
 908     }
 909
 910     /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
 911     New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
 912     PL_Cmd = savepvn(cmd, s-cmd);
 913     a = PL_Argv;
 914     for (s = PL_Cmd; *s;) {
 915         while (*s && isSPACE(*s)) s++;
 916         if (*s)
 917             *(a++) = s;
 918         while (*s && !isSPACE(*s)) s++;
 919         if (*s)
 920             *s++ = '\0';
 921     }
 922     *a = Nullch;
 923     if (PL_Argv[0])
 924         rc = do_spawn_ve(NULL, 0, execf, cmd);
 925     else
 926         rc = -1;
 927     if (news)
 928         Safefree(news);
 929     do_execfree();
 930     return rc;
 931 }
 932
 933 int
 934 do_spawn(cmd)
 935 char *cmd;
 936 {
 937     return do_spawn2(cmd, EXECF_SPAWN);
 938 }
 939
 940 int
 941 do_spawn_nowait(cmd)
 942 char *cmd;
 943 {
 944     return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
 945 }
 946
 947 bool
 948 do_exec(cmd)
 949 char *cmd;
 950 {
 951     do_spawn2(cmd, EXECF_EXEC);
 952     return FALSE;
 953 }
 954
 955 bool
 956 os2exec(cmd)
 957 char *cmd;
 958 {
 959     return do_spawn2(cmd, EXECF_TRUEEXEC);
 960 }
 961
 962 PerlIO *
 963 my_syspopen(cmd,mode)
 964 char    *cmd;
 965 char    *mode;
 966 {
 967 #ifndef USE_POPEN
 968
 969     int p[2];
 970     register I32 this, that, newfd;
 971     register I32 pid, rc;
 972     PerlIO *res;
 973     SV *sv;
 974
 975     /* `this' is what we use in the parent, `that' in the child. */
 976     this = (*mode == 'w');
 977     that = !this;
 978     if (PL_tainting) {
 979         taint_env();
 980         taint_proper("Insecure %s%s", "EXEC");
 981     }
 982     if (pipe(p) < 0)
 983         return Nullfp;
 984     /* Now we need to spawn the child. */
 985     newfd = dup(*mode == 'r');          /* Preserve std* */
 986     if (p[that] != (*mode == 'r')) {
 987         dup2(p[that], *mode == 'r');
 988         close(p[that]);
 989     }
 990     /* Where is `this' and newfd now? */
 991     fcntl(p[this], F_SETFD, FD_CLOEXEC);
 992     fcntl(newfd, F_SETFD, FD_CLOEXEC);
 993     pid = do_spawn_nowait(cmd);
 994     if (newfd != (*mode == 'r')) {
 995         dup2(newfd, *mode == 'r');      /* Return std* back. */
 996         close(newfd);
 997     }
 998     if (p[that] == (*mode == 'r'))
 999         close(p[that]);
1000     if (pid == -1) {
1001         close(p[this]);
1002         return NULL;
1003     }
1004     if (p[that] < p[this]) {
1005         dup2(p[this], p[that]);
1006         close(p[this]);
1007         p[this] = p[that];
1008     }
1009     sv = *av_fetch(PL_fdpid,p[this],TRUE);
1010     (void)SvUPGRADE(sv,SVt_IV);
1011     SvIVX(sv) = pid;
1012     PL_forkprocess = pid;
1013     return PerlIO_fdopen(p[this], mode);
1014
1015 #else  /* USE_POPEN */
1016
1017     PerlIO *res;
1018     SV *sv;
1019
1020 #  ifdef TRYSHELL
1021     res = popen(cmd, mode);
1022 #  else
1023     char *shell = getenv("EMXSHELL");
1024
1025     my_setenv("EMXSHELL", PL_sh_path);
1026     res = popen(cmd, mode);
1027     my_setenv("EMXSHELL", shell);
1028 #  endif
1029     sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1030     (void)SvUPGRADE(sv,SVt_IV);
1031     SvIVX(sv) = -1;                     /* A cooky. */
1032     return res;
1033
1034 #endif /* USE_POPEN */
1035
1036 }
1037
1038 /******************************************************************/
1039
1040 #ifndef HAS_FORK
1041 int
1042 fork(void)
1043 {
1044     croak(PL_no_func, "Unsupported function fork");
1045     errno = EINVAL;
1046     return -1;
1047 }
1048 #endif
1049
1050 /*******************************************************************/
1051 /* not implemented in EMX 0.9a */
1052
1053 void *  ctermid(x)      { return 0; }
1054
1055 #ifdef MYTTYNAME /* was not in emx0.9a */
1056 void *  ttyname(x)      { return 0; }
1057 #endif
1058
1059 /******************************************************************/
1060 /* my socket forwarders - EMX lib only provides static forwarders */
1061
1062 static HMODULE htcp = 0;
1063
1064 static void *
1065 tcp0(char *name)
1066 {
1067     static BYTE buf[20];
1068     PFN fcn;
1069
1070     if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
1071     if (!htcp)
1072         DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1073     if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1074         return (void *) ((void * (*)(void)) fcn) ();
1075     return 0;
1076 }
1077
1078 static void
1079 tcp1(char *name, int arg)
1080 {
1081     static BYTE buf[20];
1082     PFN fcn;
1083
1084     if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
1085     if (!htcp)
1086         DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1087     if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1088         ((void (*)(int)) fcn) (arg);
1089 }
1090
1091 void *  gethostent()    { return tcp0("GETHOSTENT");  }
1092 void *  getnetent()     { return tcp0("GETNETENT");   }
1093 void *  getprotoent()   { return tcp0("GETPROTOENT"); }
1094 void *  getservent()    { return tcp0("GETSERVENT");  }
1095 void    sethostent(x)   { tcp1("SETHOSTENT",  x); }
1096 void    setnetent(x)    { tcp1("SETNETENT",   x); }
1097 void    setprotoent(x)  { tcp1("SETPROTOENT", x); }
1098 void    setservent(x)   { tcp1("SETSERVENT",  x); }
1099 void    endhostent()    { tcp0("ENDHOSTENT");  }
1100 void    endnetent()     { tcp0("ENDNETENT");   }
1101 void    endprotoent()   { tcp0("ENDPROTOENT"); }
1102 void    endservent()    { tcp0("ENDSERVENT");  }
1103
1104 /*****************************************************************************/
1105 /* not implemented in C Set++ */
1106
1107 #ifndef __EMX__
1108 int     setuid(x)       { errno = EINVAL; return -1; }
1109 int     setgid(x)       { errno = EINVAL; return -1; }
1110 #endif
1111
1112 /*****************************************************************************/
1113 /* stat() hack for char/block device */
1114
1115 #if OS2_STAT_HACK
1116
1117     /* First attempt used DosQueryFSAttach which crashed the system when
1118        used with 5.001. Now just look for /dev/. */
1119
1120 int
1121 os2_stat(char *name, struct stat *st)
1122 {
1123     static int ino = SHRT_MAX;
1124
1125     if (stricmp(name, "/dev/con") != 0
1126      && stricmp(name, "/dev/tty") != 0)
1127         return stat(name, st);
1128
1129     memset(st, 0, sizeof *st);
1130     st->st_mode = S_IFCHR|0666;
1131     st->st_ino = (ino-- & 0x7FFF);
1132     st->st_nlink = 1;
1133     return 0;
1134 }
1135
1136 #endif
1137
1138 #ifdef USE_PERL_SBRK
1139
1140 /* SBRK() emulation, mostly moved to malloc.c. */
1141
1142 void *
1143 sys_alloc(int size) {
1144     void *got;
1145     APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1146
1147     if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1148         return (void *) -1;
1149     } else if ( rc )
1150         croak("Got an error from DosAllocMem: %li", (long)rc);
1151     return got;
1152 }
1153
1154 #endif /* USE_PERL_SBRK */
1155
1156 /* tmp path */
1157
1158 char *tmppath = TMPPATH1;
1159
1160 void
1161 settmppath()
1162 {
1163     char *p = getenv("TMP"), *tpath;
1164     int len;
1165
1166     if (!p) p = getenv("TEMP");
1167     if (!p) return;
1168     len = strlen(p);
1169     tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1170     strcpy(tpath, p);
1171     tpath[len] = '/';
1172     strcpy(tpath + len + 1, TMPPATH1);
1173     tmppath = tpath;
1174 }
1175
1176 #include "XSUB.h"
1177
1178 XS(XS_File__Copy_syscopy)
1179 {
1180     dXSARGS;
1181     if (items < 2 || items > 3)
1182         croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
1183     {
1184         char *  src = (char *)SvPV(ST(0),PL_na);
1185         char *  dst = (char *)SvPV(ST(1),PL_na);
1186         U32     flag;
1187         int     RETVAL, rc;
1188
1189         if (items < 3)
1190             flag = 0;
1191         else {
1192             flag = (unsigned long)SvIV(ST(2));
1193         }
1194
1195         RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1196         ST(0) = sv_newmortal();
1197         sv_setiv(ST(0), (IV)RETVAL);
1198     }
1199     XSRETURN(1);
1200 }
1201
1202 #include "patchlevel.h"
1203
1204 char *
1205 mod2fname(sv)
1206      SV   *sv;
1207 {
1208     static char fname[9];
1209     int pos = 6, len, avlen;
1210     unsigned int sum = 0;
1211     AV  *av;
1212     SV  *svp;
1213     char *s;
1214
1215     if (!SvROK(sv)) croak("Not a reference given to mod2fname");
1216     sv = SvRV(sv);
1217     if (SvTYPE(sv) != SVt_PVAV)
1218       croak("Not array reference given to mod2fname");
1219
1220     avlen = av_len((AV*)sv);
1221     if (avlen < 0)
1222       croak("Empty array reference given to mod2fname");
1223
1224     s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), PL_na);
1225     strncpy(fname, s, 8);
1226     len = strlen(s);
1227     if (len < 6) pos = len;
1228     while (*s) {
1229         sum = 33 * sum + *(s++);        /* Checksumming first chars to
1230                                          * get the capitalization into c.s. */
1231     }
1232     avlen --;
1233     while (avlen >= 0) {
1234         s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), PL_na);
1235         while (*s) {
1236             sum = 33 * sum + *(s++);    /* 7 is primitive mod 13. */
1237         }
1238         avlen --;
1239     }
1240 #ifdef USE_THREADS
1241     sum++;                              /* Avoid conflict of DLLs in memory. */
1242 #endif
1243     sum += PATCHLEVEL * 200 + SUBVERSION * 2;  /*  */
1244     fname[pos] = 'A' + (sum % 26);
1245     fname[pos + 1] = 'A' + (sum / 26 % 26);
1246     fname[pos + 2] = '\0';
1247     return (char *)fname;
1248 }
1249
1250 XS(XS_DynaLoader_mod2fname)
1251 {
1252     dXSARGS;
1253     if (items != 1)
1254         croak("Usage: DynaLoader::mod2fname(sv)");
1255     {
1256         SV *    sv = ST(0);
1257         char *  RETVAL;
1258
1259         RETVAL = mod2fname(sv);
1260         ST(0) = sv_newmortal();
1261         sv_setpv((SV*)ST(0), RETVAL);
1262     }
1263     XSRETURN(1);
1264 }
1265
1266 char *
1267 os2error(int rc)
1268 {
1269         static char buf[300];
1270         ULONG len;
1271
1272         if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1273         if (rc == 0)
1274                 return NULL;
1275         if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1276                 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1277         else
1278                 buf[len] = '\0';
1279         if (len > 0 && buf[len - 1] == '\n')
1280             buf[len - 1] = '\0';
1281         if (len > 1 && buf[len - 2] == '\r')
1282             buf[len - 2] = '\0';
1283         if (len > 2 && buf[len - 3] == '.')
1284             buf[len - 3] = '\0';
1285         return buf;
1286 }
1287
1288 char *
1289 perllib_mangle(char *s, unsigned int l)
1290 {
1291     static char *newp, *oldp;
1292     static int newl, oldl, notfound;
1293     static char ret[STATIC_FILE_LENGTH+1];
1294
1295     if (!newp && !notfound) {
1296         newp = getenv("PERLLIB_PREFIX");
1297         if (newp) {
1298             char *s;
1299
1300             oldp = newp;
1301             while (*newp && !isSPACE(*newp) && *newp != ';') {
1302                 newp++; oldl++;         /* Skip digits. */
1303             }
1304             while (*newp && (isSPACE(*newp) || *newp == ';')) {
1305                 newp++;                 /* Skip whitespace. */
1306             }
1307             newl = strlen(newp);
1308             if (newl == 0 || oldl == 0) {
1309                 croak("Malformed PERLLIB_PREFIX");
1310             }
1311             strcpy(ret, newp);
1312             s = ret;
1313             while (*s) {
1314                 if (*s == '\\') *s = '/';
1315                 s++;
1316             }
1317         } else {
1318             notfound = 1;
1319         }
1320     }
1321     if (!newp) {
1322         return s;
1323     }
1324     if (l == 0) {
1325         l = strlen(s);
1326     }
1327     if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1328         return s;
1329     }
1330     if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1331         croak("Malformed PERLLIB_PREFIX");
1332     }
1333     strcpy(ret + newl, s + oldl);
1334     return ret;
1335 }
1336
1337 unsigned long
1338 Perl_hab_GET()                  /* Needed if perl.h cannot be included */
1339 {
1340     return perl_hab_GET();
1341 }
1342
1343 HMQ
1344 Perl_Register_MQ(int serve)
1345 {
1346     PPIB pib;
1347     PTIB tib;
1348
1349     if (Perl_os2_initial_mode++)
1350         return Perl_hmq;
1351     DosGetInfoBlocks(&tib, &pib);
1352     Perl_os2_initial_mode = pib->pib_ultype;
1353     Perl_hmq_refcnt = 1;
1354     /* Try morphing into a PM application. */
1355     if (pib->pib_ultype != 3)           /* 2 is VIO */
1356         pib->pib_ultype = 3;            /* 3 is PM */
1357     init_PMWIN_entries();
1358     /* 64 messages if before OS/2 3.0, ignored otherwise */
1359     Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1360     if (!Perl_hmq) {
1361         static int cnt;
1362         if (cnt++)
1363             _exit(188);                 /* Panic can try to create a window. */
1364         croak("Cannot create a message queue, or morph to a PM application");
1365     }
1366     return Perl_hmq;
1367 }
1368
1369 int
1370 Perl_Serve_Messages(int force)
1371 {
1372     int cnt = 0;
1373     QMSG msg;
1374
1375     if (Perl_hmq_servers && !force)
1376         return 0;
1377     if (!Perl_hmq_refcnt)
1378         croak("No message queue");
1379     while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1380         cnt++;
1381         if (msg.msg == WM_QUIT)
1382             croak("QUITing...");
1383         (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1384     }
1385     return cnt;
1386 }
1387
1388 int
1389 Perl_Process_Messages(int force, I32 *cntp)
1390 {
1391     QMSG msg;
1392
1393     if (Perl_hmq_servers && !force)
1394         return 0;
1395     if (!Perl_hmq_refcnt)
1396         croak("No message queue");
1397     while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1398         if (cntp)
1399             (*cntp)++;
1400         (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1401         if (msg.msg == WM_DESTROY)
1402             return -1;
1403         if (msg.msg == WM_CREATE)
1404             return +1;
1405     }
1406     croak("QUITing...");
1407 }
1408
1409 void
1410 Perl_Deregister_MQ(int serve)
1411 {
1412     PPIB pib;
1413     PTIB tib;
1414
1415     if (--Perl_hmq_refcnt == 0) {
1416         (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1417         Perl_hmq = 0;
1418         /* Try morphing back from a PM application. */
1419         if (pib->pib_ultype == 3)               /* 3 is PM */
1420             pib->pib_ultype = Perl_os2_initial_mode;
1421         else
1422             warn("Unexpected program mode %d when morphing back from PM",
1423                  pib->pib_ultype);
1424     }
1425 }
1426
1427 extern void dlopen();
1428 void *fakedl = &dlopen;         /* Pull in dynaloading part. */
1429
1430 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1431                                 && ((path)[2] == '/' || (path)[2] == '\\'))
1432 #define sys_is_rooted _fnisabs
1433 #define sys_is_relative _fnisrel
1434 #define current_drive _getdrive
1435
1436 #undef chdir                            /* Was _chdir2. */
1437 #define sys_chdir(p) (chdir(p) == 0)
1438 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1439
1440 static int DOS_harderr_state = -1;
1441
1442 XS(XS_OS2_Error)
1443 {
1444     dXSARGS;
1445     if (items != 2)
1446         croak("Usage: OS2::Error(harderr, exception)");
1447     {
1448         int     arg1 = SvIV(ST(0));
1449         int     arg2 = SvIV(ST(1));
1450         int     a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1451                      | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1452         int     RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1453         unsigned long rc;
1454
1455         if (CheckOSError(DosError(a)))
1456             croak("DosError(%d) failed", a);
1457         ST(0) = sv_newmortal();
1458         if (DOS_harderr_state >= 0)
1459             sv_setiv(ST(0), DOS_harderr_state);
1460         DOS_harderr_state = RETVAL;
1461     }
1462     XSRETURN(1);
1463 }
1464
1465 static signed char DOS_suppression_state = -1;
1466
1467 XS(XS_OS2_Errors2Drive)
1468 {
1469     dXSARGS;
1470     if (items != 1)
1471         croak("Usage: OS2::Errors2Drive(drive)");
1472     {
1473         SV  *sv = ST(0);
1474         int     suppress = SvOK(sv);
1475         char    *s = suppress ? SvPV(sv, PL_na) : NULL;
1476         char    drive = (s ? *s : 0);
1477         unsigned long rc;
1478
1479         if (suppress && !isALPHA(drive))
1480             croak("Non-char argument '%c' to OS2::Errors2Drive()", drive);
1481         if (CheckOSError(DosSuppressPopUps((suppress
1482                                             ? SPU_ENABLESUPPRESSION
1483                                             : SPU_DISABLESUPPRESSION),
1484                                            drive)))
1485             croak("DosSuppressPopUps(%c) failed", drive);
1486         ST(0) = sv_newmortal();
1487         if (DOS_suppression_state > 0)
1488             sv_setpvn(ST(0), &DOS_suppression_state, 1);
1489         else if (DOS_suppression_state == 0)
1490             sv_setpvn(ST(0), "", 0);
1491         DOS_suppression_state = drive;
1492     }
1493     XSRETURN(1);
1494 }
1495
1496 static const char * const si_fields[QSV_MAX] = {
1497   "MAX_PATH_LENGTH",
1498   "MAX_TEXT_SESSIONS",
1499   "MAX_PM_SESSIONS",
1500   "MAX_VDM_SESSIONS",
1501   "BOOT_DRIVE",
1502   "DYN_PRI_VARIATION",
1503   "MAX_WAIT",
1504   "MIN_SLICE",
1505   "MAX_SLICE",
1506   "PAGE_SIZE",
1507   "VERSION_MAJOR",
1508   "VERSION_MINOR",
1509   "VERSION_REVISION",
1510   "MS_COUNT",
1511   "TIME_LOW",
1512   "TIME_HIGH",
1513   "TOTPHYSMEM",
1514   "TOTRESMEM",
1515   "TOTAVAILMEM",
1516   "MAXPRMEM",
1517   "MAXSHMEM",
1518   "TIMER_INTERVAL",
1519   "MAX_COMP_LENGTH",
1520   "FOREGROUND_FS_SESSION",
1521   "FOREGROUND_PROCESS"
1522 };
1523
1524 XS(XS_OS2_SysInfo)
1525 {
1526     dXSARGS;
1527     if (items != 0)
1528         croak("Usage: OS2::SysInfo()");
1529     {
1530         ULONG   si[QSV_MAX] = {0};      /* System Information Data Buffer */
1531         APIRET  rc      = NO_ERROR;     /* Return code            */
1532         int i = 0, j = 0;
1533
1534         if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
1535                                          QSV_MAX, /* information */
1536                                          (PVOID)si,
1537                                          sizeof(si))))
1538             croak("DosQuerySysInfo() failed");
1539         EXTEND(SP,2*QSV_MAX);
1540         while (i < QSV_MAX) {
1541             ST(j) = sv_newmortal();
1542             sv_setpv(ST(j++), si_fields[i]);
1543             ST(j) = sv_newmortal();
1544             sv_setiv(ST(j++), si[i]);
1545             i++;
1546         }
1547     }
1548     XSRETURN(2 * QSV_MAX);
1549 }
1550
1551 XS(XS_OS2_BootDrive)
1552 {
1553     dXSARGS;
1554     if (items != 0)
1555         croak("Usage: OS2::BootDrive()");
1556     {
1557         ULONG   si[1] = {0};    /* System Information Data Buffer */
1558         APIRET  rc    = NO_ERROR;       /* Return code            */
1559         char c;
1560
1561         if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
1562                                          (PVOID)si, sizeof(si))))
1563             croak("DosQuerySysInfo() failed");
1564         ST(0) = sv_newmortal();
1565         c = 'a' - 1 + si[0];
1566         sv_setpvn(ST(0), &c, 1);
1567     }
1568     XSRETURN(1);
1569 }
1570
1571 XS(XS_OS2_MorphPM)
1572 {
1573     dXSARGS;
1574     if (items != 1)
1575         croak("Usage: OS2::MorphPM(serve)");
1576     {
1577         bool  serve = SvOK(ST(0));
1578         unsigned long   pmq = perl_hmq_GET(serve);
1579
1580         ST(0) = sv_newmortal();
1581         sv_setiv(ST(0), pmq);
1582     }
1583     XSRETURN(1);
1584 }
1585
1586 XS(XS_OS2_UnMorphPM)
1587 {
1588     dXSARGS;
1589     if (items != 1)
1590         croak("Usage: OS2::UnMorphPM(serve)");
1591     {
1592         bool  serve = SvOK(ST(0));
1593
1594         perl_hmq_UNSET(serve);
1595     }
1596     XSRETURN(0);
1597 }
1598
1599 XS(XS_OS2_Serve_Messages)
1600 {
1601     dXSARGS;
1602     if (items != 1)
1603         croak("Usage: OS2::Serve_Messages(force)");
1604     {
1605         bool  force = SvOK(ST(0));
1606         unsigned long   cnt = Perl_Serve_Messages(force);
1607
1608         ST(0) = sv_newmortal();
1609         sv_setiv(ST(0), cnt);
1610     }
1611     XSRETURN(1);
1612 }
1613
1614 XS(XS_OS2_Process_Messages)
1615 {
1616     dXSARGS;
1617     if (items < 1 || items > 2)
1618         croak("Usage: OS2::Process_Messages(force [, cnt])");
1619     {
1620         bool  force = SvOK(ST(0));
1621         unsigned long   cnt;
1622         I32 *cntp = NULL;
1623
1624         if (items == 2) {
1625             SV *sv = ST(1);
1626             int fake = SvIV(sv);        /* Force SvIVX */
1627
1628             if (!SvIOK(sv))
1629                 croak("Can't upgrade count to IV");
1630             cntp = &SvIVX(sv);
1631         }
1632         cnt =  Perl_Process_Messages(force, cntp);
1633         ST(0) = sv_newmortal();
1634         sv_setiv(ST(0), cnt);
1635     }
1636     XSRETURN(1);
1637 }
1638
1639 XS(XS_Cwd_current_drive)
1640 {
1641     dXSARGS;
1642     if (items != 0)
1643         croak("Usage: Cwd::current_drive()");
1644     {
1645         char    RETVAL;
1646
1647         RETVAL = current_drive();
1648         ST(0) = sv_newmortal();
1649         sv_setpvn(ST(0), (char *)&RETVAL, 1);
1650     }
1651     XSRETURN(1);
1652 }
1653
1654 XS(XS_Cwd_sys_chdir)
1655 {
1656     dXSARGS;
1657     if (items != 1)
1658         croak("Usage: Cwd::sys_chdir(path)");
1659     {
1660         char *  path = (char *)SvPV(ST(0),PL_na);
1661         bool    RETVAL;
1662
1663         RETVAL = sys_chdir(path);
1664         ST(0) = boolSV(RETVAL);
1665         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1666     }
1667     XSRETURN(1);
1668 }
1669
1670 XS(XS_Cwd_change_drive)
1671 {
1672     dXSARGS;
1673     if (items != 1)
1674         croak("Usage: Cwd::change_drive(d)");
1675     {
1676         char    d = (char)*SvPV(ST(0),PL_na);
1677         bool    RETVAL;
1678
1679         RETVAL = change_drive(d);
1680         ST(0) = boolSV(RETVAL);
1681         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1682     }
1683     XSRETURN(1);
1684 }
1685
1686 XS(XS_Cwd_sys_is_absolute)
1687 {
1688     dXSARGS;
1689     if (items != 1)
1690         croak("Usage: Cwd::sys_is_absolute(path)");
1691     {
1692         char *  path = (char *)SvPV(ST(0),PL_na);
1693         bool    RETVAL;
1694
1695         RETVAL = sys_is_absolute(path);
1696         ST(0) = boolSV(RETVAL);
1697         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1698     }
1699     XSRETURN(1);
1700 }
1701
1702 XS(XS_Cwd_sys_is_rooted)
1703 {
1704     dXSARGS;
1705     if (items != 1)
1706         croak("Usage: Cwd::sys_is_rooted(path)");
1707     {
1708         char *  path = (char *)SvPV(ST(0),PL_na);
1709         bool    RETVAL;
1710
1711         RETVAL = sys_is_rooted(path);
1712         ST(0) = boolSV(RETVAL);
1713         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1714     }
1715     XSRETURN(1);
1716 }
1717
1718 XS(XS_Cwd_sys_is_relative)
1719 {
1720     dXSARGS;
1721     if (items != 1)
1722         croak("Usage: Cwd::sys_is_relative(path)");
1723     {
1724         char *  path = (char *)SvPV(ST(0),PL_na);
1725         bool    RETVAL;
1726
1727         RETVAL = sys_is_relative(path);
1728         ST(0) = boolSV(RETVAL);
1729         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1730     }
1731     XSRETURN(1);
1732 }
1733
1734 XS(XS_Cwd_sys_cwd)
1735 {
1736     dXSARGS;
1737     if (items != 0)
1738         croak("Usage: Cwd::sys_cwd()");
1739     {
1740         char p[MAXPATHLEN];
1741         char *  RETVAL;
1742         RETVAL = _getcwd2(p, MAXPATHLEN);
1743         ST(0) = sv_newmortal();
1744         sv_setpv((SV*)ST(0), RETVAL);
1745     }
1746     XSRETURN(1);
1747 }
1748
1749 XS(XS_Cwd_sys_abspath)
1750 {
1751     dXSARGS;
1752     if (items < 1 || items > 2)
1753         croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
1754     {
1755         char *  path = (char *)SvPV(ST(0),PL_na);
1756         char *  dir;
1757         char p[MAXPATHLEN];
1758         char *  RETVAL;
1759
1760         if (items < 2)
1761             dir = NULL;
1762         else {
1763             dir = (char *)SvPV(ST(1),PL_na);
1764         }
1765         if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1766             path += 2;
1767         }
1768         if (dir == NULL) {
1769             if (_abspath(p, path, MAXPATHLEN) == 0) {
1770                 RETVAL = p;
1771             } else {
1772                 RETVAL = NULL;
1773             }
1774         } else {
1775             /* Absolute with drive: */
1776             if ( sys_is_absolute(path) ) {
1777                 if (_abspath(p, path, MAXPATHLEN) == 0) {
1778                     RETVAL = p;
1779                 } else {
1780                     RETVAL = NULL;
1781                 }
1782             } else if (path[0] == '/' || path[0] == '\\') {
1783                 /* Rooted, but maybe on different drive. */
1784                 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1785                     char p1[MAXPATHLEN];
1786
1787                     /* Need to prepend the drive. */
1788                     p1[0] = dir[0];
1789                     p1[1] = dir[1];
1790                     Copy(path, p1 + 2, strlen(path) + 1, char);
1791                     RETVAL = p;
1792                     if (_abspath(p, p1, MAXPATHLEN) == 0) {
1793                         RETVAL = p;
1794                     } else {
1795                         RETVAL = NULL;
1796                     }
1797                 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1798                     RETVAL = p;
1799                 } else {
1800                     RETVAL = NULL;
1801                 }
1802             } else {
1803                 /* Either path is relative, or starts with a drive letter. */
1804                 /* If the path starts with a drive letter, then dir is
1805                    relevant only if
1806                    a/b) it is absolute/x:relative on the same drive.
1807                    c)   path is on current drive, and dir is rooted
1808                    In all the cases it is safe to drop the drive part
1809                    of the path. */
1810                 if ( !sys_is_relative(path) ) {
1811                     int is_drived;
1812
1813                     if ( ( ( sys_is_absolute(dir)
1814                              || (isALPHA(dir[0]) && dir[1] == ':'
1815                                  && strnicmp(dir, path,1) == 0))
1816                            && strnicmp(dir, path,1) == 0)
1817                          || ( !(isALPHA(dir[0]) && dir[1] == ':')
1818                               && toupper(path[0]) == current_drive())) {
1819                         path += 2;
1820                     } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1821                         RETVAL = p; goto done;
1822                     } else {
1823                         RETVAL = NULL; goto done;
1824                     }
1825                 }
1826                 {
1827                     /* Need to prepend the absolute path of dir. */
1828                     char p1[MAXPATHLEN];
1829
1830                     if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1831                         int l = strlen(p1);
1832
1833                         if (p1[ l - 1 ] != '/') {
1834                             p1[ l ] = '/';
1835                             l++;
1836                         }
1837                         Copy(path, p1 + l, strlen(path) + 1, char);
1838                         if (_abspath(p, p1, MAXPATHLEN) == 0) {
1839                             RETVAL = p;
1840                         } else {
1841                             RETVAL = NULL;
1842                         }
1843                     } else {
1844                         RETVAL = NULL;
1845                     }
1846                 }
1847               done:
1848             }
1849         }
1850         ST(0) = sv_newmortal();
1851         sv_setpv((SV*)ST(0), RETVAL);
1852     }
1853     XSRETURN(1);
1854 }
1855 typedef APIRET (*PELP)(PSZ path, ULONG type);
1856
1857 APIRET
1858 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1859 {
1860     loadByOrd("doscalls",ord);          /* Guarantied to load or die! */
1861     return (*(PELP)ExtFCN[ord])(path, type);
1862 }
1863
1864 #define extLibpath(type)                                                \
1865     (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH   \
1866                                                  : BEGIN_LIBPATH)))     \
1867      ? NULL : to )
1868
1869 #define extLibpath_set(p,type)                                  \
1870     (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH   \
1871                                                  : BEGIN_LIBPATH))))
1872
1873 XS(XS_Cwd_extLibpath)
1874 {
1875     dXSARGS;
1876     if (items < 0 || items > 1)
1877         croak("Usage: Cwd::extLibpath(type = 0)");
1878     {
1879         bool    type;
1880         char    to[1024];
1881         U32     rc;
1882         char *  RETVAL;
1883
1884         if (items < 1)
1885             type = 0;
1886         else {
1887             type = (int)SvIV(ST(0));
1888         }
1889
1890         RETVAL = extLibpath(type);
1891         ST(0) = sv_newmortal();
1892         sv_setpv((SV*)ST(0), RETVAL);
1893     }
1894     XSRETURN(1);
1895 }
1896
1897 XS(XS_Cwd_extLibpath_set)
1898 {
1899     dXSARGS;
1900     if (items < 1 || items > 2)
1901         croak("Usage: Cwd::extLibpath_set(s, type = 0)");
1902     {
1903         char *  s = (char *)SvPV(ST(0),PL_na);
1904         bool    type;
1905         U32     rc;
1906         bool    RETVAL;
1907
1908         if (items < 2)
1909             type = 0;
1910         else {
1911             type = (int)SvIV(ST(1));
1912         }
1913
1914         RETVAL = extLibpath_set(s, type);
1915         ST(0) = boolSV(RETVAL);
1916         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1917     }
1918     XSRETURN(1);
1919 }
1920
1921 int
1922 Xs_OS2_init()
1923 {
1924     char *file = __FILE__;
1925     {
1926         GV *gv;
1927
1928         if (_emx_env & 0x200) { /* OS/2 */
1929             newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
1930             newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
1931             newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
1932         }
1933         newXS("OS2::Error", XS_OS2_Error, file);
1934         newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
1935         newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
1936         newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
1937         newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
1938         newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
1939         newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
1940         newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
1941         newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
1942         newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
1943         newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
1944         newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
1945         newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
1946         newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
1947         newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
1948         newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
1949         newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
1950         gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
1951         GvMULTI_on(gv);
1952 #ifdef PERL_IS_AOUT
1953         sv_setiv(GvSV(gv), 1);
1954 #endif
1955         gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
1956         GvMULTI_on(gv);
1957         sv_setiv(GvSV(gv), _emx_rev);
1958         sv_setpv(GvSV(gv), _emx_vprt);
1959         SvIOK_on(GvSV(gv));
1960         gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
1961         GvMULTI_on(gv);
1962         sv_setiv(GvSV(gv), _emx_env);
1963         gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
1964         GvMULTI_on(gv);
1965         sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
1966     }
1967 }
1968
1969 OS2_Perl_data_t OS2_Perl_data;
1970
1971 void
1972 Perl_OS2_init(char **env)
1973 {
1974     char *shell;
1975
1976     MALLOC_INIT;
1977     settmppath();
1978     OS2_Perl_data.xs_init = &Xs_OS2_init;
1979     _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
1980     if (environ == NULL) {
1981         environ = env;
1982     }
1983     if ( (shell = getenv("PERL_SH_DRIVE")) ) {
1984         New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
1985         strcpy(PL_sh_path, SH_PATH);
1986         PL_sh_path[0] = shell[0];
1987     } else if ( (shell = getenv("PERL_SH_DIR")) ) {
1988         int l = strlen(shell), i;
1989         if (shell[l-1] == '/' || shell[l-1] == '\\') {
1990             l--;
1991         }
1992         New(1304, PL_sh_path, l + 8, char);
1993         strncpy(PL_sh_path, shell, l);
1994         strcpy(PL_sh_path + l, "/sh.exe");
1995         for (i = 0; i < l; i++) {
1996             if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
1997         }
1998     }
1999     MUTEX_INIT(&start_thread_mutex);
2000     os2_mytype = my_type();             /* Do it before morphing.  Needed? */
2001 }
2002
2003 #undef tmpnam
2004 #undef tmpfile
2005
2006 char *
2007 my_tmpnam (char *str)
2008 {
2009     char *p = getenv("TMP"), *tpath;
2010     int len;
2011
2012     if (!p) p = getenv("TEMP");
2013     tpath = tempnam(p, "pltmp");
2014     if (str && tpath) {
2015         strcpy(str, tpath);
2016         return str;
2017     }
2018     return tpath;
2019 }
2020
2021 FILE *
2022 my_tmpfile ()
2023 {
2024     struct stat s;
2025
2026     stat(".", &s);
2027     if (s.st_mode & S_IWOTH) {
2028         return tmpfile();
2029     }
2030     return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2031                                              grants TMP. */
2032 }
2033
2034 #undef flock
2035
2036 /* This code was contributed by Rocco Caputo. */
2037 int
2038 my_flock(int handle, int o)
2039 {
2040   FILELOCK      rNull, rFull;
2041   ULONG         timeout, handle_type, flag_word;
2042   APIRET        rc;
2043   int           blocking, shared;
2044   static int    use_my = -1;
2045
2046   if (use_my == -1) {
2047     char *s = getenv("USE_PERL_FLOCK");
2048     if (s)
2049         use_my = atoi(s);
2050     else
2051         use_my = 1;
2052   }
2053   if (!(_emx_env & 0x200) || !use_my)
2054     return flock(handle, o);    /* Delegate to EMX. */
2055
2056                                         // is this a file?
2057   if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2058       (handle_type & 0xFF))
2059   {
2060     errno = EBADF;
2061     return -1;
2062   }
2063                                         // set lock/unlock ranges
2064   rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2065   rFull.lRange = 0x7FFFFFFF;
2066                                         // set timeout for blocking
2067   timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2068                                         // shared or exclusive?
2069   shared = (o & LOCK_SH) ? 1 : 0;
2070                                         // do not block the unlock
2071   if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2072     rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2073     switch (rc) {
2074       case 0:
2075         errno = 0;
2076         return 0;
2077       case ERROR_INVALID_HANDLE:
2078         errno = EBADF;
2079         return -1;
2080       case ERROR_SHARING_BUFFER_EXCEEDED:
2081         errno = ENOLCK;
2082         return -1;
2083       case ERROR_LOCK_VIOLATION:
2084         break;                          // not an error
2085       case ERROR_INVALID_PARAMETER:
2086       case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2087       case ERROR_READ_LOCKS_NOT_SUPPORTED:
2088         errno = EINVAL;
2089         return -1;
2090       case ERROR_INTERRUPT:
2091         errno = EINTR;
2092         return -1;
2093       default:
2094         errno = EINVAL;
2095         return -1;
2096     }
2097   }
2098                                         // lock may block
2099   if (o & (LOCK_SH | LOCK_EX)) {
2100                                         // for blocking operations
2101     for (;;) {
2102       rc =
2103         DosSetFileLocks(
2104                 handle,
2105                 &rNull,
2106                 &rFull,
2107                 timeout,
2108                 shared
2109         );
2110       switch (rc) {
2111         case 0:
2112           errno = 0;
2113           return 0;
2114         case ERROR_INVALID_HANDLE:
2115           errno = EBADF;
2116           return -1;
2117         case ERROR_SHARING_BUFFER_EXCEEDED:
2118           errno = ENOLCK;
2119           return -1;
2120         case ERROR_LOCK_VIOLATION:
2121           if (!blocking) {
2122             errno = EWOULDBLOCK;
2123             return -1;
2124           }
2125           break;
2126         case ERROR_INVALID_PARAMETER:
2127         case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2128         case ERROR_READ_LOCKS_NOT_SUPPORTED:
2129           errno = EINVAL;
2130           return -1;
2131         case ERROR_INTERRUPT:
2132           errno = EINTR;
2133           return -1;
2134         default:
2135           errno = EINVAL;
2136           return -1;
2137       }
2138                                         // give away timeslice
2139       DosSleep(1);
2140     }
2141   }
2142
2143   errno = 0;
2144   return 0;
2145 }