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