os2/os2.c

   1 #define INCL_DOS
   2 #define INCL_NOPM
   3 #define INCL_DOSFILEMGR
   4 #define INCL_DOSMEMMGR
   5 #define INCL_DOSERRORS
   6 /* These 3 are needed for compile if os2.h includes os2tk.h, not os2emx.h */
   7 #define INCL_DOSPROCESS
   8 #define SPU_DISABLESUPPRESSION          0
   9 #define SPU_ENABLESUPPRESSION           1
  10 #include <os2.h>
  11 #include "dlfcn.h"
  12 #include <emx/syscalls.h>
  13
  14 #include <sys/uflags.h>
  15
  16 /*
  17  * Various Unix compatibility functions for OS/2
  18  */
  19
  20 #include <stdio.h>
  21 #include <errno.h>
  22 #include <limits.h>
  23 #include <process.h>
  24 #include <fcntl.h>
  25 #include <pwd.h>
  26 #include <grp.h>
  27
  28 #define PERLIO_NOT_STDIO 0
  29
  30 #include "EXTERN.h"
  31 #include "perl.h"
  32
  33 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
  34
  35 typedef void (*emx_startroutine)(void *);
  36 typedef void* (*pthreads_startroutine)(void *);
  37
  38 enum pthreads_state {
  39     pthreads_st_none = 0,
  40     pthreads_st_run,
  41     pthreads_st_exited,
  42     pthreads_st_detached,
  43     pthreads_st_waited,
  44     pthreads_st_norun,
  45     pthreads_st_exited_waited,
  46 };
  47 const char *pthreads_states[] = {
  48     "uninit",
  49     "running",
  50     "exited",
  51     "detached",
  52     "waited for",
  53     "could not start",
  54     "exited, then waited on",
  55 };
  56
  57 enum pthread_exists { pthread_not_existant = -0xff };
  58
  59 static const char*
  60 pthreads_state_string(enum pthreads_state state)
  61 {
  62   if (state < 0 || state >= sizeof(pthreads_states)/sizeof(*pthreads_states)) {
  63     static char buf[80];
  64
  65     snprintf(buf, sizeof(buf), "unknown thread state %d", (int)state);
  66     return buf;
  67   }
  68   return pthreads_states[state];
  69 }
  70
  71 typedef struct {
  72     void *status;
  73     perl_cond cond;
  74     enum pthreads_state state;
  75 } thread_join_t;
  76
  77 thread_join_t *thread_join_data;
  78 int thread_join_count;
  79 perl_mutex start_thread_mutex;
  80
  81 int
  82 pthread_join(perl_os_thread tid, void **status)
  83 {
  84     MUTEX_LOCK(&start_thread_mutex);
  85     if (tid < 1 || tid >= thread_join_count) {
  86         MUTEX_UNLOCK(&start_thread_mutex);
  87         if (tid != pthread_not_existant)
  88             Perl_croak_nocontext("panic: join with a thread with strange ordinal %d", (int)tid);
  89         Perl_warn_nocontext("panic: join with a thread which could not start");
  90         *status = 0;
  91         return 0;
  92     }
  93     switch (thread_join_data[tid].state) {
  94     case pthreads_st_exited:
  95         thread_join_data[tid].state = pthreads_st_exited_waited;
  96         *status = thread_join_data[tid].status;
  97         MUTEX_UNLOCK(&start_thread_mutex);
  98         COND_SIGNAL(&thread_join_data[tid].cond);
  99         break;
 100     case pthreads_st_waited:
 101         MUTEX_UNLOCK(&start_thread_mutex);
 102         Perl_croak_nocontext("join with a thread with a waiter");
 103         break;
 104     case pthreads_st_norun:
 105     {
 106         int state = (int)thread_join_data[tid].status;
 107
 108         thread_join_data[tid].state = pthreads_st_none;
 109         MUTEX_UNLOCK(&start_thread_mutex);
 110         Perl_croak_nocontext("panic: join with a thread which could not run"
 111                              " due to attempt of tid reuse (state='%s')",
 112                              pthreads_state_string(state));
 113         break;
 114     }
 115     case pthreads_st_run:
 116     {
 117         perl_cond cond;
 118
 119         thread_join_data[tid].state = pthreads_st_waited;
 120         thread_join_data[tid].status = (void *)status;
 121         COND_INIT(&thread_join_data[tid].cond);
 122         cond = thread_join_data[tid].cond;
 123         COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex);
 124         COND_DESTROY(&cond);
 125         MUTEX_UNLOCK(&start_thread_mutex);
 126         break;
 127     }
 128     default:
 129         MUTEX_UNLOCK(&start_thread_mutex);
 130         Perl_croak_nocontext("panic: join with thread in unknown thread state: '%s'",
 131               pthreads_state_string(thread_join_data[tid].state));
 132         break;
 133     }
 134     return 0;
 135 }
 136
 137 typedef struct {
 138   pthreads_startroutine sub;
 139   void *arg;
 140   void *ctx;
 141 } pthr_startit;
 142
 143 /* The lock is used:
 144         a) Since we temporarily usurp the caller interp, so malloc() may
 145            use it to decide on debugging the call;
 146         b) Since *args is on the caller's stack.
 147  */
 148 void
 149 pthread_startit(void *arg1)
 150 {
 151     /* Thread is already started, we need to transfer control only */
 152     pthr_startit args = *(pthr_startit *)arg1;
 153     int tid = pthread_self();
 154     void *rc;
 155     int state;
 156
 157     if (tid <= 1) {
 158         /* Can't croak, the setjmp() is not in scope... */
 159         char buf[80];
 160
 161         snprintf(buf, sizeof(buf),
 162                  "panic: thread with strange ordinal %d created\n\r", tid);
 163         write(2,buf,strlen(buf));
 164         MUTEX_UNLOCK(&start_thread_mutex);
 165         return;
 166     }
 167     /* Until args.sub resets it, makes debugging Perl_malloc() work: */
 168     PERL_SET_CONTEXT(0);
 169     if (tid >= thread_join_count) {
 170         int oc = thread_join_count;
 171
 172         thread_join_count = tid + 5 + tid/5;
 173         if (thread_join_data) {
 174             Renew(thread_join_data, thread_join_count, thread_join_t);
 175             Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
 176         } else {
 177             Newz(1323, thread_join_data, thread_join_count, thread_join_t);
 178         }
 179     }
 180     if (thread_join_data[tid].state != pthreads_st_none) {
 181         /* Can't croak, the setjmp() is not in scope... */
 182         char buf[80];
 183
 184         snprintf(buf, sizeof(buf),
 185                  "panic: attempt to reuse thread id %d (state='%s')\n\r",
 186                  tid, pthreads_state_string(thread_join_data[tid].state));
 187         write(2,buf,strlen(buf));
 188         thread_join_data[tid].status = (void*)thread_join_data[tid].state;
 189         thread_join_data[tid].state = pthreads_st_norun;
 190         MUTEX_UNLOCK(&start_thread_mutex);
 191         return;
 192     }
 193     thread_join_data[tid].state = pthreads_st_run;
 194     /* Now that we copied/updated the guys, we may release the caller... */
 195     MUTEX_UNLOCK(&start_thread_mutex);
 196     rc = (*args.sub)(args.arg);
 197     MUTEX_LOCK(&start_thread_mutex);
 198     switch (thread_join_data[tid].state) {
 199     case pthreads_st_waited:
 200         COND_SIGNAL(&thread_join_data[tid].cond);
 201         thread_join_data[tid].state = pthreads_st_none;
 202         *((void**)thread_join_data[tid].status) = rc;
 203         break;
 204     case pthreads_st_detached:
 205         thread_join_data[tid].state = pthreads_st_none;
 206         break;
 207     case pthreads_st_run:
 208         /* Somebody can wait on us; cannot exit, since OS can reuse the tid
 209            and our waiter will get somebody else's status. */
 210         thread_join_data[tid].state = pthreads_st_exited;
 211         thread_join_data[tid].status = rc;
 212         COND_INIT(&thread_join_data[tid].cond);
 213         COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex);
 214         COND_DESTROY(&thread_join_data[tid].cond);
 215         thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
 216         break;
 217     default:
 218         state = thread_join_data[tid].state;
 219         MUTEX_UNLOCK(&start_thread_mutex);
 220         Perl_croak_nocontext("panic: unexpected thread state on exit: '%s'",
 221                              pthreads_state_string(state));
 222     }
 223     MUTEX_UNLOCK(&start_thread_mutex);
 224 }
 225
 226 int
 227 pthread_create(perl_os_thread *tidp, const pthread_attr_t *attr,
 228                void *(*start_routine)(void*), void *arg)
 229 {
 230     dTHX;
 231     pthr_startit args;
 232
 233     args.sub = (void*)start_routine;
 234     args.arg = arg;
 235     args.ctx = PERL_GET_CONTEXT;
 236
 237     MUTEX_LOCK(&start_thread_mutex);
 238     /* Test suite creates 31 extra threads;
 239        on machine without shared-memory-hogs this stack sizeis OK with 31: */
 240     *tidp = _beginthread(pthread_startit, /*stack*/ NULL,
 241                          /*stacksize*/ 4*1024*1024, (void*)&args);
 242     if (*tidp == -1) {
 243         *tidp = pthread_not_existant;
 244         MUTEX_UNLOCK(&start_thread_mutex);
 245         return EINVAL;
 246     }
 247     MUTEX_LOCK(&start_thread_mutex);            /* Wait for init to proceed */
 248     MUTEX_UNLOCK(&start_thread_mutex);
 249     return 0;
 250 }
 251
 252 int
 253 pthread_detach(perl_os_thread tid)
 254 {
 255     MUTEX_LOCK(&start_thread_mutex);
 256     if (tid < 1 || tid >= thread_join_count) {
 257         MUTEX_UNLOCK(&start_thread_mutex);
 258         if (tid != pthread_not_existant)
 259             Perl_croak_nocontext("panic: detach of a thread with strange ordinal %d", (int)tid);
 260         Perl_warn_nocontext("detach of a thread which could not start");
 261         return 0;
 262     }
 263     switch (thread_join_data[tid].state) {
 264     case pthreads_st_waited:
 265         MUTEX_UNLOCK(&start_thread_mutex);
 266         Perl_croak_nocontext("detach on a thread with a waiter");
 267         break;
 268     case pthreads_st_run:
 269         thread_join_data[tid].state = pthreads_st_detached;
 270         MUTEX_UNLOCK(&start_thread_mutex);
 271         break;
 272     case pthreads_st_exited:
 273         MUTEX_UNLOCK(&start_thread_mutex);
 274         COND_SIGNAL(&thread_join_data[tid].cond);
 275         break;
 276     case pthreads_st_detached:
 277         MUTEX_UNLOCK(&start_thread_mutex);
 278         Perl_warn_nocontext("detach on an already detached thread");
 279         break;
 280     case pthreads_st_norun:
 281     {
 282         int state = (int)thread_join_data[tid].status;
 283
 284         thread_join_data[tid].state = pthreads_st_none;
 285         MUTEX_UNLOCK(&start_thread_mutex);
 286         Perl_croak_nocontext("panic: detaching thread which could not run"
 287                              " due to attempt of tid reuse (state='%s')",
 288                              pthreads_state_string(state));
 289         break;
 290     }
 291     default:
 292         MUTEX_UNLOCK(&start_thread_mutex);
 293         Perl_croak_nocontext("panic: detach of a thread with unknown thread state: '%s'",
 294               pthreads_state_string(thread_join_data[tid].state));
 295         break;
 296     }
 297     return 0;
 298 }
 299
 300 /* This is a very bastardized version; may be OK due to edge trigger of Wait */
 301 int
 302 os2_cond_wait(perl_cond *c, perl_mutex *m)
 303 {
 304     int rc;
 305     STRLEN n_a;
 306     if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET))
 307         Perl_croak_nocontext("panic: COND_WAIT-reset: rc=%i", rc);
 308     if (m) MUTEX_UNLOCK(m);
 309     if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
 310         && (rc != ERROR_INTERRUPT))
 311         Perl_croak_nocontext("panic: COND_WAIT: rc=%i", rc);
 312     if (rc == ERROR_INTERRUPT)
 313         errno = EINTR;
 314     if (m) MUTEX_LOCK(m);
 315     return 0;
 316 }
 317 #endif
 318
 319 static int exe_is_aout(void);
 320
 321 /*****************************************************************************/
 322 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
 323 #define C_ARR_LEN(sym)  (sizeof(sym)/sizeof(*sym))
 324
 325 struct dll_handle {
 326     const char *modname;
 327     HMODULE handle;
 328 };
 329 static struct dll_handle doscalls_handle = {"doscalls", 0};
 330 static struct dll_handle tcp_handle = {"tcp32dll", 0};
 331 static struct dll_handle pmwin_handle = {"pmwin", 0};
 332 static struct dll_handle rexx_handle = {"rexx", 0};
 333 static struct dll_handle rexxapi_handle = {"rexxapi", 0};
 334 static struct dll_handle sesmgr_handle = {"sesmgr", 0};
 335 static struct dll_handle pmshapi_handle = {"pmshapi", 0};
 336
 337 /* This should match enum entries_ordinals defined in os2ish.h. */
 338 static const struct {
 339     struct dll_handle *dll;
 340     const char *entryname;
 341     int entrypoint;
 342 } loadOrdinals[ORD_NENTRIES] = {
 343   {&doscalls_handle, NULL, 874},        /* DosQueryExtLibpath */
 344   {&doscalls_handle, NULL, 873},        /* DosSetExtLibpath */
 345   {&doscalls_handle, NULL, 460},        /* DosVerifyPidTid */
 346   {&tcp_handle, "SETHOSTENT", 0},
 347   {&tcp_handle, "SETNETENT" , 0},
 348   {&tcp_handle, "SETPROTOENT", 0},
 349   {&tcp_handle, "SETSERVENT", 0},
 350   {&tcp_handle, "GETHOSTENT", 0},
 351   {&tcp_handle, "GETNETENT" , 0},
 352   {&tcp_handle, "GETPROTOENT", 0},
 353   {&tcp_handle, "GETSERVENT", 0},
 354   {&tcp_handle, "ENDHOSTENT", 0},
 355   {&tcp_handle, "ENDNETENT", 0},
 356   {&tcp_handle, "ENDPROTOENT", 0},
 357   {&tcp_handle, "ENDSERVENT", 0},
 358   {&pmwin_handle, NULL, 763},           /* WinInitialize */
 359   {&pmwin_handle, NULL, 716},           /* WinCreateMsgQueue */
 360   {&pmwin_handle, NULL, 726},           /* WinDestroyMsgQueue */
 361   {&pmwin_handle, NULL, 918},           /* WinPeekMsg */
 362   {&pmwin_handle, NULL, 915},           /* WinGetMsg */
 363   {&pmwin_handle, NULL, 912},           /* WinDispatchMsg */
 364   {&pmwin_handle, NULL, 753},           /* WinGetLastError */
 365   {&pmwin_handle, NULL, 705},           /* WinCancelShutdown */
 366         /* These are needed in extensions.
 367            How to protect PMSHAPI: it comes through EMX functions? */
 368   {&rexx_handle,    "RexxStart", 0},
 369   {&rexx_handle,    "RexxVariablePool", 0},
 370   {&rexxapi_handle, "RexxRegisterFunctionExe", 0},
 371   {&rexxapi_handle, "RexxDeregisterFunction", 0},
 372   {&sesmgr_handle,  "DOSSMSETTITLE", 0}, /* Would not work runtime-loaded */
 373   {&pmshapi_handle, "PRF32QUERYPROFILESIZE", 0},
 374   {&pmshapi_handle, "PRF32OPENPROFILE", 0},
 375   {&pmshapi_handle, "PRF32CLOSEPROFILE", 0},
 376   {&pmshapi_handle, "PRF32QUERYPROFILE", 0},
 377   {&pmshapi_handle, "PRF32RESET", 0},
 378   {&pmshapi_handle, "PRF32QUERYPROFILEDATA", 0},
 379   {&pmshapi_handle, "PRF32WRITEPROFILEDATA", 0},
 380
 381   /* At least some of these do not work by name, since they need
 382         WIN32 instead of WIN... */
 383 #if 0
 384   These were generated with
 385     nm I:\emx\lib\os2.a  | fgrep -f API-list | grep = > API-list-entries
 386     perl -wnle "next unless /^0+\s+E\s+_(\w+)=(\w+).(\d+)/; print qq(    ORD_$1,)" API-list-entries > API-list-ORD_
 387     perl -wnle "next unless /^0+\s+E\s+_(\w+)=(\w+).(\d+)/; print qq(  {${2}_handle, NULL, $3},\t\t/* $1 */)" WinSwitch-API-list-entries  >API-list-entry
 388 #endif
 389   {&pmshapi_handle, NULL, 123},         /* WinChangeSwitchEntry */
 390   {&pmshapi_handle, NULL, 124},         /* WinQuerySwitchEntry */
 391   {&pmshapi_handle, NULL, 125},         /* WinQuerySwitchHandle */
 392   {&pmshapi_handle, NULL, 126},         /* WinQuerySwitchList */
 393   {&pmshapi_handle, NULL, 131},         /* WinSwitchToProgram */
 394   {&pmwin_handle, NULL, 702},           /* WinBeginEnumWindows */
 395   {&pmwin_handle, NULL, 737},           /* WinEndEnumWindows */
 396   {&pmwin_handle, NULL, 740},           /* WinEnumDlgItem */
 397   {&pmwin_handle, NULL, 756},           /* WinGetNextWindow */
 398   {&pmwin_handle, NULL, 768},           /* WinIsChild */
 399   {&pmwin_handle, NULL, 799},           /* WinQueryActiveWindow */
 400   {&pmwin_handle, NULL, 805},           /* WinQueryClassName */
 401   {&pmwin_handle, NULL, 817},           /* WinQueryFocus */
 402   {&pmwin_handle, NULL, 834},           /* WinQueryWindow */
 403   {&pmwin_handle, NULL, 837},           /* WinQueryWindowPos */
 404   {&pmwin_handle, NULL, 838},           /* WinQueryWindowProcess */
 405   {&pmwin_handle, NULL, 841},           /* WinQueryWindowText */
 406   {&pmwin_handle, NULL, 842},           /* WinQueryWindowTextLength */
 407   {&pmwin_handle, NULL, 860},           /* WinSetFocus */
 408   {&pmwin_handle, NULL, 875},           /* WinSetWindowPos */
 409   {&pmwin_handle, NULL, 877},           /* WinSetWindowText */
 410   {&pmwin_handle, NULL, 883},           /* WinShowWindow */
 411   {&pmwin_handle, NULL, 772},           /* WinIsWindow */
 412   {&pmwin_handle, NULL, 899},           /* WinWindowFromId */
 413   {&pmwin_handle, NULL, 900},           /* WinWindowFromPoint */
 414   {&pmwin_handle, NULL, 919},           /* WinPostMsg */
 415   {&pmwin_handle, NULL, 735},           /* WinEnableWindow */
 416   {&pmwin_handle, NULL, 736},           /* WinEnableWindowUpdate */
 417   {&pmwin_handle, NULL, 773},           /* WinIsWindowEnabled */
 418   {&pmwin_handle, NULL, 774},           /* WinIsWindowShowing */
 419   {&pmwin_handle, NULL, 775},           /* WinIsWindowVisible */
 420   {&pmwin_handle, NULL, 839},           /* WinQueryWindowPtr */
 421   {&pmwin_handle, NULL, 843},           /* WinQueryWindowULong */
 422   {&pmwin_handle, NULL, 844},           /* WinQueryWindowUShort */
 423   {&pmwin_handle, NULL, 874},           /* WinSetWindowBits */
 424   {&pmwin_handle, NULL, 876},           /* WinSetWindowPtr */
 425   {&pmwin_handle, NULL, 878},           /* WinSetWindowULong */
 426   {&pmwin_handle, NULL, 879},           /* WinSetWindowUShort */
 427   {&pmwin_handle, NULL, 813},           /* WinQueryDesktopWindow */
 428   {&pmwin_handle, NULL, 851},           /* WinSetActiveWindow */
 429   {&doscalls_handle, NULL, 360},        /* DosQueryModFromEIP */
 430 };
 431
 432 static PFN ExtFCN[C_ARR_LEN(loadOrdinals)];     /* Labeled by ord ORD_*. */
 433 const Perl_PFN * const pExtFCN = ExtFCN;
 434 struct PMWIN_entries_t PMWIN_entries;
 435
 436 HMODULE
 437 loadModule(const char *modname, int fail)
 438 {
 439     HMODULE h = (HMODULE)dlopen(modname, 0);
 440
 441     if (!h && fail)
 442         Perl_croak_nocontext("Error loading module '%s': %s",
 443                              modname, dlerror());
 444     return h;
 445 }
 446
 447 PFN
 448 loadByOrdinal(enum entries_ordinals ord, int fail)
 449 {
 450     if (ExtFCN[ord] == NULL) {
 451         PFN fcn = (PFN)-1;
 452         APIRET rc;
 453
 454         if (!loadOrdinals[ord].dll->handle)
 455             loadOrdinals[ord].dll->handle
 456                 = loadModule(loadOrdinals[ord].dll->modname, fail);
 457         if (!loadOrdinals[ord].dll->handle)
 458             return 0;                   /* Possible with FAIL==0 only */
 459         if (CheckOSError(DosQueryProcAddr(loadOrdinals[ord].dll->handle,
 460                                           loadOrdinals[ord].entrypoint,
 461                                           loadOrdinals[ord].entryname,&fcn))) {
 462             char buf[20], *s = (char*)loadOrdinals[ord].entryname;
 463
 464             if (!fail)
 465                 return 0;
 466             if (!s)
 467                 sprintf(s = buf, "%d", loadOrdinals[ord].entrypoint);
 468             Perl_croak_nocontext(
 469                  "This version of OS/2 does not support %s.%s",
 470                  loadOrdinals[ord].dll->modname, s);
 471         }
 472         ExtFCN[ord] = fcn;
 473     }
 474     if ((long)ExtFCN[ord] == -1)
 475         Perl_croak_nocontext("panic queryaddr");
 476     return ExtFCN[ord];
 477 }
 478
 479 void
 480 init_PMWIN_entries(void)
 481 {
 482     int i;
 483
 484     for (i = ORD_WinInitialize; i <= ORD_WinCancelShutdown; i++)
 485         ((PFN*)&PMWIN_entries)[i - ORD_WinInitialize] = loadByOrdinal(i, 1);
 486 }
 487
 488 /*****************************************************/
 489 /* socket forwarders without linking with tcpip DLLs */
 490
 491 DeclFuncByORD(struct hostent *,  gethostent,  ORD_GETHOSTENT,  (void), ())
 492 DeclFuncByORD(struct netent  *,  getnetent,   ORD_GETNETENT,   (void), ())
 493 DeclFuncByORD(struct protoent *, getprotoent, ORD_GETPROTOENT, (void), ())
 494 DeclFuncByORD(struct servent *,  getservent,  ORD_GETSERVENT,  (void), ())
 495
 496 DeclVoidFuncByORD(sethostent,  ORD_SETHOSTENT,  (int x), (x))
 497 DeclVoidFuncByORD(setnetent,   ORD_SETNETENT,   (int x), (x))
 498 DeclVoidFuncByORD(setprotoent, ORD_SETPROTOENT, (int x), (x))
 499 DeclVoidFuncByORD(setservent,  ORD_SETSERVENT,  (int x), (x))
 500
 501 DeclVoidFuncByORD(endhostent,  ORD_ENDHOSTENT,  (void), ())
 502 DeclVoidFuncByORD(endnetent,   ORD_ENDNETENT,   (void), ())
 503 DeclVoidFuncByORD(endprotoent, ORD_ENDPROTOENT, (void), ())
 504 DeclVoidFuncByORD(endservent,  ORD_ENDSERVENT,  (void), ())
 505
 506 /* priorities */
 507 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
 508                                                self inverse. */
 509 #define QSS_INI_BUFFER 1024
 510
 511 ULONG (*pDosVerifyPidTid) (PID pid, TID tid);
 512 static int pidtid_lookup;
 513
 514 PQTOPLEVEL
 515 get_sysinfo(ULONG pid, ULONG flags)
 516 {
 517     char *pbuffer;
 518     ULONG rc, buf_len = QSS_INI_BUFFER;
 519     PQTOPLEVEL psi;
 520
 521     if (!pidtid_lookup) {
 522         pidtid_lookup = 1;
 523         *(PFN*)&pDosVerifyPidTid = loadByOrdinal(ORD_DosVerifyPidTid, 0);
 524     }
 525     if (pDosVerifyPidTid) {     /* Warp3 or later */
 526         /* Up to some fixpak QuerySysState() kills the system if a non-existent
 527            pid is used. */
 528         if (CheckOSError(pDosVerifyPidTid(pid, 1)))
 529             return 0;
 530     }
 531     New(1322, pbuffer, buf_len, char);
 532     /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
 533     rc = QuerySysState(flags, pid, pbuffer, buf_len);
 534     while (rc == ERROR_BUFFER_OVERFLOW) {
 535         Renew(pbuffer, buf_len *= 2, char);
 536         rc = QuerySysState(flags, pid, pbuffer, buf_len);
 537     }
 538     if (rc) {
 539         FillOSError(rc);
 540         Safefree(pbuffer);
 541         return 0;
 542     }
 543     psi = (PQTOPLEVEL)pbuffer;
 544     if (psi && pid && pid != psi->procdata->pid) {
 545       Safefree(psi);
 546       Perl_croak_nocontext("panic: wrong pid in sysinfo");
 547     }
 548     return psi;
 549 }
 550
 551 #define PRIO_ERR 0x1111
 552
 553 static ULONG
 554 sys_prio(pid)
 555 {
 556   ULONG prio;
 557   PQTOPLEVEL psi;
 558
 559   if (!pid)
 560       return PRIO_ERR;
 561   psi = get_sysinfo(pid, QSS_PROCESS);
 562   if (!psi)
 563       return PRIO_ERR;
 564   prio = psi->procdata->threads->priority;
 565   Safefree(psi);
 566   return prio;
 567 }
 568
 569 int
 570 setpriority(int which, int pid, int val)
 571 {
 572   ULONG rc, prio = sys_prio(pid);
 573
 574   if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
 575   if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
 576       /* Do not change class. */
 577       return CheckOSError(DosSetPriority((pid < 0)
 578                                          ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
 579                                          0,
 580                                          (32 - val) % 32 - (prio & 0xFF),
 581                                          abs(pid)))
 582       ? -1 : 0;
 583   } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
 584       /* Documentation claims one can change both class and basevalue,
 585        * but I find it wrong. */
 586       /* Change class, but since delta == 0 denotes absolute 0, correct. */
 587       if (CheckOSError(DosSetPriority((pid < 0)
 588                                       ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
 589                                       priors[(32 - val) >> 5] + 1,
 590                                       0,
 591                                       abs(pid))))
 592           return -1;
 593       if ( ((32 - val) % 32) == 0 ) return 0;
 594       return CheckOSError(DosSetPriority((pid < 0)
 595                                          ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
 596                                          0,
 597                                          (32 - val) % 32,
 598                                          abs(pid)))
 599           ? -1 : 0;
 600   }
 601 }
 602
 603 int
 604 getpriority(int which /* ignored */, int pid)
 605 {
 606   ULONG ret;
 607
 608   if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
 609   ret = sys_prio(pid);
 610   if (ret == PRIO_ERR) {
 611       return -1;
 612   }
 613   return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
 614 }
 615
 616 /*****************************************************************************/
 617 /* spawn */
 618
 619 int emx_runtime_init;                   /* If 1, we need to manually init it */
 620 int emx_exception_init;                 /* If 1, we need to manually set it */
 621
 622 /* There is no big sense to make it thread-specific, since signals
 623    are delivered to thread 1 only.  XXXX Maybe make it into an array? */
 624 static int spawn_pid;
 625 static int spawn_killed;
 626
 627 static Signal_t
 628 spawn_sighandler(int sig)
 629 {
 630     /* Some programs do not arrange for the keyboard signals to be
 631        delivered to them.  We need to deliver the signal manually. */
 632     /* We may get a signal only if
 633        a) kid does not receive keyboard signal: deliver it;
 634        b) kid already died, and we get a signal.  We may only hope
 635           that the pid number was not reused.
 636      */
 637
 638     if (spawn_killed)
 639         sig = SIGKILL;                  /* Try harder. */
 640     kill(spawn_pid, sig);
 641     spawn_killed = 1;
 642 }
 643
 644 static int
 645 result(pTHX_ int flag, int pid)
 646 {
 647         int r, status;
 648         Signal_t (*ihand)();     /* place to save signal during system() */
 649         Signal_t (*qhand)();     /* place to save signal during system() */
 650 #ifndef __EMX__
 651         RESULTCODES res;
 652         int rpid;
 653 #endif
 654
 655         if (pid < 0 || flag != 0)
 656                 return pid;
 657
 658 #ifdef __EMX__
 659         spawn_pid = pid;
 660         spawn_killed = 0;
 661         ihand = rsignal(SIGINT, &spawn_sighandler);
 662         qhand = rsignal(SIGQUIT, &spawn_sighandler);
 663         do {
 664             r = wait4pid(pid, &status, 0);
 665         } while (r == -1 && errno == EINTR);
 666         rsignal(SIGINT, ihand);
 667         rsignal(SIGQUIT, qhand);
 668
 669         PL_statusvalue = (U16)status;
 670         if (r < 0)
 671                 return -1;
 672         return status & 0xFFFF;
 673 #else
 674         ihand = rsignal(SIGINT, SIG_IGN);
 675         r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
 676         rsignal(SIGINT, ihand);
 677         PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
 678         if (r)
 679                 return -1;
 680         return PL_statusvalue;
 681 #endif
 682 }
 683
 684 enum execf_t {
 685   EXECF_SPAWN,
 686   EXECF_EXEC,
 687   EXECF_TRUEEXEC,
 688   EXECF_SPAWN_NOWAIT,
 689   EXECF_SPAWN_BYFLAG,
 690   EXECF_SYNC
 691 };
 692
 693 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
 694
 695 static int
 696 my_type()
 697 {
 698     int rc;
 699     TIB *tib;
 700     PIB *pib;
 701
 702     if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
 703     if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
 704         return -1;
 705
 706     return (pib->pib_ultype);
 707 }
 708
 709 static ULONG
 710 file_type(char *path)
 711 {
 712     int rc;
 713     ULONG apptype;
 714
 715     if (!(_emx_env & 0x200))
 716         Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */
 717     if (CheckOSError(DosQueryAppType(path, &apptype))) {
 718         switch (rc) {
 719         case ERROR_FILE_NOT_FOUND:
 720         case ERROR_PATH_NOT_FOUND:
 721             return -1;
 722         case ERROR_ACCESS_DENIED:       /* Directory with this name found? */
 723             return -3;
 724         default:                        /* Found, but not an
 725                                            executable, or some other
 726                                            read error. */
 727             return -2;
 728         }
 729     }
 730     return apptype;
 731 }
 732
 733 static ULONG os2_mytype;
 734
 735 /* Spawn/exec a program, revert to shell if needed. */
 736 /* global PL_Argv[] contains arguments. */
 737
 738 extern ULONG _emx_exception (   EXCEPTIONREPORTRECORD *,
 739                                 EXCEPTIONREGISTRATIONRECORD *,
 740                                 CONTEXTRECORD *,
 741                                 void *);
 742
 743 int
 744 do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
 745 {
 746         int trueflag = flag;
 747         int rc, pass = 1;
 748         char *tmps;
 749         char *args[4];
 750         static char * fargs[4]
 751             = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
 752         char **argsp = fargs;
 753         int nargs = 4;
 754         int force_shell;
 755         int new_stderr = -1, nostderr = 0;
 756         int fl_stderr = 0;
 757         STRLEN n_a;
 758         char *buf;
 759         PerlIO *file;
 760
 761         if (flag == P_WAIT)
 762                 flag = P_NOWAIT;
 763
 764       retry:
 765         if (strEQ(PL_Argv[0],"/bin/sh"))
 766             PL_Argv[0] = PL_sh_path;
 767
 768         /* We should check PERL_SH* and PERLLIB_* as well? */
 769         if (!really || !*(tmps = SvPV(really, n_a)))
 770             tmps = PL_Argv[0];
 771         if (tmps[0] != '/' && tmps[0] != '\\'
 772             && !(tmps[0] && tmps[1] == ':'
 773                  && (tmps[2] == '/' || tmps[2] != '\\'))
 774             ) /* will spawnvp use PATH? */
 775             TAINT_ENV();        /* testing IFS here is overkill, probably */
 776
 777       reread:
 778         force_shell = 0;
 779         if (_emx_env & 0x200) { /* OS/2. */
 780             int type = file_type(tmps);
 781           type_again:
 782             if (type == -1) {           /* Not found */
 783                 errno = ENOENT;
 784                 rc = -1;
 785                 goto do_script;
 786             }
 787             else if (type == -2) {              /* Not an EXE */
 788                 errno = ENOEXEC;
 789                 rc = -1;
 790                 goto do_script;
 791             }
 792             else if (type == -3) {              /* Is a directory? */
 793                 /* Special-case this */
 794                 char tbuf[512];
 795                 int l = strlen(tmps);
 796
 797                 if (l + 5 <= sizeof tbuf) {
 798                     strcpy(tbuf, tmps);
 799                     strcpy(tbuf + l, ".exe");
 800                     type = file_type(tbuf);
 801                     if (type >= -3)
 802                         goto type_again;
 803                 }
 804
 805                 errno = ENOEXEC;
 806                 rc = -1;
 807                 goto do_script;
 808             }
 809             switch (type & 7) {
 810                 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
 811             case FAPPTYP_WINDOWAPI:
 812             {
 813                 if (os2_mytype != 3) {  /* not PM */
 814                     if (flag == P_NOWAIT)
 815                         flag = P_PM;
 816                     else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION)
 817                         Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting PM process with flag=%d, mytype=%d",
 818                              flag, os2_mytype);
 819                 }
 820             }
 821             break;
 822             case FAPPTYP_NOTWINDOWCOMPAT:
 823             {
 824                 if (os2_mytype != 0) {  /* not full screen */
 825                     if (flag == P_NOWAIT)
 826                         flag = P_SESSION;
 827                     else if ((flag & 7) != P_SESSION)
 828                         Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting Full Screen process with flag=%d, mytype=%d",
 829                              flag, os2_mytype);
 830                 }
 831             }
 832             break;
 833             case FAPPTYP_NOTSPEC:
 834                 /* Let the shell handle this... */
 835                 force_shell = 1;
 836                 buf = "";               /* Pacify a warning */
 837                 file = 0;               /* Pacify a warning */
 838                 goto doshell_args;
 839                 break;
 840             }
 841         }
 842
 843         if (addflag) {
 844             addflag = 0;
 845             new_stderr = dup(2);                /* Preserve stderr */
 846             if (new_stderr == -1) {
 847                 if (errno == EBADF)
 848                     nostderr = 1;
 849                 else {
 850                     rc = -1;
 851                     goto finish;
 852                 }
 853             } else
 854                 fl_stderr = fcntl(2, F_GETFD);
 855             rc = dup2(1,2);
 856             if (rc == -1)
 857                 goto finish;
 858             fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
 859         }
 860
 861 #if 0
 862         rc = result(aTHX_ trueflag, spawnvp(flag,tmps,PL_Argv));
 863 #else
 864         if (execf == EXECF_TRUEEXEC)
 865             rc = execvp(tmps,PL_Argv);
 866         else if (execf == EXECF_EXEC)
 867             rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
 868         else if (execf == EXECF_SPAWN_NOWAIT)
 869             rc = spawnvp(flag,tmps,PL_Argv);
 870         else if (execf == EXECF_SYNC)
 871             rc = spawnvp(trueflag,tmps,PL_Argv);
 872         else                            /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
 873             rc = result(aTHX_ trueflag,
 874                         spawnvp(flag,tmps,PL_Argv));
 875 #endif
 876         if (rc < 0 && pass == 1
 877             && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
 878               do_script:
 879             {
 880             int err = errno;
 881
 882             if (err == ENOENT || err == ENOEXEC) {
 883                 /* No such file, or is a script. */
 884                 /* Try adding script extensions to the file name, and
 885                    search on PATH. */
 886                 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
 887
 888                 if (scr) {
 889                     char *s = 0, *s1;
 890                     SV *scrsv = sv_2mortal(newSVpv(scr, 0));
 891                     SV *bufsv = sv_newmortal();
 892
 893                     Safefree(scr);
 894                     scr = SvPV(scrsv, n_a); /* free()ed later */
 895
 896                     file = PerlIO_open(scr, "r");
 897                     PL_Argv[0] = scr;
 898                     if (!file)
 899                         goto panic_file;
 900
 901                     buf = sv_gets(bufsv, file, 0 /* No append */);
 902                     if (!buf)
 903                         buf = "";       /* XXX Needed? */
 904                     if (!buf[0]) {      /* Empty... */
 905                         PerlIO_close(file);
 906                         /* Special case: maybe from -Zexe build, so
 907                            there is an executable around (contrary to
 908                            documentation, DosQueryAppType sometimes (?)
 909                            does not append ".exe", so we could have
 910                            reached this place). */
 911                         sv_catpv(scrsv, ".exe");
 912                         scr = SvPV(scrsv, n_a); /* Reload */
 913                         if (PerlLIO_stat(scr,&PL_statbuf) >= 0
 914                             && !S_ISDIR(PL_statbuf.st_mode)) {  /* Found */
 915                                 tmps = scr;
 916                                 pass++;
 917                                 goto reread;
 918                         } else {                /* Restore */
 919                                 SvCUR_set(scrsv, SvCUR(scrsv) - 4);
 920                                 *SvEND(scrsv) = 0;
 921                         }
 922                     }
 923                     if (PerlIO_close(file) != 0) { /* Failure */
 924                       panic_file:
 925                         Perl_warner(aTHX_ packWARN(WARN_EXEC), "Error reading \"%s\": %s",
 926                              scr, Strerror(errno));
 927                         buf = "";       /* Not #! */
 928                         goto doshell_args;
 929                     }
 930                     if (buf[0] == '#') {
 931                         if (buf[1] == '!')
 932                             s = buf + 2;
 933                     } else if (buf[0] == 'e') {
 934                         if (strnEQ(buf, "extproc", 7)
 935                             && isSPACE(buf[7]))
 936                             s = buf + 8;
 937                     } else if (buf[0] == 'E') {
 938                         if (strnEQ(buf, "EXTPROC", 7)
 939                             && isSPACE(buf[7]))
 940                             s = buf + 8;
 941                     }
 942                     if (!s) {
 943                         buf = "";       /* Not #! */
 944                         goto doshell_args;
 945                     }
 946
 947                     s1 = s;
 948                     nargs = 0;
 949                     argsp = args;
 950                     while (1) {
 951                         /* Do better than pdksh: allow a few args,
 952                            strip trailing whitespace.  */
 953                         while (isSPACE(*s))
 954                             s++;
 955                         if (*s == 0)
 956                             break;
 957                         if (nargs == 4) {
 958                             nargs = -1;
 959                             break;
 960                         }
 961                         args[nargs++] = s;
 962                         while (*s && !isSPACE(*s))
 963                             s++;
 964                         if (*s == 0)
 965                             break;
 966                         *s++ = 0;
 967                     }
 968                     if (nargs == -1) {
 969                         Perl_warner(aTHX_ packWARN(WARN_EXEC), "Too many args on %.*s line of \"%s\"",
 970                              s1 - buf, buf, scr);
 971                         nargs = 4;
 972                         argsp = fargs;
 973                     }
 974                     /* Can jump from far, buf/file invalid if force_shell: */
 975                   doshell_args:
 976                     {
 977                         char **a = PL_Argv;
 978                         char *exec_args[2];
 979
 980                         if (force_shell
 981                             || (!buf[0] && file)) { /* File without magic */
 982                             /* In fact we tried all what pdksh would
 983                                try.  There is no point in calling
 984                                pdksh, we may just emulate its logic. */
 985                             char *shell = getenv("EXECSHELL");
 986                             char *shell_opt = NULL;
 987
 988                             if (!shell) {
 989                                 char *s;
 990
 991                                 shell_opt = "/c";
 992                                 shell = getenv("OS2_SHELL");
 993                                 if (inicmd) { /* No spaces at start! */
 994                                     s = inicmd;
 995                                     while (*s && !isSPACE(*s)) {
 996                                         if (*s++ == '/') {
 997                                             inicmd = NULL; /* Cannot use */
 998                                             break;
 999                                         }
1000                                     }
1001                                 }
1002                                 if (!inicmd) {
1003                                     s = PL_Argv[0];
1004                                     while (*s) {
1005                                         /* Dosish shells will choke on slashes
1006                                            in paths, fortunately, this is
1007                                            important for zeroth arg only. */
1008                                         if (*s == '/')
1009                                             *s = '\\';
1010                                         s++;
1011                                     }
1012                                 }
1013                             }
1014                             /* If EXECSHELL is set, we do not set */
1015
1016                             if (!shell)
1017                                 shell = ((_emx_env & 0x200)
1018                                          ? "c:/os2/cmd.exe"
1019                                          : "c:/command.com");
1020                             nargs = shell_opt ? 2 : 1;  /* shell file args */
1021                             exec_args[0] = shell;
1022                             exec_args[1] = shell_opt;
1023                             argsp = exec_args;
1024                             if (nargs == 2 && inicmd) {
1025                                 /* Use the original cmd line */
1026                                 /* XXXX This is good only until we refuse
1027                                         quoted arguments... */
1028                                 PL_Argv[0] = inicmd;
1029                                 PL_Argv[1] = Nullch;
1030                             }
1031                         } else if (!buf[0] && inicmd) { /* No file */
1032                             /* Start with the original cmdline. */
1033                             /* XXXX This is good only until we refuse
1034                                     quoted arguments... */
1035
1036                             PL_Argv[0] = inicmd;
1037                             PL_Argv[1] = Nullch;
1038                             nargs = 2;  /* shell -c */
1039                         }
1040
1041                         while (a[1])            /* Get to the end */
1042                             a++;
1043                         a++;                    /* Copy finil NULL too */
1044                         while (a >= PL_Argv) {
1045                             *(a + nargs) = *a;  /* PL_Argv was preallocated to be
1046                                                    long enough. */
1047                             a--;
1048                         }
1049                         while (--nargs >= 0)
1050                             PL_Argv[nargs] = argsp[nargs];
1051                         /* Enable pathless exec if #! (as pdksh). */
1052                         pass = (buf[0] == '#' ? 2 : 3);
1053                         goto retry;
1054                     }
1055                 }
1056                 /* Not found: restore errno */
1057                 errno = err;
1058             }
1059           }
1060         } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
1061             char *no_dir = strrchr(PL_Argv[0], '/');
1062
1063             /* Do as pdksh port does: if not found with /, try without
1064                path. */
1065             if (no_dir) {
1066                 PL_Argv[0] = no_dir + 1;
1067                 pass++;
1068                 goto retry;
1069             }
1070         }
1071         if (rc < 0 && ckWARN(WARN_EXEC))
1072             Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s\n",
1073                  ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1074                   ? "spawn" : "exec"),
1075                  PL_Argv[0], Strerror(errno));
1076         if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
1077             && ((trueflag & 0xFF) == P_WAIT))
1078             rc = -1;
1079
1080   finish:
1081     if (new_stderr != -1) {     /* How can we use error codes? */
1082         dup2(new_stderr, 2);
1083         close(new_stderr);
1084         fcntl(2, F_SETFD, fl_stderr);
1085     } else if (nostderr)
1086        close(2);
1087     return rc;
1088 }
1089
1090 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
1091 int
1092 do_spawn3(pTHX_ char *cmd, int execf, int flag)
1093 {
1094     register char **a;
1095     register char *s;
1096     char *shell, *copt, *news = NULL;
1097     int rc, seenspace = 0, mergestderr = 0;
1098
1099 #ifdef TRYSHELL
1100     if ((shell = getenv("EMXSHELL")) != NULL)
1101         copt = "-c";
1102     else if ((shell = getenv("SHELL")) != NULL)
1103         copt = "-c";
1104     else if ((shell = getenv("COMSPEC")) != NULL)
1105         copt = "/C";
1106     else
1107         shell = "cmd.exe";
1108 #else
1109     /* Consensus on perl5-porters is that it is _very_ important to
1110        have a shell which will not change between computers with the
1111        same architecture, to avoid "action on a distance".
1112        And to have simple build, this shell should be sh. */
1113     shell = PL_sh_path;
1114     copt = "-c";
1115 #endif
1116
1117     while (*cmd && isSPACE(*cmd))
1118         cmd++;
1119
1120     if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
1121         STRLEN l = strlen(PL_sh_path);
1122
1123         New(1302, news, strlen(cmd) - 7 + l + 1, char);
1124         strcpy(news, PL_sh_path);
1125         strcpy(news + l, cmd + 7);
1126         cmd = news;
1127     }
1128
1129     /* save an extra exec if possible */
1130     /* see if there are shell metacharacters in it */
1131
1132     if (*cmd == '.' && isSPACE(cmd[1]))
1133         goto doshell;
1134
1135     if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
1136         goto doshell;
1137
1138     for (s = cmd; *s && isALPHA(*s); s++) ;     /* catch VAR=val gizmo */
1139     if (*s == '=')
1140         goto doshell;
1141
1142     for (s = cmd; *s; s++) {
1143         if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
1144             if (*s == '\n' && s[1] == '\0') {
1145                 *s = '\0';
1146                 break;
1147             } else if (*s == '\\' && !seenspace) {
1148                 continue;               /* Allow backslashes in names */
1149             } else if (*s == '>' && s >= cmd + 3
1150                         && s[-1] == '2' && s[1] == '&' && s[2] == '1'
1151                         && isSPACE(s[-2]) ) {
1152                 char *t = s + 3;
1153
1154                 while (*t && isSPACE(*t))
1155                     t++;
1156                 if (!*t) {
1157                     s[-2] = '\0';
1158                     mergestderr = 1;
1159                     break;              /* Allow 2>&1 as the last thing */
1160                 }
1161             }
1162             /* We do not convert this to do_spawn_ve since shell
1163                should be smart enough to start itself gloriously. */
1164           doshell:
1165             if (execf == EXECF_TRUEEXEC)
1166                 rc = execl(shell,shell,copt,cmd,(char*)0);
1167             else if (execf == EXECF_EXEC)
1168                 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
1169             else if (execf == EXECF_SPAWN_NOWAIT)
1170                 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
1171             else if (execf == EXECF_SPAWN_BYFLAG)
1172                 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
1173             else {
1174                 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
1175                 if (execf == EXECF_SYNC)
1176                    rc = spawnl(P_WAIT,shell,shell,copt,cmd,(char*)0);
1177                 else
1178                    rc = result(aTHX_ P_WAIT,
1179                                spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
1180                 if (rc < 0 && ckWARN(WARN_EXEC))
1181                     Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
1182                          (execf == EXECF_SPAWN ? "spawn" : "exec"),
1183                          shell, Strerror(errno));
1184                 if (rc < 0)
1185                     rc = -1;
1186             }
1187             if (news)
1188                 Safefree(news);
1189             return rc;
1190         } else if (*s == ' ' || *s == '\t') {
1191             seenspace = 1;
1192         }
1193     }
1194
1195     /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
1196     New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
1197     PL_Cmd = savepvn(cmd, s-cmd);
1198     a = PL_Argv;
1199     for (s = PL_Cmd; *s;) {
1200         while (*s && isSPACE(*s)) s++;
1201         if (*s)
1202             *(a++) = s;
1203         while (*s && !isSPACE(*s)) s++;
1204         if (*s)
1205             *s++ = '\0';
1206     }
1207     *a = Nullch;
1208     if (PL_Argv[0])
1209         rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr);
1210     else
1211         rc = -1;
1212     if (news)
1213         Safefree(news);
1214     do_execfree();
1215     return rc;
1216 }
1217
1218 /* Array spawn.  */
1219 int
1220 os2_do_aspawn(pTHX_ SV *really, register void **vmark, register void **vsp)
1221 {
1222     register SV **mark = (SV **)vmark;
1223     register SV **sp = (SV **)vsp;
1224     register char **a;
1225     int rc;
1226     int flag = P_WAIT, flag_set = 0;
1227     STRLEN n_a;
1228
1229     if (sp > mark) {
1230         New(1301,PL_Argv, sp - mark + 3, char*);
1231         a = PL_Argv;
1232
1233         if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
1234                 ++mark;
1235                 flag = SvIVx(*mark);
1236                 flag_set = 1;
1237
1238         }
1239
1240         while (++mark <= sp) {
1241             if (*mark)
1242                 *a++ = SvPVx(*mark, n_a);
1243             else
1244                 *a++ = "";
1245         }
1246         *a = Nullch;
1247
1248         if (flag_set && (a == PL_Argv + 1)) { /* One arg? */
1249             rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
1250         } else
1251             rc = do_spawn_ve(aTHX_ really, flag, EXECF_SPAWN, NULL, 0);
1252     } else
1253         rc = -1;
1254     do_execfree();
1255     return rc;
1256 }
1257
1258 int
1259 os2_do_spawn(pTHX_ char *cmd)
1260 {
1261     return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
1262 }
1263
1264 int
1265 do_spawn_nowait(pTHX_ char *cmd)
1266 {
1267     return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
1268 }
1269
1270 bool
1271 Perl_do_exec(pTHX_ char *cmd)
1272 {
1273     do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
1274     return FALSE;
1275 }
1276
1277 bool
1278 os2exec(pTHX_ char *cmd)
1279 {
1280     return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
1281 }
1282
1283 PerlIO *
1284 my_syspopen(pTHX_ char *cmd, char *mode)
1285 {
1286 #ifndef USE_POPEN
1287     int p[2];
1288     register I32 this, that, newfd;
1289     register I32 pid;
1290     SV *sv;
1291     int fh_fl = 0;                      /* Pacify the warning */
1292
1293     /* `this' is what we use in the parent, `that' in the child. */
1294     this = (*mode == 'w');
1295     that = !this;
1296     if (PL_tainting) {
1297         taint_env();
1298         taint_proper("Insecure %s%s", "EXEC");
1299     }
1300     if (pipe(p) < 0)
1301         return Nullfp;
1302     /* Now we need to spawn the child. */
1303     if (p[this] == (*mode == 'r')) {    /* if fh 0/1 was initially closed. */
1304         int new = dup(p[this]);
1305
1306         if (new == -1)
1307             goto closepipes;
1308         close(p[this]);
1309         p[this] = new;
1310     }
1311     newfd = dup(*mode == 'r');          /* Preserve std* */
1312     if (newfd == -1) {
1313         /* This cannot happen due to fh being bad after pipe(), since
1314            pipe() should have created fh 0 and 1 even if they were
1315            initially closed.  But we closed p[this] before.  */
1316         if (errno != EBADF) {
1317           closepipes:
1318             close(p[0]);
1319             close(p[1]);
1320             return Nullfp;
1321         }
1322     } else
1323         fh_fl = fcntl(*mode == 'r', F_GETFD);
1324     if (p[that] != (*mode == 'r')) {    /* if fh 0/1 was initially closed. */
1325         dup2(p[that], *mode == 'r');
1326         close(p[that]);
1327     }
1328     /* Where is `this' and newfd now? */
1329     fcntl(p[this], F_SETFD, FD_CLOEXEC);
1330     if (newfd != -1)
1331         fcntl(newfd, F_SETFD, FD_CLOEXEC);
1332     pid = do_spawn_nowait(aTHX_ cmd);
1333     if (newfd == -1)
1334         close(*mode == 'r');            /* It was closed initially */
1335     else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
1336         dup2(newfd, *mode == 'r');      /* Return std* back. */
1337         close(newfd);
1338         fcntl(*mode == 'r', F_SETFD, fh_fl);
1339     } else
1340         fcntl(*mode == 'r', F_SETFD, fh_fl);
1341     if (p[that] == (*mode == 'r'))
1342         close(p[that]);
1343     if (pid == -1) {
1344         close(p[this]);
1345         return Nullfp;
1346     }
1347     if (p[that] < p[this]) {            /* Make fh as small as possible */
1348         dup2(p[this], p[that]);
1349         close(p[this]);
1350         p[this] = p[that];
1351     }
1352     sv = *av_fetch(PL_fdpid,p[this],TRUE);
1353     (void)SvUPGRADE(sv,SVt_IV);
1354     SvIVX(sv) = pid;
1355     PL_forkprocess = pid;
1356     return PerlIO_fdopen(p[this], mode);
1357
1358 #else  /* USE_POPEN */
1359
1360     PerlIO *res;
1361     SV *sv;
1362
1363 #  ifdef TRYSHELL
1364     res = popen(cmd, mode);
1365 #  else
1366     char *shell = getenv("EMXSHELL");
1367
1368     my_setenv("EMXSHELL", PL_sh_path);
1369     res = popen(cmd, mode);
1370     my_setenv("EMXSHELL", shell);
1371 #  endif
1372     sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1373     (void)SvUPGRADE(sv,SVt_IV);
1374     SvIVX(sv) = -1;                     /* A cooky. */
1375     return res;
1376
1377 #endif /* USE_POPEN */
1378
1379 }
1380
1381 /******************************************************************/
1382
1383 #ifndef HAS_FORK
1384 int
1385 fork(void)
1386 {
1387     Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
1388     errno = EINVAL;
1389     return -1;
1390 }
1391 #endif
1392
1393 /*******************************************************************/
1394 /* not implemented in EMX 0.9d */
1395
1396 char *  ctermid(char *s)        { return 0; }
1397
1398 #ifdef MYTTYNAME /* was not in emx0.9a */
1399 void *  ttyname(x)      { return 0; }
1400 #endif
1401
1402 /*****************************************************************************/
1403 /* not implemented in C Set++ */
1404
1405 #ifndef __EMX__
1406 int     setuid(x)       { errno = EINVAL; return -1; }
1407 int     setgid(x)       { errno = EINVAL; return -1; }
1408 #endif
1409
1410 /*****************************************************************************/
1411 /* stat() hack for char/block device */
1412
1413 #if OS2_STAT_HACK
1414
1415 enum os2_stat_extra {   /* EMX 0.9d fix 4 defines up to 0100000 */
1416   os2_stat_archived     = 0x1000000,    /* 0100000000 */
1417   os2_stat_hidden       = 0x2000000,    /* 0200000000 */
1418   os2_stat_system       = 0x4000000,    /* 0400000000 */
1419   os2_stat_force        = 0x8000000,    /* Do not ignore flags on chmod */
1420 };
1421
1422 #define OS2_STAT_SPECIAL (os2_stat_system | os2_stat_archived | os2_stat_hidden)
1423
1424 static void
1425 massage_os2_attr(struct stat *st)
1426 {
1427     if ( ((st->st_mode & S_IFMT) != S_IFREG
1428           && (st->st_mode & S_IFMT) != S_IFDIR)
1429          || !(st->st_attr & (FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM)))
1430         return;
1431
1432     if ( st->st_attr & FILE_ARCHIVED )
1433         st->st_mode |= (os2_stat_archived | os2_stat_force);
1434     if ( st->st_attr & FILE_HIDDEN )
1435         st->st_mode |= (os2_stat_hidden | os2_stat_force);
1436     if ( st->st_attr & FILE_SYSTEM )
1437         st->st_mode |= (os2_stat_system | os2_stat_force);
1438 }
1439
1440     /* First attempt used DosQueryFSAttach which crashed the system when
1441        used with 5.001. Now just look for /dev/. */
1442 int
1443 os2_stat(const char *name, struct stat *st)
1444 {
1445     static int ino = SHRT_MAX;
1446     STRLEN l = strlen(name);
1447
1448     if ( ( l < 8 || l > 9) || strnicmp(name, "/dev/", 5) != 0
1449          || (    stricmp(name + 5, "con") != 0
1450               && stricmp(name + 5, "tty") != 0
1451               && stricmp(name + 5, "nul") != 0
1452               && stricmp(name + 5, "null") != 0) ) {
1453         int s = stat(name, st);
1454
1455         if (s)
1456             return s;
1457         massage_os2_attr(st);
1458         return 0;
1459     }
1460
1461     memset(st, 0, sizeof *st);
1462     st->st_mode = S_IFCHR|0666;
1463     st->st_ino = (ino-- & 0x7FFF);
1464     st->st_nlink = 1;
1465     return 0;
1466 }
1467
1468 int
1469 os2_fstat(int handle, struct stat *st)
1470 {
1471     int s = fstat(handle, st);
1472
1473     if (s)
1474         return s;
1475     massage_os2_attr(st);
1476     return 0;
1477 }
1478
1479 #undef chmod
1480 int
1481 os2_chmod (const char *name, int pmode) /* Modelled after EMX src/lib/io/chmod.c */
1482 {
1483     int attr, rc;
1484
1485     if (!(pmode & os2_stat_force))
1486         return chmod(name, pmode);
1487
1488     attr = __chmod (name, 0, 0);           /* Get attributes */
1489     if (attr < 0)
1490         return -1;
1491     if (pmode & S_IWRITE)
1492         attr &= ~FILE_READONLY;
1493     else
1494         attr |= FILE_READONLY;
1495     /* New logic */
1496     attr &= ~(FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM);
1497
1498     if ( pmode & os2_stat_archived )
1499         attr |= FILE_ARCHIVED;
1500     if ( pmode & os2_stat_hidden )
1501         attr |= FILE_HIDDEN;
1502     if ( pmode & os2_stat_system )
1503         attr |= FILE_SYSTEM;
1504
1505     rc = __chmod (name, 1, attr);
1506     if (rc >= 0) rc = 0;
1507     return rc;
1508 }
1509
1510 #endif
1511
1512 #ifdef USE_PERL_SBRK
1513
1514 /* SBRK() emulation, mostly moved to malloc.c. */
1515
1516 void *
1517 sys_alloc(int size) {
1518     void *got;
1519     APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1520
1521     if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1522         return (void *) -1;
1523     } else if ( rc )
1524         Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
1525     return got;
1526 }
1527
1528 #endif /* USE_PERL_SBRK */
1529
1530 /* tmp path */
1531
1532 char *tmppath = TMPPATH1;
1533
1534 void
1535 settmppath()
1536 {
1537     char *p = getenv("TMP"), *tpath;
1538     int len;
1539
1540     if (!p) p = getenv("TEMP");
1541     if (!p) return;
1542     len = strlen(p);
1543     tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1544     if (tpath) {
1545         strcpy(tpath, p);
1546         tpath[len] = '/';
1547         strcpy(tpath + len + 1, TMPPATH1);
1548         tmppath = tpath;
1549     }
1550 }
1551
1552 #include "XSUB.h"
1553
1554 XS(XS_File__Copy_syscopy)
1555 {
1556     dXSARGS;
1557     if (items < 2 || items > 3)
1558         Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
1559     {
1560         STRLEN n_a;
1561         char *  src = (char *)SvPV(ST(0),n_a);
1562         char *  dst = (char *)SvPV(ST(1),n_a);
1563         U32     flag;
1564         int     RETVAL, rc;
1565
1566         if (items < 3)
1567             flag = 0;
1568         else {
1569             flag = (unsigned long)SvIV(ST(2));
1570         }
1571
1572         RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1573         ST(0) = sv_newmortal();
1574         sv_setiv(ST(0), (IV)RETVAL);
1575     }
1576     XSRETURN(1);
1577 }
1578
1579 #define PERL_PATCHLEVEL_H_IMPLICIT      /* Do not init local_patches. */
1580 #include "patchlevel.h"
1581 #undef PERL_PATCHLEVEL_H_IMPLICIT
1582
1583 char *
1584 mod2fname(pTHX_ SV *sv)
1585 {
1586     static char fname[9];
1587     int pos = 6, len, avlen;
1588     unsigned int sum = 0;
1589     char *s;
1590     STRLEN n_a;
1591
1592     if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
1593     sv = SvRV(sv);
1594     if (SvTYPE(sv) != SVt_PVAV)
1595       Perl_croak_nocontext("Not array reference given to mod2fname");
1596
1597     avlen = av_len((AV*)sv);
1598     if (avlen < 0)
1599       Perl_croak_nocontext("Empty array reference given to mod2fname");
1600
1601     s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1602     strncpy(fname, s, 8);
1603     len = strlen(s);
1604     if (len < 6) pos = len;
1605     while (*s) {
1606         sum = 33 * sum + *(s++);        /* Checksumming first chars to
1607                                          * get the capitalization into c.s. */
1608     }
1609     avlen --;
1610     while (avlen >= 0) {
1611         s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1612         while (*s) {
1613             sum = 33 * sum + *(s++);    /* 7 is primitive mod 13. */
1614         }
1615         avlen --;
1616     }
1617    /* We always load modules as *specific* DLLs, and with the full name.
1618       When loading a specific DLL by its full name, one cannot get a
1619       different DLL, even if a DLL with the same basename is loaded already.
1620       Thus there is no need to include the version into the mangling scheme. */
1621 #if 0
1622     sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2;  /* Up to 5.6.1 */
1623 #else
1624 #  ifndef COMPATIBLE_VERSION_SUM  /* Binary compatibility with the 5.00553 binary */
1625 #    define COMPATIBLE_VERSION_SUM (5 * 200 + 53 * 2)
1626 #  endif
1627     sum += COMPATIBLE_VERSION_SUM;
1628 #endif
1629     fname[pos] = 'A' + (sum % 26);
1630     fname[pos + 1] = 'A' + (sum / 26 % 26);
1631     fname[pos + 2] = '\0';
1632     return (char *)fname;
1633 }
1634
1635 XS(XS_DynaLoader_mod2fname)
1636 {
1637     dXSARGS;
1638     if (items != 1)
1639         Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
1640     {
1641         SV *    sv = ST(0);
1642         char *  RETVAL;
1643
1644         RETVAL = mod2fname(aTHX_ sv);
1645         ST(0) = sv_newmortal();
1646         sv_setpv((SV*)ST(0), RETVAL);
1647     }
1648     XSRETURN(1);
1649 }
1650
1651 char *
1652 os2error(int rc)
1653 {
1654         dTHX;
1655         static char buf[300];
1656         ULONG len;
1657         char *s;
1658         int number = SvTRUE(get_sv("OS2::nsyserror", TRUE));
1659
1660         if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1661         if (rc == 0)
1662                 return "";
1663         if (number) {
1664             sprintf(buf, "SYS%04d=%#x: ", rc, rc);
1665             s = buf + strlen(buf);
1666         } else
1667             s = buf;
1668         if (DosGetMessage(NULL, 0, s, sizeof(buf) - 1 - (s-buf),
1669                           rc, "OSO001.MSG", &len)) {
1670             if (!number) {
1671                 sprintf(buf, "SYS%04d=%#x: ", rc, rc);
1672                 s = buf + strlen(buf);
1673             }
1674             sprintf(s, "[No description found in OSO001.MSG]");
1675         } else {
1676                 s[len] = '\0';
1677                 if (len && s[len - 1] == '\n')
1678                         s[--len] = 0;
1679                 if (len && s[len - 1] == '\r')
1680                         s[--len] = 0;
1681                 if (len && s[len - 1] == '.')
1682                         s[--len] = 0;
1683                 if (len >= 10 && number && strnEQ(s, buf, 7)
1684                     && s[7] == ':' && s[8] == ' ')
1685                     /* Some messages start with SYSdddd:, some not */
1686                     Move(s + 9, s, (len -= 9) + 1, char);
1687         }
1688         return buf;
1689 }
1690
1691 void
1692 ResetWinError(void)
1693 {
1694   WinError_2_Perl_rc;
1695 }
1696
1697 void
1698 CroakWinError(int die, char *name)
1699 {
1700   FillWinError;
1701   if (die && Perl_rc) {
1702     dTHX;
1703
1704     Perl_croak(aTHX_ "%s: %s", (name ? name : "Win* API call"), os2error(Perl_rc));
1705   }
1706 }
1707
1708 char *
1709 os2_execname(pTHX)
1710 {
1711   char buf[300], *p, *o = PL_origargv[0], ok = 1;
1712
1713   if (_execname(buf, sizeof buf) != 0)
1714         return o;
1715   p = buf;
1716   while (*p) {
1717     if (*p == '\\')
1718         *p = '/';
1719     if (*p == '/') {
1720         if (ok && *o != '/' && *o != '\\')
1721             ok = 0;
1722     } else if (ok && tolower(*o) != tolower(*p))
1723         ok = 0;
1724     p++;
1725     o++;
1726   }
1727   if (ok) { /* PL_origargv[0] matches the real name.  Use PL_origargv[0]: */
1728      strcpy(buf, PL_origargv[0]);       /* _execname() is always uppercased */
1729      p = buf;
1730      while (*p) {
1731        if (*p == '\\')
1732            *p = '/';
1733        p++;
1734      }
1735   }
1736   p = savepv(buf);
1737   SAVEFREEPV(p);
1738   return p;
1739 }
1740
1741 char *
1742 perllib_mangle(char *s, unsigned int l)
1743 {
1744     static char *newp, *oldp;
1745     static int newl, oldl, notfound;
1746     static char ret[STATIC_FILE_LENGTH+1];
1747
1748     if (!newp && !notfound) {
1749         newp = getenv("PERLLIB_PREFIX");
1750         if (newp) {
1751             char *s;
1752
1753             oldp = newp;
1754             while (*newp && !isSPACE(*newp) && *newp != ';') {
1755                 newp++; oldl++;         /* Skip digits. */
1756             }
1757             while (*newp && (isSPACE(*newp) || *newp == ';')) {
1758                 newp++;                 /* Skip whitespace. */
1759             }
1760             newl = strlen(newp);
1761             if (newl == 0 || oldl == 0) {
1762                 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1763             }
1764             strcpy(ret, newp);
1765             s = ret;
1766             while (*s) {
1767                 if (*s == '\\') *s = '/';
1768                 s++;
1769             }
1770         } else {
1771             notfound = 1;
1772         }
1773     }
1774     if (!newp) {
1775         return s;
1776     }
1777     if (l == 0) {
1778         l = strlen(s);
1779     }
1780     if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1781         return s;
1782     }
1783     if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1784         Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1785     }
1786     strcpy(ret + newl, s + oldl);
1787     return ret;
1788 }
1789
1790 unsigned long
1791 Perl_hab_GET()                  /* Needed if perl.h cannot be included */
1792 {
1793     return perl_hab_GET();
1794 }
1795
1796 HMQ
1797 Perl_Register_MQ(int serve)
1798 {
1799   if (Perl_hmq_refcnt <= 0) {
1800     PPIB pib;
1801     PTIB tib;
1802
1803     Perl_hmq_refcnt = 0;                /* Be extra safe */
1804     DosGetInfoBlocks(&tib, &pib);
1805     Perl_os2_initial_mode = pib->pib_ultype;
1806     /* Try morphing into a PM application. */
1807     if (pib->pib_ultype != 3)           /* 2 is VIO */
1808         pib->pib_ultype = 3;            /* 3 is PM */
1809     init_PMWIN_entries();
1810     /* 64 messages if before OS/2 3.0, ignored otherwise */
1811     Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1812     if (!Perl_hmq) {
1813         dTHX;
1814         static int cnt;
1815
1816         SAVEINT(cnt);                   /* Allow catch()ing. */
1817         if (cnt++)
1818             _exit(188);                 /* Panic can try to create a window. */
1819         Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application");
1820     }
1821   }
1822     if (serve) {
1823         if ( Perl_hmq_servers <= 0      /* Safe to inform us on shutdown, */
1824              && Perl_hmq_refcnt > 0 )   /* this was switched off before... */
1825             (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0);
1826         Perl_hmq_servers++;
1827     } else if (!Perl_hmq_servers)       /* Do not inform us on shutdown */
1828         (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
1829     Perl_hmq_refcnt++;
1830     return Perl_hmq;
1831 }
1832
1833 int
1834 Perl_Serve_Messages(int force)
1835 {
1836     int cnt = 0;
1837     QMSG msg;
1838
1839     if (Perl_hmq_servers > 0 && !force)
1840         return 0;
1841     if (Perl_hmq_refcnt <= 0)
1842         Perl_croak_nocontext("No message queue");
1843     while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1844         cnt++;
1845         if (msg.msg == WM_QUIT)
1846             Perl_croak_nocontext("QUITing...");
1847         (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1848     }
1849     return cnt;
1850 }
1851
1852 int
1853 Perl_Process_Messages(int force, I32 *cntp)
1854 {
1855     QMSG msg;
1856
1857     if (Perl_hmq_servers > 0 && !force)
1858         return 0;
1859     if (Perl_hmq_refcnt <= 0)
1860         Perl_croak_nocontext("No message queue");
1861     while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1862         if (cntp)
1863             (*cntp)++;
1864         (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1865         if (msg.msg == WM_DESTROY)
1866             return -1;
1867         if (msg.msg == WM_CREATE)
1868             return +1;
1869     }
1870     Perl_croak_nocontext("QUITing...");
1871 }
1872
1873 void
1874 Perl_Deregister_MQ(int serve)
1875 {
1876     PPIB pib;
1877     PTIB tib;
1878
1879     if (serve)
1880         Perl_hmq_servers--;
1881     if (--Perl_hmq_refcnt <= 0) {
1882         init_PMWIN_entries();                   /* To be extra safe */
1883         (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1884         Perl_hmq = 0;
1885         /* Try morphing back from a PM application. */
1886         DosGetInfoBlocks(&tib, &pib);
1887         if (pib->pib_ultype == 3)               /* 3 is PM */
1888             pib->pib_ultype = Perl_os2_initial_mode;
1889         else
1890             Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
1891                  pib->pib_ultype);
1892     } else if (serve && Perl_hmq_servers <= 0)  /* Last server exited */
1893         (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
1894 }
1895
1896 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1897                                 && ((path)[2] == '/' || (path)[2] == '\\'))
1898 #define sys_is_rooted _fnisabs
1899 #define sys_is_relative _fnisrel
1900 #define current_drive _getdrive
1901
1902 #undef chdir                            /* Was _chdir2. */
1903 #define sys_chdir(p) (chdir(p) == 0)
1904 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1905
1906 static int DOS_harderr_state = -1;
1907
1908 XS(XS_OS2_Error)
1909 {
1910     dXSARGS;
1911     if (items != 2)
1912         Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
1913     {
1914         int     arg1 = SvIV(ST(0));
1915         int     arg2 = SvIV(ST(1));
1916         int     a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1917                      | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1918         int     RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1919         unsigned long rc;
1920
1921         if (CheckOSError(DosError(a)))
1922             Perl_croak_nocontext("DosError(%d) failed", a);
1923         ST(0) = sv_newmortal();
1924         if (DOS_harderr_state >= 0)
1925             sv_setiv(ST(0), DOS_harderr_state);
1926         DOS_harderr_state = RETVAL;
1927     }
1928     XSRETURN(1);
1929 }
1930
1931 static signed char DOS_suppression_state = -1;
1932
1933 XS(XS_OS2_Errors2Drive)
1934 {
1935     dXSARGS;
1936     if (items != 1)
1937         Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
1938     {
1939         STRLEN n_a;
1940         SV  *sv = ST(0);
1941         int     suppress = SvOK(sv);
1942         char    *s = suppress ? SvPV(sv, n_a) : NULL;
1943         char    drive = (s ? *s : 0);
1944         unsigned long rc;
1945
1946         if (suppress && !isALPHA(drive))
1947             Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
1948         if (CheckOSError(DosSuppressPopUps((suppress
1949                                             ? SPU_ENABLESUPPRESSION
1950                                             : SPU_DISABLESUPPRESSION),
1951                                            drive)))
1952             Perl_croak_nocontext("DosSuppressPopUps(%c) failed", drive);
1953         ST(0) = sv_newmortal();
1954         if (DOS_suppression_state > 0)
1955             sv_setpvn(ST(0), &DOS_suppression_state, 1);
1956         else if (DOS_suppression_state == 0)
1957             sv_setpvn(ST(0), "", 0);
1958         DOS_suppression_state = drive;
1959     }
1960     XSRETURN(1);
1961 }
1962
1963 static const char * const si_fields[QSV_MAX] = {
1964   "MAX_PATH_LENGTH",
1965   "MAX_TEXT_SESSIONS",
1966   "MAX_PM_SESSIONS",
1967   "MAX_VDM_SESSIONS",
1968   "BOOT_DRIVE",
1969   "DYN_PRI_VARIATION",
1970   "MAX_WAIT",
1971   "MIN_SLICE",
1972   "MAX_SLICE",
1973   "PAGE_SIZE",
1974   "VERSION_MAJOR",
1975   "VERSION_MINOR",
1976   "VERSION_REVISION",
1977   "MS_COUNT",
1978   "TIME_LOW",
1979   "TIME_HIGH",
1980   "TOTPHYSMEM",
1981   "TOTRESMEM",
1982   "TOTAVAILMEM",
1983   "MAXPRMEM",
1984   "MAXSHMEM",
1985   "TIMER_INTERVAL",
1986   "MAX_COMP_LENGTH",
1987   "FOREGROUND_FS_SESSION",
1988   "FOREGROUND_PROCESS"
1989 };
1990
1991 XS(XS_OS2_SysInfo)
1992 {
1993     dXSARGS;
1994     if (items != 0)
1995         Perl_croak_nocontext("Usage: OS2::SysInfo()");
1996     {
1997         ULONG   si[QSV_MAX] = {0};      /* System Information Data Buffer */
1998         APIRET  rc      = NO_ERROR;     /* Return code            */
1999         int i = 0, j = 0;
2000
2001         if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
2002                                          QSV_MAX, /* information */
2003                                          (PVOID)si,
2004                                          sizeof(si))))
2005             Perl_croak_nocontext("DosQuerySysInfo() failed");
2006         EXTEND(SP,2*QSV_MAX);
2007         while (i < QSV_MAX) {
2008             ST(j) = sv_newmortal();
2009             sv_setpv(ST(j++), si_fields[i]);
2010             ST(j) = sv_newmortal();
2011             sv_setiv(ST(j++), si[i]);
2012             i++;
2013         }
2014     }
2015     XSRETURN(2 * QSV_MAX);
2016 }
2017
2018 XS(XS_OS2_BootDrive)
2019 {
2020     dXSARGS;
2021     if (items != 0)
2022         Perl_croak_nocontext("Usage: OS2::BootDrive()");
2023     {
2024         ULONG   si[1] = {0};    /* System Information Data Buffer */
2025         APIRET  rc    = NO_ERROR;       /* Return code            */
2026         char c;
2027
2028         if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
2029                                          (PVOID)si, sizeof(si))))
2030             Perl_croak_nocontext("DosQuerySysInfo() failed");
2031         ST(0) = sv_newmortal();
2032         c = 'a' - 1 + si[0];
2033         sv_setpvn(ST(0), &c, 1);
2034     }
2035     XSRETURN(1);
2036 }
2037
2038 XS(XS_OS2_MorphPM)
2039 {
2040     dXSARGS;
2041     if (items != 1)
2042         Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
2043     {
2044         bool  serve = SvOK(ST(0));
2045         unsigned long   pmq = perl_hmq_GET(serve);
2046
2047         ST(0) = sv_newmortal();
2048         sv_setiv(ST(0), pmq);
2049     }
2050     XSRETURN(1);
2051 }
2052
2053 XS(XS_OS2_UnMorphPM)
2054 {
2055     dXSARGS;
2056     if (items != 1)
2057         Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
2058     {
2059         bool  serve = SvOK(ST(0));
2060
2061         perl_hmq_UNSET(serve);
2062     }
2063     XSRETURN(0);
2064 }
2065
2066 XS(XS_OS2_Serve_Messages)
2067 {
2068     dXSARGS;
2069     if (items != 1)
2070         Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
2071     {
2072         bool  force = SvOK(ST(0));
2073         unsigned long   cnt = Perl_Serve_Messages(force);
2074
2075         ST(0) = sv_newmortal();
2076         sv_setiv(ST(0), cnt);
2077     }
2078     XSRETURN(1);
2079 }
2080
2081 XS(XS_OS2_Process_Messages)
2082 {
2083     dXSARGS;
2084     if (items < 1 || items > 2)
2085         Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
2086     {
2087         bool  force = SvOK(ST(0));
2088         unsigned long   cnt;
2089
2090         if (items == 2) {
2091             I32 cntr;
2092             SV *sv = ST(1);
2093
2094             (void)SvIV(sv);             /* Force SvIVX */
2095             if (!SvIOK(sv))
2096                 Perl_croak_nocontext("Can't upgrade count to IV");
2097             cntr = SvIVX(sv);
2098             cnt =  Perl_Process_Messages(force, &cntr);
2099             SvIVX(sv) = cntr;
2100         } else {
2101             cnt =  Perl_Process_Messages(force, NULL);
2102         }
2103         ST(0) = sv_newmortal();
2104         sv_setiv(ST(0), cnt);
2105     }
2106     XSRETURN(1);
2107 }
2108
2109 XS(XS_Cwd_current_drive)
2110 {
2111     dXSARGS;
2112     if (items != 0)
2113         Perl_croak_nocontext("Usage: Cwd::current_drive()");
2114     {
2115         char    RETVAL;
2116
2117         RETVAL = current_drive();
2118         ST(0) = sv_newmortal();
2119         sv_setpvn(ST(0), (char *)&RETVAL, 1);
2120     }
2121     XSRETURN(1);
2122 }
2123
2124 XS(XS_Cwd_sys_chdir)
2125 {
2126     dXSARGS;
2127     if (items != 1)
2128         Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
2129     {
2130         STRLEN n_a;
2131         char *  path = (char *)SvPV(ST(0),n_a);
2132         bool    RETVAL;
2133
2134         RETVAL = sys_chdir(path);
2135         ST(0) = boolSV(RETVAL);
2136         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2137     }
2138     XSRETURN(1);
2139 }
2140
2141 XS(XS_Cwd_change_drive)
2142 {
2143     dXSARGS;
2144     if (items != 1)
2145         Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
2146     {
2147         STRLEN n_a;
2148         char    d = (char)*SvPV(ST(0),n_a);
2149         bool    RETVAL;
2150
2151         RETVAL = change_drive(d);
2152         ST(0) = boolSV(RETVAL);
2153         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2154     }
2155     XSRETURN(1);
2156 }
2157
2158 XS(XS_Cwd_sys_is_absolute)
2159 {
2160     dXSARGS;
2161     if (items != 1)
2162         Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
2163     {
2164         STRLEN n_a;
2165         char *  path = (char *)SvPV(ST(0),n_a);
2166         bool    RETVAL;
2167
2168         RETVAL = sys_is_absolute(path);
2169         ST(0) = boolSV(RETVAL);
2170         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2171     }
2172     XSRETURN(1);
2173 }
2174
2175 XS(XS_Cwd_sys_is_rooted)
2176 {
2177     dXSARGS;
2178     if (items != 1)
2179         Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
2180     {
2181         STRLEN n_a;
2182         char *  path = (char *)SvPV(ST(0),n_a);
2183         bool    RETVAL;
2184
2185         RETVAL = sys_is_rooted(path);
2186         ST(0) = boolSV(RETVAL);
2187         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2188     }
2189     XSRETURN(1);
2190 }
2191
2192 XS(XS_Cwd_sys_is_relative)
2193 {
2194     dXSARGS;
2195     if (items != 1)
2196         Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
2197     {
2198         STRLEN n_a;
2199         char *  path = (char *)SvPV(ST(0),n_a);
2200         bool    RETVAL;
2201
2202         RETVAL = sys_is_relative(path);
2203         ST(0) = boolSV(RETVAL);
2204         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2205     }
2206     XSRETURN(1);
2207 }
2208
2209 XS(XS_Cwd_sys_cwd)
2210 {
2211     dXSARGS;
2212     if (items != 0)
2213         Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
2214     {
2215         char p[MAXPATHLEN];
2216         char *  RETVAL;
2217         RETVAL = _getcwd2(p, MAXPATHLEN);
2218         ST(0) = sv_newmortal();
2219         sv_setpv((SV*)ST(0), RETVAL);
2220 #ifndef INCOMPLETE_TAINTS
2221         SvTAINTED_on(ST(0));
2222 #endif
2223     }
2224     XSRETURN(1);
2225 }
2226
2227 XS(XS_Cwd_sys_abspath)
2228 {
2229     dXSARGS;
2230     if (items < 1 || items > 2)
2231         Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
2232     {
2233         STRLEN n_a;
2234         char *  path = (char *)SvPV(ST(0),n_a);
2235         char *  dir, *s, *t, *e;
2236         char p[MAXPATHLEN];
2237         char *  RETVAL;
2238         int l;
2239         SV *sv;
2240
2241         if (items < 2)
2242             dir = NULL;
2243         else {
2244             dir = (char *)SvPV(ST(1),n_a);
2245         }
2246         if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
2247             path += 2;
2248         }
2249         if (dir == NULL) {
2250             if (_abspath(p, path, MAXPATHLEN) == 0) {
2251                 RETVAL = p;
2252             } else {
2253                 RETVAL = NULL;
2254             }
2255         } else {
2256             /* Absolute with drive: */
2257             if ( sys_is_absolute(path) ) {
2258                 if (_abspath(p, path, MAXPATHLEN) == 0) {
2259                     RETVAL = p;
2260                 } else {
2261                     RETVAL = NULL;
2262                 }
2263             } else if (path[0] == '/' || path[0] == '\\') {
2264                 /* Rooted, but maybe on different drive. */
2265                 if (isALPHA(dir[0]) && dir[1] == ':' ) {
2266                     char p1[MAXPATHLEN];
2267
2268                     /* Need to prepend the drive. */
2269                     p1[0] = dir[0];
2270                     p1[1] = dir[1];
2271                     Copy(path, p1 + 2, strlen(path) + 1, char);
2272                     RETVAL = p;
2273                     if (_abspath(p, p1, MAXPATHLEN) == 0) {
2274                         RETVAL = p;
2275                     } else {
2276                         RETVAL = NULL;
2277                     }
2278                 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
2279                     RETVAL = p;
2280                 } else {
2281                     RETVAL = NULL;
2282                 }
2283             } else {
2284                 /* Either path is relative, or starts with a drive letter. */
2285                 /* If the path starts with a drive letter, then dir is
2286                    relevant only if
2287                    a/b) it is absolute/x:relative on the same drive.
2288                    c)   path is on current drive, and dir is rooted
2289                    In all the cases it is safe to drop the drive part
2290                    of the path. */
2291                 if ( !sys_is_relative(path) ) {
2292                     if ( ( ( sys_is_absolute(dir)
2293                              || (isALPHA(dir[0]) && dir[1] == ':'
2294                                  && strnicmp(dir, path,1) == 0))
2295                            && strnicmp(dir, path,1) == 0)
2296                          || ( !(isALPHA(dir[0]) && dir[1] == ':')
2297                               && toupper(path[0]) == current_drive())) {
2298                         path += 2;
2299                     } else if (_abspath(p, path, MAXPATHLEN) == 0) {
2300                         RETVAL = p; goto done;
2301                     } else {
2302                         RETVAL = NULL; goto done;
2303                     }
2304                 }
2305                 {
2306                     /* Need to prepend the absolute path of dir. */
2307                     char p1[MAXPATHLEN];
2308
2309                     if (_abspath(p1, dir, MAXPATHLEN) == 0) {
2310                         int l = strlen(p1);
2311
2312                         if (p1[ l - 1 ] != '/') {
2313                             p1[ l ] = '/';
2314                             l++;
2315                         }
2316                         Copy(path, p1 + l, strlen(path) + 1, char);
2317                         if (_abspath(p, p1, MAXPATHLEN) == 0) {
2318                             RETVAL = p;
2319                         } else {
2320                             RETVAL = NULL;
2321                         }
2322                     } else {
2323                         RETVAL = NULL;
2324                     }
2325                 }
2326               done:
2327             }
2328         }
2329         if (!RETVAL)
2330             XSRETURN_EMPTY;
2331         /* Backslashes are already converted to slashes. */
2332         /* Remove trailing slashes */
2333         l = strlen(RETVAL);
2334         while (l > 0 && RETVAL[l-1] == '/')
2335             l--;
2336         ST(0) = sv_newmortal();
2337         sv_setpvn( sv = (SV*)ST(0), RETVAL, l);
2338         /* Remove duplicate slashes, skipping the first three, which
2339            may be parts of a server-based path */
2340         s = t = 3 + SvPV_force(sv, n_a);
2341         e = SvEND(sv);
2342         /* Do not worry about multibyte chars here, this would contradict the
2343            eventual UTFization, and currently most other places break too... */
2344         while (s < e) {
2345             if (s[0] == t[-1] && s[0] == '/')
2346                 s++;                            /* Skip duplicate / */
2347             else
2348                 *t++ = *s++;
2349         }
2350         if (t < e) {
2351             *t = 0;
2352             SvCUR_set(sv, t - SvPVX(sv));
2353         }
2354     }
2355     XSRETURN(1);
2356 }
2357 typedef APIRET (*PELP)(PSZ path, ULONG type);
2358
2359 /* Kernels after 2000/09/15 understand this too: */
2360 #ifndef LIBPATHSTRICT
2361 #  define LIBPATHSTRICT 3
2362 #endif
2363
2364 APIRET
2365 ExtLIBPATH(ULONG ord, PSZ path, IV type)
2366 {
2367     ULONG what;
2368     PFN f = loadByOrdinal(ord, 1);      /* Guarantied to load or die! */
2369
2370     if (type > 0)
2371         what = END_LIBPATH;
2372     else if (type == 0)
2373         what = BEGIN_LIBPATH;
2374     else
2375         what = LIBPATHSTRICT;
2376     return (*(PELP)f)(path, what);
2377 }
2378
2379 #define extLibpath(to,type)                                             \
2380     (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type))) ? NULL : (to) )
2381
2382 #define extLibpath_set(p,type)                                  \
2383     (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type))))
2384
2385 XS(XS_Cwd_extLibpath)
2386 {
2387     dXSARGS;
2388     if (items < 0 || items > 1)
2389         Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
2390     {
2391         IV      type;
2392         char    to[1024];
2393         U32     rc;
2394         char *  RETVAL;
2395
2396         if (items < 1)
2397             type = 0;
2398         else {
2399             type = SvIV(ST(0));
2400         }
2401
2402         to[0] = 1; to[1] = 0;           /* Sometimes no error reported */
2403         RETVAL = extLibpath(to, type);
2404         if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
2405             Perl_croak_nocontext("panic Cwd::extLibpath parameter");
2406         ST(0) = sv_newmortal();
2407         sv_setpv((SV*)ST(0), RETVAL);
2408     }
2409     XSRETURN(1);
2410 }
2411
2412 XS(XS_Cwd_extLibpath_set)
2413 {
2414     dXSARGS;
2415     if (items < 1 || items > 2)
2416         Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
2417     {
2418         STRLEN n_a;
2419         char *  s = (char *)SvPV(ST(0),n_a);
2420         IV      type;
2421         U32     rc;
2422         bool    RETVAL;
2423
2424         if (items < 2)
2425             type = 0;
2426         else {
2427             type = SvIV(ST(1));
2428         }
2429
2430         RETVAL = extLibpath_set(s, type);
2431         ST(0) = boolSV(RETVAL);
2432         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2433     }
2434     XSRETURN(1);
2435 }
2436
2437 /* Input: Address, BufLen
2438 APIRET APIENTRY
2439 DosQueryModFromEIP (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
2440                     ULONG * Offset, ULONG Address);
2441 */
2442
2443 DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP,
2444                         (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
2445                         ULONG * Offset, ULONG Address),
2446                         (hmod, obj, BufLen, Buf, Offset, Address))
2447
2448 enum module_name_how { mod_name_handle, mod_name_shortname, mod_name_full};
2449
2450 static SV*
2451 module_name_at(void *pp, enum module_name_how how)
2452 {
2453     dTHX;
2454     char buf[MAXPATHLEN];
2455     char *p = buf;
2456     HMODULE mod;
2457     ULONG obj, offset, rc;
2458
2459     if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, (ULONG)pp))
2460         return &PL_sv_undef;
2461     if (how == mod_name_handle)
2462         return newSVuv(mod);
2463     /* Full name... */
2464     if ( how == mod_name_full
2465          && CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) )
2466         return &PL_sv_undef;
2467     while (*p) {
2468         if (*p == '\\')
2469             *p = '/';
2470         p++;
2471     }
2472     return newSVpv(buf, 0);
2473 }
2474
2475 static SV*
2476 module_name_of_cv(SV *cv, enum module_name_how how)
2477 {
2478     if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv))) {
2479         dTHX;
2480
2481         Perl_croak(aTHX_ "Not an XSUB reference");
2482     }
2483     return module_name_at(CvXSUB(SvRV(cv)), how);
2484 }
2485
2486 /* Find module name to which *this* subroutine is compiled */
2487 #define module_name(how)        module_name_at(&module_name_at, how)
2488
2489 XS(XS_OS2_DLLname)
2490 {
2491     dXSARGS;
2492     if (items > 2)
2493         Perl_croak(aTHX_ "Usage: OS2::DLLname( [ how, [\\&xsub] ] )");
2494     {
2495         SV *    RETVAL;
2496         int     how;
2497
2498         if (items < 1)
2499             how = mod_name_full;
2500         else {
2501             how = (int)SvIV(ST(0));
2502         }
2503         if (items < 2)
2504             RETVAL = module_name(how);
2505         else
2506             RETVAL = module_name_of_cv(ST(1), how);
2507         ST(0) = RETVAL;
2508         sv_2mortal(ST(0));
2509     }
2510     XSRETURN(1);
2511 }
2512
2513 #define get_control87()         _control87(0,0)
2514 #define set_control87           _control87
2515
2516 XS(XS_OS2__control87)
2517 {
2518     dXSARGS;
2519     if (items != 2)
2520         Perl_croak(aTHX_ "Usage: OS2::_control87(new,mask)");
2521     {
2522         unsigned        new = (unsigned)SvIV(ST(0));
2523         unsigned        mask = (unsigned)SvIV(ST(1));
2524         unsigned        RETVAL;
2525
2526         RETVAL = _control87(new, mask);
2527         ST(0) = sv_newmortal();
2528         sv_setiv(ST(0), (IV)RETVAL);
2529     }
2530     XSRETURN(1);
2531 }
2532
2533 XS(XS_OS2_get_control87)
2534 {
2535     dXSARGS;
2536     if (items != 0)
2537         Perl_croak(aTHX_ "Usage: OS2::get_control87()");
2538     {
2539         unsigned        RETVAL;
2540
2541         RETVAL = get_control87();
2542         ST(0) = sv_newmortal();
2543         sv_setiv(ST(0), (IV)RETVAL);
2544     }
2545     XSRETURN(1);
2546 }
2547
2548
2549 XS(XS_OS2_set_control87)
2550 {
2551     dXSARGS;
2552     if (items < 0 || items > 2)
2553         Perl_croak(aTHX_ "Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
2554     {
2555         unsigned        new;
2556         unsigned        mask;
2557         unsigned        RETVAL;
2558
2559         if (items < 1)
2560             new = MCW_EM;
2561         else {
2562             new = (unsigned)SvIV(ST(0));
2563         }
2564
2565         if (items < 2)
2566             mask = MCW_EM;
2567         else {
2568             mask = (unsigned)SvIV(ST(1));
2569         }
2570
2571         RETVAL = set_control87(new, mask);
2572         ST(0) = sv_newmortal();
2573         sv_setiv(ST(0), (IV)RETVAL);
2574     }
2575     XSRETURN(1);
2576 }
2577
2578 int
2579 Xs_OS2_init(pTHX)
2580 {
2581     char *file = __FILE__;
2582     {
2583         GV *gv;
2584
2585         if (_emx_env & 0x200) { /* OS/2 */
2586             newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2587             newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2588             newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2589         }
2590         newXS("OS2::Error", XS_OS2_Error, file);
2591         newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2592         newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2593         newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2594         newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2595         newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2596         newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2597         newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
2598         newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2599         newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2600         newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2601         newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2602         newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2603         newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2604         newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2605         newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2606         newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
2607         newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
2608         newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
2609         newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
2610         newXSproto("OS2::DLLname", XS_OS2_DLLname, file, ";$$");
2611         gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2612         GvMULTI_on(gv);
2613 #ifdef PERL_IS_AOUT
2614         sv_setiv(GvSV(gv), 1);
2615 #endif
2616         gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV);
2617         GvMULTI_on(gv);
2618         sv_setiv(GvSV(gv), exe_is_aout());
2619         gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2620         GvMULTI_on(gv);
2621         sv_setiv(GvSV(gv), _emx_rev);
2622         sv_setpv(GvSV(gv), _emx_vprt);
2623         SvIOK_on(GvSV(gv));
2624         gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2625         GvMULTI_on(gv);
2626         sv_setiv(GvSV(gv), _emx_env);
2627         gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2628         GvMULTI_on(gv);
2629         sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
2630         gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV);
2631         GvMULTI_on(gv);
2632         sv_setiv(GvSV(gv), 1);          /* DEFAULT: Show number on syserror */
2633     }
2634     return 0;
2635 }
2636
2637 OS2_Perl_data_t OS2_Perl_data;
2638
2639 extern void _emx_init(void*);
2640
2641 static void jmp_out_of_atexit(void);
2642
2643 #define FORCE_EMX_INIT_CONTRACT_ARGV    1
2644 #define FORCE_EMX_INIT_INSTALL_ATEXIT   2
2645
2646 static void
2647 my_emx_init(void *layout) {
2648     static volatile void *p = 0;        /* Cannot be on stack! */
2649
2650     /* Can't just call emx_init(), since it moves the stack pointer */
2651     /* It also busts a lot of registers, so be extra careful */
2652     __asm__(    "pushf\n"
2653                 "pusha\n"
2654                 "movl %%esp, %1\n"
2655                 "push %0\n"
2656                 "call __emx_init\n"
2657                 "movl %1, %%esp\n"
2658                 "popa\n"
2659                 "popf\n" : : "r" (layout), "m" (p)      );
2660 }
2661
2662 struct layout_table_t {
2663     ULONG text_base;
2664     ULONG text_end;
2665     ULONG data_base;
2666     ULONG data_end;
2667     ULONG bss_base;
2668     ULONG bss_end;
2669     ULONG heap_base;
2670     ULONG heap_end;
2671     ULONG heap_brk;
2672     ULONG heap_off;
2673     ULONG os2_dll;
2674     ULONG stack_base;
2675     ULONG stack_end;
2676     ULONG flags;
2677     ULONG reserved[2];
2678     char options[64];
2679 };
2680
2681 static ULONG
2682 my_os_version() {
2683     static ULONG res;                   /* Cannot be on stack! */
2684
2685     /* Can't just call __os_version(), since it does not follow C
2686        calling convention: it busts a lot of registers, so be extra careful */
2687     __asm__(    "pushf\n"
2688                 "pusha\n"
2689                 "call ___os_version\n"
2690                 "movl %%eax, %0\n"
2691                 "popa\n"
2692                 "popf\n" : "=m" (res)   );
2693
2694     return res;
2695 }
2696
2697 static void
2698 force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags)
2699 {
2700     /* Calling emx_init() will bust the top of stack: it installs an
2701        exception handler and puts argv data there. */
2702     char *oldarg, *oldenv;
2703     void *oldstackend, *oldstack;
2704     PPIB pib;
2705     PTIB tib;
2706     static ULONG os2_dll;
2707     ULONG rc, error = 0, out;
2708     char buf[512];
2709     static struct layout_table_t layout_table;
2710     struct {
2711         char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */
2712         double alignment1;
2713         EXCEPTIONREGISTRATIONRECORD xreg;
2714     } *newstack;
2715     char *s;
2716
2717     layout_table.os2_dll = (ULONG)&os2_dll;
2718     layout_table.flags   = 0x02000002;  /* flags: application, OMF */
2719
2720     DosGetInfoBlocks(&tib, &pib);
2721     oldarg = pib->pib_pchcmd;
2722     oldenv = pib->pib_pchenv;
2723     oldstack = tib->tib_pstack;
2724     oldstackend = tib->tib_pstacklimit;
2725
2726     /* Minimize the damage to the stack via reducing the size of argv. */
2727     if (flags & FORCE_EMX_INIT_CONTRACT_ARGV) {
2728         pib->pib_pchcmd = "\0\0";       /* Need 3 concatenated strings */
2729         pib->pib_pchcmd = "\0";         /* Ended by an extra \0. */
2730     }
2731
2732     newstack = alloca(sizeof(*newstack));
2733     /* Emulate the stack probe */
2734     s = ((char*)newstack) + sizeof(*newstack);
2735     while (s > (char*)newstack) {
2736         s[-1] = 0;
2737         s -= 4096;
2738     }
2739
2740     /* Reassigning stack is documented to work */
2741     tib->tib_pstack = (void*)newstack;
2742     tib->tib_pstacklimit = (void*)((char*)newstack + sizeof(*newstack));
2743
2744     /* Can't just call emx_init(), since it moves the stack pointer */
2745     my_emx_init((void*)&layout_table);
2746
2747     /* Remove the exception handler, cannot use it - too low on the stack.
2748        Check whether it is inside the new stack.  */
2749     buf[0] = 0;
2750     if (tib->tib_pexchain >= tib->tib_pstacklimit
2751         || tib->tib_pexchain < tib->tib_pstack) {
2752         error = 1;
2753         sprintf(buf,
2754                 "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n",
2755                 (unsigned long)tib->tib_pstack,
2756                 (unsigned long)tib->tib_pexchain,
2757                 (unsigned long)tib->tib_pstacklimit);
2758         goto finish;
2759     }
2760     if (tib->tib_pexchain != &(newstack->xreg)) {
2761         sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n",
2762                 (unsigned long)tib->tib_pexchain,
2763                 (unsigned long)&(newstack->xreg));
2764     }
2765     rc = DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)tib->tib_pexchain);
2766     if (rc)
2767         sprintf(buf + strlen(buf),
2768                 "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc);
2769
2770     if (preg) {
2771         /* ExceptionRecords should be on stack, in a correct order.  Sigh... */
2772         preg->prev_structure = 0;
2773         preg->ExceptionHandler = _emx_exception;
2774         rc = DosSetExceptionHandler(preg);
2775         if (rc) {
2776             sprintf(buf + strlen(buf),
2777                     "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc);
2778             DosWrite(2, buf, strlen(buf), &out);
2779             emx_exception_init = 1;     /* Do it around spawn*() calls */
2780         }
2781     } else
2782         emx_exception_init = 1;         /* Do it around spawn*() calls */
2783
2784   finish:
2785     /* Restore the damage */
2786     pib->pib_pchcmd = oldarg;
2787     pib->pib_pchcmd = oldenv;
2788     tib->tib_pstacklimit = oldstackend;
2789     tib->tib_pstack = oldstack;
2790     emx_runtime_init = 1;
2791     if (buf[0])
2792         DosWrite(2, buf, strlen(buf), &out);
2793     if (error)
2794         exit(56);
2795 }
2796
2797 jmp_buf at_exit_buf;
2798 int longjmp_at_exit;
2799
2800 static void
2801 jmp_out_of_atexit(void)
2802 {
2803     if (longjmp_at_exit)
2804         longjmp(at_exit_buf, 1);
2805 }
2806
2807 extern void _CRT_term(void);
2808
2809 int emx_runtime_secondary;
2810
2811 void
2812 Perl_OS2_term(void **p, int exitstatus, int flags)
2813 {
2814     if (!emx_runtime_secondary)
2815         return;
2816
2817     /* The principal executable is not running the same CRTL, so there
2818        is nobody to shutdown *this* CRTL except us... */
2819     if (flags & FORCE_EMX_DEINIT_EXIT) {
2820         if (p && !emx_exception_init)
2821             DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
2822         /* Do not run the executable's CRTL's termination routines */
2823         exit(exitstatus);               /* Run at-exit, flush buffers, etc */
2824     }
2825     /* Run at-exit list, and jump out at the end */
2826     if ((flags & FORCE_EMX_DEINIT_RUN_ATEXIT) && !setjmp(at_exit_buf)) {
2827         longjmp_at_exit = 1;
2828         exit(exitstatus);               /* The first pass through "if" */
2829     }
2830
2831     /* Get here if we managed to jump out of exit(), or did not run atexit. */
2832     longjmp_at_exit = 0;                /* Maybe exit() is called again? */
2833 #if 0 /* _atexit_n is not exported */
2834     if (flags & FORCE_EMX_DEINIT_RUN_ATEXIT)
2835         _atexit_n = 0;                  /* Remove the atexit() handlers */
2836 #endif
2837     /* Will segfault on program termination if we leave this dangling... */
2838     if (p && !emx_exception_init)
2839         DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
2840     /* Typically there is no need to do this, done from _DLL_InitTerm() */
2841     if (flags & FORCE_EMX_DEINIT_CRT_TERM)
2842         _CRT_term();                    /* Flush buffers, etc. */
2843     /* Now it is a good time to call exit() in the caller's CRTL... */
2844 }
2845
2846 #include <emx/startup.h>
2847
2848 extern ULONG __os_version();            /* See system.doc */
2849
2850 static int emx_wasnt_initialized;
2851
2852 void
2853 check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
2854 {
2855     ULONG v_crt, v_emx;
2856
2857     /*  If _environ is not set, this code sits in a DLL which
2858         uses a CRT DLL which not compatible with the executable's
2859         CRT library.  Some parts of the DLL are not initialized.
2860      */
2861     if (_environ != NULL)
2862         return;                         /* Properly initialized */
2863
2864     /*  If the executable does not use EMX.DLL, EMX.DLL is not completely
2865         initialized either.  Uninitialized EMX.DLL returns 0 in the low
2866         nibble of __os_version().  */
2867     v_emx = my_os_version();
2868
2869     /*  _osmajor and _osminor are normally set in _DLL_InitTerm of CRT DLL
2870         (=>_CRT_init=>_entry2) via a call to __os_version(), then
2871         reset when the EXE initialization code calls _text=>_init=>_entry2.
2872         The first time they are wrongly set to 0; the second time the
2873         EXE initialization code had already called emx_init=>initialize1
2874         which correctly set version_major, version_minor used by
2875         __os_version().  */
2876     v_crt = (_osmajor | _osminor);
2877
2878     if ((_emx_env & 0x200) && !(v_emx & 0xFFFF)) {      /* OS/2, EMX uninit. */
2879         force_init_emx_runtime( preg,
2880                                 FORCE_EMX_INIT_CONTRACT_ARGV
2881                                 | FORCE_EMX_INIT_INSTALL_ATEXIT );
2882         emx_wasnt_initialized = 1;
2883         /* Update CRTL data basing on now-valid EMX runtime data */
2884         if (!v_crt) {           /* The only wrong data are the versions. */
2885             v_emx = my_os_version();                    /* *Now* it works */
2886             *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */
2887             *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF;
2888         }
2889     }
2890     emx_runtime_secondary = 1;
2891     /* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */
2892     atexit(jmp_out_of_atexit);          /* Allow run of atexit() w/o exit()  */
2893
2894     if (env == NULL) {                  /* Fetch from the process info block */
2895         int c = 0;
2896         PPIB pib;
2897         PTIB tib;
2898         char *e, **ep;
2899
2900         DosGetInfoBlocks(&tib, &pib);
2901         e = pib->pib_pchenv;
2902         while (*e) {                    /* Get count */
2903             c++;
2904             e = e + strlen(e) + 1;
2905         }
2906         New(1307, env, c + 1, char*);
2907         ep = env;
2908         e = pib->pib_pchenv;
2909         while (c--) {
2910             *ep++ = e;
2911             e = e + strlen(e) + 1;
2912         }
2913         *ep = NULL;
2914     }
2915     _environ = _org_environ = env;
2916 }
2917
2918 #define ENTRY_POINT 0x10000
2919
2920 static int
2921 exe_is_aout(void)
2922 {
2923     struct layout_table_t *layout;
2924     if (emx_wasnt_initialized)
2925         return 0;
2926     /* Now we know that the principal executable is an EMX application
2927        - unless somebody did already play with delayed initialization... */
2928     /* With EMX applications to determine whether it is AOUT one needs
2929        to examine the start of the executable to find "layout" */
2930     if ( *(unsigned char*)ENTRY_POINT != 0x68           /* PUSH n */
2931          || *(unsigned char*)(ENTRY_POINT+5) != 0xe8    /* CALL */
2932          || *(unsigned char*)(ENTRY_POINT+10) != 0xeb   /* JMP */
2933          || *(unsigned char*)(ENTRY_POINT+12) != 0xe8)  /* CALL */
2934         return 0;                                       /* ! EMX executable */
2935     /* Fix alignment */
2936     Copy((char*)(ENTRY_POINT+1), &layout, 1, struct layout_table_t*);
2937     return !(layout->flags & 2);
2938 }
2939
2940 void
2941 Perl_OS2_init(char **env)
2942 {
2943     Perl_OS2_init3(env, 0, 0);
2944 }
2945
2946 void
2947 Perl_OS2_init3(char **env, void **preg, int flags)
2948 {
2949     char *shell;
2950
2951     _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
2952     MALLOC_INIT;
2953
2954     check_emx_runtime(env, (EXCEPTIONREGISTRATIONRECORD *)preg);
2955
2956     settmppath();
2957     OS2_Perl_data.xs_init = &Xs_OS2_init;
2958     if ( (shell = getenv("PERL_SH_DRIVE")) ) {
2959         New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2960         strcpy(PL_sh_path, SH_PATH);
2961         PL_sh_path[0] = shell[0];
2962     } else if ( (shell = getenv("PERL_SH_DIR")) ) {
2963         int l = strlen(shell), i;
2964         if (shell[l-1] == '/' || shell[l-1] == '\\') {
2965             l--;
2966         }
2967         New(1304, PL_sh_path, l + 8, char);
2968         strncpy(PL_sh_path, shell, l);
2969         strcpy(PL_sh_path + l, "/sh.exe");
2970         for (i = 0; i < l; i++) {
2971             if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2972         }
2973     }
2974 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2975     MUTEX_INIT(&start_thread_mutex);
2976 #endif
2977     os2_mytype = my_type();             /* Do it before morphing.  Needed? */
2978     /* Some DLLs reset FP flags on load.  We may have been linked with them */
2979     _control87(MCW_EM, MCW_EM);
2980 }
2981
2982 #undef tmpnam
2983 #undef tmpfile
2984
2985 char *
2986 my_tmpnam (char *str)
2987 {
2988     char *p = getenv("TMP"), *tpath;
2989
2990     if (!p) p = getenv("TEMP");
2991     tpath = tempnam(p, "pltmp");
2992     if (str && tpath) {
2993         strcpy(str, tpath);
2994         return str;
2995     }
2996     return tpath;
2997 }
2998
2999 FILE *
3000 my_tmpfile ()
3001 {
3002     struct stat s;
3003
3004     stat(".", &s);
3005     if (s.st_mode & S_IWOTH) {
3006         return tmpfile();
3007     }
3008     return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
3009                                              grants TMP. */
3010 }
3011
3012 #undef rmdir
3013
3014 /* EMX flavors do not tolerate trailing slashes.  t/op/mkdir.t has many
3015    trailing slashes, so we need to support this as well. */
3016
3017 int
3018 my_rmdir (__const__ char *s)
3019 {
3020     char b[MAXPATHLEN];
3021     char *buf = b;
3022     STRLEN l = strlen(s);
3023     int rc;
3024
3025     if (s[l-1] == '/' || s[l-1] == '\\') {      /* EMX mkdir fails... */
3026         if (l >= sizeof b)
3027             New(1305, buf, l + 1, char);
3028         strcpy(buf,s);
3029         while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
3030             l--;
3031         buf[l] = 0;
3032         s = buf;
3033     }
3034     rc = rmdir(s);
3035     if (b != buf)
3036         Safefree(buf);
3037     return rc;
3038 }
3039
3040 #undef mkdir
3041
3042 int
3043 my_mkdir (__const__ char *s, long perm)
3044 {
3045     char b[MAXPATHLEN];
3046     char *buf = b;
3047     STRLEN l = strlen(s);
3048     int rc;
3049
3050     if (s[l-1] == '/' || s[l-1] == '\\') {      /* EMX mkdir fails... */
3051         if (l >= sizeof b)
3052             New(1305, buf, l + 1, char);
3053         strcpy(buf,s);
3054         while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
3055             l--;
3056         buf[l] = 0;
3057         s = buf;
3058     }
3059     rc = mkdir(s, perm);
3060     if (b != buf)
3061         Safefree(buf);
3062     return rc;
3063 }
3064
3065 #undef flock
3066
3067 /* This code was contributed by Rocco Caputo. */
3068 int
3069 my_flock(int handle, int o)
3070 {
3071   FILELOCK      rNull, rFull;
3072   ULONG         timeout, handle_type, flag_word;
3073   APIRET        rc;
3074   int           blocking, shared;
3075   static int    use_my = -1;
3076
3077   if (use_my == -1) {
3078     char *s = getenv("USE_PERL_FLOCK");
3079     if (s)
3080         use_my = atoi(s);
3081     else
3082         use_my = 1;
3083   }
3084   if (!(_emx_env & 0x200) || !use_my)
3085     return flock(handle, o);    /* Delegate to EMX. */
3086
3087                                         /* is this a file? */
3088   if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
3089       (handle_type & 0xFF))
3090   {
3091     errno = EBADF;
3092     return -1;
3093   }
3094                                         /* set lock/unlock ranges */
3095   rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
3096   rFull.lRange = 0x7FFFFFFF;
3097                                         /* set timeout for blocking */
3098   timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
3099                                         /* shared or exclusive? */
3100   shared = (o & LOCK_SH) ? 1 : 0;
3101                                         /* do not block the unlock */
3102   if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
3103     rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
3104     switch (rc) {
3105       case 0:
3106         errno = 0;
3107         return 0;
3108       case ERROR_INVALID_HANDLE:
3109         errno = EBADF;
3110         return -1;
3111       case ERROR_SHARING_BUFFER_EXCEEDED:
3112         errno = ENOLCK;
3113         return -1;
3114       case ERROR_LOCK_VIOLATION:
3115         break;                          /* not an error */
3116       case ERROR_INVALID_PARAMETER:
3117       case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
3118       case ERROR_READ_LOCKS_NOT_SUPPORTED:
3119         errno = EINVAL;
3120         return -1;
3121       case ERROR_INTERRUPT:
3122         errno = EINTR;
3123         return -1;
3124       default:
3125         errno = EINVAL;
3126         return -1;
3127     }
3128   }
3129                                         /* lock may block */
3130   if (o & (LOCK_SH | LOCK_EX)) {
3131                                         /* for blocking operations */
3132     for (;;) {
3133       rc =
3134         DosSetFileLocks(
3135                 handle,
3136                 &rNull,
3137                 &rFull,
3138                 timeout,
3139                 shared
3140         );
3141       switch (rc) {
3142         case 0:
3143           errno = 0;
3144           return 0;
3145         case ERROR_INVALID_HANDLE:
3146           errno = EBADF;
3147           return -1;
3148         case ERROR_SHARING_BUFFER_EXCEEDED:
3149           errno = ENOLCK;
3150           return -1;
3151         case ERROR_LOCK_VIOLATION:
3152           if (!blocking) {
3153             errno = EWOULDBLOCK;
3154             return -1;
3155           }
3156           break;
3157         case ERROR_INVALID_PARAMETER:
3158         case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
3159         case ERROR_READ_LOCKS_NOT_SUPPORTED:
3160           errno = EINVAL;
3161           return -1;
3162         case ERROR_INTERRUPT:
3163           errno = EINTR;
3164           return -1;
3165         default:
3166           errno = EINVAL;
3167           return -1;
3168       }
3169                                         /* give away timeslice */
3170       DosSleep(1);
3171     }
3172   }
3173
3174   errno = 0;
3175   return 0;
3176 }
3177
3178 static int pwent_cnt;
3179 static int _my_pwent = -1;
3180
3181 static int
3182 use_my_pwent(void)
3183 {
3184   if (_my_pwent == -1) {
3185     char *s = getenv("USE_PERL_PWENT");
3186     if (s)
3187         _my_pwent = atoi(s);
3188     else
3189         _my_pwent = 1;
3190   }
3191   return _my_pwent;
3192 }
3193
3194 #undef setpwent
3195 #undef getpwent
3196 #undef endpwent
3197
3198 void
3199 my_setpwent(void)
3200 {
3201   if (!use_my_pwent()) {
3202     setpwent();                 /* Delegate to EMX. */
3203     return;
3204   }
3205   pwent_cnt = 0;
3206 }
3207
3208 void
3209 my_endpwent(void)
3210 {
3211   if (!use_my_pwent()) {
3212     endpwent();                 /* Delegate to EMX. */
3213     return;
3214   }
3215 }
3216
3217 struct passwd *
3218 my_getpwent (void)
3219 {
3220   if (!use_my_pwent())
3221     return getpwent();                  /* Delegate to EMX. */
3222   if (pwent_cnt++)
3223     return 0;                           /* Return one entry only */
3224   return getpwuid(0);
3225 }
3226
3227 static int grent_cnt;
3228
3229 void
3230 setgrent(void)
3231 {
3232   grent_cnt = 0;
3233 }
3234
3235 void
3236 endgrent(void)
3237 {
3238 }
3239
3240 struct group *
3241 getgrent (void)
3242 {
3243   if (grent_cnt++)
3244     return 0;                           /* Return one entry only */
3245   return getgrgid(0);
3246 }
3247
3248 #undef getpwuid
3249 #undef getpwnam
3250
3251 /* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */
3252 static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
3253
3254 static struct passwd *
3255 passw_wrap(struct passwd *p)
3256 {
3257     static struct passwd pw;
3258     char *s;
3259
3260     if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
3261         return p;
3262     pw = *p;
3263     s = getenv("PW_PASSWD");
3264     if (!s)
3265         s = (char*)pw_p;                /* Make match impossible */
3266
3267     pw.pw_passwd = s;
3268     return &pw;
3269 }
3270
3271 struct passwd *
3272 my_getpwuid (uid_t id)
3273 {
3274     return passw_wrap(getpwuid(id));
3275 }
3276
3277 struct passwd *
3278 my_getpwnam (__const__ char *n)
3279 {
3280     return passw_wrap(getpwnam(n));
3281 }
3282
3283 char *
3284 gcvt_os2 (double value, int digits, char *buffer)
3285 {
3286   return gcvt (value, digits, buffer);
3287 }
3288
3289 #undef fork
3290 int fork_with_resources()
3291 {
3292 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
3293   dTHX;
3294   void *ctx = PERL_GET_CONTEXT;
3295 #endif
3296
3297   int rc = fork();
3298
3299 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
3300   if (rc == 0) {                        /* child */
3301     ALLOC_THREAD_KEY;                   /* Acquire the thread-local memory */
3302     PERL_SET_CONTEXT(ctx);              /* Reinit the thread-local memory */
3303   }
3304 #endif
3305   return rc;
3306 }