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