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