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         /* We should check PERL_SH* and PERLLIB_* as well? */
 622         if (!really || !*(tmps = SvPV(really, n_a)))
 623             tmps = PL_Argv[0];
 624         if (tmps[0] != '/' && tmps[0] != '\\'
 625             && !(tmps[0] && tmps[1] == ':'
 626                  && (tmps[2] == '/' || tmps[2] != '\\'))
 627             ) /* will spawnvp use PATH? */
 628             TAINT_ENV();        /* testing IFS here is overkill, probably */
 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 #ifndef INCOMPLETE_TAINTS
1981         SvTAINTED_on(ST(0));
1982 #endif
1983     }
1984     XSRETURN(1);
1985 }
1986
1987 XS(XS_Cwd_sys_abspath)
1988 {
1989     dXSARGS;
1990     if (items < 1 || items > 2)
1991         Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
1992     {
1993         STRLEN n_a;
1994         char *  path = (char *)SvPV(ST(0),n_a);
1995         char *  dir, *s, *t, *e;
1996         char p[MAXPATHLEN];
1997         char *  RETVAL;
1998         int l;
1999         SV *sv;
2000
2001         if (items < 2)
2002             dir = NULL;
2003         else {
2004             dir = (char *)SvPV(ST(1),n_a);
2005         }
2006         if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
2007             path += 2;
2008         }
2009         if (dir == NULL) {
2010             if (_abspath(p, path, MAXPATHLEN) == 0) {
2011                 RETVAL = p;
2012             } else {
2013                 RETVAL = NULL;
2014             }
2015         } else {
2016             /* Absolute with drive: */
2017             if ( sys_is_absolute(path) ) {
2018                 if (_abspath(p, path, MAXPATHLEN) == 0) {
2019                     RETVAL = p;
2020                 } else {
2021                     RETVAL = NULL;
2022                 }
2023             } else if (path[0] == '/' || path[0] == '\\') {
2024                 /* Rooted, but maybe on different drive. */
2025                 if (isALPHA(dir[0]) && dir[1] == ':' ) {
2026                     char p1[MAXPATHLEN];
2027
2028                     /* Need to prepend the drive. */
2029                     p1[0] = dir[0];
2030                     p1[1] = dir[1];
2031                     Copy(path, p1 + 2, strlen(path) + 1, char);
2032                     RETVAL = p;
2033                     if (_abspath(p, p1, MAXPATHLEN) == 0) {
2034                         RETVAL = p;
2035                     } else {
2036                         RETVAL = NULL;
2037                     }
2038                 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
2039                     RETVAL = p;
2040                 } else {
2041                     RETVAL = NULL;
2042                 }
2043             } else {
2044                 /* Either path is relative, or starts with a drive letter. */
2045                 /* If the path starts with a drive letter, then dir is
2046                    relevant only if
2047                    a/b) it is absolute/x:relative on the same drive.
2048                    c)   path is on current drive, and dir is rooted
2049                    In all the cases it is safe to drop the drive part
2050                    of the path. */
2051                 if ( !sys_is_relative(path) ) {
2052                     if ( ( ( sys_is_absolute(dir)
2053                              || (isALPHA(dir[0]) && dir[1] == ':'
2054                                  && strnicmp(dir, path,1) == 0))
2055                            && strnicmp(dir, path,1) == 0)
2056                          || ( !(isALPHA(dir[0]) && dir[1] == ':')
2057                               && toupper(path[0]) == current_drive())) {
2058                         path += 2;
2059                     } else if (_abspath(p, path, MAXPATHLEN) == 0) {
2060                         RETVAL = p; goto done;
2061                     } else {
2062                         RETVAL = NULL; goto done;
2063                     }
2064                 }
2065                 {
2066                     /* Need to prepend the absolute path of dir. */
2067                     char p1[MAXPATHLEN];
2068
2069                     if (_abspath(p1, dir, MAXPATHLEN) == 0) {
2070                         int l = strlen(p1);
2071
2072                         if (p1[ l - 1 ] != '/') {
2073                             p1[ l ] = '/';
2074                             l++;
2075                         }
2076                         Copy(path, p1 + l, strlen(path) + 1, char);
2077                         if (_abspath(p, p1, MAXPATHLEN) == 0) {
2078                             RETVAL = p;
2079                         } else {
2080                             RETVAL = NULL;
2081                         }
2082                     } else {
2083                         RETVAL = NULL;
2084                     }
2085                 }
2086               done:
2087             }
2088         }
2089         if (!RETVAL)
2090             XSRETURN_EMPTY;
2091         /* Backslashes are already converted to slashes. */
2092         /* Remove trailing slashes */
2093         l = strlen(RETVAL);
2094         while (l > 0 && RETVAL[l-1] == '/')
2095             l--;
2096         ST(0) = sv_newmortal();
2097         sv_setpvn( sv = (SV*)ST(0), RETVAL, l);
2098         /* Remove duplicate slashes, skipping the first three, which
2099            may be parts of a server-based path */
2100         s = t = 3 + SvPV_force(sv, n_a);
2101         e = SvEND(sv);
2102         /* Do not worry about multibyte chars here, this would contradict the
2103            eventual UTFization, and currently most other places break too... */
2104         while (s < e) {
2105             if (s[0] == t[-1] && s[0] == '/')
2106                 s++;                            /* Skip duplicate / */
2107             else
2108                 *t++ = *s++;
2109         }
2110         if (t < e) {
2111             *t = 0;
2112             SvCUR_set(sv, t - SvPVX(sv));
2113         }
2114     }
2115     XSRETURN(1);
2116 }
2117 typedef APIRET (*PELP)(PSZ path, ULONG type);
2118
2119 /* Kernels after 2000/09/15 understand this too: */
2120 #ifndef LIBPATHSTRICT
2121 #  define LIBPATHSTRICT 3
2122 #endif
2123
2124 APIRET
2125 ExtLIBPATH(ULONG ord, PSZ path, IV type)
2126 {
2127     ULONG what;
2128     PFN f = loadByOrdinal(ord, 1);      /* Guarantied to load or die! */
2129
2130     if (type > 0)
2131         what = END_LIBPATH;
2132     else if (type == 0)
2133         what = BEGIN_LIBPATH;
2134     else
2135         what = LIBPATHSTRICT;
2136     return (*(PELP)f)(path, what);
2137 }
2138
2139 #define extLibpath(to,type)                                             \
2140     (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type))) ? NULL : (to) )
2141
2142 #define extLibpath_set(p,type)                                  \
2143     (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type))))
2144
2145 XS(XS_Cwd_extLibpath)
2146 {
2147     dXSARGS;
2148     if (items < 0 || items > 1)
2149         Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
2150     {
2151         IV      type;
2152         char    to[1024];
2153         U32     rc;
2154         char *  RETVAL;
2155
2156         if (items < 1)
2157             type = 0;
2158         else {
2159             type = SvIV(ST(0));
2160         }
2161
2162         to[0] = 1; to[1] = 0;           /* Sometimes no error reported */
2163         RETVAL = extLibpath(to, type);
2164         if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
2165             Perl_croak_nocontext("panic Cwd::extLibpath parameter");
2166         ST(0) = sv_newmortal();
2167         sv_setpv((SV*)ST(0), RETVAL);
2168     }
2169     XSRETURN(1);
2170 }
2171
2172 XS(XS_Cwd_extLibpath_set)
2173 {
2174     dXSARGS;
2175     if (items < 1 || items > 2)
2176         Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
2177     {
2178         STRLEN n_a;
2179         char *  s = (char *)SvPV(ST(0),n_a);
2180         IV      type;
2181         U32     rc;
2182         bool    RETVAL;
2183
2184         if (items < 2)
2185             type = 0;
2186         else {
2187             type = SvIV(ST(1));
2188         }
2189
2190         RETVAL = extLibpath_set(s, type);
2191         ST(0) = boolSV(RETVAL);
2192         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2193     }
2194     XSRETURN(1);
2195 }
2196
2197 #define get_control87()         _control87(0,0)
2198 #define set_control87           _control87
2199
2200 XS(XS_OS2__control87)
2201 {
2202     dXSARGS;
2203     if (items != 2)
2204         croak("Usage: OS2::_control87(new,mask)");
2205     {
2206         unsigned        new = (unsigned)SvIV(ST(0));
2207         unsigned        mask = (unsigned)SvIV(ST(1));
2208         unsigned        RETVAL;
2209
2210         RETVAL = _control87(new, mask);
2211         ST(0) = sv_newmortal();
2212         sv_setiv(ST(0), (IV)RETVAL);
2213     }
2214     XSRETURN(1);
2215 }
2216
2217 XS(XS_OS2_get_control87)
2218 {
2219     dXSARGS;
2220     if (items != 0)
2221         croak("Usage: OS2::get_control87()");
2222     {
2223         unsigned        RETVAL;
2224
2225         RETVAL = get_control87();
2226         ST(0) = sv_newmortal();
2227         sv_setiv(ST(0), (IV)RETVAL);
2228     }
2229     XSRETURN(1);
2230 }
2231
2232
2233 XS(XS_OS2_set_control87)
2234 {
2235     dXSARGS;
2236     if (items < 0 || items > 2)
2237         croak("Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
2238     {
2239         unsigned        new;
2240         unsigned        mask;
2241         unsigned        RETVAL;
2242
2243         if (items < 1)
2244             new = MCW_EM;
2245         else {
2246             new = (unsigned)SvIV(ST(0));
2247         }
2248
2249         if (items < 2)
2250             mask = MCW_EM;
2251         else {
2252             mask = (unsigned)SvIV(ST(1));
2253         }
2254
2255         RETVAL = set_control87(new, mask);
2256         ST(0) = sv_newmortal();
2257         sv_setiv(ST(0), (IV)RETVAL);
2258     }
2259     XSRETURN(1);
2260 }
2261
2262 int
2263 Xs_OS2_init(pTHX)
2264 {
2265     char *file = __FILE__;
2266     {
2267         GV *gv;
2268
2269         if (_emx_env & 0x200) { /* OS/2 */
2270             newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2271             newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2272             newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2273         }
2274         newXS("OS2::Error", XS_OS2_Error, file);
2275         newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2276         newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2277         newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2278         newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2279         newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2280         newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2281         newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
2282         newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2283         newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2284         newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2285         newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2286         newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2287         newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2288         newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2289         newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2290         newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
2291         newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
2292         newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
2293         newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
2294         gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2295         GvMULTI_on(gv);
2296 #ifdef PERL_IS_AOUT
2297         sv_setiv(GvSV(gv), 1);
2298 #endif
2299         gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV);
2300         GvMULTI_on(gv);
2301         sv_setiv(GvSV(gv), exe_is_aout());
2302         gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2303         GvMULTI_on(gv);
2304         sv_setiv(GvSV(gv), _emx_rev);
2305         sv_setpv(GvSV(gv), _emx_vprt);
2306         SvIOK_on(GvSV(gv));
2307         gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2308         GvMULTI_on(gv);
2309         sv_setiv(GvSV(gv), _emx_env);
2310         gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2311         GvMULTI_on(gv);
2312         sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
2313         gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV);
2314         GvMULTI_on(gv);
2315         sv_setiv(GvSV(gv), 1);          /* DEFAULT: Show number on syserror */
2316     }
2317     return 0;
2318 }
2319
2320 OS2_Perl_data_t OS2_Perl_data;
2321
2322 extern void _emx_init(void*);
2323
2324 static void jmp_out_of_atexit(void);
2325
2326 #define FORCE_EMX_INIT_CONTRACT_ARGV    1
2327 #define FORCE_EMX_INIT_INSTALL_ATEXIT   2
2328
2329 static void
2330 my_emx_init(void *layout) {
2331     static volatile void *p = 0;        /* Cannot be on stack! */
2332
2333     /* Can't just call emx_init(), since it moves the stack pointer */
2334     /* It also busts a lot of registers, so be extra careful */
2335     __asm__(    "pushf\n"
2336                 "pusha\n"
2337                 "movl %%esp, %1\n"
2338                 "push %0\n"
2339                 "call __emx_init\n"
2340                 "movl %1, %%esp\n"
2341                 "popa\n"
2342                 "popf\n" : : "r" (layout), "m" (p)      );
2343 }
2344
2345 struct layout_table_t {
2346     ULONG text_base;
2347     ULONG text_end;
2348     ULONG data_base;
2349     ULONG data_end;
2350     ULONG bss_base;
2351     ULONG bss_end;
2352     ULONG heap_base;
2353     ULONG heap_end;
2354     ULONG heap_brk;
2355     ULONG heap_off;
2356     ULONG os2_dll;
2357     ULONG stack_base;
2358     ULONG stack_end;
2359     ULONG flags;
2360     ULONG reserved[2];
2361     char options[64];
2362 };
2363
2364 static ULONG
2365 my_os_version() {
2366     static ULONG res;                   /* Cannot be on stack! */
2367
2368     /* Can't just call emx_init(), since it moves the stack pointer */
2369     /* It also busts a lot of registers, so be extra careful */
2370     __asm__(    "pushf\n"
2371                 "pusha\n"
2372                 "call ___os_version\n"
2373                 "movl %%eax, %0\n"
2374                 "popa\n"
2375                 "popf\n" : "=m" (res)   );
2376
2377     return res;
2378 }
2379
2380 static void
2381 force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags)
2382 {
2383     /* Calling emx_init() will bust the top of stack: it installs an
2384        exception handler and puts argv data there. */
2385     char *oldarg, *oldenv;
2386     void *oldstackend, *oldstack;
2387     PPIB pib;
2388     PTIB tib;
2389     static ULONG os2_dll;
2390     ULONG rc, error = 0, out;
2391     char buf[512];
2392     static struct layout_table_t layout_table;
2393     struct {
2394         char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */
2395         double alignment1;
2396         EXCEPTIONREGISTRATIONRECORD xreg;
2397     } *newstack;
2398     char *s;
2399
2400     layout_table.os2_dll = (ULONG)&os2_dll;
2401     layout_table.flags   = 0x02000002;  /* flags: application, OMF */
2402
2403     DosGetInfoBlocks(&tib, &pib);
2404     oldarg = pib->pib_pchcmd;
2405     oldenv = pib->pib_pchenv;
2406     oldstack = tib->tib_pstack;
2407     oldstackend = tib->tib_pstacklimit;
2408
2409     /* Minimize the damage to the stack via reducing the size of argv. */
2410     if (flags & FORCE_EMX_INIT_CONTRACT_ARGV) {
2411         pib->pib_pchcmd = "\0\0";       /* Need 3 concatenated strings */
2412         pib->pib_pchcmd = "\0";         /* Ended by an extra \0. */
2413     }
2414
2415     newstack = alloca(sizeof(*newstack));
2416     /* Emulate the stack probe */
2417     s = ((char*)newstack) + sizeof(*newstack);
2418     while (s > (char*)newstack) {
2419         s[-1] = 0;
2420         s -= 4096;
2421     }
2422
2423     /* Reassigning stack is documented to work */
2424     tib->tib_pstack = (void*)newstack;
2425     tib->tib_pstacklimit = (void*)((char*)newstack + sizeof(*newstack));
2426
2427     /* Can't just call emx_init(), since it moves the stack pointer */
2428     my_emx_init((void*)&layout_table);
2429
2430     /* Remove the exception handler, cannot use it - too low on the stack.
2431        Check whether it is inside the new stack.  */
2432     buf[0] = 0;
2433     if (tib->tib_pexchain >= tib->tib_pstacklimit
2434         || tib->tib_pexchain < tib->tib_pstack) {
2435         error = 1;
2436         sprintf(buf,
2437                 "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n",
2438                 (unsigned long)tib->tib_pstack,
2439                 (unsigned long)tib->tib_pexchain,
2440                 (unsigned long)tib->tib_pstacklimit);
2441         goto finish;
2442     }
2443     if (tib->tib_pexchain != &(newstack->xreg)) {
2444         sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n",
2445                 (unsigned long)tib->tib_pexchain,
2446                 (unsigned long)&(newstack->xreg));
2447     }
2448     rc = DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)tib->tib_pexchain);
2449     if (rc)
2450         sprintf(buf + strlen(buf),
2451                 "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc);
2452
2453     if (preg) {
2454         /* ExceptionRecords should be on stack, in a correct order.  Sigh... */
2455         preg->prev_structure = 0;
2456         preg->ExceptionHandler = _emx_exception;
2457         rc = DosSetExceptionHandler(preg);
2458         if (rc) {
2459             sprintf(buf + strlen(buf),
2460                     "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc);
2461             DosWrite(2, buf, strlen(buf), &out);
2462             emx_exception_init = 1;     /* Do it around spawn*() calls */
2463         }
2464     } else
2465         emx_exception_init = 1;         /* Do it around spawn*() calls */
2466
2467   finish:
2468     /* Restore the damage */
2469     pib->pib_pchcmd = oldarg;
2470     pib->pib_pchcmd = oldenv;
2471     tib->tib_pstacklimit = oldstackend;
2472     tib->tib_pstack = oldstack;
2473     emx_runtime_init = 1;
2474     if (buf[0])
2475         DosWrite(2, buf, strlen(buf), &out);
2476     if (error)
2477         exit(56);
2478 }
2479
2480 jmp_buf at_exit_buf;
2481 int longjmp_at_exit;
2482
2483 static void
2484 jmp_out_of_atexit(void)
2485 {
2486     if (longjmp_at_exit)
2487         longjmp(at_exit_buf, 1);
2488 }
2489
2490 extern void _CRT_term(void);
2491
2492 int emx_runtime_secondary;
2493
2494 void
2495 Perl_OS2_term(void **p, int exitstatus, int flags)
2496 {
2497     if (!emx_runtime_secondary)
2498         return;
2499
2500     /* The principal executable is not running the same CRTL, so there
2501        is nobody to shutdown *this* CRTL except us... */
2502     if (flags & FORCE_EMX_DEINIT_EXIT) {
2503         if (p && !emx_exception_init)
2504             DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
2505         /* Do not run the executable's CRTL's termination routines */
2506         exit(exitstatus);               /* Run at-exit, flush buffers, etc */
2507     }
2508     /* Run at-exit list, and jump out at the end */
2509     if ((flags & FORCE_EMX_DEINIT_RUN_ATEXIT) && !setjmp(at_exit_buf)) {
2510         longjmp_at_exit = 1;
2511         exit(exitstatus);               /* The first pass through "if" */
2512     }
2513
2514     /* Get here if we managed to jump out of exit(), or did not run atexit. */
2515     longjmp_at_exit = 0;                /* Maybe exit() is called again? */
2516 #if 0 /* _atexit_n is not exported */
2517     if (flags & FORCE_EMX_DEINIT_RUN_ATEXIT)
2518         _atexit_n = 0;                  /* Remove the atexit() handlers */
2519 #endif
2520     /* Will segfault on program termination if we leave this dangling... */
2521     if (p && !emx_exception_init)
2522         DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
2523     /* Typically there is no need to do this, done from _DLL_InitTerm() */
2524     if (flags & FORCE_EMX_DEINIT_CRT_TERM)
2525         _CRT_term();                    /* Flush buffers, etc. */
2526     /* Now it is a good time to call exit() in the caller's CRTL... */
2527 }
2528
2529 #include <emx/startup.h>
2530
2531 extern ULONG __os_version();            /* See system.doc */
2532
2533 static int emx_wasnt_initialized;
2534
2535 void
2536 check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
2537 {
2538     ULONG v_crt, v_emx;
2539
2540     /*  If _environ is not set, this code sits in a DLL which
2541         uses a CRT DLL which not compatible with the executable's
2542         CRT library.  Some parts of the DLL are not initialized.
2543      */
2544     if (_environ != NULL)
2545         return;                         /* Properly initialized */
2546
2547     /*  If the executable does not use EMX.DLL, EMX.DLL is not completely
2548         initialized either.  Uninitialized EMX.DLL returns 0 in the low
2549         nibble of __os_version().  */
2550     v_emx = my_os_version();
2551
2552     /*  _osmajor and _osminor are normally set in _DLL_InitTerm of CRT DLL
2553         (=>_CRT_init=>_entry2) via a call to __os_version(), then
2554         reset when the EXE initialization code calls _text=>_init=>_entry2.
2555         The first time they are wrongly set to 0; the second time the
2556         EXE initialization code had already called emx_init=>initialize1
2557         which correctly set version_major, version_minor used by
2558         __os_version().  */
2559     v_crt = (_osmajor | _osminor);
2560
2561     if ((_emx_env & 0x200) && !(v_emx & 0xFFFF)) {      /* OS/2, EMX uninit. */
2562         force_init_emx_runtime( preg,
2563                                 FORCE_EMX_INIT_CONTRACT_ARGV
2564                                 | FORCE_EMX_INIT_INSTALL_ATEXIT );
2565         emx_wasnt_initialized = 1;
2566         /* Update CRTL data basing on now-valid EMX runtime data */
2567         if (!v_crt) {           /* The only wrong data are the versions. */
2568             v_emx = my_os_version();                    /* *Now* it works */
2569             *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */
2570             *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF;
2571         }
2572     }
2573     emx_runtime_secondary = 1;
2574     /* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */
2575     atexit(jmp_out_of_atexit);          /* Allow run of atexit() w/o exit()  */
2576
2577     if (env == NULL) {                  /* Fetch from the process info block */
2578         int c = 0;
2579         PPIB pib;
2580         PTIB tib;
2581         char *e, **ep;
2582
2583         DosGetInfoBlocks(&tib, &pib);
2584         e = pib->pib_pchenv;
2585         while (*e) {                    /* Get count */
2586             c++;
2587             e = e + strlen(e) + 1;
2588         }
2589         New(1307, env, c + 1, char*);
2590         ep = env;
2591         e = pib->pib_pchenv;
2592         while (c--) {
2593             *ep++ = e;
2594             e = e + strlen(e) + 1;
2595         }
2596         *ep = NULL;
2597     }
2598     _environ = _org_environ = env;
2599 }
2600
2601 #define ENTRY_POINT 0x10000
2602
2603 static int
2604 exe_is_aout(void)
2605 {
2606     struct layout_table_t *layout;
2607     if (emx_wasnt_initialized)
2608         return 0;
2609     /* Now we know that the principal executable is an EMX application
2610        - unless somebody did already play with delayed initialization... */
2611     /* With EMX applications to determine whether it is AOUT one needs
2612        to examine the start of the executable to find "layout" */
2613     if ( *(unsigned char*)ENTRY_POINT != 0x68           /* PUSH n */
2614          || *(unsigned char*)(ENTRY_POINT+5) != 0xe8    /* CALL */
2615          || *(unsigned char*)(ENTRY_POINT+10) != 0xeb   /* JMP */
2616          || *(unsigned char*)(ENTRY_POINT+12) != 0xe8)  /* CALL */
2617         return 0;                                       /* ! EMX executable */
2618     /* Fix alignment */
2619     Copy((char*)(ENTRY_POINT+1), &layout, 1, struct layout_table_t*);
2620     return !(layout->flags & 2);
2621 }
2622
2623 void
2624 Perl_OS2_init(char **env)
2625 {
2626     Perl_OS2_init3(env, 0, 0);
2627 }
2628
2629 void
2630 Perl_OS2_init3(char **env, void **preg, int flags)
2631 {
2632     char *shell;
2633
2634     _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
2635     MALLOC_INIT;
2636
2637     check_emx_runtime(env, (EXCEPTIONREGISTRATIONRECORD *)preg);
2638
2639     settmppath();
2640     OS2_Perl_data.xs_init = &Xs_OS2_init;
2641     if ( (shell = getenv("PERL_SH_DRIVE")) ) {
2642         New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2643         strcpy(PL_sh_path, SH_PATH);
2644         PL_sh_path[0] = shell[0];
2645     } else if ( (shell = getenv("PERL_SH_DIR")) ) {
2646         int l = strlen(shell), i;
2647         if (shell[l-1] == '/' || shell[l-1] == '\\') {
2648             l--;
2649         }
2650         New(1304, PL_sh_path, l + 8, char);
2651         strncpy(PL_sh_path, shell, l);
2652         strcpy(PL_sh_path + l, "/sh.exe");
2653         for (i = 0; i < l; i++) {
2654             if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2655         }
2656     }
2657     MUTEX_INIT(&start_thread_mutex);
2658     os2_mytype = my_type();             /* Do it before morphing.  Needed? */
2659     /* Some DLLs reset FP flags on load.  We may have been linked with them */
2660     _control87(MCW_EM, MCW_EM);
2661 }
2662
2663 #undef tmpnam
2664 #undef tmpfile
2665
2666 char *
2667 my_tmpnam (char *str)
2668 {
2669     char *p = getenv("TMP"), *tpath;
2670
2671     if (!p) p = getenv("TEMP");
2672     tpath = tempnam(p, "pltmp");
2673     if (str && tpath) {
2674         strcpy(str, tpath);
2675         return str;
2676     }
2677     return tpath;
2678 }
2679
2680 FILE *
2681 my_tmpfile ()
2682 {
2683     struct stat s;
2684
2685     stat(".", &s);
2686     if (s.st_mode & S_IWOTH) {
2687         return tmpfile();
2688     }
2689     return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2690                                              grants TMP. */
2691 }
2692
2693 #undef rmdir
2694
2695 int
2696 my_rmdir (__const__ char *s)
2697 {
2698     char buf[MAXPATHLEN];
2699     STRLEN l = strlen(s);
2700
2701     if (s[l-1] == '/' || s[l-1] == '\\') {      /* EMX rmdir fails... */
2702         strcpy(buf,s);
2703         buf[l - 1] = 0;
2704         s = buf;
2705     }
2706     return rmdir(s);
2707 }
2708
2709 #undef mkdir
2710
2711 int
2712 my_mkdir (__const__ char *s, long perm)
2713 {
2714     char buf[MAXPATHLEN];
2715     STRLEN l = strlen(s);
2716
2717     if (s[l-1] == '/' || s[l-1] == '\\') {      /* EMX mkdir fails... */
2718         strcpy(buf,s);
2719         buf[l - 1] = 0;
2720         s = buf;
2721     }
2722     return mkdir(s, perm);
2723 }
2724
2725 #undef flock
2726
2727 /* This code was contributed by Rocco Caputo. */
2728 int
2729 my_flock(int handle, int o)
2730 {
2731   FILELOCK      rNull, rFull;
2732   ULONG         timeout, handle_type, flag_word;
2733   APIRET        rc;
2734   int           blocking, shared;
2735   static int    use_my = -1;
2736
2737   if (use_my == -1) {
2738     char *s = getenv("USE_PERL_FLOCK");
2739     if (s)
2740         use_my = atoi(s);
2741     else
2742         use_my = 1;
2743   }
2744   if (!(_emx_env & 0x200) || !use_my)
2745     return flock(handle, o);    /* Delegate to EMX. */
2746
2747                                         /* is this a file? */
2748   if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2749       (handle_type & 0xFF))
2750   {
2751     errno = EBADF;
2752     return -1;
2753   }
2754                                         /* set lock/unlock ranges */
2755   rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2756   rFull.lRange = 0x7FFFFFFF;
2757                                         /* set timeout for blocking */
2758   timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2759                                         /* shared or exclusive? */
2760   shared = (o & LOCK_SH) ? 1 : 0;
2761                                         /* do not block the unlock */
2762   if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2763     rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2764     switch (rc) {
2765       case 0:
2766         errno = 0;
2767         return 0;
2768       case ERROR_INVALID_HANDLE:
2769         errno = EBADF;
2770         return -1;
2771       case ERROR_SHARING_BUFFER_EXCEEDED:
2772         errno = ENOLCK;
2773         return -1;
2774       case ERROR_LOCK_VIOLATION:
2775         break;                          /* not an error */
2776       case ERROR_INVALID_PARAMETER:
2777       case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2778       case ERROR_READ_LOCKS_NOT_SUPPORTED:
2779         errno = EINVAL;
2780         return -1;
2781       case ERROR_INTERRUPT:
2782         errno = EINTR;
2783         return -1;
2784       default:
2785         errno = EINVAL;
2786         return -1;
2787     }
2788   }
2789                                         /* lock may block */
2790   if (o & (LOCK_SH | LOCK_EX)) {
2791                                         /* for blocking operations */
2792     for (;;) {
2793       rc =
2794         DosSetFileLocks(
2795                 handle,
2796                 &rNull,
2797                 &rFull,
2798                 timeout,
2799                 shared
2800         );
2801       switch (rc) {
2802         case 0:
2803           errno = 0;
2804           return 0;
2805         case ERROR_INVALID_HANDLE:
2806           errno = EBADF;
2807           return -1;
2808         case ERROR_SHARING_BUFFER_EXCEEDED:
2809           errno = ENOLCK;
2810           return -1;
2811         case ERROR_LOCK_VIOLATION:
2812           if (!blocking) {
2813             errno = EWOULDBLOCK;
2814             return -1;
2815           }
2816           break;
2817         case ERROR_INVALID_PARAMETER:
2818         case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2819         case ERROR_READ_LOCKS_NOT_SUPPORTED:
2820           errno = EINVAL;
2821           return -1;
2822         case ERROR_INTERRUPT:
2823           errno = EINTR;
2824           return -1;
2825         default:
2826           errno = EINVAL;
2827           return -1;
2828       }
2829                                         /* give away timeslice */
2830       DosSleep(1);
2831     }
2832   }
2833
2834   errno = 0;
2835   return 0;
2836 }
2837
2838 static int pwent_cnt;
2839 static int _my_pwent = -1;
2840
2841 static int
2842 use_my_pwent(void)
2843 {
2844   if (_my_pwent == -1) {
2845     char *s = getenv("USE_PERL_PWENT");
2846     if (s)
2847         _my_pwent = atoi(s);
2848     else
2849         _my_pwent = 1;
2850   }
2851   return _my_pwent;
2852 }
2853
2854 #undef setpwent
2855 #undef getpwent
2856 #undef endpwent
2857
2858 void
2859 my_setpwent(void)
2860 {
2861   if (!use_my_pwent()) {
2862     setpwent();                 /* Delegate to EMX. */
2863     return;
2864   }
2865   pwent_cnt = 0;
2866 }
2867
2868 void
2869 my_endpwent(void)
2870 {
2871   if (!use_my_pwent()) {
2872     endpwent();                 /* Delegate to EMX. */
2873     return;
2874   }
2875 }
2876
2877 struct passwd *
2878 my_getpwent (void)
2879 {
2880   if (!use_my_pwent())
2881     return getpwent();                  /* Delegate to EMX. */
2882   if (pwent_cnt++)
2883     return 0;                           /* Return one entry only */
2884   return getpwuid(0);
2885 }
2886
2887 static int grent_cnt;
2888
2889 void
2890 setgrent(void)
2891 {
2892   grent_cnt = 0;
2893 }
2894
2895 void
2896 endgrent(void)
2897 {
2898 }
2899
2900 struct group *
2901 getgrent (void)
2902 {
2903   if (grent_cnt++)
2904     return 0;                           /* Return one entry only */
2905   return getgrgid(0);
2906 }
2907
2908 #undef getpwuid
2909 #undef getpwnam
2910
2911 /* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */
2912 static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
2913
2914 static struct passwd *
2915 passw_wrap(struct passwd *p)
2916 {
2917     static struct passwd pw;
2918     char *s;
2919
2920     if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
2921         return p;
2922     pw = *p;
2923     s = getenv("PW_PASSWD");
2924     if (!s)
2925         s = (char*)pw_p;                /* Make match impossible */
2926
2927     pw.pw_passwd = s;
2928     return &pw;
2929 }
2930
2931 struct passwd *
2932 my_getpwuid (uid_t id)
2933 {
2934     return passw_wrap(getpwuid(id));
2935 }
2936
2937 struct passwd *
2938 my_getpwnam (__const__ char *n)
2939 {
2940     return passw_wrap(getpwnam(n));
2941 }
2942
2943 char *
2944 gcvt_os2 (double value, int digits, char *buffer)
2945 {
2946   return gcvt (value, digits, buffer);
2947 }