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
 584                 if (scr) {
 585                     FILE *file;
 586                     char *s = 0, *s1;
 587                     int l;
 588
 589                     l = strlen(scr);
 590
 591                     if (l >= sizeof scrbuf) {
 592                        Safefree(scr);
 593                      longbuf:
 594                        croak("Size of scriptname too big: %d", l);
 595                     }
 596                     strcpy(scrbuf, scr);
 597                     Safefree(scr);
 598                     scr = scrbuf;
 599
 600                     file = fopen(scr, "r");
 601                     PL_Argv[0] = scr;
 602                     if (!file)
 603                         goto panic_file;
 604                     if (!fgets(buf, sizeof buf, file)) { /* Empty... */
 605
 606                         buf[0] = 0;
 607                         fclose(file);
 608                         /* Special case: maybe from -Zexe build, so
 609                            there is an executable around (contrary to
 610                            documentation, DosQueryAppType sometimes (?)
 611                            does not append ".exe", so we could have
 612                            reached this place). */
 613                         if (l + 5 < sizeof scrbuf) {
 614                             strcpy(scrbuf + l, ".exe");
 615                             if (PerlLIO_stat(scrbuf,&PL_statbuf) >= 0
 616                                 && !S_ISDIR(PL_statbuf.st_mode)) {
 617                                 /* Found */
 618                                 tmps = scr;
 619                                 pass++;
 620                                 goto reread;
 621                             } else
 622                                 scrbuf[l] = 0;
 623                         } else
 624                             goto longbuf;
 625                     }
 626                     if (fclose(file) != 0) { /* Failure */
 627                       panic_file:
 628                         warn("Error reading \"%s\": %s",
 629                              scr, Strerror(errno));
 630                         buf[0] = 0;     /* Not #! */
 631                         goto doshell_args;
 632                     }
 633                     if (buf[0] == '#') {
 634                         if (buf[1] == '!')
 635                             s = buf + 2;
 636                     } else if (buf[0] == 'e') {
 637                         if (strnEQ(buf, "extproc", 7)
 638                             && isSPACE(buf[7]))
 639                             s = buf + 8;
 640                     } else if (buf[0] == 'E') {
 641                         if (strnEQ(buf, "EXTPROC", 7)
 642                             && isSPACE(buf[7]))
 643                             s = buf + 8;
 644                     }
 645                     if (!s) {
 646                         buf[0] = 0;     /* Not #! */
 647                         goto doshell_args;
 648                     }
 649
 650                     s1 = s;
 651                     nargs = 0;
 652                     argsp = args;
 653                     while (1) {
 654                         /* Do better than pdksh: allow a few args,
 655                            strip trailing whitespace.  */
 656                         while (isSPACE(*s))
 657                             s++;
 658                         if (*s == 0)
 659                             break;
 660                         if (nargs == 4) {
 661                             nargs = -1;
 662                             break;
 663                         }
 664                         args[nargs++] = s;
 665                         while (*s && !isSPACE(*s))
 666                             s++;
 667                         if (*s == 0)
 668                             break;
 669                         *s++ = 0;
 670                     }
 671                     if (nargs == -1) {
 672                         warn("Too many args on %.*s line of \"%s\"",
 673                              s1 - buf, buf, scr);
 674                         nargs = 4;
 675                         argsp = fargs;
 676                     }
 677                   doshell_args:
 678                     {
 679                         char **a = PL_Argv;
 680                         char *exec_args[2];
 681
 682                         if (force_shell
 683                             || (!buf[0] && file)) { /* File without magic */
 684                             /* In fact we tried all what pdksh would
 685                                try.  There is no point in calling
 686                                pdksh, we may just emulate its logic. */
 687                             char *shell = getenv("EXECSHELL");
 688                             char *shell_opt = NULL;
 689
 690                             if (!shell) {
 691                                 char *s;
 692
 693                                 shell_opt = "/c";
 694                                 shell = getenv("OS2_SHELL");
 695                                 if (inicmd) { /* No spaces at start! */
 696                                     s = inicmd;
 697                                     while (*s && !isSPACE(*s)) {
 698                                         if (*s++ = '/') {
 699                                             inicmd = NULL; /* Cannot use */
 700                                             break;
 701                                         }
 702                                     }
 703                                 }
 704                                 if (!inicmd) {
 705                                     s = PL_Argv[0];
 706                                     while (*s) {
 707                                         /* Dosish shells will choke on slashes
 708                                            in paths, fortunately, this is
 709                                            important for zeroth arg only. */
 710                                         if (*s == '/')
 711                                             *s = '\\';
 712                                         s++;
 713                                     }
 714                                 }
 715                             }
 716                             /* If EXECSHELL is set, we do not set */
 717
 718                             if (!shell)
 719                                 shell = ((_emx_env & 0x200)
 720                                          ? "c:/os2/cmd.exe"
 721                                          : "c:/command.com");
 722                             nargs = shell_opt ? 2 : 1;  /* shell file args */
 723                             exec_args[0] = shell;
 724                             exec_args[1] = shell_opt;
 725                             argsp = exec_args;
 726                             if (nargs == 2 && inicmd) {
 727                                 /* Use the original cmd line */
 728                                 /* XXXX This is good only until we refuse
 729                                         quoted arguments... */
 730                                 PL_Argv[0] = inicmd;
 731                                 PL_Argv[1] = Nullch;
 732                             }
 733                         } else if (!buf[0] && inicmd) { /* No file */
 734                             /* Start with the original cmdline. */
 735                             /* XXXX This is good only until we refuse
 736                                     quoted arguments... */
 737
 738                             PL_Argv[0] = inicmd;
 739                             PL_Argv[1] = Nullch;
 740                             nargs = 2;  /* shell -c */
 741                         }
 742
 743                         while (a[1])            /* Get to the end */
 744                             a++;
 745                         a++;                    /* Copy finil NULL too */
 746                         while (a >= PL_Argv) {
 747                             *(a + nargs) = *a;  /* PL_Argv was preallocated to be
 748                                                    long enough. */
 749                             a--;
 750                         }
 751                         while (nargs-- >= 0)
 752                             PL_Argv[nargs] = argsp[nargs];
 753                         /* Enable pathless exec if #! (as pdksh). */
 754                         pass = (buf[0] == '#' ? 2 : 3);
 755                         goto retry;
 756                     }
 757                 }
 758                 /* Not found: restore errno */
 759                 errno = err;
 760             }
 761           }
 762         } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
 763             char *no_dir = strrchr(PL_Argv[0], '/');
 764
 765             /* Do as pdksh port does: if not found with /, try without
 766                path. */
 767             if (no_dir) {
 768                 PL_Argv[0] = no_dir + 1;
 769                 pass++;
 770                 goto retry;
 771             }
 772         }
 773         if (rc < 0 && PL_dowarn)
 774             warn("Can't %s \"%s\": %s\n",
 775                  ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
 776                   ? "spawn" : "exec"),
 777                  PL_Argv[0], Strerror(errno));
 778         if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
 779             && ((trueflag & 0xFF) == P_WAIT))
 780             rc = 255 << 8; /* Emulate the fork(). */
 781
 782     return rc;
 783 }
 784
 785 /* Array spawn.  */
 786 int
 787 do_aspawn(really,mark,sp)
 788 SV *really;
 789 register SV **mark;
 790 register SV **sp;
 791 {
 792     dTHR;
 793     register char **a;
 794     char *tmps = NULL;
 795     int rc;
 796     int flag = P_WAIT, trueflag, err, secondtry = 0;
 797
 798     if (sp > mark) {
 799         New(1301,PL_Argv, sp - mark + 3, char*);
 800         a = PL_Argv;
 801
 802         if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
 803                 ++mark;
 804                 flag = SvIVx(*mark);
 805         }
 806
 807         while (++mark <= sp) {
 808             if (*mark)
 809                 *a++ = SvPVx(*mark, PL_na);
 810             else
 811                 *a++ = "";
 812         }
 813         *a = Nullch;
 814
 815         rc = do_spawn_ve(really, flag, EXECF_SPAWN, NULL);
 816     } else
 817         rc = -1;
 818     do_execfree();
 819     return rc;
 820 }
 821
 822 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
 823 int
 824 do_spawn2(cmd, execf)
 825 char *cmd;
 826 int execf;
 827 {
 828     register char **a;
 829     register char *s;
 830     char flags[10];
 831     char *shell, *copt, *news = NULL;
 832     int rc, err, seenspace = 0;
 833     char fullcmd[MAXNAMLEN + 1];
 834
 835 #ifdef TRYSHELL
 836     if ((shell = getenv("EMXSHELL")) != NULL)
 837         copt = "-c";
 838     else if ((shell = getenv("SHELL")) != NULL)
 839         copt = "-c";
 840     else if ((shell = getenv("COMSPEC")) != NULL)
 841         copt = "/C";
 842     else
 843         shell = "cmd.exe";
 844 #else
 845     /* Consensus on perl5-porters is that it is _very_ important to
 846        have a shell which will not change between computers with the
 847        same architecture, to avoid "action on a distance".
 848        And to have simple build, this shell should be sh. */
 849     shell = PL_sh_path;
 850     copt = "-c";
 851 #endif
 852
 853     while (*cmd && isSPACE(*cmd))
 854         cmd++;
 855
 856     if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
 857         STRLEN l = strlen(PL_sh_path);
 858
 859         New(1302, news, strlen(cmd) - 7 + l + 1, char);
 860         strcpy(news, PL_sh_path);
 861         strcpy(news + l, cmd + 7);
 862         cmd = news;
 863     }
 864
 865     /* save an extra exec if possible */
 866     /* see if there are shell metacharacters in it */
 867
 868     if (*cmd == '.' && isSPACE(cmd[1]))
 869         goto doshell;
 870
 871     if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
 872         goto doshell;
 873
 874     for (s = cmd; *s && isALPHA(*s); s++) ;     /* catch VAR=val gizmo */
 875     if (*s == '=')
 876         goto doshell;
 877
 878     for (s = cmd; *s; s++) {
 879         if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
 880             if (*s == '\n' && s[1] == '\0') {
 881                 *s = '\0';
 882                 break;
 883             } else if (*s == '\\' && !seenspace) {
 884                 continue;               /* Allow backslashes in names */
 885             }
 886             /* We do not convert this to do_spawn_ve since shell
 887                should be smart enough to start itself gloriously. */
 888           doshell:
 889             if (execf == EXECF_TRUEEXEC)
 890                 rc = execl(shell,shell,copt,cmd,(char*)0);
 891             else if (execf == EXECF_EXEC)
 892                 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
 893             else if (execf == EXECF_SPAWN_NOWAIT)
 894                 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
 895             else {
 896                 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
 897                 rc = result(P_WAIT,
 898                             spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
 899                 if (rc < 0 && PL_dowarn)
 900                     warn("Can't %s \"%s\": %s",
 901                          (execf == EXECF_SPAWN ? "spawn" : "exec"),
 902                          shell, Strerror(errno));
 903                 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
 904             }
 905             if (news)
 906                 Safefree(news);
 907             return rc;
 908         } else if (*s == ' ' || *s == '\t') {
 909             seenspace = 1;
 910         }
 911     }
 912
 913     /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
 914     New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
 915     PL_Cmd = savepvn(cmd, s-cmd);
 916     a = PL_Argv;
 917     for (s = PL_Cmd; *s;) {
 918         while (*s && isSPACE(*s)) s++;
 919         if (*s)
 920             *(a++) = s;
 921         while (*s && !isSPACE(*s)) s++;
 922         if (*s)
 923             *s++ = '\0';
 924     }
 925     *a = Nullch;
 926     if (PL_Argv[0])
 927         rc = do_spawn_ve(NULL, 0, execf, cmd);
 928     else
 929         rc = -1;
 930     if (news)
 931         Safefree(news);
 932     do_execfree();
 933     return rc;
 934 }
 935
 936 int
 937 do_spawn(cmd)
 938 char *cmd;
 939 {
 940     return do_spawn2(cmd, EXECF_SPAWN);
 941 }
 942
 943 int
 944 do_spawn_nowait(cmd)
 945 char *cmd;
 946 {
 947     return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
 948 }
 949
 950 bool
 951 do_exec(cmd)
 952 char *cmd;
 953 {
 954     do_spawn2(cmd, EXECF_EXEC);
 955     return FALSE;
 956 }
 957
 958 bool
 959 os2exec(cmd)
 960 char *cmd;
 961 {
 962     return do_spawn2(cmd, EXECF_TRUEEXEC);
 963 }
 964
 965 PerlIO *
 966 my_syspopen(cmd,mode)
 967 char    *cmd;
 968 char    *mode;
 969 {
 970 #ifndef USE_POPEN
 971
 972     int p[2];
 973     register I32 this, that, newfd;
 974     register I32 pid, rc;
 975     PerlIO *res;
 976     SV *sv;
 977
 978     /* `this' is what we use in the parent, `that' in the child. */
 979     this = (*mode == 'w');
 980     that = !this;
 981     if (PL_tainting) {
 982         taint_env();
 983         taint_proper("Insecure %s%s", "EXEC");
 984     }
 985     if (pipe(p) < 0)
 986         return Nullfp;
 987     /* Now we need to spawn the child. */
 988     newfd = dup(*mode == 'r');          /* Preserve std* */
 989     if (p[that] != (*mode == 'r')) {
 990         dup2(p[that], *mode == 'r');
 991         close(p[that]);
 992     }
 993     /* Where is `this' and newfd now? */
 994     fcntl(p[this], F_SETFD, FD_CLOEXEC);
 995     fcntl(newfd, F_SETFD, FD_CLOEXEC);
 996     pid = do_spawn_nowait(cmd);
 997     if (newfd != (*mode == 'r')) {
 998         dup2(newfd, *mode == 'r');      /* Return std* back. */
 999         close(newfd);
1000     }
1001     if (p[that] == (*mode == 'r'))
1002         close(p[that]);
1003     if (pid == -1) {
1004         close(p[this]);
1005         return NULL;
1006     }
1007     if (p[that] < p[this]) {
1008         dup2(p[this], p[that]);
1009         close(p[this]);
1010         p[this] = p[that];
1011     }
1012     sv = *av_fetch(PL_fdpid,p[this],TRUE);
1013     (void)SvUPGRADE(sv,SVt_IV);
1014     SvIVX(sv) = pid;
1015     PL_forkprocess = pid;
1016     return PerlIO_fdopen(p[this], mode);
1017
1018 #else  /* USE_POPEN */
1019
1020     PerlIO *res;
1021     SV *sv;
1022
1023 #  ifdef TRYSHELL
1024     res = popen(cmd, mode);
1025 #  else
1026     char *shell = getenv("EMXSHELL");
1027
1028     my_setenv("EMXSHELL", PL_sh_path);
1029     res = popen(cmd, mode);
1030     my_setenv("EMXSHELL", shell);
1031 #  endif
1032     sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1033     (void)SvUPGRADE(sv,SVt_IV);
1034     SvIVX(sv) = -1;                     /* A cooky. */
1035     return res;
1036
1037 #endif /* USE_POPEN */
1038
1039 }
1040
1041 /******************************************************************/
1042
1043 #ifndef HAS_FORK
1044 int
1045 fork(void)
1046 {
1047     croak(PL_no_func, "Unsupported function fork");
1048     errno = EINVAL;
1049     return -1;
1050 }
1051 #endif
1052
1053 /*******************************************************************/
1054 /* not implemented in EMX 0.9a */
1055
1056 void *  ctermid(x)      { return 0; }
1057
1058 #ifdef MYTTYNAME /* was not in emx0.9a */
1059 void *  ttyname(x)      { return 0; }
1060 #endif
1061
1062 /******************************************************************/
1063 /* my socket forwarders - EMX lib only provides static forwarders */
1064
1065 static HMODULE htcp = 0;
1066
1067 static void *
1068 tcp0(char *name)
1069 {
1070     static BYTE buf[20];
1071     PFN fcn;
1072
1073     if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
1074     if (!htcp)
1075         DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1076     if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1077         return (void *) ((void * (*)(void)) fcn) ();
1078     return 0;
1079 }
1080
1081 static void
1082 tcp1(char *name, int arg)
1083 {
1084     static BYTE buf[20];
1085     PFN fcn;
1086
1087     if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
1088     if (!htcp)
1089         DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1090     if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1091         ((void (*)(int)) fcn) (arg);
1092 }
1093
1094 void *  gethostent()    { return tcp0("GETHOSTENT");  }
1095 void *  getnetent()     { return tcp0("GETNETENT");   }
1096 void *  getprotoent()   { return tcp0("GETPROTOENT"); }
1097 void *  getservent()    { return tcp0("GETSERVENT");  }
1098 void    sethostent(x)   { tcp1("SETHOSTENT",  x); }
1099 void    setnetent(x)    { tcp1("SETNETENT",   x); }
1100 void    setprotoent(x)  { tcp1("SETPROTOENT", x); }
1101 void    setservent(x)   { tcp1("SETSERVENT",  x); }
1102 void    endhostent()    { tcp0("ENDHOSTENT");  }
1103 void    endnetent()     { tcp0("ENDNETENT");   }
1104 void    endprotoent()   { tcp0("ENDPROTOENT"); }
1105 void    endservent()    { tcp0("ENDSERVENT");  }
1106
1107 /*****************************************************************************/
1108 /* not implemented in C Set++ */
1109
1110 #ifndef __EMX__
1111 int     setuid(x)       { errno = EINVAL; return -1; }
1112 int     setgid(x)       { errno = EINVAL; return -1; }
1113 #endif
1114
1115 /*****************************************************************************/
1116 /* stat() hack for char/block device */
1117
1118 #if OS2_STAT_HACK
1119
1120     /* First attempt used DosQueryFSAttach which crashed the system when
1121        used with 5.001. Now just look for /dev/. */
1122
1123 int
1124 os2_stat(char *name, struct stat *st)
1125 {
1126     static int ino = SHRT_MAX;
1127
1128     if (stricmp(name, "/dev/con") != 0
1129      && stricmp(name, "/dev/tty") != 0)
1130         return stat(name, st);
1131
1132     memset(st, 0, sizeof *st);
1133     st->st_mode = S_IFCHR|0666;
1134     st->st_ino = (ino-- & 0x7FFF);
1135     st->st_nlink = 1;
1136     return 0;
1137 }
1138
1139 #endif
1140
1141 #ifdef USE_PERL_SBRK
1142
1143 /* SBRK() emulation, mostly moved to malloc.c. */
1144
1145 void *
1146 sys_alloc(int size) {
1147     void *got;
1148     APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1149
1150     if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1151         return (void *) -1;
1152     } else if ( rc )
1153         croak("Got an error from DosAllocMem: %li", (long)rc);
1154     return got;
1155 }
1156
1157 #endif /* USE_PERL_SBRK */
1158
1159 /* tmp path */
1160
1161 char *tmppath = TMPPATH1;
1162
1163 void
1164 settmppath()
1165 {
1166     char *p = getenv("TMP"), *tpath;
1167     int len;
1168
1169     if (!p) p = getenv("TEMP");
1170     if (!p) return;
1171     len = strlen(p);
1172     tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1173     strcpy(tpath, p);
1174     tpath[len] = '/';
1175     strcpy(tpath + len + 1, TMPPATH1);
1176     tmppath = tpath;
1177 }
1178
1179 #include "XSUB.h"
1180
1181 XS(XS_File__Copy_syscopy)
1182 {
1183     dXSARGS;
1184     if (items < 2 || items > 3)
1185         croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
1186     {
1187         char *  src = (char *)SvPV(ST(0),PL_na);
1188         char *  dst = (char *)SvPV(ST(1),PL_na);
1189         U32     flag;
1190         int     RETVAL, rc;
1191
1192         if (items < 3)
1193             flag = 0;
1194         else {
1195             flag = (unsigned long)SvIV(ST(2));
1196         }
1197
1198         RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1199         ST(0) = sv_newmortal();
1200         sv_setiv(ST(0), (IV)RETVAL);
1201     }
1202     XSRETURN(1);
1203 }
1204
1205 #include "patchlevel.h"
1206
1207 char *
1208 mod2fname(sv)
1209      SV   *sv;
1210 {
1211     static char fname[9];
1212     int pos = 6, len, avlen;
1213     unsigned int sum = 0;
1214     AV  *av;
1215     SV  *svp;
1216     char *s;
1217
1218     if (!SvROK(sv)) croak("Not a reference given to mod2fname");
1219     sv = SvRV(sv);
1220     if (SvTYPE(sv) != SVt_PVAV)
1221       croak("Not array reference given to mod2fname");
1222
1223     avlen = av_len((AV*)sv);
1224     if (avlen < 0)
1225       croak("Empty array reference given to mod2fname");
1226
1227     s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), PL_na);
1228     strncpy(fname, s, 8);
1229     len = strlen(s);
1230     if (len < 6) pos = len;
1231     while (*s) {
1232         sum = 33 * sum + *(s++);        /* Checksumming first chars to
1233                                          * get the capitalization into c.s. */
1234     }
1235     avlen --;
1236     while (avlen >= 0) {
1237         s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), PL_na);
1238         while (*s) {
1239             sum = 33 * sum + *(s++);    /* 7 is primitive mod 13. */
1240         }
1241         avlen --;
1242     }
1243 #ifdef USE_THREADS
1244     sum++;                              /* Avoid conflict of DLLs in memory. */
1245 #endif
1246     sum += PATCHLEVEL * 200 + SUBVERSION * 2;  /*  */
1247     fname[pos] = 'A' + (sum % 26);
1248     fname[pos + 1] = 'A' + (sum / 26 % 26);
1249     fname[pos + 2] = '\0';
1250     return (char *)fname;
1251 }
1252
1253 XS(XS_DynaLoader_mod2fname)
1254 {
1255     dXSARGS;
1256     if (items != 1)
1257         croak("Usage: DynaLoader::mod2fname(sv)");
1258     {
1259         SV *    sv = ST(0);
1260         char *  RETVAL;
1261
1262         RETVAL = mod2fname(sv);
1263         ST(0) = sv_newmortal();
1264         sv_setpv((SV*)ST(0), RETVAL);
1265     }
1266     XSRETURN(1);
1267 }
1268
1269 char *
1270 os2error(int rc)
1271 {
1272         static char buf[300];
1273         ULONG len;
1274
1275         if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1276         if (rc == 0)
1277                 return NULL;
1278         if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1279                 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1280         else
1281                 buf[len] = '\0';
1282         if (len > 0 && buf[len - 1] == '\n')
1283             buf[len - 1] = '\0';
1284         if (len > 1 && buf[len - 2] == '\r')
1285             buf[len - 2] = '\0';
1286         if (len > 2 && buf[len - 3] == '.')
1287             buf[len - 3] = '\0';
1288         return buf;
1289 }
1290
1291 char *
1292 perllib_mangle(char *s, unsigned int l)
1293 {
1294     static char *newp, *oldp;
1295     static int newl, oldl, notfound;
1296     static char ret[STATIC_FILE_LENGTH+1];
1297
1298     if (!newp && !notfound) {
1299         newp = getenv("PERLLIB_PREFIX");
1300         if (newp) {
1301             char *s;
1302
1303             oldp = newp;
1304             while (*newp && !isSPACE(*newp) && *newp != ';') {
1305                 newp++; oldl++;         /* Skip digits. */
1306             }
1307             while (*newp && (isSPACE(*newp) || *newp == ';')) {
1308                 newp++;                 /* Skip whitespace. */
1309             }
1310             newl = strlen(newp);
1311             if (newl == 0 || oldl == 0) {
1312                 croak("Malformed PERLLIB_PREFIX");
1313             }
1314             strcpy(ret, newp);
1315             s = ret;
1316             while (*s) {
1317                 if (*s == '\\') *s = '/';
1318                 s++;
1319             }
1320         } else {
1321             notfound = 1;
1322         }
1323     }
1324     if (!newp) {
1325         return s;
1326     }
1327     if (l == 0) {
1328         l = strlen(s);
1329     }
1330     if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1331         return s;
1332     }
1333     if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1334         croak("Malformed PERLLIB_PREFIX");
1335     }
1336     strcpy(ret + newl, s + oldl);
1337     return ret;
1338 }
1339
1340 unsigned long
1341 Perl_hab_GET()                  /* Needed if perl.h cannot be included */
1342 {
1343     return perl_hab_GET();
1344 }
1345
1346 HMQ
1347 Perl_Register_MQ(int serve)
1348 {
1349     PPIB pib;
1350     PTIB tib;
1351
1352     if (Perl_os2_initial_mode++)
1353         return Perl_hmq;
1354     DosGetInfoBlocks(&tib, &pib);
1355     Perl_os2_initial_mode = pib->pib_ultype;
1356     Perl_hmq_refcnt = 1;
1357     /* Try morphing into a PM application. */
1358     if (pib->pib_ultype != 3)           /* 2 is VIO */
1359         pib->pib_ultype = 3;            /* 3 is PM */
1360     init_PMWIN_entries();
1361     /* 64 messages if before OS/2 3.0, ignored otherwise */
1362     Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1363     if (!Perl_hmq) {
1364         static int cnt;
1365         if (cnt++)
1366             _exit(188);                 /* Panic can try to create a window. */
1367         croak("Cannot create a message queue, or morph to a PM application");
1368     }
1369     return Perl_hmq;
1370 }
1371
1372 int
1373 Perl_Serve_Messages(int force)
1374 {
1375     int cnt = 0;
1376     QMSG msg;
1377
1378     if (Perl_hmq_servers && !force)
1379         return 0;
1380     if (!Perl_hmq_refcnt)
1381         croak("No message queue");
1382     while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1383         cnt++;
1384         if (msg.msg == WM_QUIT)
1385             croak("QUITing...");
1386         (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1387     }
1388     return cnt;
1389 }
1390
1391 int
1392 Perl_Process_Messages(int force, I32 *cntp)
1393 {
1394     QMSG msg;
1395
1396     if (Perl_hmq_servers && !force)
1397         return 0;
1398     if (!Perl_hmq_refcnt)
1399         croak("No message queue");
1400     while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1401         if (cntp)
1402             (*cntp)++;
1403         (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1404         if (msg.msg == WM_DESTROY)
1405             return -1;
1406         if (msg.msg == WM_CREATE)
1407             return +1;
1408     }
1409     croak("QUITing...");
1410 }
1411
1412 void
1413 Perl_Deregister_MQ(int serve)
1414 {
1415     PPIB pib;
1416     PTIB tib;
1417
1418     if (--Perl_hmq_refcnt == 0) {
1419         (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1420         Perl_hmq = 0;
1421         /* Try morphing back from a PM application. */
1422         if (pib->pib_ultype == 3)               /* 3 is PM */
1423             pib->pib_ultype = Perl_os2_initial_mode;
1424         else
1425             warn("Unexpected program mode %d when morphing back from PM",
1426                  pib->pib_ultype);
1427     }
1428 }
1429
1430 extern void dlopen();
1431 void *fakedl = &dlopen;         /* Pull in dynaloading part. */
1432
1433 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1434                                 && ((path)[2] == '/' || (path)[2] == '\\'))
1435 #define sys_is_rooted _fnisabs
1436 #define sys_is_relative _fnisrel
1437 #define current_drive _getdrive
1438
1439 #undef chdir                            /* Was _chdir2. */
1440 #define sys_chdir(p) (chdir(p) == 0)
1441 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1442
1443 static int DOS_harderr_state = -1;
1444
1445 XS(XS_OS2_Error)
1446 {
1447     dXSARGS;
1448     if (items != 2)
1449         croak("Usage: OS2::Error(harderr, exception)");
1450     {
1451         int     arg1 = SvIV(ST(0));
1452         int     arg2 = SvIV(ST(1));
1453         int     a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1454                      | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1455         int     RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1456         unsigned long rc;
1457
1458         if (CheckOSError(DosError(a)))
1459             croak("DosError(%d) failed", a);
1460         ST(0) = sv_newmortal();
1461         if (DOS_harderr_state >= 0)
1462             sv_setiv(ST(0), DOS_harderr_state);
1463         DOS_harderr_state = RETVAL;
1464     }
1465     XSRETURN(1);
1466 }
1467
1468 static signed char DOS_suppression_state = -1;
1469
1470 XS(XS_OS2_Errors2Drive)
1471 {
1472     dXSARGS;
1473     if (items != 1)
1474         croak("Usage: OS2::Errors2Drive(drive)");
1475     {
1476         SV  *sv = ST(0);
1477         int     suppress = SvOK(sv);
1478         char    *s = suppress ? SvPV(sv, PL_na) : NULL;
1479         char    drive = (s ? *s : 0);
1480         unsigned long rc;
1481
1482         if (suppress && !isALPHA(drive))
1483             croak("Non-char argument '%c' to OS2::Errors2Drive()", drive);
1484         if (CheckOSError(DosSuppressPopUps((suppress
1485                                             ? SPU_ENABLESUPPRESSION
1486                                             : SPU_DISABLESUPPRESSION),
1487                                            drive)))
1488             croak("DosSuppressPopUps(%c) failed", drive);
1489         ST(0) = sv_newmortal();
1490         if (DOS_suppression_state > 0)
1491             sv_setpvn(ST(0), &DOS_suppression_state, 1);
1492         else if (DOS_suppression_state == 0)
1493             sv_setpvn(ST(0), "", 0);
1494         DOS_suppression_state = drive;
1495     }
1496     XSRETURN(1);
1497 }
1498
1499 static const char * const si_fields[QSV_MAX] = {
1500   "MAX_PATH_LENGTH",
1501   "MAX_TEXT_SESSIONS",
1502   "MAX_PM_SESSIONS",
1503   "MAX_VDM_SESSIONS",
1504   "BOOT_DRIVE",
1505   "DYN_PRI_VARIATION",
1506   "MAX_WAIT",
1507   "MIN_SLICE",
1508   "MAX_SLICE",
1509   "PAGE_SIZE",
1510   "VERSION_MAJOR",
1511   "VERSION_MINOR",
1512   "VERSION_REVISION",
1513   "MS_COUNT",
1514   "TIME_LOW",
1515   "TIME_HIGH",
1516   "TOTPHYSMEM",
1517   "TOTRESMEM",
1518   "TOTAVAILMEM",
1519   "MAXPRMEM",
1520   "MAXSHMEM",
1521   "TIMER_INTERVAL",
1522   "MAX_COMP_LENGTH",
1523   "FOREGROUND_FS_SESSION",
1524   "FOREGROUND_PROCESS"
1525 };
1526
1527 XS(XS_OS2_SysInfo)
1528 {
1529     dXSARGS;
1530     if (items != 0)
1531         croak("Usage: OS2::SysInfo()");
1532     {
1533         ULONG   si[QSV_MAX] = {0};      /* System Information Data Buffer */
1534         APIRET  rc      = NO_ERROR;     /* Return code            */
1535         int i = 0, j = 0;
1536
1537         if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
1538                                          QSV_MAX, /* information */
1539                                          (PVOID)si,
1540                                          sizeof(si))))
1541             croak("DosQuerySysInfo() failed");
1542         EXTEND(SP,2*QSV_MAX);
1543         while (i < QSV_MAX) {
1544             ST(j) = sv_newmortal();
1545             sv_setpv(ST(j++), si_fields[i]);
1546             ST(j) = sv_newmortal();
1547             sv_setiv(ST(j++), si[i]);
1548             i++;
1549         }
1550     }
1551     XSRETURN(2 * QSV_MAX);
1552 }
1553
1554 XS(XS_OS2_BootDrive)
1555 {
1556     dXSARGS;
1557     if (items != 0)
1558         croak("Usage: OS2::BootDrive()");
1559     {
1560         ULONG   si[1] = {0};    /* System Information Data Buffer */
1561         APIRET  rc    = NO_ERROR;       /* Return code            */
1562         char c;
1563
1564         if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
1565                                          (PVOID)si, sizeof(si))))
1566             croak("DosQuerySysInfo() failed");
1567         ST(0) = sv_newmortal();
1568         c = 'a' - 1 + si[0];
1569         sv_setpvn(ST(0), &c, 1);
1570     }
1571     XSRETURN(1);
1572 }
1573
1574 XS(XS_OS2_MorphPM)
1575 {
1576     dXSARGS;
1577     if (items != 1)
1578         croak("Usage: OS2::MorphPM(serve)");
1579     {
1580         bool  serve = SvOK(ST(0));
1581         unsigned long   pmq = perl_hmq_GET(serve);
1582
1583         ST(0) = sv_newmortal();
1584         sv_setiv(ST(0), pmq);
1585     }
1586     XSRETURN(1);
1587 }
1588
1589 XS(XS_OS2_UnMorphPM)
1590 {
1591     dXSARGS;
1592     if (items != 1)
1593         croak("Usage: OS2::UnMorphPM(serve)");
1594     {
1595         bool  serve = SvOK(ST(0));
1596
1597         perl_hmq_UNSET(serve);
1598     }
1599     XSRETURN(0);
1600 }
1601
1602 XS(XS_OS2_Serve_Messages)
1603 {
1604     dXSARGS;
1605     if (items != 1)
1606         croak("Usage: OS2::Serve_Messages(force)");
1607     {
1608         bool  force = SvOK(ST(0));
1609         unsigned long   cnt = Perl_Serve_Messages(force);
1610
1611         ST(0) = sv_newmortal();
1612         sv_setiv(ST(0), cnt);
1613     }
1614     XSRETURN(1);
1615 }
1616
1617 XS(XS_OS2_Process_Messages)
1618 {
1619     dXSARGS;
1620     if (items < 1 || items > 2)
1621         croak("Usage: OS2::Process_Messages(force [, cnt])");
1622     {
1623         bool  force = SvOK(ST(0));
1624         unsigned long   cnt;
1625         I32 *cntp = NULL;
1626
1627         if (items == 2) {
1628             SV *sv = ST(1);
1629             int fake = SvIV(sv);        /* Force SvIVX */
1630
1631             if (!SvIOK(sv))
1632                 croak("Can't upgrade count to IV");
1633             cntp = &SvIVX(sv);
1634         }
1635         cnt =  Perl_Process_Messages(force, cntp);
1636         ST(0) = sv_newmortal();
1637         sv_setiv(ST(0), cnt);
1638     }
1639     XSRETURN(1);
1640 }
1641
1642 XS(XS_Cwd_current_drive)
1643 {
1644     dXSARGS;
1645     if (items != 0)
1646         croak("Usage: Cwd::current_drive()");
1647     {
1648         char    RETVAL;
1649
1650         RETVAL = current_drive();
1651         ST(0) = sv_newmortal();
1652         sv_setpvn(ST(0), (char *)&RETVAL, 1);
1653     }
1654     XSRETURN(1);
1655 }
1656
1657 XS(XS_Cwd_sys_chdir)
1658 {
1659     dXSARGS;
1660     if (items != 1)
1661         croak("Usage: Cwd::sys_chdir(path)");
1662     {
1663         char *  path = (char *)SvPV(ST(0),PL_na);
1664         bool    RETVAL;
1665
1666         RETVAL = sys_chdir(path);
1667         ST(0) = boolSV(RETVAL);
1668         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1669     }
1670     XSRETURN(1);
1671 }
1672
1673 XS(XS_Cwd_change_drive)
1674 {
1675     dXSARGS;
1676     if (items != 1)
1677         croak("Usage: Cwd::change_drive(d)");
1678     {
1679         char    d = (char)*SvPV(ST(0),PL_na);
1680         bool    RETVAL;
1681
1682         RETVAL = change_drive(d);
1683         ST(0) = boolSV(RETVAL);
1684         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1685     }
1686     XSRETURN(1);
1687 }
1688
1689 XS(XS_Cwd_sys_is_absolute)
1690 {
1691     dXSARGS;
1692     if (items != 1)
1693         croak("Usage: Cwd::sys_is_absolute(path)");
1694     {
1695         char *  path = (char *)SvPV(ST(0),PL_na);
1696         bool    RETVAL;
1697
1698         RETVAL = sys_is_absolute(path);
1699         ST(0) = boolSV(RETVAL);
1700         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1701     }
1702     XSRETURN(1);
1703 }
1704
1705 XS(XS_Cwd_sys_is_rooted)
1706 {
1707     dXSARGS;
1708     if (items != 1)
1709         croak("Usage: Cwd::sys_is_rooted(path)");
1710     {
1711         char *  path = (char *)SvPV(ST(0),PL_na);
1712         bool    RETVAL;
1713
1714         RETVAL = sys_is_rooted(path);
1715         ST(0) = boolSV(RETVAL);
1716         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1717     }
1718     XSRETURN(1);
1719 }
1720
1721 XS(XS_Cwd_sys_is_relative)
1722 {
1723     dXSARGS;
1724     if (items != 1)
1725         croak("Usage: Cwd::sys_is_relative(path)");
1726     {
1727         char *  path = (char *)SvPV(ST(0),PL_na);
1728         bool    RETVAL;
1729
1730         RETVAL = sys_is_relative(path);
1731         ST(0) = boolSV(RETVAL);
1732         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1733     }
1734     XSRETURN(1);
1735 }
1736
1737 XS(XS_Cwd_sys_cwd)
1738 {
1739     dXSARGS;
1740     if (items != 0)
1741         croak("Usage: Cwd::sys_cwd()");
1742     {
1743         char p[MAXPATHLEN];
1744         char *  RETVAL;
1745         RETVAL = _getcwd2(p, MAXPATHLEN);
1746         ST(0) = sv_newmortal();
1747         sv_setpv((SV*)ST(0), RETVAL);
1748     }
1749     XSRETURN(1);
1750 }
1751
1752 XS(XS_Cwd_sys_abspath)
1753 {
1754     dXSARGS;
1755     if (items < 1 || items > 2)
1756         croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
1757     {
1758         char *  path = (char *)SvPV(ST(0),PL_na);
1759         char *  dir;
1760         char p[MAXPATHLEN];
1761         char *  RETVAL;
1762
1763         if (items < 2)
1764             dir = NULL;
1765         else {
1766             dir = (char *)SvPV(ST(1),PL_na);
1767         }
1768         if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1769             path += 2;
1770         }
1771         if (dir == NULL) {
1772             if (_abspath(p, path, MAXPATHLEN) == 0) {
1773                 RETVAL = p;
1774             } else {
1775                 RETVAL = NULL;
1776             }
1777         } else {
1778             /* Absolute with drive: */
1779             if ( sys_is_absolute(path) ) {
1780                 if (_abspath(p, path, MAXPATHLEN) == 0) {
1781                     RETVAL = p;
1782                 } else {
1783                     RETVAL = NULL;
1784                 }
1785             } else if (path[0] == '/' || path[0] == '\\') {
1786                 /* Rooted, but maybe on different drive. */
1787                 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1788                     char p1[MAXPATHLEN];
1789
1790                     /* Need to prepend the drive. */
1791                     p1[0] = dir[0];
1792                     p1[1] = dir[1];
1793                     Copy(path, p1 + 2, strlen(path) + 1, char);
1794                     RETVAL = p;
1795                     if (_abspath(p, p1, MAXPATHLEN) == 0) {
1796                         RETVAL = p;
1797                     } else {
1798                         RETVAL = NULL;
1799                     }
1800                 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1801                     RETVAL = p;
1802                 } else {
1803                     RETVAL = NULL;
1804                 }
1805             } else {
1806                 /* Either path is relative, or starts with a drive letter. */
1807                 /* If the path starts with a drive letter, then dir is
1808                    relevant only if
1809                    a/b) it is absolute/x:relative on the same drive.
1810                    c)   path is on current drive, and dir is rooted
1811                    In all the cases it is safe to drop the drive part
1812                    of the path. */
1813                 if ( !sys_is_relative(path) ) {
1814                     int is_drived;
1815
1816                     if ( ( ( sys_is_absolute(dir)
1817                              || (isALPHA(dir[0]) && dir[1] == ':'
1818                                  && strnicmp(dir, path,1) == 0))
1819                            && strnicmp(dir, path,1) == 0)
1820                          || ( !(isALPHA(dir[0]) && dir[1] == ':')
1821                               && toupper(path[0]) == current_drive())) {
1822                         path += 2;
1823                     } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1824                         RETVAL = p; goto done;
1825                     } else {
1826                         RETVAL = NULL; goto done;
1827                     }
1828                 }
1829                 {
1830                     /* Need to prepend the absolute path of dir. */
1831                     char p1[MAXPATHLEN];
1832
1833                     if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1834                         int l = strlen(p1);
1835
1836                         if (p1[ l - 1 ] != '/') {
1837                             p1[ l ] = '/';
1838                             l++;
1839                         }
1840                         Copy(path, p1 + l, strlen(path) + 1, char);
1841                         if (_abspath(p, p1, MAXPATHLEN) == 0) {
1842                             RETVAL = p;
1843                         } else {
1844                             RETVAL = NULL;
1845                         }
1846                     } else {
1847                         RETVAL = NULL;
1848                     }
1849                 }
1850               done:
1851             }
1852         }
1853         ST(0) = sv_newmortal();
1854         sv_setpv((SV*)ST(0), RETVAL);
1855     }
1856     XSRETURN(1);
1857 }
1858 typedef APIRET (*PELP)(PSZ path, ULONG type);
1859
1860 APIRET
1861 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1862 {
1863     loadByOrd("doscalls",ord);          /* Guarantied to load or die! */
1864     return (*(PELP)ExtFCN[ord])(path, type);
1865 }
1866
1867 #define extLibpath(type)                                                \
1868     (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH   \
1869                                                  : BEGIN_LIBPATH)))     \
1870      ? NULL : to )
1871
1872 #define extLibpath_set(p,type)                                  \
1873     (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH   \
1874                                                  : BEGIN_LIBPATH))))
1875
1876 XS(XS_Cwd_extLibpath)
1877 {
1878     dXSARGS;
1879     if (items < 0 || items > 1)
1880         croak("Usage: Cwd::extLibpath(type = 0)");
1881     {
1882         bool    type;
1883         char    to[1024];
1884         U32     rc;
1885         char *  RETVAL;
1886
1887         if (items < 1)
1888             type = 0;
1889         else {
1890             type = (int)SvIV(ST(0));
1891         }
1892
1893         RETVAL = extLibpath(type);
1894         ST(0) = sv_newmortal();
1895         sv_setpv((SV*)ST(0), RETVAL);
1896     }
1897     XSRETURN(1);
1898 }
1899
1900 XS(XS_Cwd_extLibpath_set)
1901 {
1902     dXSARGS;
1903     if (items < 1 || items > 2)
1904         croak("Usage: Cwd::extLibpath_set(s, type = 0)");
1905     {
1906         char *  s = (char *)SvPV(ST(0),PL_na);
1907         bool    type;
1908         U32     rc;
1909         bool    RETVAL;
1910
1911         if (items < 2)
1912             type = 0;
1913         else {
1914             type = (int)SvIV(ST(1));
1915         }
1916
1917         RETVAL = extLibpath_set(s, type);
1918         ST(0) = boolSV(RETVAL);
1919         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1920     }
1921     XSRETURN(1);
1922 }
1923
1924 int
1925 Xs_OS2_init()
1926 {
1927     char *file = __FILE__;
1928     {
1929         GV *gv;
1930
1931         if (_emx_env & 0x200) { /* OS/2 */
1932             newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
1933             newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
1934             newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
1935         }
1936         newXS("OS2::Error", XS_OS2_Error, file);
1937         newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
1938         newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
1939         newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
1940         newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
1941         newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
1942         newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
1943         newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
1944         newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
1945         newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
1946         newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
1947         newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
1948         newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
1949         newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
1950         newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
1951         newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
1952         newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
1953         gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
1954         GvMULTI_on(gv);
1955 #ifdef PERL_IS_AOUT
1956         sv_setiv(GvSV(gv), 1);
1957 #endif
1958         gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
1959         GvMULTI_on(gv);
1960         sv_setiv(GvSV(gv), _emx_rev);
1961         sv_setpv(GvSV(gv), _emx_vprt);
1962         SvIOK_on(GvSV(gv));
1963         gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
1964         GvMULTI_on(gv);
1965         sv_setiv(GvSV(gv), _emx_env);
1966         gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
1967         GvMULTI_on(gv);
1968         sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
1969     }
1970 }
1971
1972 OS2_Perl_data_t OS2_Perl_data;
1973
1974 void
1975 Perl_OS2_init(char **env)
1976 {
1977     char *shell;
1978
1979     MALLOC_INIT;
1980     settmppath();
1981     OS2_Perl_data.xs_init = &Xs_OS2_init;
1982     _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
1983     if (environ == NULL) {
1984         environ = env;
1985     }
1986     if ( (shell = getenv("PERL_SH_DRIVE")) ) {
1987         New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
1988         strcpy(PL_sh_path, SH_PATH);
1989         PL_sh_path[0] = shell[0];
1990     } else if ( (shell = getenv("PERL_SH_DIR")) ) {
1991         int l = strlen(shell), i;
1992         if (shell[l-1] == '/' || shell[l-1] == '\\') {
1993             l--;
1994         }
1995         New(1304, PL_sh_path, l + 8, char);
1996         strncpy(PL_sh_path, shell, l);
1997         strcpy(PL_sh_path + l, "/sh.exe");
1998         for (i = 0; i < l; i++) {
1999             if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2000         }
2001     }
2002     MUTEX_INIT(&start_thread_mutex);
2003     os2_mytype = my_type();             /* Do it before morphing.  Needed? */
2004 }
2005
2006 #undef tmpnam
2007 #undef tmpfile
2008
2009 char *
2010 my_tmpnam (char *str)
2011 {
2012     char *p = getenv("TMP"), *tpath;
2013     int len;
2014
2015     if (!p) p = getenv("TEMP");
2016     tpath = tempnam(p, "pltmp");
2017     if (str && tpath) {
2018         strcpy(str, tpath);
2019         return str;
2020     }
2021     return tpath;
2022 }
2023
2024 FILE *
2025 my_tmpfile ()
2026 {
2027     struct stat s;
2028
2029     stat(".", &s);
2030     if (s.st_mode & S_IWOTH) {
2031         return tmpfile();
2032     }
2033     return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2034                                              grants TMP. */
2035 }
2036
2037 #undef flock
2038
2039 /* This code was contributed by Rocco Caputo. */
2040 int
2041 my_flock(int handle, int o)
2042 {
2043   FILELOCK      rNull, rFull;
2044   ULONG         timeout, handle_type, flag_word;
2045   APIRET        rc;
2046   int           blocking, shared;
2047   static int    use_my = -1;
2048
2049   if (use_my == -1) {
2050     char *s = getenv("USE_PERL_FLOCK");
2051     if (s)
2052         use_my = atoi(s);
2053     else
2054         use_my = 1;
2055   }
2056   if (!(_emx_env & 0x200) || !use_my)
2057     return flock(handle, o);    /* Delegate to EMX. */
2058
2059                                         // is this a file?
2060   if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2061       (handle_type & 0xFF))
2062   {
2063     errno = EBADF;
2064     return -1;
2065   }
2066                                         // set lock/unlock ranges
2067   rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2068   rFull.lRange = 0x7FFFFFFF;
2069                                         // set timeout for blocking
2070   timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2071                                         // shared or exclusive?
2072   shared = (o & LOCK_SH) ? 1 : 0;
2073                                         // do not block the unlock
2074   if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2075     rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2076     switch (rc) {
2077       case 0:
2078         errno = 0;
2079         return 0;
2080       case ERROR_INVALID_HANDLE:
2081         errno = EBADF;
2082         return -1;
2083       case ERROR_SHARING_BUFFER_EXCEEDED:
2084         errno = ENOLCK;
2085         return -1;
2086       case ERROR_LOCK_VIOLATION:
2087         break;                          // not an error
2088       case ERROR_INVALID_PARAMETER:
2089       case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2090       case ERROR_READ_LOCKS_NOT_SUPPORTED:
2091         errno = EINVAL;
2092         return -1;
2093       case ERROR_INTERRUPT:
2094         errno = EINTR;
2095         return -1;
2096       default:
2097         errno = EINVAL;
2098         return -1;
2099     }
2100   }
2101                                         // lock may block
2102   if (o & (LOCK_SH | LOCK_EX)) {
2103                                         // for blocking operations
2104     for (;;) {
2105       rc =
2106         DosSetFileLocks(
2107                 handle,
2108                 &rNull,
2109                 &rFull,
2110                 timeout,
2111                 shared
2112         );
2113       switch (rc) {
2114         case 0:
2115           errno = 0;
2116           return 0;
2117         case ERROR_INVALID_HANDLE:
2118           errno = EBADF;
2119           return -1;
2120         case ERROR_SHARING_BUFFER_EXCEEDED:
2121           errno = ENOLCK;
2122           return -1;
2123         case ERROR_LOCK_VIOLATION:
2124           if (!blocking) {
2125             errno = EWOULDBLOCK;
2126             return -1;
2127           }
2128           break;
2129         case ERROR_INVALID_PARAMETER:
2130         case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2131         case ERROR_READ_LOCKS_NOT_SUPPORTED:
2132           errno = EINVAL;
2133           return -1;
2134         case ERROR_INTERRUPT:
2135           errno = EINTR;
2136           return -1;
2137         default:
2138           errno = EINVAL;
2139           return -1;
2140       }
2141                                         // give away timeslice
2142       DosSleep(1);
2143     }
2144   }
2145
2146   errno = 0;
2147   return 0;
2148 }