os2/os2.c

   1 #define INCL_DOS
   2 #define INCL_NOPM
   3 #define INCL_DOSFILEMGR
   4 #define INCL_DOSMEMMGR
   5 #define INCL_DOSERRORS
   6 #define INCL_WINERRORS
   7 #define INCL_WINSYS
   8 /* These 3 are needed for compile if os2.h includes os2tk.h, not os2emx.h */
   9 #define INCL_DOSPROCESS
  10 #define SPU_DISABLESUPPRESSION          0
  11 #define SPU_ENABLESUPPRESSION           1
  12 #include <os2.h>
  13 #include "dlfcn.h"
  14 #include <emx/syscalls.h>
  15 #include <sys/emxload.h>
  16
  17 #include <sys/uflags.h>
  18
  19 /*
  20  * Various Unix compatibility functions for OS/2
  21  */
  22
  23 #include <stdio.h>
  24 #include <errno.h>
  25 #include <limits.h>
  26 #include <process.h>
  27 #include <fcntl.h>
  28 #include <pwd.h>
  29 #include <grp.h>
  30
  31 #define PERLIO_NOT_STDIO 0
  32
  33 #include "EXTERN.h"
  34 #include "perl.h"
  35
  36 enum module_name_how { mod_name_handle, mod_name_shortname, mod_name_full,
  37   mod_name_C_function = 0x100, mod_name_HMODULE = 0x200};
  38
  39 /* Find module name to which *this* subroutine is compiled */
  40 #define module_name(how)        module_name_at(&module_name_at, how)
  41
  42 static SV* module_name_at(void *pp, enum module_name_how how);
  43
  44 void
  45 croak_with_os2error(char *s)
  46 {
  47     Perl_croak_nocontext("%s: %s", s, os2error(Perl_rc));
  48 }
  49
  50 struct PMWIN_entries_t PMWIN_entries;
  51
  52 /*****************************************************************************/
  53 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
  54
  55 struct dll_handle_t {
  56     const char *modname;
  57     HMODULE handle;
  58     int requires_pm;
  59 };
  60
  61 static struct dll_handle_t dll_handles[] = {
  62     {"doscalls", 0, 0},
  63     {"tcp32dll", 0, 0},
  64     {"pmwin", 0, 1},
  65     {"rexx", 0, 0},
  66     {"rexxapi", 0, 0},
  67     {"sesmgr", 0, 0},
  68     {"pmshapi", 0, 1},
  69     {"pmwp", 0, 1},
  70     {"pmgpi", 0, 1},
  71     {NULL, 0},
  72 };
  73
  74 enum dll_handle_e {
  75     dll_handle_doscalls,
  76     dll_handle_tcp32dll,
  77     dll_handle_pmwin,
  78     dll_handle_rexx,
  79     dll_handle_rexxapi,
  80     dll_handle_sesmgr,
  81     dll_handle_pmshapi,
  82     dll_handle_pmwp,
  83     dll_handle_pmgpi,
  84     dll_handle_LAST,
  85 };
  86
  87 #define doscalls_handle         (dll_handles[dll_handle_doscalls])
  88 #define tcp_handle              (dll_handles[dll_handle_tcp32dll])
  89 #define pmwin_handle            (dll_handles[dll_handle_pmwin])
  90 #define rexx_handle             (dll_handles[dll_handle_rexx])
  91 #define rexxapi_handle          (dll_handles[dll_handle_rexxapi])
  92 #define sesmgr_handle           (dll_handles[dll_handle_sesmgr])
  93 #define pmshapi_handle          (dll_handles[dll_handle_pmshapi])
  94 #define pmwp_handle             (dll_handles[dll_handle_pmwp])
  95 #define pmgpi_handle            (dll_handles[dll_handle_pmgpi])
  96
  97 /*  The following local-scope data is not yet included:
  98        fargs.140                        // const => OK
  99        ino.165                          // locked - and the access is almost cosmetic
 100        layout_table.260                 // startup only, locked
 101        osv_res.257                      // startup only, locked
 102        old_esp.254                      // startup only, locked
 103        priors                           // const ==> OK
 104        use_my_flock.283                 // locked
 105        emx_init_done.268                // locked
 106        dll_handles                      // locked
 107        hmtx_emx_init.267                // THIS is the lock for startup
 108        perlos2_state_mutex              // THIS is the lock for all the rest
 109 BAD:
 110        perlos2_state                    // see below
 111 */
 112 /*  The following global-scope data is not yet included:
 113        OS2_Perl_data
 114        pthreads_states                  // const now?
 115        start_thread_mutex
 116        thread_join_count                // protected
 117        thread_join_data                 // protected
 118        tmppath
 119
 120        pDosVerifyPidTid
 121
 122        Perl_OS2_init3() - should it be protected?
 123 */
 124 OS2_Perl_data_t OS2_Perl_data;
 125
 126 static struct perlos2_state_t {
 127   int po2__my_pwent;                            /* = -1; */
 128   int po2_DOS_harderr_state;                    /* = -1;    */
 129   signed char po2_DOS_suppression_state;        /* = -1;    */
 130
 131   PFN po2_ExtFCN[ORD_NENTRIES]; /* Labeled by ord ORD_*. */
 132 /*  struct PMWIN_entries_t po2_PMWIN_entries; */
 133
 134   int po2_emx_wasnt_initialized;
 135
 136   char po2_fname[9];
 137   int po2_rmq_cnt;
 138
 139   int po2_grent_cnt;
 140
 141   char *po2_newp;
 142   char *po2_oldp;
 143   int po2_newl;
 144   int po2_oldl;
 145   int po2_notfound;
 146   char po2_mangle_ret[STATIC_FILE_LENGTH+1];
 147   ULONG po2_os2_dll_fake;
 148   ULONG po2_os2_mytype;
 149   ULONG po2_os2_mytype_ini;
 150   int po2_pidtid_lookup;
 151   struct passwd po2_pw;
 152
 153   int po2_pwent_cnt;
 154   char po2_pthreads_state_buf[80];
 155   char po2_os2error_buf[300];
 156 /* There is no big sense to make it thread-specific, since signals
 157    are delivered to thread 1 only.  XXXX Maybe make it into an array? */
 158   int po2_spawn_pid;
 159   int po2_spawn_killed;
 160
 161   jmp_buf po2_at_exit_buf;
 162   int po2_longjmp_at_exit;
 163   int po2_emx_runtime_init;             /* If 1, we need to manually init it */
 164   int po2_emx_exception_init;           /* If 1, we need to manually set it */
 165   int po2_emx_runtime_secondary;
 166   char* (*po2_perllib_mangle_installed)(char *s, unsigned int l);
 167   char* po2_perl_sh_installed;
 168   PGINFOSEG po2_gTable;
 169   PLINFOSEG po2_lTable;
 170 } perlos2_state = {
 171     -1,                                 /* po2__my_pwent */
 172     -1,                                 /* po2_DOS_harderr_state */
 173     -1,                                 /* po2_DOS_suppression_state */
 174 };
 175
 176 #define Perl_po2()              (&perlos2_state)
 177
 178 #define ExtFCN                  (Perl_po2()->po2_ExtFCN)
 179 /* #define PMWIN_entries                (Perl_po2()->po2_PMWIN_entries) */
 180 #define emx_wasnt_initialized   (Perl_po2()->po2_emx_wasnt_initialized)
 181 #define fname                   (Perl_po2()->po2_fname)
 182 #define rmq_cnt                 (Perl_po2()->po2_rmq_cnt)
 183 #define grent_cnt               (Perl_po2()->po2_grent_cnt)
 184 #define newp                    (Perl_po2()->po2_newp)
 185 #define oldp                    (Perl_po2()->po2_oldp)
 186 #define newl                    (Perl_po2()->po2_newl)
 187 #define oldl                    (Perl_po2()->po2_oldl)
 188 #define notfound                (Perl_po2()->po2_notfound)
 189 #define mangle_ret              (Perl_po2()->po2_mangle_ret)
 190 #define os2_dll_fake            (Perl_po2()->po2_os2_dll_fake)
 191 #define os2_mytype              (Perl_po2()->po2_os2_mytype)
 192 #define os2_mytype_ini          (Perl_po2()->po2_os2_mytype_ini)
 193 #define pidtid_lookup           (Perl_po2()->po2_pidtid_lookup)
 194 #define pw                      (Perl_po2()->po2_pw)
 195 #define pwent_cnt               (Perl_po2()->po2_pwent_cnt)
 196 #define _my_pwent               (Perl_po2()->po2__my_pwent)
 197 #define pthreads_state_buf      (Perl_po2()->po2_pthreads_state_buf)
 198 #define os2error_buf            (Perl_po2()->po2_os2error_buf)
 199 /* There is no big sense to make it thread-specific, since signals
 200    are delivered to thread 1 only.  XXXX Maybe make it into an array? */
 201 #define spawn_pid               (Perl_po2()->po2_spawn_pid)
 202 #define spawn_killed            (Perl_po2()->po2_spawn_killed)
 203 #define DOS_harderr_state       (Perl_po2()->po2_DOS_harderr_state)
 204 #define DOS_suppression_state           (Perl_po2()->po2_DOS_suppression_state)
 205
 206 #define at_exit_buf             (Perl_po2()->po2_at_exit_buf)
 207 #define longjmp_at_exit         (Perl_po2()->po2_longjmp_at_exit)
 208 #define emx_runtime_init        (Perl_po2()->po2_emx_runtime_init)
 209 #define emx_exception_init      (Perl_po2()->po2_emx_exception_init)
 210 #define emx_runtime_secondary   (Perl_po2()->po2_emx_runtime_secondary)
 211 #define perllib_mangle_installed        (Perl_po2()->po2_perllib_mangle_installed)
 212 #define perl_sh_installed       (Perl_po2()->po2_perl_sh_installed)
 213 #define gTable                  (Perl_po2()->po2_gTable)
 214 #define lTable                  (Perl_po2()->po2_lTable)
 215
 216 const Perl_PFN * const pExtFCN = (Perl_po2()->po2_ExtFCN);
 217
 218 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
 219
 220 typedef void (*emx_startroutine)(void *);
 221 typedef void* (*pthreads_startroutine)(void *);
 222
 223 enum pthreads_state {
 224     pthreads_st_none = 0,
 225     pthreads_st_run,
 226     pthreads_st_exited,
 227     pthreads_st_detached,
 228     pthreads_st_waited,
 229     pthreads_st_norun,
 230     pthreads_st_exited_waited,
 231 };
 232 const char * const pthreads_states[] = {
 233     "uninit",
 234     "running",
 235     "exited",
 236     "detached",
 237     "waited for",
 238     "could not start",
 239     "exited, then waited on",
 240 };
 241
 242 enum pthread_exists { pthread_not_existant = -0xff };
 243
 244 static const char*
 245 pthreads_state_string(enum pthreads_state state)
 246 {
 247   if (state < 0 || state >= sizeof(pthreads_states)/sizeof(*pthreads_states)) {
 248     snprintf(pthreads_state_buf, sizeof(pthreads_state_buf),
 249              "unknown thread state %d", (int)state);
 250     return pthreads_state_buf;
 251   }
 252   return pthreads_states[state];
 253 }
 254
 255 typedef struct {
 256     void *status;
 257     perl_cond cond;
 258     enum pthreads_state state;
 259 } thread_join_t;
 260
 261 thread_join_t *thread_join_data;
 262 int thread_join_count;
 263 perl_mutex start_thread_mutex;
 264 static perl_mutex perlos2_state_mutex;
 265
 266
 267 int
 268 pthread_join(perl_os_thread tid, void **status)
 269 {
 270     MUTEX_LOCK(&start_thread_mutex);
 271     if (tid < 1 || tid >= thread_join_count) {
 272         MUTEX_UNLOCK(&start_thread_mutex);
 273         if (tid != pthread_not_existant)
 274             Perl_croak_nocontext("panic: join with a thread with strange ordinal %d", (int)tid);
 275         Perl_warn_nocontext("panic: join with a thread which could not start");
 276         *status = 0;
 277         return 0;
 278     }
 279     switch (thread_join_data[tid].state) {
 280     case pthreads_st_exited:
 281         thread_join_data[tid].state = pthreads_st_exited_waited;
 282         *status = thread_join_data[tid].status;
 283         MUTEX_UNLOCK(&start_thread_mutex);
 284         COND_SIGNAL(&thread_join_data[tid].cond);
 285         break;
 286     case pthreads_st_waited:
 287         MUTEX_UNLOCK(&start_thread_mutex);
 288         Perl_croak_nocontext("join with a thread with a waiter");
 289         break;
 290     case pthreads_st_norun:
 291     {
 292         int state = (int)thread_join_data[tid].status;
 293
 294         thread_join_data[tid].state = pthreads_st_none;
 295         MUTEX_UNLOCK(&start_thread_mutex);
 296         Perl_croak_nocontext("panic: join with a thread which could not run"
 297                              " due to attempt of tid reuse (state='%s')",
 298                              pthreads_state_string(state));
 299         break;
 300     }
 301     case pthreads_st_run:
 302     {
 303         perl_cond cond;
 304
 305         thread_join_data[tid].state = pthreads_st_waited;
 306         thread_join_data[tid].status = (void *)status;
 307         COND_INIT(&thread_join_data[tid].cond);
 308         cond = thread_join_data[tid].cond;
 309         COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex);
 310         COND_DESTROY(&cond);
 311         MUTEX_UNLOCK(&start_thread_mutex);
 312         break;
 313     }
 314     default:
 315         MUTEX_UNLOCK(&start_thread_mutex);
 316         Perl_croak_nocontext("panic: join with thread in unknown thread state: '%s'",
 317               pthreads_state_string(thread_join_data[tid].state));
 318         break;
 319     }
 320     return 0;
 321 }
 322
 323 typedef struct {
 324   pthreads_startroutine sub;
 325   void *arg;
 326   void *ctx;
 327 } pthr_startit;
 328
 329 /* The lock is used:
 330         a) Since we temporarily usurp the caller interp, so malloc() may
 331            use it to decide on debugging the call;
 332         b) Since *args is on the caller's stack.
 333  */
 334 void
 335 pthread_startit(void *arg1)
 336 {
 337     /* Thread is already started, we need to transfer control only */
 338     pthr_startit args = *(pthr_startit *)arg1;
 339     int tid = pthread_self();
 340     void *rc;
 341     int state;
 342
 343     if (tid <= 1) {
 344         /* Can't croak, the setjmp() is not in scope... */
 345         char buf[80];
 346
 347         snprintf(buf, sizeof(buf),
 348                  "panic: thread with strange ordinal %d created\n\r", tid);
 349         write(2,buf,strlen(buf));
 350         MUTEX_UNLOCK(&start_thread_mutex);
 351         return;
 352     }
 353     /* Until args.sub resets it, makes debugging Perl_malloc() work: */
 354     PERL_SET_CONTEXT(0);
 355     if (tid >= thread_join_count) {
 356         int oc = thread_join_count;
 357
 358         thread_join_count = tid + 5 + tid/5;
 359         if (thread_join_data) {
 360             Renew(thread_join_data, thread_join_count, thread_join_t);
 361             Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
 362         } else {
 363             Newxz(thread_join_data, thread_join_count, thread_join_t);
 364         }
 365     }
 366     if (thread_join_data[tid].state != pthreads_st_none) {
 367         /* Can't croak, the setjmp() is not in scope... */
 368         char buf[80];
 369
 370         snprintf(buf, sizeof(buf),
 371                  "panic: attempt to reuse thread id %d (state='%s')\n\r",
 372                  tid, pthreads_state_string(thread_join_data[tid].state));
 373         write(2,buf,strlen(buf));
 374         thread_join_data[tid].status = (void*)thread_join_data[tid].state;
 375         thread_join_data[tid].state = pthreads_st_norun;
 376         MUTEX_UNLOCK(&start_thread_mutex);
 377         return;
 378     }
 379     thread_join_data[tid].state = pthreads_st_run;
 380     /* Now that we copied/updated the guys, we may release the caller... */
 381     MUTEX_UNLOCK(&start_thread_mutex);
 382     rc = (*args.sub)(args.arg);
 383     MUTEX_LOCK(&start_thread_mutex);
 384     switch (thread_join_data[tid].state) {
 385     case pthreads_st_waited:
 386         COND_SIGNAL(&thread_join_data[tid].cond);
 387         thread_join_data[tid].state = pthreads_st_none;
 388         *((void**)thread_join_data[tid].status) = rc;
 389         break;
 390     case pthreads_st_detached:
 391         thread_join_data[tid].state = pthreads_st_none;
 392         break;
 393     case pthreads_st_run:
 394         /* Somebody can wait on us; cannot exit, since OS can reuse the tid
 395            and our waiter will get somebody else's status. */
 396         thread_join_data[tid].state = pthreads_st_exited;
 397         thread_join_data[tid].status = rc;
 398         COND_INIT(&thread_join_data[tid].cond);
 399         COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex);
 400         COND_DESTROY(&thread_join_data[tid].cond);
 401         thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
 402         break;
 403     default:
 404         state = thread_join_data[tid].state;
 405         MUTEX_UNLOCK(&start_thread_mutex);
 406         Perl_croak_nocontext("panic: unexpected thread state on exit: '%s'",
 407                              pthreads_state_string(state));
 408     }
 409     MUTEX_UNLOCK(&start_thread_mutex);
 410 }
 411
 412 int
 413 pthread_create(perl_os_thread *tidp, const pthread_attr_t *attr,
 414                void *(*start_routine)(void*), void *arg)
 415 {
 416     dTHX;
 417     pthr_startit args;
 418
 419     args.sub = (void*)start_routine;
 420     args.arg = arg;
 421     args.ctx = PERL_GET_CONTEXT;
 422
 423     MUTEX_LOCK(&start_thread_mutex);
 424     /* Test suite creates 31 extra threads;
 425        on machine without shared-memory-hogs this stack sizeis OK with 31: */
 426     *tidp = _beginthread(pthread_startit, /*stack*/ NULL,
 427                          /*stacksize*/ 4*1024*1024, (void*)&args);
 428     if (*tidp == -1) {
 429         *tidp = pthread_not_existant;
 430         MUTEX_UNLOCK(&start_thread_mutex);
 431         return EINVAL;
 432     }
 433     MUTEX_LOCK(&start_thread_mutex);            /* Wait for init to proceed */
 434     MUTEX_UNLOCK(&start_thread_mutex);
 435     return 0;
 436 }
 437
 438 int
 439 pthread_detach(perl_os_thread tid)
 440 {
 441     MUTEX_LOCK(&start_thread_mutex);
 442     if (tid < 1 || tid >= thread_join_count) {
 443         MUTEX_UNLOCK(&start_thread_mutex);
 444         if (tid != pthread_not_existant)
 445             Perl_croak_nocontext("panic: detach of a thread with strange ordinal %d", (int)tid);
 446         Perl_warn_nocontext("detach of a thread which could not start");
 447         return 0;
 448     }
 449     switch (thread_join_data[tid].state) {
 450     case pthreads_st_waited:
 451         MUTEX_UNLOCK(&start_thread_mutex);
 452         Perl_croak_nocontext("detach on a thread with a waiter");
 453         break;
 454     case pthreads_st_run:
 455         thread_join_data[tid].state = pthreads_st_detached;
 456         MUTEX_UNLOCK(&start_thread_mutex);
 457         break;
 458     case pthreads_st_exited:
 459         MUTEX_UNLOCK(&start_thread_mutex);
 460         COND_SIGNAL(&thread_join_data[tid].cond);
 461         break;
 462     case pthreads_st_detached:
 463         MUTEX_UNLOCK(&start_thread_mutex);
 464         Perl_warn_nocontext("detach on an already detached thread");
 465         break;
 466     case pthreads_st_norun:
 467     {
 468         int state = (int)thread_join_data[tid].status;
 469
 470         thread_join_data[tid].state = pthreads_st_none;
 471         MUTEX_UNLOCK(&start_thread_mutex);
 472         Perl_croak_nocontext("panic: detaching thread which could not run"
 473                              " due to attempt of tid reuse (state='%s')",
 474                              pthreads_state_string(state));
 475         break;
 476     }
 477     default:
 478         MUTEX_UNLOCK(&start_thread_mutex);
 479         Perl_croak_nocontext("panic: detach of a thread with unknown thread state: '%s'",
 480               pthreads_state_string(thread_join_data[tid].state));
 481         break;
 482     }
 483     return 0;
 484 }
 485
 486 /* This is a very bastardized version; may be OK due to edge trigger of Wait */
 487 int
 488 os2_cond_wait(perl_cond *c, perl_mutex *m)
 489 {
 490     int rc;
 491     STRLEN n_a;
 492     if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET))
 493         Perl_rc = CheckOSError(rc), croak_with_os2error("panic: COND_WAIT-reset");
 494     if (m) MUTEX_UNLOCK(m);
 495     if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
 496         && (rc != ERROR_INTERRUPT))
 497         croak_with_os2error("panic: COND_WAIT");
 498     if (rc == ERROR_INTERRUPT)
 499         errno = EINTR;
 500     if (m) MUTEX_LOCK(m);
 501     return 0;
 502 }
 503 #endif
 504
 505 static int exe_is_aout(void);
 506
 507 /* This should match enum entries_ordinals defined in os2ish.h. */
 508 static const struct {
 509     struct dll_handle_t *dll;
 510     const char *entryname;
 511     int entrypoint;
 512 } loadOrdinals[] = {
 513   {&doscalls_handle, NULL, 874},        /* DosQueryExtLibpath */
 514   {&doscalls_handle, NULL, 873},        /* DosSetExtLibpath */
 515   {&doscalls_handle, NULL, 460},        /* DosVerifyPidTid */
 516   {&tcp_handle, "SETHOSTENT", 0},
 517   {&tcp_handle, "SETNETENT" , 0},
 518   {&tcp_handle, "SETPROTOENT", 0},
 519   {&tcp_handle, "SETSERVENT", 0},
 520   {&tcp_handle, "GETHOSTENT", 0},
 521   {&tcp_handle, "GETNETENT" , 0},
 522   {&tcp_handle, "GETPROTOENT", 0},
 523   {&tcp_handle, "GETSERVENT", 0},
 524   {&tcp_handle, "ENDHOSTENT", 0},
 525   {&tcp_handle, "ENDNETENT", 0},
 526   {&tcp_handle, "ENDPROTOENT", 0},
 527   {&tcp_handle, "ENDSERVENT", 0},
 528   {&pmwin_handle, NULL, 763},           /* WinInitialize */
 529   {&pmwin_handle, NULL, 716},           /* WinCreateMsgQueue */
 530   {&pmwin_handle, NULL, 726},           /* WinDestroyMsgQueue */
 531   {&pmwin_handle, NULL, 918},           /* WinPeekMsg */
 532   {&pmwin_handle, NULL, 915},           /* WinGetMsg */
 533   {&pmwin_handle, NULL, 912},           /* WinDispatchMsg */
 534   {&pmwin_handle, NULL, 753},           /* WinGetLastError */
 535   {&pmwin_handle, NULL, 705},           /* WinCancelShutdown */
 536         /* These are needed in extensions.
 537            How to protect PMSHAPI: it comes through EMX functions? */
 538   {&rexx_handle,    "RexxStart", 0},
 539   {&rexx_handle,    "RexxVariablePool", 0},
 540   {&rexxapi_handle, "RexxRegisterFunctionExe", 0},
 541   {&rexxapi_handle, "RexxDeregisterFunction", 0},
 542   {&sesmgr_handle,  "DOSSMSETTITLE", 0}, /* Would not work runtime-loaded */
 543   {&pmshapi_handle, "PRF32QUERYPROFILESIZE", 0},
 544   {&pmshapi_handle, "PRF32OPENPROFILE", 0},
 545   {&pmshapi_handle, "PRF32CLOSEPROFILE", 0},
 546   {&pmshapi_handle, "PRF32QUERYPROFILE", 0},
 547   {&pmshapi_handle, "PRF32RESET", 0},
 548   {&pmshapi_handle, "PRF32QUERYPROFILEDATA", 0},
 549   {&pmshapi_handle, "PRF32WRITEPROFILEDATA", 0},
 550
 551   /* At least some of these do not work by name, since they need
 552         WIN32 instead of WIN... */
 553 #if 0
 554   These were generated with
 555     nm I:\emx\lib\os2.a  | fgrep -f API-list | grep = > API-list-entries
 556     perl -wnle "next unless /^0+\s+E\s+_(\w+)=(\w+).(\d+)/; print qq(    ORD_$1,)" API-list-entries > API-list-ORD_
 557     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
 558 #endif
 559   {&pmshapi_handle, NULL, 123},         /* WinChangeSwitchEntry */
 560   {&pmshapi_handle, NULL, 124},         /* WinQuerySwitchEntry */
 561   {&pmshapi_handle, NULL, 125},         /* WinQuerySwitchHandle */
 562   {&pmshapi_handle, NULL, 126},         /* WinQuerySwitchList */
 563   {&pmshapi_handle, NULL, 131},         /* WinSwitchToProgram */
 564   {&pmwin_handle, NULL, 702},           /* WinBeginEnumWindows */
 565   {&pmwin_handle, NULL, 737},           /* WinEndEnumWindows */
 566   {&pmwin_handle, NULL, 740},           /* WinEnumDlgItem */
 567   {&pmwin_handle, NULL, 756},           /* WinGetNextWindow */
 568   {&pmwin_handle, NULL, 768},           /* WinIsChild */
 569   {&pmwin_handle, NULL, 799},           /* WinQueryActiveWindow */
 570   {&pmwin_handle, NULL, 805},           /* WinQueryClassName */
 571   {&pmwin_handle, NULL, 817},           /* WinQueryFocus */
 572   {&pmwin_handle, NULL, 834},           /* WinQueryWindow */
 573   {&pmwin_handle, NULL, 837},           /* WinQueryWindowPos */
 574   {&pmwin_handle, NULL, 838},           /* WinQueryWindowProcess */
 575   {&pmwin_handle, NULL, 841},           /* WinQueryWindowText */
 576   {&pmwin_handle, NULL, 842},           /* WinQueryWindowTextLength */
 577   {&pmwin_handle, NULL, 860},           /* WinSetFocus */
 578   {&pmwin_handle, NULL, 875},           /* WinSetWindowPos */
 579   {&pmwin_handle, NULL, 877},           /* WinSetWindowText */
 580   {&pmwin_handle, NULL, 883},           /* WinShowWindow */
 581   {&pmwin_handle, NULL, 772},           /* WinIsWindow */
 582   {&pmwin_handle, NULL, 899},           /* WinWindowFromId */
 583   {&pmwin_handle, NULL, 900},           /* WinWindowFromPoint */
 584   {&pmwin_handle, NULL, 919},           /* WinPostMsg */
 585   {&pmwin_handle, NULL, 735},           /* WinEnableWindow */
 586   {&pmwin_handle, NULL, 736},           /* WinEnableWindowUpdate */
 587   {&pmwin_handle, NULL, 773},           /* WinIsWindowEnabled */
 588   {&pmwin_handle, NULL, 774},           /* WinIsWindowShowing */
 589   {&pmwin_handle, NULL, 775},           /* WinIsWindowVisible */
 590   {&pmwin_handle, NULL, 839},           /* WinQueryWindowPtr */
 591   {&pmwin_handle, NULL, 843},           /* WinQueryWindowULong */
 592   {&pmwin_handle, NULL, 844},           /* WinQueryWindowUShort */
 593   {&pmwin_handle, NULL, 874},           /* WinSetWindowBits */
 594   {&pmwin_handle, NULL, 876},           /* WinSetWindowPtr */
 595   {&pmwin_handle, NULL, 878},           /* WinSetWindowULong */
 596   {&pmwin_handle, NULL, 879},           /* WinSetWindowUShort */
 597   {&pmwin_handle, NULL, 813},           /* WinQueryDesktopWindow */
 598   {&pmwin_handle, NULL, 851},           /* WinSetActiveWindow */
 599   {&doscalls_handle, NULL, 360},        /* DosQueryModFromEIP */
 600   {&doscalls_handle, NULL, 582},        /* Dos32QueryHeaderInfo */
 601   {&doscalls_handle, NULL, 362},        /* DosTmrQueryFreq */
 602   {&doscalls_handle, NULL, 363},        /* DosTmrQueryTime */
 603   {&pmwp_handle, NULL, 262},            /* WinQueryActiveDesktopPathname */
 604   {&pmwin_handle, NULL, 765},           /* WinInvalidateRect */
 605   {&pmwin_handle, NULL, 906},           /* WinCreateFrameControl */
 606   {&pmwin_handle, NULL, 807},           /* WinQueryClipbrdFmtInfo */
 607   {&pmwin_handle, NULL, 808},           /* WinQueryClipbrdOwner */
 608   {&pmwin_handle, NULL, 809},           /* WinQueryClipbrdViewer */
 609   {&pmwin_handle, NULL, 806},           /* WinQueryClipbrdData */
 610   {&pmwin_handle, NULL, 793},           /* WinOpenClipbrd */
 611   {&pmwin_handle, NULL, 707},           /* WinCloseClipbrd */
 612   {&pmwin_handle, NULL, 854},           /* WinSetClipbrdData */
 613   {&pmwin_handle, NULL, 855},           /* WinSetClipbrdOwner */
 614   {&pmwin_handle, NULL, 856},           /* WinSetClipbrdViewer */
 615   {&pmwin_handle, NULL, 739},           /* WinEnumClipbrdFmts  */
 616   {&pmwin_handle, NULL, 733},           /* WinEmptyClipbrd */
 617   {&pmwin_handle, NULL, 700},           /* WinAddAtom */
 618   {&pmwin_handle, NULL, 744},           /* WinFindAtom */
 619   {&pmwin_handle, NULL, 721},           /* WinDeleteAtom */
 620   {&pmwin_handle, NULL, 803},           /* WinQueryAtomUsage */
 621   {&pmwin_handle, NULL, 802},           /* WinQueryAtomName */
 622   {&pmwin_handle, NULL, 801},           /* WinQueryAtomLength */
 623   {&pmwin_handle, NULL, 830},           /* WinQuerySystemAtomTable */
 624   {&pmwin_handle, NULL, 714},           /* WinCreateAtomTable */
 625   {&pmwin_handle, NULL, 724},           /* WinDestroyAtomTable */
 626   {&pmwin_handle, NULL, 794},           /* WinOpenWindowDC */
 627   {&pmgpi_handle, NULL, 610},           /* DevOpenDC */
 628   {&pmgpi_handle, NULL, 606},           /* DevQueryCaps */
 629   {&pmgpi_handle, NULL, 604},           /* DevCloseDC */
 630   {&pmwin_handle, NULL, 789},           /* WinMessageBox */
 631   {&pmwin_handle, NULL, 1015},          /* WinMessageBox2 */
 632   {&pmwin_handle, NULL, 829},           /* WinQuerySysValue */
 633   {&pmwin_handle, NULL, 873},           /* WinSetSysValue */
 634   {&pmwin_handle, NULL, 701},           /* WinAlarm */
 635   {&pmwin_handle, NULL, 745},           /* WinFlashWindow */
 636   {&pmwin_handle, NULL, 780},           /* WinLoadPointer */
 637   {&pmwin_handle, NULL, 828},           /* WinQuerySysPointer */
 638   {&doscalls_handle, NULL, 417},        /* DosReplaceModule */
 639   {&doscalls_handle, NULL, 976},        /* DosPerfSysCall */
 640   {&rexxapi_handle, "RexxRegisterSubcomExe", 0},
 641 };
 642
 643 HMODULE
 644 loadModule(const char *modname, int fail)
 645 {
 646     HMODULE h = (HMODULE)dlopen(modname, 0);
 647
 648     if (!h && fail)
 649         Perl_croak_nocontext("Error loading module '%s': %s",
 650                              modname, dlerror());
 651     return h;
 652 }
 653
 654 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
 655
 656 static int
 657 my_type()
 658 {
 659     int rc;
 660     TIB *tib;
 661     PIB *pib;
 662
 663     if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
 664     if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
 665         return -1;
 666
 667     return (pib->pib_ultype);
 668 }
 669
 670 static void
 671 my_type_set(int type)
 672 {
 673     int rc;
 674     TIB *tib;
 675     PIB *pib;
 676
 677     if (!(_emx_env & 0x200))
 678         Perl_croak_nocontext("Can't set type on DOS"); /* not OS/2. */
 679     if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
 680         croak_with_os2error("Error getting info blocks");
 681     pib->pib_ultype = type;
 682 }
 683
 684 PFN
 685 loadByOrdinal(enum entries_ordinals ord, int fail)
 686 {
 687     if (sizeof(loadOrdinals)/sizeof(loadOrdinals[0]) != ORD_NENTRIES)
 688             Perl_croak_nocontext(
 689                  "Wrong size of loadOrdinals array: expected %d, actual %d",
 690                  sizeof(loadOrdinals)/sizeof(loadOrdinals[0]), ORD_NENTRIES);
 691     if (ExtFCN[ord] == NULL) {
 692         PFN fcn = (PFN)-1;
 693         APIRET rc;
 694
 695         if (!loadOrdinals[ord].dll->handle) {
 696             if (loadOrdinals[ord].dll->requires_pm && my_type() < 2) { /* FS */
 697                 char *s = getenv("PERL_ASIF_PM");
 698
 699                 if (!s || !atoi(s)) {
 700                     /* The module will not function well without PM.
 701                        The usual way to detect PM is the existence of the mutex
 702                        \SEM32\PMDRAG.SEM. */
 703                     HMTX hMtx = 0;
 704
 705                     if (CheckOSError(DosOpenMutexSem("\\SEM32\\PMDRAG.SEM",
 706                                                      &hMtx)))
 707                         Perl_croak_nocontext("Looks like we have no PM; will not load DLL %s without $ENV{PERL_ASIF_PM}",
 708                                              loadOrdinals[ord].dll->modname);
 709                     DosCloseMutexSem(hMtx);
 710                 }
 711             }
 712             MUTEX_LOCK(&perlos2_state_mutex);
 713             loadOrdinals[ord].dll->handle
 714                 = loadModule(loadOrdinals[ord].dll->modname, fail);
 715             MUTEX_UNLOCK(&perlos2_state_mutex);
 716         }
 717         if (!loadOrdinals[ord].dll->handle)
 718             return 0;                   /* Possible with FAIL==0 only */
 719         if (CheckOSError(DosQueryProcAddr(loadOrdinals[ord].dll->handle,
 720                                           loadOrdinals[ord].entrypoint,
 721                                           loadOrdinals[ord].entryname,&fcn))) {
 722             char buf[20], *s = (char*)loadOrdinals[ord].entryname;
 723
 724             if (!fail)
 725                 return 0;
 726             if (!s)
 727                 sprintf(s = buf, "%d", loadOrdinals[ord].entrypoint);
 728             Perl_croak_nocontext(
 729                  "This version of OS/2 does not support %s.%s",
 730                  loadOrdinals[ord].dll->modname, s);
 731         }
 732         ExtFCN[ord] = fcn;
 733     }
 734     if ((long)ExtFCN[ord] == -1)
 735         Perl_croak_nocontext("panic queryaddr");
 736     return ExtFCN[ord];
 737 }
 738
 739 void
 740 init_PMWIN_entries(void)
 741 {
 742     int i;
 743
 744     for (i = ORD_WinInitialize; i <= ORD_WinCancelShutdown; i++)
 745         ((PFN*)&PMWIN_entries)[i - ORD_WinInitialize] = loadByOrdinal(i, 1);
 746 }
 747
 748 /*****************************************************/
 749 /* socket forwarders without linking with tcpip DLLs */
 750
 751 DeclFuncByORD(struct hostent *,  gethostent,  ORD_GETHOSTENT,  (void), ())
 752 DeclFuncByORD(struct netent  *,  getnetent,   ORD_GETNETENT,   (void), ())
 753 DeclFuncByORD(struct protoent *, getprotoent, ORD_GETPROTOENT, (void), ())
 754 DeclFuncByORD(struct servent *,  getservent,  ORD_GETSERVENT,  (void), ())
 755
 756 DeclVoidFuncByORD(sethostent,  ORD_SETHOSTENT,  (int x), (x))
 757 DeclVoidFuncByORD(setnetent,   ORD_SETNETENT,   (int x), (x))
 758 DeclVoidFuncByORD(setprotoent, ORD_SETPROTOENT, (int x), (x))
 759 DeclVoidFuncByORD(setservent,  ORD_SETSERVENT,  (int x), (x))
 760
 761 DeclVoidFuncByORD(endhostent,  ORD_ENDHOSTENT,  (void), ())
 762 DeclVoidFuncByORD(endnetent,   ORD_ENDNETENT,   (void), ())
 763 DeclVoidFuncByORD(endprotoent, ORD_ENDPROTOENT, (void), ())
 764 DeclVoidFuncByORD(endservent,  ORD_ENDSERVENT,  (void), ())
 765
 766 /* priorities */
 767 static const signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
 768                                                      self inverse. */
 769 #define QSS_INI_BUFFER 1024
 770
 771 ULONG (*pDosVerifyPidTid) (PID pid, TID tid);
 772
 773 PQTOPLEVEL
 774 get_sysinfo(ULONG pid, ULONG flags)
 775 {
 776     char *pbuffer;
 777     ULONG rc, buf_len = QSS_INI_BUFFER;
 778     PQTOPLEVEL psi;
 779
 780     if (pid) {
 781         if (!pidtid_lookup) {
 782             pidtid_lookup = 1;
 783             *(PFN*)&pDosVerifyPidTid = loadByOrdinal(ORD_DosVerifyPidTid, 0);
 784         }
 785         if (pDosVerifyPidTid) { /* Warp3 or later */
 786             /* Up to some fixpak QuerySysState() kills the system if a non-existent
 787                pid is used. */
 788             if (CheckOSError(pDosVerifyPidTid(pid, 1)))
 789                 return 0;
 790         }
 791     }
 792     Newx(pbuffer, buf_len, char);
 793     /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
 794     rc = QuerySysState(flags, pid, pbuffer, buf_len);
 795     while (rc == ERROR_BUFFER_OVERFLOW) {
 796         Renew(pbuffer, buf_len *= 2, char);
 797         rc = QuerySysState(flags, pid, pbuffer, buf_len);
 798     }
 799     if (rc) {
 800         FillOSError(rc);
 801         Safefree(pbuffer);
 802         return 0;
 803     }
 804     psi = (PQTOPLEVEL)pbuffer;
 805     if (psi && pid && psi->procdata && pid != psi->procdata->pid) {
 806       Safefree(psi);
 807       Perl_croak_nocontext("panic: wrong pid in sysinfo");
 808     }
 809     return psi;
 810 }
 811
 812 #define PRIO_ERR 0x1111
 813
 814 static ULONG
 815 sys_prio(pid)
 816 {
 817   ULONG prio;
 818   PQTOPLEVEL psi;
 819
 820   if (!pid)
 821       return PRIO_ERR;
 822   psi = get_sysinfo(pid, QSS_PROCESS);
 823   if (!psi)
 824       return PRIO_ERR;
 825   prio = psi->procdata->threads->priority;
 826   Safefree(psi);
 827   return prio;
 828 }
 829
 830 int
 831 setpriority(int which, int pid, int val)
 832 {
 833   ULONG rc, prio = sys_prio(pid);
 834
 835   if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
 836   if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
 837       /* Do not change class. */
 838       return CheckOSError(DosSetPriority((pid < 0)
 839                                          ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
 840                                          0,
 841                                          (32 - val) % 32 - (prio & 0xFF),
 842                                          abs(pid)))
 843       ? -1 : 0;
 844   } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
 845       /* Documentation claims one can change both class and basevalue,
 846        * but I find it wrong. */
 847       /* Change class, but since delta == 0 denotes absolute 0, correct. */
 848       if (CheckOSError(DosSetPriority((pid < 0)
 849                                       ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
 850                                       priors[(32 - val) >> 5] + 1,
 851                                       0,
 852                                       abs(pid))))
 853           return -1;
 854       if ( ((32 - val) % 32) == 0 ) return 0;
 855       return CheckOSError(DosSetPriority((pid < 0)
 856                                          ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
 857                                          0,
 858                                          (32 - val) % 32,
 859                                          abs(pid)))
 860           ? -1 : 0;
 861   }
 862 }
 863
 864 int
 865 getpriority(int which /* ignored */, int pid)
 866 {
 867   ULONG ret;
 868
 869   if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
 870   ret = sys_prio(pid);
 871   if (ret == PRIO_ERR) {
 872       return -1;
 873   }
 874   return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
 875 }
 876
 877 /*****************************************************************************/
 878 /* spawn */
 879
 880
 881
 882 static Signal_t
 883 spawn_sighandler(int sig)
 884 {
 885     /* Some programs do not arrange for the keyboard signals to be
 886        delivered to them.  We need to deliver the signal manually. */
 887     /* We may get a signal only if
 888        a) kid does not receive keyboard signal: deliver it;
 889        b) kid already died, and we get a signal.  We may only hope
 890           that the pid number was not reused.
 891      */
 892
 893     if (spawn_killed)
 894         sig = SIGKILL;                  /* Try harder. */
 895     kill(spawn_pid, sig);
 896     spawn_killed = 1;
 897 }
 898
 899 static int
 900 result(pTHX_ int flag, int pid)
 901 {
 902         int r, status;
 903         Signal_t (*ihand)();     /* place to save signal during system() */
 904         Signal_t (*qhand)();     /* place to save signal during system() */
 905 #ifndef __EMX__
 906         RESULTCODES res;
 907         int rpid;
 908 #endif
 909
 910         if (pid < 0 || flag != 0)
 911                 return pid;
 912
 913 #ifdef __EMX__
 914         spawn_pid = pid;
 915         spawn_killed = 0;
 916         ihand = rsignal(SIGINT, &spawn_sighandler);
 917         qhand = rsignal(SIGQUIT, &spawn_sighandler);
 918         do {
 919             r = wait4pid(pid, &status, 0);
 920         } while (r == -1 && errno == EINTR);
 921         rsignal(SIGINT, ihand);
 922         rsignal(SIGQUIT, qhand);
 923
 924         PL_statusvalue = (U16)status;
 925         if (r < 0)
 926                 return -1;
 927         return status & 0xFFFF;
 928 #else
 929         ihand = rsignal(SIGINT, SIG_IGN);
 930         r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
 931         rsignal(SIGINT, ihand);
 932         PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
 933         if (r)
 934                 return -1;
 935         return PL_statusvalue;
 936 #endif
 937 }
 938
 939 enum execf_t {
 940   EXECF_SPAWN,
 941   EXECF_EXEC,
 942   EXECF_TRUEEXEC,
 943   EXECF_SPAWN_NOWAIT,
 944   EXECF_SPAWN_BYFLAG,
 945   EXECF_SYNC
 946 };
 947
 948 static ULONG
 949 file_type(char *path)
 950 {
 951     int rc;
 952     ULONG apptype;
 953
 954     if (!(_emx_env & 0x200))
 955         Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */
 956     if (CheckOSError(DosQueryAppType(path, &apptype))) {
 957         switch (rc) {
 958         case ERROR_FILE_NOT_FOUND:
 959         case ERROR_PATH_NOT_FOUND:
 960             return -1;
 961         case ERROR_ACCESS_DENIED:       /* Directory with this name found? */
 962             return -3;
 963         default:                        /* Found, but not an
 964                                            executable, or some other
 965                                            read error. */
 966             return -2;
 967         }
 968     }
 969     return apptype;
 970 }
 971
 972 /* Spawn/exec a program, revert to shell if needed. */
 973 /* global PL_Argv[] contains arguments. */
 974
 975 extern ULONG _emx_exception (   EXCEPTIONREPORTRECORD *,
 976                                 EXCEPTIONREGISTRATIONRECORD *,
 977                                 CONTEXTRECORD *,
 978                                 void *);
 979
 980 int
 981 do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
 982 {
 983         int trueflag = flag;
 984         int rc, pass = 1;
 985         char *real_name = NULL;                 /* Shut down the warning */
 986         char const * args[4];
 987         static const char * const fargs[4]
 988             = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
 989         const char * const *argsp = fargs;
 990         int nargs = 4;
 991         int force_shell;
 992         int new_stderr = -1, nostderr = 0;
 993         int fl_stderr = 0;
 994         STRLEN n_a;
 995         char *buf;
 996         PerlIO *file;
 997
 998         if (flag == P_WAIT)
 999                 flag = P_NOWAIT;
1000         if (really && !*(real_name = SvPV(really, n_a)))
1001             really = Nullsv;
1002
1003       retry:
1004         if (strEQ(PL_Argv[0],"/bin/sh"))
1005             PL_Argv[0] = PL_sh_path;
1006
1007         /* We should check PERL_SH* and PERLLIB_* as well? */
1008         if (!really || pass >= 2)
1009             real_name = PL_Argv[0];
1010         if (real_name[0] != '/' && real_name[0] != '\\'
1011             && !(real_name[0] && real_name[1] == ':'
1012                  && (real_name[2] == '/' || real_name[2] != '\\'))
1013             ) /* will spawnvp use PATH? */
1014             TAINT_ENV();        /* testing IFS here is overkill, probably */
1015
1016       reread:
1017         force_shell = 0;
1018         if (_emx_env & 0x200) { /* OS/2. */
1019             int type = file_type(real_name);
1020           type_again:
1021             if (type == -1) {           /* Not found */
1022                 errno = ENOENT;
1023                 rc = -1;
1024                 goto do_script;
1025             }
1026             else if (type == -2) {              /* Not an EXE */
1027                 errno = ENOEXEC;
1028                 rc = -1;
1029                 goto do_script;
1030             }
1031             else if (type == -3) {              /* Is a directory? */
1032                 /* Special-case this */
1033                 char tbuf[512];
1034                 int l = strlen(real_name);
1035
1036                 if (l + 5 <= sizeof tbuf) {
1037                     strcpy(tbuf, real_name);
1038                     strcpy(tbuf + l, ".exe");
1039                     type = file_type(tbuf);
1040                     if (type >= -3)
1041                         goto type_again;
1042                 }
1043
1044                 errno = ENOEXEC;
1045                 rc = -1;
1046                 goto do_script;
1047             }
1048             switch (type & 7) {
1049                 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
1050             case FAPPTYP_WINDOWAPI:
1051             {   /* Apparently, kids are started basing on startup type, not the morphed type */
1052                 if (os2_mytype != 3) {  /* not PM */
1053                     if (flag == P_NOWAIT)
1054                         flag = P_PM;
1055                     else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION && ckWARN(WARN_EXEC))
1056                         Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting PM process with flag=%d, mytype=%d",
1057                              flag, os2_mytype);
1058                 }
1059             }
1060             break;
1061             case FAPPTYP_NOTWINDOWCOMPAT:
1062             {
1063                 if (os2_mytype != 0) {  /* not full screen */
1064                     if (flag == P_NOWAIT)
1065                         flag = P_SESSION;
1066                     else if ((flag & 7) != P_SESSION && ckWARN(WARN_EXEC))
1067                         Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting Full Screen process with flag=%d, mytype=%d",
1068                              flag, os2_mytype);
1069                 }
1070             }
1071             break;
1072             case FAPPTYP_NOTSPEC:
1073                 /* Let the shell handle this... */
1074                 force_shell = 1;
1075                 buf = "";               /* Pacify a warning */
1076                 file = 0;               /* Pacify a warning */
1077                 goto doshell_args;
1078                 break;
1079             }
1080         }
1081
1082         if (addflag) {
1083             addflag = 0;
1084             new_stderr = dup(2);                /* Preserve stderr */
1085             if (new_stderr == -1) {
1086                 if (errno == EBADF)
1087                     nostderr = 1;
1088                 else {
1089                     rc = -1;
1090                     goto finish;
1091                 }
1092             } else
1093                 fl_stderr = fcntl(2, F_GETFD);
1094             rc = dup2(1,2);
1095             if (rc == -1)
1096                 goto finish;
1097             fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
1098         }
1099
1100 #if 0
1101         rc = result(aTHX_ trueflag, spawnvp(flag,real_name,PL_Argv));
1102 #else
1103         if (execf == EXECF_TRUEEXEC)
1104             rc = execvp(real_name,PL_Argv);
1105         else if (execf == EXECF_EXEC)
1106             rc = spawnvp(trueflag | P_OVERLAY,real_name,PL_Argv);
1107         else if (execf == EXECF_SPAWN_NOWAIT)
1108             rc = spawnvp(flag,real_name,PL_Argv);
1109         else if (execf == EXECF_SYNC)
1110             rc = spawnvp(trueflag,real_name,PL_Argv);
1111         else                            /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
1112             rc = result(aTHX_ trueflag,
1113                         spawnvp(flag,real_name,PL_Argv));
1114 #endif
1115         if (rc < 0 && pass == 1) {
1116               do_script:
1117           if (real_name == PL_Argv[0]) {
1118             int err = errno;
1119
1120             if (err == ENOENT || err == ENOEXEC) {
1121                 /* No such file, or is a script. */
1122                 /* Try adding script extensions to the file name, and
1123                    search on PATH. */
1124                 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
1125
1126                 if (scr) {
1127                     char *s = 0, *s1;
1128                     SV *scrsv = sv_2mortal(newSVpv(scr, 0));
1129                     SV *bufsv = sv_newmortal();
1130
1131                     Safefree(scr);
1132                     scr = SvPV(scrsv, n_a); /* free()ed later */
1133
1134                     file = PerlIO_open(scr, "r");
1135                     PL_Argv[0] = scr;
1136                     if (!file)
1137                         goto panic_file;
1138
1139                     buf = sv_gets(bufsv, file, 0 /* No append */);
1140                     if (!buf)
1141                         buf = "";       /* XXX Needed? */
1142                     if (!buf[0]) {      /* Empty... */
1143                         PerlIO_close(file);
1144                         /* Special case: maybe from -Zexe build, so
1145                            there is an executable around (contrary to
1146                            documentation, DosQueryAppType sometimes (?)
1147                            does not append ".exe", so we could have
1148                            reached this place). */
1149                         sv_catpv(scrsv, ".exe");
1150                         PL_Argv[0] = scr = SvPV(scrsv, n_a);    /* Reload */
1151                         if (PerlLIO_stat(scr,&PL_statbuf) >= 0
1152                             && !S_ISDIR(PL_statbuf.st_mode)) {  /* Found */
1153                                 real_name = scr;
1154                                 pass++;
1155                                 goto reread;
1156                         } else {                /* Restore */
1157                                 SvCUR_set(scrsv, SvCUR(scrsv) - 4);
1158                                 *SvEND(scrsv) = 0;
1159                         }
1160                     }
1161                     if (PerlIO_close(file) != 0) { /* Failure */
1162                       panic_file:
1163                         if (ckWARN(WARN_EXEC))
1164                            Perl_warner(aTHX_ packWARN(WARN_EXEC), "Error reading \"%s\": %s",
1165                              scr, Strerror(errno));
1166                         buf = "";       /* Not #! */
1167                         goto doshell_args;
1168                     }
1169                     if (buf[0] == '#') {
1170                         if (buf[1] == '!')
1171                             s = buf + 2;
1172                     } else if (buf[0] == 'e') {
1173                         if (strnEQ(buf, "extproc", 7)
1174                             && isSPACE(buf[7]))
1175                             s = buf + 8;
1176                     } else if (buf[0] == 'E') {
1177                         if (strnEQ(buf, "EXTPROC", 7)
1178                             && isSPACE(buf[7]))
1179                             s = buf + 8;
1180                     }
1181                     if (!s) {
1182                         buf = "";       /* Not #! */
1183                         goto doshell_args;
1184                     }
1185
1186                     s1 = s;
1187                     nargs = 0;
1188                     argsp = args;
1189                     while (1) {
1190                         /* Do better than pdksh: allow a few args,
1191                            strip trailing whitespace.  */
1192                         while (isSPACE(*s))
1193                             s++;
1194                         if (*s == 0)
1195                             break;
1196                         if (nargs == 4) {
1197                             nargs = -1;
1198                             break;
1199                         }
1200                         args[nargs++] = s;
1201                         while (*s && !isSPACE(*s))
1202                             s++;
1203                         if (*s == 0)
1204                             break;
1205                         *s++ = 0;
1206                     }
1207                     if (nargs == -1) {
1208                         Perl_warner(aTHX_ packWARN(WARN_EXEC), "Too many args on %.*s line of \"%s\"",
1209                              s1 - buf, buf, scr);
1210                         nargs = 4;
1211                         argsp = fargs;
1212                     }
1213                     /* Can jump from far, buf/file invalid if force_shell: */
1214                   doshell_args:
1215                     {
1216                         char **a = PL_Argv;
1217                         const char *exec_args[2];
1218
1219                         if (force_shell
1220                             || (!buf[0] && file)) { /* File without magic */
1221                             /* In fact we tried all what pdksh would
1222                                try.  There is no point in calling
1223                                pdksh, we may just emulate its logic. */
1224                             char *shell = getenv("EXECSHELL");
1225                             char *shell_opt = NULL;
1226
1227                             if (!shell) {
1228                                 char *s;
1229
1230                                 shell_opt = "/c";
1231                                 shell = getenv("OS2_SHELL");
1232                                 if (inicmd) { /* No spaces at start! */
1233                                     s = inicmd;
1234                                     while (*s && !isSPACE(*s)) {
1235                                         if (*s++ == '/') {
1236                                             inicmd = NULL; /* Cannot use */
1237                                             break;
1238                                         }
1239                                     }
1240                                 }
1241                                 if (!inicmd) {
1242                                     s = PL_Argv[0];
1243                                     while (*s) {
1244                                         /* Dosish shells will choke on slashes
1245                                            in paths, fortunately, this is
1246                                            important for zeroth arg only. */
1247                                         if (*s == '/')
1248                                             *s = '\\';
1249                                         s++;
1250                                     }
1251                                 }
1252                             }
1253                             /* If EXECSHELL is set, we do not set */
1254
1255                             if (!shell)
1256                                 shell = ((_emx_env & 0x200)
1257                                          ? "c:/os2/cmd.exe"
1258                                          : "c:/command.com");
1259                             nargs = shell_opt ? 2 : 1;  /* shell file args */
1260                             exec_args[0] = shell;
1261                             exec_args[1] = shell_opt;
1262                             argsp = exec_args;
1263                             if (nargs == 2 && inicmd) {
1264                                 /* Use the original cmd line */
1265                                 /* XXXX This is good only until we refuse
1266                                         quoted arguments... */
1267                                 PL_Argv[0] = inicmd;
1268                                 PL_Argv[1] = Nullch;
1269                             }
1270                         } else if (!buf[0] && inicmd) { /* No file */
1271                             /* Start with the original cmdline. */
1272                             /* XXXX This is good only until we refuse
1273                                     quoted arguments... */
1274
1275                             PL_Argv[0] = inicmd;
1276                             PL_Argv[1] = Nullch;
1277                             nargs = 2;  /* shell -c */
1278                         }
1279
1280                         while (a[1])            /* Get to the end */
1281                             a++;
1282                         a++;                    /* Copy finil NULL too */
1283                         while (a >= PL_Argv) {
1284                             *(a + nargs) = *a;  /* PL_Argv was preallocated to be
1285                                                    long enough. */
1286                             a--;
1287                         }
1288                         while (--nargs >= 0) /* XXXX Discard const... */
1289                             PL_Argv[nargs] = (char*)argsp[nargs];
1290                         /* Enable pathless exec if #! (as pdksh). */
1291                         pass = (buf[0] == '#' ? 2 : 3);
1292                         goto retry;
1293                     }
1294                 }
1295                 /* Not found: restore errno */
1296                 errno = err;
1297             }
1298           } else if (errno == ENOEXEC) { /* Cannot transfer `real_name' via shell. */
1299                 if (rc < 0 && ckWARN(WARN_EXEC))
1300                     Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s script `%s' with ARGV[0] being `%s'",
1301                          ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1302                           ? "spawn" : "exec"),
1303                          real_name, PL_Argv[0]);
1304                 goto warned;
1305           } else if (errno == ENOENT) { /* Cannot transfer `real_name' via shell. */
1306                 if (rc < 0 && ckWARN(WARN_EXEC))
1307                     Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)",
1308                          ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1309                           ? "spawn" : "exec"),
1310                          real_name, PL_Argv[0]);
1311                 goto warned;
1312           }
1313         } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
1314             char *no_dir = strrchr(PL_Argv[0], '/');
1315
1316             /* Do as pdksh port does: if not found with /, try without
1317                path. */
1318             if (no_dir) {
1319                 PL_Argv[0] = no_dir + 1;
1320                 pass++;
1321                 goto retry;
1322             }
1323         }
1324         if (rc < 0 && ckWARN(WARN_EXEC))
1325             Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s\n",
1326                  ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1327                   ? "spawn" : "exec"),
1328                  real_name, Strerror(errno));
1329       warned:
1330         if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
1331             && ((trueflag & 0xFF) == P_WAIT))
1332             rc = -1;
1333
1334   finish:
1335     if (new_stderr != -1) {     /* How can we use error codes? */
1336         dup2(new_stderr, 2);
1337         close(new_stderr);
1338         fcntl(2, F_SETFD, fl_stderr);
1339     } else if (nostderr)
1340        close(2);
1341     return rc;
1342 }
1343
1344 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
1345 int
1346 do_spawn3(pTHX_ char *cmd, int execf, int flag)
1347 {
1348     register char **a;
1349     register char *s;
1350     char *shell, *copt, *news = NULL;
1351     int rc, seenspace = 0, mergestderr = 0;
1352
1353 #ifdef TRYSHELL
1354     if ((shell = getenv("EMXSHELL")) != NULL)
1355         copt = "-c";
1356     else if ((shell = getenv("SHELL")) != NULL)
1357         copt = "-c";
1358     else if ((shell = getenv("COMSPEC")) != NULL)
1359         copt = "/C";
1360     else
1361         shell = "cmd.exe";
1362 #else
1363     /* Consensus on perl5-porters is that it is _very_ important to
1364        have a shell which will not change between computers with the
1365        same architecture, to avoid "action on a distance".
1366        And to have simple build, this shell should be sh. */
1367     shell = PL_sh_path;
1368     copt = "-c";
1369 #endif
1370
1371     while (*cmd && isSPACE(*cmd))
1372         cmd++;
1373
1374     if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
1375         STRLEN l = strlen(PL_sh_path);
1376
1377         Newx(news, strlen(cmd) - 7 + l + 1, char);
1378         strcpy(news, PL_sh_path);
1379         strcpy(news + l, cmd + 7);
1380         cmd = news;
1381     }
1382
1383     /* save an extra exec if possible */
1384     /* see if there are shell metacharacters in it */
1385
1386     if (*cmd == '.' && isSPACE(cmd[1]))
1387         goto doshell;
1388
1389     if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
1390         goto doshell;
1391
1392     for (s = cmd; *s && isALPHA(*s); s++) ;     /* catch VAR=val gizmo */
1393     if (*s == '=')
1394         goto doshell;
1395
1396     for (s = cmd; *s; s++) {
1397         if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
1398             if (*s == '\n' && s[1] == '\0') {
1399                 *s = '\0';
1400                 break;
1401             } else if (*s == '\\' && !seenspace) {
1402                 continue;               /* Allow backslashes in names */
1403             } else if (*s == '>' && s >= cmd + 3
1404                         && s[-1] == '2' && s[1] == '&' && s[2] == '1'
1405                         && isSPACE(s[-2]) ) {
1406                 char *t = s + 3;
1407
1408                 while (*t && isSPACE(*t))
1409                     t++;
1410                 if (!*t) {
1411                     s[-2] = '\0';
1412                     mergestderr = 1;
1413                     break;              /* Allow 2>&1 as the last thing */
1414                 }
1415             }
1416             /* We do not convert this to do_spawn_ve since shell
1417                should be smart enough to start itself gloriously. */
1418           doshell:
1419             if (execf == EXECF_TRUEEXEC)
1420                 rc = execl(shell,shell,copt,cmd,(char*)0);
1421             else if (execf == EXECF_EXEC)
1422                 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
1423             else if (execf == EXECF_SPAWN_NOWAIT)
1424                 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
1425             else if (execf == EXECF_SPAWN_BYFLAG)
1426                 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
1427             else {
1428                 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
1429                 if (execf == EXECF_SYNC)
1430                    rc = spawnl(P_WAIT,shell,shell,copt,cmd,(char*)0);
1431                 else
1432                    rc = result(aTHX_ P_WAIT,
1433                                spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
1434                 if (rc < 0 && ckWARN(WARN_EXEC))
1435                     Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
1436                          (execf == EXECF_SPAWN ? "spawn" : "exec"),
1437                          shell, Strerror(errno));
1438                 if (rc < 0)
1439                     rc = -1;
1440             }
1441             if (news)
1442                 Safefree(news);
1443             return rc;
1444         } else if (*s == ' ' || *s == '\t') {
1445             seenspace = 1;
1446         }
1447     }
1448
1449     /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
1450     Newx(PL_Argv, (s - cmd + 11) / 2, char*);
1451     PL_Cmd = savepvn(cmd, s-cmd);
1452     a = PL_Argv;
1453     for (s = PL_Cmd; *s;) {
1454         while (*s && isSPACE(*s)) s++;
1455         if (*s)
1456             *(a++) = s;
1457         while (*s && !isSPACE(*s)) s++;
1458         if (*s)
1459             *s++ = '\0';
1460     }
1461     *a = Nullch;
1462     if (PL_Argv[0])
1463         rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr);
1464     else
1465         rc = -1;
1466     if (news)
1467         Safefree(news);
1468     do_execfree();
1469     return rc;
1470 }
1471
1472 #define ASPAWN_WAIT     0
1473 #define ASPAWN_EXEC     1
1474 #define ASPAWN_NOWAIT   2
1475
1476 /* Array spawn/exec.  */
1477 int
1478 os2_aspawn_4(pTHX_ SV *really, register SV **args, I32 cnt, int execing)
1479 {
1480     register SV **argp = (SV **)args;
1481     register SV **last = argp + cnt;
1482     register char **a;
1483     int rc;
1484     int flag = P_WAIT, flag_set = 0;
1485     STRLEN n_a;
1486
1487     if (cnt) {
1488         Newx(PL_Argv, cnt + 3, char*); /* 3 extra to expand #! */
1489         a = PL_Argv;
1490
1491         if (cnt > 1 && SvNIOKp(*argp) && !SvPOKp(*argp)) {
1492             flag = SvIVx(*argp);
1493             flag_set = 1;
1494         } else
1495             --argp;
1496
1497         while (++argp < last) {
1498             if (*argp)
1499                 *a++ = SvPVx(*argp, n_a);
1500             else
1501                 *a++ = "";
1502         }
1503         *a = Nullch;
1504
1505         if ( flag_set && (a == PL_Argv + 1)
1506              && !really && execing == ASPAWN_WAIT ) {           /* One arg? */
1507             rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
1508         } else {
1509             const int execf[3] = {EXECF_SPAWN, EXECF_EXEC, EXECF_SPAWN_NOWAIT};
1510
1511             rc = do_spawn_ve(aTHX_ really, flag, execf[execing], NULL, 0);
1512         }
1513     } else
1514         rc = -1;
1515     do_execfree();
1516     return rc;
1517 }
1518
1519 /* Array spawn.  */
1520 int
1521 os2_do_aspawn(pTHX_ SV *really, register SV **vmark, register SV **vsp)
1522 {
1523     return os2_aspawn_4(aTHX_ really, vmark + 1, vsp - vmark, ASPAWN_WAIT);
1524 }
1525
1526 /* Array exec.  */
1527 bool
1528 Perl_do_aexec(pTHX_ SV* really, SV** vmark, SV** vsp)
1529 {
1530     return os2_aspawn_4(aTHX_ really, vmark + 1, vsp - vmark, ASPAWN_EXEC);
1531 }
1532
1533 int
1534 os2_do_spawn(pTHX_ char *cmd)
1535 {
1536     return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
1537 }
1538
1539 int
1540 do_spawn_nowait(pTHX_ char *cmd)
1541 {
1542     return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
1543 }
1544
1545 bool
1546 Perl_do_exec(pTHX_ const char *cmd)
1547 {
1548     do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
1549     return FALSE;
1550 }
1551
1552 bool
1553 os2exec(pTHX_ char *cmd)
1554 {
1555     return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
1556 }
1557
1558 PerlIO *
1559 my_syspopen4(pTHX_ char *cmd, char *mode, I32 cnt, SV** args)
1560 {
1561 #ifndef USE_POPEN
1562     int p[2];
1563     register I32 this, that, newfd;
1564     register I32 pid;
1565     SV *sv;
1566     int fh_fl = 0;                      /* Pacify the warning */
1567
1568     /* `this' is what we use in the parent, `that' in the child. */
1569     this = (*mode == 'w');
1570     that = !this;
1571     if (PL_tainting) {
1572         taint_env();
1573         taint_proper("Insecure %s%s", "EXEC");
1574     }
1575     if (pipe(p) < 0)
1576         return Nullfp;
1577     /* Now we need to spawn the child. */
1578     if (p[this] == (*mode == 'r')) {    /* if fh 0/1 was initially closed. */
1579         int new = dup(p[this]);
1580
1581         if (new == -1)
1582             goto closepipes;
1583         close(p[this]);
1584         p[this] = new;
1585     }
1586     newfd = dup(*mode == 'r');          /* Preserve std* */
1587     if (newfd == -1) {
1588         /* This cannot happen due to fh being bad after pipe(), since
1589            pipe() should have created fh 0 and 1 even if they were
1590            initially closed.  But we closed p[this] before.  */
1591         if (errno != EBADF) {
1592           closepipes:
1593             close(p[0]);
1594             close(p[1]);
1595             return Nullfp;
1596         }
1597     } else
1598         fh_fl = fcntl(*mode == 'r', F_GETFD);
1599     if (p[that] != (*mode == 'r')) {    /* if fh 0/1 was initially closed. */
1600         dup2(p[that], *mode == 'r');
1601         close(p[that]);
1602     }
1603     /* Where is `this' and newfd now? */
1604     fcntl(p[this], F_SETFD, FD_CLOEXEC);
1605     if (newfd != -1)
1606         fcntl(newfd, F_SETFD, FD_CLOEXEC);
1607     if (cnt) {  /* Args: "Real cmd", before first arg, the last, execing */
1608         pid = os2_aspawn_4(aTHX_ Nullsv, args, cnt, ASPAWN_NOWAIT);
1609     } else
1610         pid = do_spawn_nowait(aTHX_ cmd);
1611     if (newfd == -1)
1612         close(*mode == 'r');            /* It was closed initially */
1613     else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
1614         dup2(newfd, *mode == 'r');      /* Return std* back. */
1615         close(newfd);
1616         fcntl(*mode == 'r', F_SETFD, fh_fl);
1617     } else
1618         fcntl(*mode == 'r', F_SETFD, fh_fl);
1619     if (p[that] == (*mode == 'r'))
1620         close(p[that]);
1621     if (pid == -1) {
1622         close(p[this]);
1623         return Nullfp;
1624     }
1625     if (p[that] < p[this]) {            /* Make fh as small as possible */
1626         dup2(p[this], p[that]);
1627         close(p[this]);
1628         p[this] = p[that];
1629     }
1630     sv = *av_fetch(PL_fdpid,p[this],TRUE);
1631     (void)SvUPGRADE(sv,SVt_IV);
1632     SvIVX(sv) = pid;
1633     PL_forkprocess = pid;
1634     return PerlIO_fdopen(p[this], mode);
1635
1636 #else  /* USE_POPEN */
1637
1638     PerlIO *res;
1639     SV *sv;
1640
1641     if (cnt)
1642         Perl_croak(aTHX_ "List form of piped open not implemented");
1643
1644 #  ifdef TRYSHELL
1645     res = popen(cmd, mode);
1646 #  else
1647     char *shell = getenv("EMXSHELL");
1648
1649     my_setenv("EMXSHELL", PL_sh_path);
1650     res = popen(cmd, mode);
1651     my_setenv("EMXSHELL", shell);
1652 #  endif
1653     sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1654     (void)SvUPGRADE(sv,SVt_IV);
1655     SvIVX(sv) = -1;                     /* A cooky. */
1656     return res;
1657
1658 #endif /* USE_POPEN */
1659
1660 }
1661
1662 PerlIO *
1663 my_syspopen(pTHX_ char *cmd, char *mode)
1664 {
1665     return my_syspopen4(aTHX_ cmd, mode, 0, NULL);
1666 }
1667
1668 /******************************************************************/
1669
1670 #ifndef HAS_FORK
1671 int
1672 fork(void)
1673 {
1674     Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
1675     errno = EINVAL;
1676     return -1;
1677 }
1678 #endif
1679
1680 /*******************************************************************/
1681 /* not implemented in EMX 0.9d */
1682
1683 char *  ctermid(char *s)        { return 0; }
1684
1685 #ifdef MYTTYNAME /* was not in emx0.9a */
1686 void *  ttyname(x)      { return 0; }
1687 #endif
1688
1689 /*****************************************************************************/
1690 /* not implemented in C Set++ */
1691
1692 #ifndef __EMX__
1693 int     setuid(x)       { errno = EINVAL; return -1; }
1694 int     setgid(x)       { errno = EINVAL; return -1; }
1695 #endif
1696
1697 /*****************************************************************************/
1698 /* stat() hack for char/block device */
1699
1700 #if OS2_STAT_HACK
1701
1702 enum os2_stat_extra {   /* EMX 0.9d fix 4 defines up to 0100000 */
1703   os2_stat_archived     = 0x1000000,    /* 0100000000 */
1704   os2_stat_hidden       = 0x2000000,    /* 0200000000 */
1705   os2_stat_system       = 0x4000000,    /* 0400000000 */
1706   os2_stat_force        = 0x8000000,    /* Do not ignore flags on chmod */
1707 };
1708
1709 #define OS2_STAT_SPECIAL (os2_stat_system | os2_stat_archived | os2_stat_hidden)
1710
1711 static void
1712 massage_os2_attr(struct stat *st)
1713 {
1714     if ( ((st->st_mode & S_IFMT) != S_IFREG
1715           && (st->st_mode & S_IFMT) != S_IFDIR)
1716          || !(st->st_attr & (FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM)))
1717         return;
1718
1719     if ( st->st_attr & FILE_ARCHIVED )
1720         st->st_mode |= (os2_stat_archived | os2_stat_force);
1721     if ( st->st_attr & FILE_HIDDEN )
1722         st->st_mode |= (os2_stat_hidden | os2_stat_force);
1723     if ( st->st_attr & FILE_SYSTEM )
1724         st->st_mode |= (os2_stat_system | os2_stat_force);
1725 }
1726
1727     /* First attempt used DosQueryFSAttach which crashed the system when
1728        used with 5.001. Now just look for /dev/. */
1729 int
1730 os2_stat(const char *name, struct stat *st)
1731 {
1732     static int ino = SHRT_MAX;
1733     STRLEN l = strlen(name);
1734
1735     if ( ( l < 8 || l > 9) || strnicmp(name, "/dev/", 5) != 0
1736          || (    stricmp(name + 5, "con") != 0
1737               && stricmp(name + 5, "tty") != 0
1738               && stricmp(name + 5, "nul") != 0
1739               && stricmp(name + 5, "null") != 0) ) {
1740         int s = stat(name, st);
1741
1742         if (s)
1743             return s;
1744         massage_os2_attr(st);
1745         return 0;
1746     }
1747
1748     memset(st, 0, sizeof *st);
1749     st->st_mode = S_IFCHR|0666;
1750     MUTEX_LOCK(&perlos2_state_mutex);
1751     st->st_ino = (ino-- & 0x7FFF);
1752     MUTEX_UNLOCK(&perlos2_state_mutex);
1753     st->st_nlink = 1;
1754     return 0;
1755 }
1756
1757 int
1758 os2_fstat(int handle, struct stat *st)
1759 {
1760     int s = fstat(handle, st);
1761
1762     if (s)
1763         return s;
1764     massage_os2_attr(st);
1765     return 0;
1766 }
1767
1768 #undef chmod
1769 int
1770 os2_chmod (const char *name, int pmode) /* Modelled after EMX src/lib/io/chmod.c */
1771 {
1772     int attr, rc;
1773
1774     if (!(pmode & os2_stat_force))
1775         return chmod(name, pmode);
1776
1777     attr = __chmod (name, 0, 0);           /* Get attributes */
1778     if (attr < 0)
1779         return -1;
1780     if (pmode & S_IWRITE)
1781         attr &= ~FILE_READONLY;
1782     else
1783         attr |= FILE_READONLY;
1784     /* New logic */
1785     attr &= ~(FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM);
1786
1787     if ( pmode & os2_stat_archived )
1788         attr |= FILE_ARCHIVED;
1789     if ( pmode & os2_stat_hidden )
1790         attr |= FILE_HIDDEN;
1791     if ( pmode & os2_stat_system )
1792         attr |= FILE_SYSTEM;
1793
1794     rc = __chmod (name, 1, attr);
1795     if (rc >= 0) rc = 0;
1796     return rc;
1797 }
1798
1799 #endif
1800
1801 #ifdef USE_PERL_SBRK
1802
1803 /* SBRK() emulation, mostly moved to malloc.c. */
1804
1805 void *
1806 sys_alloc(int size) {
1807     void *got;
1808     APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1809
1810     if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1811         return (void *) -1;
1812     } else if ( rc )
1813         Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
1814     return got;
1815 }
1816
1817 #endif /* USE_PERL_SBRK */
1818
1819 /* tmp path */
1820
1821 const char *tmppath = TMPPATH1;
1822
1823 void
1824 settmppath()
1825 {
1826     char *p = getenv("TMP"), *tpath;
1827     int len;
1828
1829     if (!p) p = getenv("TEMP");
1830     if (!p) p = getenv("TMPDIR");
1831     if (!p) return;
1832     len = strlen(p);
1833     tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1834     if (tpath) {
1835         strcpy(tpath, p);
1836         tpath[len] = '/';
1837         strcpy(tpath + len + 1, TMPPATH1);
1838         tmppath = tpath;
1839     }
1840 }
1841
1842 #include "XSUB.h"
1843
1844 XS(XS_File__Copy_syscopy)
1845 {
1846     dXSARGS;
1847     if (items < 2 || items > 3)
1848         Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
1849     {
1850         STRLEN n_a;
1851         char *  src = (char *)SvPV(ST(0),n_a);
1852         char *  dst = (char *)SvPV(ST(1),n_a);
1853         U32     flag;
1854         int     RETVAL, rc;
1855         dXSTARG;
1856
1857         if (items < 3)
1858             flag = 0;
1859         else {
1860             flag = (unsigned long)SvIV(ST(2));
1861         }
1862
1863         RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1864         XSprePUSH; PUSHi((IV)RETVAL);
1865     }
1866     XSRETURN(1);
1867 }
1868
1869 /* APIRET APIENTRY DosReplaceModule (PCSZ pszOld, PCSZ pszNew, PCSZ pszBackup); */
1870
1871 DeclOSFuncByORD(ULONG,replaceModule,ORD_DosReplaceModule,
1872                 (char *old, char *new, char *backup), (old, new, backup))
1873
1874 XS(XS_OS2_replaceModule); /* prototype to pass -Wmissing-prototypes */
1875 XS(XS_OS2_replaceModule)
1876 {
1877     dXSARGS;
1878     if (items < 1 || items > 3)
1879         Perl_croak(aTHX_ "Usage: OS2::replaceModule(target [, source [, backup]])");
1880     {
1881         char *  target = (char *)SvPV_nolen(ST(0));
1882         char *  source = (items < 2) ? Nullch : (char *)SvPV_nolen(ST(1));
1883         char *  backup = (items < 3) ? Nullch : (char *)SvPV_nolen(ST(2));
1884
1885         if (!replaceModule(target, source, backup))
1886             croak_with_os2error("replaceModule() error");
1887     }
1888     XSRETURN_YES;
1889 }
1890
1891 /* APIRET APIENTRY DosPerfSysCall(ULONG ulCommand, ULONG ulParm1,
1892                                   ULONG ulParm2, ULONG ulParm3); */
1893
1894 DeclOSFuncByORD(ULONG,perfSysCall,ORD_DosPerfSysCall,
1895                 (ULONG ulCommand, ULONG ulParm1, ULONG ulParm2, ULONG ulParm3),
1896                 (ulCommand, ulParm1, ulParm2, ulParm3))
1897
1898 #ifndef CMD_KI_RDCNT
1899 #  define CMD_KI_RDCNT  0x63
1900 #endif
1901 #ifndef CMD_KI_GETQTY
1902 #  define CMD_KI_GETQTY 0x41
1903 #endif
1904 #ifndef QSV_NUMPROCESSORS
1905 #  define QSV_NUMPROCESSORS         26
1906 #endif
1907
1908 typedef unsigned long long myCPUUTIL[4];        /* time/idle/busy/intr */
1909
1910 /*
1911 NO_OUTPUT ULONG
1912 perfSysCall(ULONG ulCommand, ULONG ulParm1, ULONG ulParm2, ULONG ulParm3)
1913     PREINIT:
1914         ULONG rc;
1915     POSTCALL:
1916         if (!RETVAL)
1917             croak_with_os2error("perfSysCall() error");
1918  */
1919
1920 static int
1921 numprocessors(void)
1922 {
1923     ULONG res;
1924
1925     if (DosQuerySysInfo(QSV_NUMPROCESSORS, QSV_NUMPROCESSORS, (PVOID)&res, sizeof(res)))
1926         return 1;                       /* Old system? */
1927     return res;
1928 }
1929
1930 XS(XS_OS2_perfSysCall); /* prototype to pass -Wmissing-prototypes */
1931 XS(XS_OS2_perfSysCall)
1932 {
1933     dXSARGS;
1934     if (items < 0 || items > 4)
1935         Perl_croak(aTHX_ "Usage: OS2::perfSysCall(ulCommand = CMD_KI_RDCNT, ulParm1= 0, ulParm2= 0, ulParm3= 0)");
1936     SP -= items;
1937     {
1938         dXSTARG;
1939         ULONG RETVAL, ulCommand, ulParm1, ulParm2, ulParm3, res;
1940         myCPUUTIL u[64];
1941         int total = 0, tot2 = 0;
1942
1943         if (items < 1)
1944             ulCommand = CMD_KI_RDCNT;
1945         else {
1946             ulCommand = (ULONG)SvUV(ST(0));
1947         }
1948
1949         if (items < 2) {
1950             total = (ulCommand == CMD_KI_RDCNT ? numprocessors() : 0);
1951             ulParm1 = (total ? (ULONG)u : 0);
1952
1953             if (total > C_ARRAY_LENGTH(u))
1954                 croak("Unexpected number of processors: %d", total);
1955         } else {
1956             ulParm1 = (ULONG)SvUV(ST(1));
1957         }
1958
1959         if (items < 3) {
1960             tot2 = (ulCommand == CMD_KI_GETQTY);
1961             ulParm2 = (tot2 ? (ULONG)&res : 0);
1962         } else {
1963             ulParm2 = (ULONG)SvUV(ST(2));
1964         }
1965
1966         if (items < 4)
1967             ulParm3 = 0;
1968         else {
1969             ulParm3 = (ULONG)SvUV(ST(3));
1970         }
1971
1972         RETVAL = perfSysCall(ulCommand, ulParm1, ulParm2, ulParm3);
1973         if (!RETVAL)
1974             croak_with_os2error("perfSysCall() error");
1975         XSprePUSH;
1976         if (total) {
1977             int i,j;
1978
1979             if (GIMME_V != G_ARRAY) {
1980                 PUSHn(u[0][0]);         /* Total ticks on the first processor */
1981                 XSRETURN(1);
1982             }
1983             EXTEND(SP, 4*total);
1984             for (i=0; i < total; i++)
1985                 for (j=0; j < 4; j++)
1986                     PUSHs(sv_2mortal(newSVnv(u[i][j])));
1987             XSRETURN(4*total);
1988         }
1989         if (tot2) {
1990             PUSHu(res);
1991             XSRETURN(1);
1992         }
1993     }
1994     XSRETURN_EMPTY;
1995 }
1996
1997 #define PERL_PATCHLEVEL_H_IMPLICIT      /* Do not init local_patches. */
1998 #include "patchlevel.h"
1999 #undef PERL_PATCHLEVEL_H_IMPLICIT
2000
2001 char *
2002 mod2fname(pTHX_ SV *sv)
2003 {
2004     int pos = 6, len, avlen;
2005     unsigned int sum = 0;
2006     char *s;
2007     STRLEN n_a;
2008
2009     if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
2010     sv = SvRV(sv);
2011     if (SvTYPE(sv) != SVt_PVAV)
2012       Perl_croak_nocontext("Not array reference given to mod2fname");
2013
2014     avlen = av_len((AV*)sv);
2015     if (avlen < 0)
2016       Perl_croak_nocontext("Empty array reference given to mod2fname");
2017
2018     s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
2019     strncpy(fname, s, 8);
2020     len = strlen(s);
2021     if (len < 6) pos = len;
2022     while (*s) {
2023         sum = 33 * sum + *(s++);        /* Checksumming first chars to
2024                                          * get the capitalization into c.s. */
2025     }
2026     avlen --;
2027     while (avlen >= 0) {
2028         s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
2029         while (*s) {
2030             sum = 33 * sum + *(s++);    /* 7 is primitive mod 13. */
2031         }
2032         avlen --;
2033     }
2034    /* We always load modules as *specific* DLLs, and with the full name.
2035       When loading a specific DLL by its full name, one cannot get a
2036       different DLL, even if a DLL with the same basename is loaded already.
2037       Thus there is no need to include the version into the mangling scheme. */
2038 #if 0
2039     sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2;  /* Up to 5.6.1 */
2040 #else
2041 #  ifndef COMPATIBLE_VERSION_SUM  /* Binary compatibility with the 5.00553 binary */
2042 #    define COMPATIBLE_VERSION_SUM (5 * 200 + 53 * 2)
2043 #  endif
2044     sum += COMPATIBLE_VERSION_SUM;
2045 #endif
2046     fname[pos] = 'A' + (sum % 26);
2047     fname[pos + 1] = 'A' + (sum / 26 % 26);
2048     fname[pos + 2] = '\0';
2049     return (char *)fname;
2050 }
2051
2052 XS(XS_DynaLoader_mod2fname)
2053 {
2054     dXSARGS;
2055     if (items != 1)
2056         Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
2057     {
2058         SV *    sv = ST(0);
2059         char *  RETVAL;
2060         dXSTARG;
2061
2062         RETVAL = mod2fname(aTHX_ sv);
2063         sv_setpv(TARG, RETVAL);
2064         XSprePUSH; PUSHTARG;
2065     }
2066     XSRETURN(1);
2067 }
2068
2069 char *
2070 os2error(int rc)
2071 {
2072         dTHX;
2073         ULONG len;
2074         char *s;
2075         int number = SvTRUE(get_sv("OS2::nsyserror", TRUE));
2076
2077         if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
2078         if (rc == 0)
2079                 return "";
2080         if (number) {
2081             sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc);
2082             s = os2error_buf + strlen(os2error_buf);
2083         } else
2084             s = os2error_buf;
2085         if (DosGetMessage(NULL, 0, s, sizeof(os2error_buf) - 1 - (s-os2error_buf),
2086                           rc, "OSO001.MSG", &len)) {
2087             char *name = "";
2088
2089             if (!number) {
2090                 sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc);
2091                 s = os2error_buf + strlen(os2error_buf);
2092             }
2093             switch (rc) {
2094             case PMERR_INVALID_HWND:
2095                 name = "PMERR_INVALID_HWND";
2096                 break;
2097             case PMERR_INVALID_HMQ:
2098                 name = "PMERR_INVALID_HMQ";
2099                 break;
2100             case PMERR_CALL_FROM_WRONG_THREAD:
2101                 name = "PMERR_CALL_FROM_WRONG_THREAD";
2102                 break;
2103             case PMERR_NO_MSG_QUEUE:
2104                 name = "PMERR_NO_MSG_QUEUE";
2105                 break;
2106             case PMERR_NOT_IN_A_PM_SESSION:
2107                 name = "PMERR_NOT_IN_A_PM_SESSION";
2108                 break;
2109             case PMERR_INVALID_ATOM:
2110                 name = "PMERR_INVALID_ATOM";
2111                 break;
2112             case PMERR_INVALID_HATOMTBL:
2113                 name = "PMERR_INVALID_HATOMTMB";
2114                 break;
2115             case PMERR_INVALID_INTEGER_ATOM:
2116                 name = "PMERR_INVALID_INTEGER_ATOM";
2117                 break;
2118             case PMERR_INVALID_ATOM_NAME:
2119                 name = "PMERR_INVALID_ATOM_NAME";
2120                 break;
2121             case PMERR_ATOM_NAME_NOT_FOUND:
2122                 name = "PMERR_ATOM_NAME_NOT_FOUND";
2123                 break;
2124             }
2125             sprintf(s, "%s%s[No description found in OSO001.MSG]",
2126                     name, (*name ? "=" : ""));
2127         } else {
2128                 s[len] = '\0';
2129                 if (len && s[len - 1] == '\n')
2130                         s[--len] = 0;
2131                 if (len && s[len - 1] == '\r')
2132                         s[--len] = 0;
2133                 if (len && s[len - 1] == '.')
2134                         s[--len] = 0;
2135                 if (len >= 10 && number && strnEQ(s, os2error_buf, 7)
2136                     && s[7] == ':' && s[8] == ' ')
2137                     /* Some messages start with SYSdddd:, some not */
2138                     Move(s + 9, s, (len -= 9) + 1, char);
2139         }
2140         return os2error_buf;
2141 }
2142
2143 void
2144 ResetWinError(void)
2145 {
2146   WinError_2_Perl_rc;
2147 }
2148
2149 void
2150 CroakWinError(int die, char *name)
2151 {
2152   FillWinError;
2153   if (die && Perl_rc)
2154     croak_with_os2error(name ? name : "Win* API call");
2155 }
2156
2157 static char *
2158 dllname2buffer(pTHX_ char *buf, STRLEN l)
2159 {
2160     char *o;
2161     STRLEN ll;
2162     SV *dll = Nullsv;
2163
2164     dll = module_name(mod_name_full);
2165     o = SvPV(dll, ll);
2166     if (ll < l)
2167        memcpy(buf,o,ll);
2168     SvREFCNT_dec(dll);
2169     return (ll >= l ? "???" : buf);
2170 }
2171
2172 static char *
2173 execname2buffer(char *buf, STRLEN l, char *oname)
2174 {
2175   char *p, *orig = oname, ok = oname != NULL;
2176
2177   if (_execname(buf, l) != 0) {
2178     if (!oname || strlen(oname) >= l)
2179       return oname;
2180     strcpy(buf, oname);
2181     ok = 0;
2182   }
2183   p = buf;
2184   while (*p) {
2185     if (*p == '\\')
2186         *p = '/';
2187     if (*p == '/') {
2188         if (ok && *oname != '/' && *oname != '\\')
2189             ok = 0;
2190     } else if (ok && tolower(*oname) != tolower(*p))
2191         ok = 0;
2192     p++;
2193     oname++;
2194   }
2195   if (ok) { /* orig matches the real name.  Use orig: */
2196      strcpy(buf, orig);         /* _execname() is always uppercased */
2197      p = buf;
2198      while (*p) {
2199        if (*p == '\\')
2200            *p = '/';
2201        p++;
2202      }
2203   }
2204   return buf;
2205 }
2206
2207 char *
2208 os2_execname(pTHX)
2209 {
2210   char buf[300], *p = execname2buffer(buf, sizeof buf, PL_origargv[0]);
2211
2212   p = savepv(p);
2213   SAVEFREEPV(p);
2214   return p;
2215 }
2216
2217 int
2218 Perl_OS2_handler_install(void *handler, enum Perlos2_handler how)
2219 {
2220     char *s, b[300];
2221
2222     switch (how) {
2223       case Perlos2_handler_mangle:
2224         perllib_mangle_installed = (char *(*)(char *s, unsigned int l))handler;
2225         return 1;
2226       case Perlos2_handler_perl_sh:
2227         s = (char *)handler;
2228         s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perl_sh");
2229         perl_sh_installed = savepv(s);
2230         return 1;
2231       case Perlos2_handler_perllib_from:
2232         s = (char *)handler;
2233         s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perllib_from");
2234         oldl = strlen(s);
2235         oldp = savepv(s);
2236         return 1;
2237       case Perlos2_handler_perllib_to:
2238         s = (char *)handler;
2239         s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perllib_to");
2240         newl = strlen(s);
2241         newp = savepv(s);
2242         strcpy(mangle_ret, newp);
2243         s = mangle_ret - 1;
2244         while (*++s)
2245             if (*s == '\\')
2246                 *s = '/';
2247         return 1;
2248       default:
2249         return 0;
2250     }
2251 }
2252
2253 /* Returns a malloc()ed copy */
2254 char *
2255 dir_subst(char *s, unsigned int l, char *b, unsigned int bl, enum dir_subst_e flags, char *msg)
2256 {
2257     char *from, *to = b, *e = b; /* `to' assignment: shut down the warning */
2258     STRLEN froml = 0, tol = 0, rest = 0;        /* froml: likewise */
2259
2260     if (l >= 2 && s[0] == '~') {
2261         switch (s[1]) {
2262           case 'i': case 'I':
2263             from = "installprefix";     break;
2264           case 'd': case 'D':
2265             from = "dll";               break;
2266           case 'e': case 'E':
2267             from = "exe";               break;
2268           default:
2269             from = NULL;
2270             froml = l + 1;                      /* Will not match */
2271             break;
2272         }
2273         if (from)
2274             froml = strlen(from) + 1;
2275         if (l >= froml && strnicmp(s + 2, from + 1, froml - 2) == 0) {
2276             int strip = 1;
2277
2278             switch (s[1]) {
2279               case 'i': case 'I':
2280                 strip = 0;
2281                 tol = strlen(INSTALL_PREFIX);
2282                 if (tol >= bl) {
2283                     if (flags & dir_subst_fatal)
2284                         Perl_croak_nocontext("INSTALL_PREFIX too long: `%s'", INSTALL_PREFIX);
2285                     else
2286                         return NULL;
2287                 }
2288                 memcpy(b, INSTALL_PREFIX, tol + 1);
2289                 to = b;
2290                 e = b + tol;
2291                 break;
2292               case 'd': case 'D':
2293                 if (flags & dir_subst_fatal) {
2294                     dTHX;
2295
2296                     to = dllname2buffer(aTHX_ b, bl);
2297                 } else {                                /* No Perl present yet */
2298                     HMODULE self = find_myself();
2299                     APIRET rc = DosQueryModuleName(self, bl, b);
2300
2301                     if (rc)
2302                         return 0;
2303                     to = b - 1;
2304                     while (*++to)
2305                         if (*to == '\\')
2306                             *to = '/';
2307                     to = b;
2308                 }
2309                 break;
2310               case 'e': case 'E':
2311                 if (flags & dir_subst_fatal) {
2312                     dTHX;
2313
2314                     to = execname2buffer(b, bl, PL_origargv[0]);
2315                 } else
2316                     to = execname2buffer(b, bl, NULL);
2317                 break;
2318             }
2319             if (!to)
2320                 return NULL;
2321             if (strip) {
2322                 e = strrchr(to, '/');
2323                 if (!e && (flags & dir_subst_fatal))
2324                     Perl_croak_nocontext("%s: Can't parse EXE/DLL name: '%s'", msg, to);
2325                 else if (!e)
2326                     return NULL;
2327                 *e = 0;
2328             }
2329             s += froml; l -= froml;
2330             if (!l)
2331                 return to;
2332             if (!tol)
2333                 tol = strlen(to);
2334
2335             while (l >= 3 && (s[0] == '/' || s[0] == '\\')
2336                    && s[1] == '.' && s[2] == '.'
2337                    && (l == 3 || s[3] == '/' || s[3] == '\\' || s[3] == ';')) {
2338                 e = strrchr(b, '/');
2339                 if (!e && (flags & dir_subst_fatal))
2340                         Perl_croak_nocontext("%s: Error stripping dirs from EXE/DLL/INSTALLDIR name", msg);
2341                 else if (!e)
2342                         return NULL;
2343                 *e = 0;
2344                 l -= 3; s += 3;
2345             }
2346             if (l && s[0] != '/' && s[0] != '\\' && s[0] != ';')
2347                 *e++ = '/';
2348         }
2349     }                                           /* Else: copy as is */
2350     if (l && (flags & dir_subst_pathlike)) {
2351         STRLEN i = 0;
2352
2353         while ( i < l - 2 && s[i] != ';')       /* May have ~char after `;' */
2354             i++;
2355         if (i < l - 2) {                        /* Found */
2356             rest = l - i - 1;
2357             l = i + 1;
2358         }
2359     }
2360     if (e + l >= b + bl) {
2361         if (flags & dir_subst_fatal)
2362             Perl_croak_nocontext("%s: name `%s%s' too long", msg, b, s);
2363         else
2364             return NULL;
2365     }
2366     memcpy(e, s, l);
2367     if (rest) {
2368         e = dir_subst(s + l, rest, e + l, bl - (e + l - b), flags, msg);
2369         return e ? b : e;
2370     }
2371     e[l] = 0;
2372     return b;
2373 }
2374
2375 char *
2376 perllib_mangle_with(char *s, unsigned int l, char *from, unsigned int froml, char *to, unsigned int tol)
2377 {
2378     if (!to)
2379         return s;
2380     if (l == 0)
2381         l = strlen(s);
2382     if (l < froml || strnicmp(from, s, froml) != 0)
2383         return s;
2384     if (l + tol - froml > STATIC_FILE_LENGTH || tol > STATIC_FILE_LENGTH)
2385         Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
2386     if (to && to != mangle_ret)
2387         memcpy(mangle_ret, to, tol);
2388     strcpy(mangle_ret + tol, s + froml);
2389     return mangle_ret;
2390 }
2391
2392 char *
2393 perllib_mangle(char *s, unsigned int l)
2394 {
2395     char *name;
2396
2397     if (perllib_mangle_installed && (name = perllib_mangle_installed(s,l)))
2398         return name;
2399     if (!newp && !notfound) {
2400         newp = getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION)
2401                       STRINGIFY(PERL_VERSION) STRINGIFY(PERL_SUBVERSION)
2402                       "_PREFIX");
2403         if (!newp)
2404             newp = getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION)
2405                           STRINGIFY(PERL_VERSION) "_PREFIX");
2406         if (!newp)
2407             newp = getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION) "_PREFIX");
2408         if (!newp)
2409             newp = getenv(name = "PERLLIB_PREFIX");
2410         if (newp) {
2411             char *s, b[300];
2412
2413             oldp = newp;
2414             while (*newp && !isSPACE(*newp) && *newp != ';')
2415                 newp++;                 /* Skip old name. */
2416             oldl = newp - oldp;
2417             s = dir_subst(oldp, oldl, b, sizeof b, dir_subst_fatal, name);
2418             oldp = savepv(s);
2419             oldl = strlen(s);
2420             while (*newp && (isSPACE(*newp) || *newp == ';'))
2421                 newp++;                 /* Skip whitespace. */
2422             Perl_OS2_handler_install((void *)newp, Perlos2_handler_perllib_to);
2423             if (newl == 0 || oldl == 0)
2424                 Perl_croak_nocontext("Malformed %s", name);
2425         } else
2426             notfound = 1;
2427     }
2428     if (!newp)
2429         return s;
2430     if (l == 0)
2431         l = strlen(s);
2432     if (l < oldl || strnicmp(oldp, s, oldl) != 0)
2433         return s;
2434     if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH)
2435         Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
2436     strcpy(mangle_ret + newl, s + oldl);
2437     return mangle_ret;
2438 }
2439
2440 unsigned long
2441 Perl_hab_GET()                  /* Needed if perl.h cannot be included */
2442 {
2443     return perl_hab_GET();
2444 }
2445
2446 static void
2447 Create_HMQ(int serve, char *message)    /* Assumes morphing */
2448 {
2449     unsigned fpflag = _control87(0,0);
2450
2451     init_PMWIN_entries();
2452     /* 64 messages if before OS/2 3.0, ignored otherwise */
2453     Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
2454     if (!Perl_hmq) {
2455         dTHX;
2456
2457         SAVEINT(rmq_cnt);               /* Allow catch()ing. */
2458         if (rmq_cnt++)
2459             _exit(188);         /* Panic can try to create a window. */
2460         CroakWinError(1, message ? message : "Cannot create a message queue");
2461     }
2462     if (serve != -1)
2463         (*PMWIN_entries.CancelShutdown)(Perl_hmq, !serve);
2464     /* We may have loaded some modules */
2465     _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
2466 }
2467
2468 #define REGISTERMQ_WILL_SERVE           1
2469 #define REGISTERMQ_IMEDIATE_UNMORPH     2
2470
2471 HMQ
2472 Perl_Register_MQ(int serve)
2473 {
2474   if (Perl_hmq_refcnt <= 0) {
2475     PPIB pib;
2476     PTIB tib;
2477
2478     Perl_hmq_refcnt = 0;                /* Be extra safe */
2479     DosGetInfoBlocks(&tib, &pib);
2480     if (!Perl_morph_refcnt) {
2481         Perl_os2_initial_mode = pib->pib_ultype;
2482         /* Try morphing into a PM application. */
2483         if (pib->pib_ultype != 3)               /* 2 is VIO */
2484             pib->pib_ultype = 3;                /* 3 is PM */
2485     }
2486     Create_HMQ(-1,                      /* We do CancelShutdown ourselves */
2487                "Cannot create a message queue, or morph to a PM application");
2488     if ((serve & REGISTERMQ_IMEDIATE_UNMORPH)) {
2489         if (!Perl_morph_refcnt && Perl_os2_initial_mode != 3)
2490             pib->pib_ultype = Perl_os2_initial_mode;
2491     }
2492   }
2493     if (serve & REGISTERMQ_WILL_SERVE) {
2494         if ( Perl_hmq_servers <= 0      /* Safe to inform us on shutdown, */
2495              && Perl_hmq_refcnt > 0 )   /* this was switched off before... */
2496             (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0);
2497         Perl_hmq_servers++;
2498     } else if (!Perl_hmq_servers)       /* Do not inform us on shutdown */
2499         (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
2500     Perl_hmq_refcnt++;
2501     if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH))
2502         Perl_morph_refcnt++;
2503     return Perl_hmq;
2504 }
2505
2506 int
2507 Perl_Serve_Messages(int force)
2508 {
2509     int cnt = 0;
2510     QMSG msg;
2511
2512     if (Perl_hmq_servers > 0 && !force)
2513         return 0;
2514     if (Perl_hmq_refcnt <= 0)
2515         Perl_croak_nocontext("No message queue");
2516     while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
2517         cnt++;
2518         if (msg.msg == WM_QUIT)
2519             Perl_croak_nocontext("QUITing...");
2520         (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
2521     }
2522     return cnt;
2523 }
2524
2525 int
2526 Perl_Process_Messages(int force, I32 *cntp)
2527 {
2528     QMSG msg;
2529
2530     if (Perl_hmq_servers > 0 && !force)
2531         return 0;
2532     if (Perl_hmq_refcnt <= 0)
2533         Perl_croak_nocontext("No message queue");
2534     while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
2535         if (cntp)
2536             (*cntp)++;
2537         (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
2538         if (msg.msg == WM_DESTROY)
2539             return -1;
2540         if (msg.msg == WM_CREATE)
2541             return +1;
2542     }
2543     Perl_croak_nocontext("QUITing...");
2544 }
2545
2546 void
2547 Perl_Deregister_MQ(int serve)
2548 {
2549     if (serve & REGISTERMQ_WILL_SERVE)
2550         Perl_hmq_servers--;
2551
2552     if (--Perl_hmq_refcnt <= 0) {
2553         unsigned fpflag = _control87(0,0);
2554
2555         init_PMWIN_entries();                   /* To be extra safe */
2556         (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
2557         Perl_hmq = 0;
2558         /* We may have (un)loaded some modules */
2559         _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
2560     } else if ((serve & REGISTERMQ_WILL_SERVE) && Perl_hmq_servers <= 0)
2561         (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); /* Last server exited */
2562     if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH) && (--Perl_morph_refcnt <= 0)) {
2563         /* Try morphing back from a PM application. */
2564         PPIB pib;
2565         PTIB tib;
2566
2567         DosGetInfoBlocks(&tib, &pib);
2568         if (pib->pib_ultype == 3)               /* 3 is PM */
2569             pib->pib_ultype = Perl_os2_initial_mode;
2570         else
2571             Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
2572                                 pib->pib_ultype);
2573     }
2574 }
2575
2576 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
2577                                 && ((path)[2] == '/' || (path)[2] == '\\'))
2578 #define sys_is_rooted _fnisabs
2579 #define sys_is_relative _fnisrel
2580 #define current_drive _getdrive
2581
2582 #undef chdir                            /* Was _chdir2. */
2583 #define sys_chdir(p) (chdir(p) == 0)
2584 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
2585
2586 XS(XS_OS2_Error)
2587 {
2588     dXSARGS;
2589     if (items != 2)
2590         Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
2591     {
2592         int     arg1 = SvIV(ST(0));
2593         int     arg2 = SvIV(ST(1));
2594         int     a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
2595                      | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
2596         int     RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
2597         unsigned long rc;
2598
2599         if (CheckOSError(DosError(a)))
2600             Perl_croak_nocontext("DosError(%d) failed: %s", a, os2error(Perl_rc));
2601         ST(0) = sv_newmortal();
2602         if (DOS_harderr_state >= 0)
2603             sv_setiv(ST(0), DOS_harderr_state);
2604         DOS_harderr_state = RETVAL;
2605     }
2606     XSRETURN(1);
2607 }
2608
2609 XS(XS_OS2_Errors2Drive)
2610 {
2611     dXSARGS;
2612     if (items != 1)
2613         Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
2614     {
2615         STRLEN n_a;
2616         SV  *sv = ST(0);
2617         int     suppress = SvOK(sv);
2618         char    *s = suppress ? SvPV(sv, n_a) : NULL;
2619         char    drive = (s ? *s : 0);
2620         unsigned long rc;
2621
2622         if (suppress && !isALPHA(drive))
2623             Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
2624         if (CheckOSError(DosSuppressPopUps((suppress
2625                                             ? SPU_ENABLESUPPRESSION
2626                                             : SPU_DISABLESUPPRESSION),
2627                                            drive)))
2628             Perl_croak_nocontext("DosSuppressPopUps(%c) failed: %s", drive,
2629                                  os2error(Perl_rc));
2630         ST(0) = sv_newmortal();
2631         if (DOS_suppression_state > 0)
2632             sv_setpvn(ST(0), &DOS_suppression_state, 1);
2633         else if (DOS_suppression_state == 0)
2634             sv_setpvn(ST(0), "", 0);
2635         DOS_suppression_state = drive;
2636     }
2637     XSRETURN(1);
2638 }
2639
2640 int
2641 async_mssleep(ULONG ms, int switch_priority) {
2642   /* This is similar to DosSleep(), but has 8ms granularity in time-critical
2643      threads even on Warp3. */
2644   HEV     hevEvent1     = 0;                    /* Event semaphore handle    */
2645   HTIMER  htimerEvent1  = 0;                    /* Timer handle              */
2646   APIRET  rc            = NO_ERROR;             /* Return code               */
2647   int ret = 1;
2648   ULONG priority = 0, nesting;                  /* Shut down the warnings */
2649   PPIB pib;
2650   PTIB tib;
2651   char *e = NULL;
2652   APIRET badrc;
2653
2654   if (!(_emx_env & 0x200))      /* DOS */
2655     return !_sleep2(ms);
2656
2657   os2cp_croak(DosCreateEventSem(NULL,        /* Unnamed */
2658                                 &hevEvent1,  /* Handle of semaphore returned */
2659                                 DC_SEM_SHARED, /* Shared needed for DosAsyncTimer */
2660                                 FALSE),      /* Semaphore is in RESET state  */
2661               "DosCreateEventSem");
2662
2663   if (ms >= switch_priority)
2664     switch_priority = 0;
2665   if (switch_priority) {
2666     if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
2667         switch_priority = 0;
2668     else {
2669         /* In Warp3, to switch scheduling to 8ms step, one needs to do
2670            DosAsyncTimer() in time-critical thread.  On laters versions,
2671            more and more cases of wait-for-something are covered.
2672
2673            It turns out that on Warp3fp42 it is the priority at the time
2674            of DosAsyncTimer() which matters.  Let's hope that this works
2675            with later versions too...           XXXX
2676          */
2677         priority = (tib->tib_ptib2->tib2_ulpri);
2678         if ((priority & 0xFF00) == 0x0300) /* already time-critical */
2679             switch_priority = 0;
2680         /* Make us time-critical.  Just modifying TIB is not enough... */
2681         /* tib->tib_ptib2->tib2_ulpri = 0x0300;*/
2682         /* We do not want to run at high priority if a signal causes us
2683            to longjmp() out of this section... */
2684         if (DosEnterMustComplete(&nesting))
2685             switch_priority = 0;
2686         else
2687             DosSetPriority(PRTYS_THREAD, PRTYC_TIMECRITICAL, 0, 0);
2688     }
2689   }
2690
2691   if ((badrc = DosAsyncTimer(ms,
2692                              (HSEM) hevEvent1,  /* Semaphore to post        */
2693                              &htimerEvent1)))   /* Timer handler (returned) */
2694      e = "DosAsyncTimer";
2695
2696   if (switch_priority && tib->tib_ptib2->tib2_ulpri == 0x0300) {
2697         /* Nobody switched priority while we slept...  Ignore errors... */
2698         /* tib->tib_ptib2->tib2_ulpri = priority; */    /* Get back... */
2699         if (!(rc = DosSetPriority(PRTYS_THREAD, (priority>>8) & 0xFF, 0, 0)))
2700             rc = DosSetPriority(PRTYS_THREAD, 0, priority & 0xFF, 0);
2701   }
2702   if (switch_priority)
2703       rc = DosExitMustComplete(&nesting);       /* Ignore errors */
2704
2705   /* The actual blocking call is made with "normal" priority.  This way we
2706      should not bother with DosSleep(0) etc. to compensate for us interrupting
2707      higher-priority threads.  The goal is to prohibit the system spending too
2708      much time halt()ing, not to run us "no matter what". */
2709   if (!e)                                       /* Wait for AsyncTimer event */
2710       badrc = DosWaitEventSem(hevEvent1, SEM_INDEFINITE_WAIT);
2711
2712   if (e) ;                              /* Do nothing */
2713   else if (badrc == ERROR_INTERRUPT)
2714      ret = 0;
2715   else if (badrc)
2716      e = "DosWaitEventSem";
2717   if ((rc = DosCloseEventSem(hevEvent1)) && !e) { /* Get rid of semaphore */
2718      e = "DosCloseEventSem";
2719      badrc = rc;
2720   }
2721   if (e)
2722      os2cp_croak(badrc, e);
2723   return ret;
2724 }
2725
2726 XS(XS_OS2_ms_sleep)             /* for testing only... */
2727 {
2728     dXSARGS;
2729     ULONG ms, lim;
2730
2731     if (items > 2 || items < 1)
2732         Perl_croak_nocontext("Usage: OS2::ms_sleep(wait_ms [, high_priority_limit])");
2733     ms = SvUV(ST(0));
2734     lim = items > 1 ? SvUV(ST(1)) : ms + 1;
2735     async_mssleep(ms, lim);
2736     XSRETURN_YES;
2737 }
2738
2739 ULONG (*pDosTmrQueryFreq) (PULONG);
2740 ULONG (*pDosTmrQueryTime) (unsigned long long *);
2741
2742 XS(XS_OS2_Timer)
2743 {
2744     dXSARGS;
2745     static ULONG freq;
2746     unsigned long long count;
2747     ULONG rc;
2748
2749     if (items != 0)
2750         Perl_croak_nocontext("Usage: OS2::Timer()");
2751     if (!freq) {
2752         *(PFN*)&pDosTmrQueryFreq = loadByOrdinal(ORD_DosTmrQueryFreq, 0);
2753         *(PFN*)&pDosTmrQueryTime = loadByOrdinal(ORD_DosTmrQueryTime, 0);
2754         MUTEX_LOCK(&perlos2_state_mutex);
2755         if (!freq)
2756             if (CheckOSError(pDosTmrQueryFreq(&freq)))
2757                 croak_with_os2error("DosTmrQueryFreq");
2758         MUTEX_UNLOCK(&perlos2_state_mutex);
2759     }
2760     if (CheckOSError(pDosTmrQueryTime(&count)))
2761         croak_with_os2error("DosTmrQueryTime");
2762     {
2763         dXSTARG;
2764
2765         XSprePUSH; PUSHn(((NV)count)/freq);
2766     }
2767     XSRETURN(1);
2768 }
2769
2770 XS(XS_OS2_msCounter)
2771 {
2772     dXSARGS;
2773
2774     if (items != 0)
2775         Perl_croak_nocontext("Usage: OS2::msCounter()");
2776     {
2777         dXSTARG;
2778
2779         XSprePUSH; PUSHu(msCounter());
2780     }
2781     XSRETURN(1);
2782 }
2783
2784 XS(XS_OS2__InfoTable)
2785 {
2786     dXSARGS;
2787     int is_local = 0;
2788
2789     if (items > 1)
2790         Perl_croak_nocontext("Usage: OS2::_infoTable([isLocal])");
2791     if (items == 1)
2792         is_local = (int)SvIV(ST(0));
2793     {
2794         dXSTARG;
2795
2796         XSprePUSH; PUSHu(InfoTable(is_local));
2797     }
2798     XSRETURN(1);
2799 }
2800
2801 static const char * const dc_fields[] = {
2802   "FAMILY",
2803   "IO_CAPS",
2804   "TECHNOLOGY",
2805   "DRIVER_VERSION",
2806   "WIDTH",
2807   "HEIGHT",
2808   "WIDTH_IN_CHARS",
2809   "HEIGHT_IN_CHARS",
2810   "HORIZONTAL_RESOLUTION",
2811   "VERTICAL_RESOLUTION",
2812   "CHAR_WIDTH",
2813   "CHAR_HEIGHT",
2814   "SMALL_CHAR_WIDTH",
2815   "SMALL_CHAR_HEIGHT",
2816   "COLORS",
2817   "COLOR_PLANES",
2818   "COLOR_BITCOUNT",
2819   "COLOR_TABLE_SUPPORT",
2820   "MOUSE_BUTTONS",
2821   "FOREGROUND_MIX_SUPPORT",
2822   "BACKGROUND_MIX_SUPPORT",
2823   "VIO_LOADABLE_FONTS",
2824   "WINDOW_BYTE_ALIGNMENT",
2825   "BITMAP_FORMATS",
2826   "RASTER_CAPS",
2827   "MARKER_HEIGHT",
2828   "MARKER_WIDTH",
2829   "DEVICE_FONTS",
2830   "GRAPHICS_SUBSET",
2831   "GRAPHICS_VERSION",
2832   "GRAPHICS_VECTOR_SUBSET",
2833   "DEVICE_WINDOWING",
2834   "ADDITIONAL_GRAPHICS",
2835   "PHYS_COLORS",
2836   "COLOR_INDEX",
2837   "GRAPHICS_CHAR_WIDTH",
2838   "GRAPHICS_CHAR_HEIGHT",
2839   "HORIZONTAL_FONT_RES",
2840   "VERTICAL_FONT_RES",
2841   "DEVICE_FONT_SIM",
2842   "LINEWIDTH_THICK",
2843   "DEVICE_POLYSET_POINTS",
2844 };
2845
2846 enum {
2847     DevCap_dc, DevCap_hwnd
2848 };
2849
2850 HDC (*pWinOpenWindowDC) (HWND hwnd);
2851 HMF (*pDevCloseDC) (HDC hdc);
2852 HDC (*pDevOpenDC) (HAB hab, LONG lType, PCSZ pszToken, LONG lCount,
2853     PDEVOPENDATA pdopData, HDC hdcComp);
2854 BOOL (*pDevQueryCaps) (HDC hdc, LONG lStart, LONG lCount, PLONG alArray);
2855
2856
2857 XS(XS_OS2_DevCap)
2858 {
2859     dXSARGS;
2860     if (items > 2)
2861         Perl_croak_nocontext("Usage: OS2::DevCap()");
2862     {
2863         /* Device Capabilities Data Buffer (10 extra w.r.t. Warp 4.5) */
2864         LONG   si[CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1];
2865         int i = 0, j = 0, how = DevCap_dc;
2866         HDC hScreenDC;
2867         DEVOPENSTRUC doStruc= {0L, (PSZ)"DISPLAY", NULL, 0L, 0L, 0L, 0L, 0L, 0L};
2868         ULONG rc1 = NO_ERROR;
2869         HWND hwnd;
2870         static volatile int devcap_loaded;
2871
2872         if (!devcap_loaded) {
2873             *(PFN*)&pWinOpenWindowDC = loadByOrdinal(ORD_WinOpenWindowDC, 0);
2874             *(PFN*)&pDevOpenDC = loadByOrdinal(ORD_DevOpenDC, 0);
2875             *(PFN*)&pDevCloseDC = loadByOrdinal(ORD_DevCloseDC, 0);
2876             *(PFN*)&pDevQueryCaps = loadByOrdinal(ORD_DevQueryCaps, 0);
2877             devcap_loaded = 1;
2878         }
2879
2880         if (items >= 2)
2881             how = SvIV(ST(1));
2882         if (!items) {                   /* Get device contents from PM */
2883             hScreenDC = pDevOpenDC(perl_hab_GET(), OD_MEMORY, (PSZ)"*", 0,
2884                                   (PDEVOPENDATA)&doStruc, NULLHANDLE);
2885             if (CheckWinError(hScreenDC))
2886                 croak_with_os2error("DevOpenDC() failed");
2887         } else if (how == DevCap_dc)
2888             hScreenDC = (HDC)SvIV(ST(0));
2889         else {                          /* DevCap_hwnd */
2890             if (!Perl_hmq)
2891                 Perl_croak(aTHX_ "Getting a window's device context without a message queue would lock PM");
2892             hwnd = (HWND)SvIV(ST(0));
2893             hScreenDC = pWinOpenWindowDC(hwnd); /* No need to DevCloseDC() */
2894             if (CheckWinError(hScreenDC))
2895                 croak_with_os2error("WinOpenWindowDC() failed");
2896         }
2897         if (CheckWinError(pDevQueryCaps(hScreenDC,
2898                                         CAPS_FAMILY, /* W3 documented caps */
2899                                         CAPS_DEVICE_POLYSET_POINTS
2900                                           - CAPS_FAMILY + 1,
2901                                         si)))
2902             rc1 = Perl_rc;
2903         else {
2904             EXTEND(SP,2*(CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1));
2905             while (i < CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1) {
2906                 ST(j) = sv_newmortal();
2907                 sv_setpv(ST(j++), dc_fields[i]);
2908                 ST(j) = sv_newmortal();
2909                 sv_setiv(ST(j++), si[i]);
2910                 i++;
2911             }
2912             i = CAPS_DEVICE_POLYSET_POINTS + 1;
2913             while (i < CAPS_DEVICE_POLYSET_POINTS + 11) { /* Just in case... */
2914                 LONG l;
2915
2916                 if (CheckWinError(pDevQueryCaps(hScreenDC, i, 1, &l)))
2917                     break;
2918                 EXTEND(SP, j + 2);
2919                 ST(j) = sv_newmortal();
2920                 sv_setiv(ST(j++), i);
2921                 ST(j) = sv_newmortal();
2922                 sv_setiv(ST(j++), l);
2923                 i++;
2924             }
2925         }
2926         if (!items && CheckWinError(pDevCloseDC(hScreenDC)))
2927             Perl_warn_nocontext("DevCloseDC() failed: %s", os2error(Perl_rc));
2928         if (rc1)
2929             Perl_rc = rc1, croak_with_os2error("DevQueryCaps() failed");
2930         XSRETURN(j);
2931     }
2932 }
2933
2934 LONG (*pWinQuerySysValue) (HWND hwndDesktop, LONG iSysValue);
2935 BOOL (*pWinSetSysValue) (HWND hwndDesktop, LONG iSysValue, LONG lValue);
2936
2937 const char * const sv_keys[] = {
2938   "SWAPBUTTON",
2939   "DBLCLKTIME",
2940   "CXDBLCLK",
2941   "CYDBLCLK",
2942   "CXSIZEBORDER",
2943   "CYSIZEBORDER",
2944   "ALARM",
2945   "7",
2946   "8",
2947   "CURSORRATE",
2948   "FIRSTSCROLLRATE",
2949   "SCROLLRATE",
2950   "NUMBEREDLISTS",
2951   "WARNINGFREQ",
2952   "NOTEFREQ",
2953   "ERRORFREQ",
2954   "WARNINGDURATION",
2955   "NOTEDURATION",
2956   "ERRORDURATION",
2957   "19",
2958   "CXSCREEN",
2959   "CYSCREEN",
2960   "CXVSCROLL",
2961   "CYHSCROLL",
2962   "CYVSCROLLARROW",
2963   "CXHSCROLLARROW",
2964   "CXBORDER",
2965   "CYBORDER",
2966   "CXDLGFRAME",
2967   "CYDLGFRAME",
2968   "CYTITLEBAR",
2969   "CYVSLIDER",
2970   "CXHSLIDER",
2971   "CXMINMAXBUTTON",
2972   "CYMINMAXBUTTON",
2973   "CYMENU",
2974   "CXFULLSCREEN",
2975   "CYFULLSCREEN",
2976   "CXICON",
2977   "CYICON",
2978   "CXPOINTER",
2979   "CYPOINTER",
2980   "DEBUG",
2981   "CPOINTERBUTTONS",
2982   "POINTERLEVEL",
2983   "CURSORLEVEL",
2984   "TRACKRECTLEVEL",
2985   "CTIMERS",
2986   "MOUSEPRESENT",
2987   "CXALIGN",
2988   "CYALIGN",
2989   "DESKTOPWORKAREAYTOP",
2990   "DESKTOPWORKAREAYBOTTOM",
2991   "DESKTOPWORKAREAXRIGHT",
2992   "DESKTOPWORKAREAXLEFT",
2993   "55",
2994   "NOTRESERVED",
2995   "EXTRAKEYBEEP",
2996   "SETLIGHTS",
2997   "INSERTMODE",
2998   "60",
2999   "61",
3000   "62",
3001   "63",
3002   "MENUROLLDOWNDELAY",
3003   "MENUROLLUPDELAY",
3004   "ALTMNEMONIC",
3005   "TASKLISTMOUSEACCESS",
3006   "CXICONTEXTWIDTH",
3007   "CICONTEXTLINES",
3008   "CHORDTIME",
3009   "CXCHORD",
3010   "CYCHORD",
3011   "CXMOTIONSTART",
3012   "CYMOTIONSTART",
3013   "BEGINDRAG",
3014   "ENDDRAG",
3015   "SINGLESELECT",
3016   "OPEN",
3017   "CONTEXTMENU",
3018   "CONTEXTHELP",
3019   "TEXTEDIT",
3020   "BEGINSELECT",
3021   "ENDSELECT",
3022   "BEGINDRAGKB",
3023   "ENDDRAGKB",
3024   "SELECTKB",
3025   "OPENKB",
3026   "CONTEXTMENUKB",
3027   "CONTEXTHELPKB",
3028   "TEXTEDITKB",
3029   "BEGINSELECTKB",
3030   "ENDSELECTKB",
3031   "ANIMATION",
3032   "ANIMATIONSPEED",
3033   "MONOICONS",
3034   "KBDALTERED",
3035   "PRINTSCREEN",                /* 97, the last one on one of the DDK header */
3036   "LOCKSTARTINPUT",
3037   "DYNAMICDRAG",
3038   "100",
3039   "101",
3040   "102",
3041   "103",
3042   "104",
3043   "105",
3044   "106",
3045   "107",
3046 /*  "CSYSVALUES",*/
3047                                         /* In recent DDK the limit is 108 */
3048 };
3049
3050 XS(XS_OS2_SysValues)
3051 {
3052     dXSARGS;
3053     if (items > 2)
3054         Perl_croak_nocontext("Usage: OS2::SysValues(which = -1, hwndDesktop = HWND_DESKTOP)");
3055     {
3056         int i = 0, j = 0, which = -1;
3057         HWND hwnd = HWND_DESKTOP;
3058         static volatile int sv_loaded;
3059         LONG RETVAL;
3060
3061         if (!sv_loaded) {
3062             *(PFN*)&pWinQuerySysValue = loadByOrdinal(ORD_WinQuerySysValue, 0);
3063             sv_loaded = 1;
3064         }
3065
3066         if (items == 2)
3067             hwnd = (HWND)SvIV(ST(1));
3068         if (items >= 1)
3069             which = (int)SvIV(ST(0));
3070         if (which == -1) {
3071             EXTEND(SP,2*C_ARRAY_LENGTH(sv_keys));
3072             while (i < C_ARRAY_LENGTH(sv_keys)) {
3073                 ResetWinError();
3074                 RETVAL = pWinQuerySysValue(hwnd, i);
3075                 if ( !RETVAL
3076                      && !(sv_keys[i][0] >= '0' && sv_keys[i][0] <= '9'
3077                           && i <= SV_PRINTSCREEN) ) {
3078                     FillWinError;
3079                     if (Perl_rc) {
3080                         if (i > SV_PRINTSCREEN)
3081                             break; /* May be not present on older systems */
3082                         croak_with_os2error("SysValues():");
3083                     }
3084
3085                 }
3086                 ST(j) = sv_newmortal();
3087                 sv_setpv(ST(j++), sv_keys[i]);
3088                 ST(j) = sv_newmortal();
3089                 sv_setiv(ST(j++), RETVAL);
3090                 i++;
3091             }
3092             XSRETURN(2 * i);
3093         } else {
3094             dXSTARG;
3095
3096             ResetWinError();
3097             RETVAL = pWinQuerySysValue(hwnd, which);
3098             if (!RETVAL) {
3099                 FillWinError;
3100                 if (Perl_rc)
3101                     croak_with_os2error("SysValues():");
3102             }
3103             XSprePUSH; PUSHi((IV)RETVAL);
3104         }
3105     }
3106 }
3107
3108 XS(XS_OS2_SysValues_set)
3109 {
3110     dXSARGS;
3111     if (items < 2 || items > 3)
3112         Perl_croak_nocontext("Usage: OS2::SysValues_set(which, val, hwndDesktop = HWND_DESKTOP)");
3113     {
3114         int which = (int)SvIV(ST(0));
3115         LONG val = (LONG)SvIV(ST(1));
3116         HWND hwnd = HWND_DESKTOP;
3117         static volatile int svs_loaded;
3118
3119         if (!svs_loaded) {
3120             *(PFN*)&pWinSetSysValue = loadByOrdinal(ORD_WinSetSysValue, 0);
3121             svs_loaded = 1;
3122         }
3123
3124         if (items == 3)
3125             hwnd = (HWND)SvIV(ST(2));
3126         if (CheckWinError(pWinSetSysValue(hwnd, which, val)))
3127             croak_with_os2error("SysValues_set()");
3128     }
3129     XSRETURN_YES;
3130 }
3131
3132 #define QSV_MAX_WARP3                           QSV_MAX_COMP_LENGTH
3133
3134 static const char * const si_fields[] = {
3135   "MAX_PATH_LENGTH",
3136   "MAX_TEXT_SESSIONS",
3137   "MAX_PM_SESSIONS",
3138   "MAX_VDM_SESSIONS",
3139   "BOOT_DRIVE",
3140   "DYN_PRI_VARIATION",
3141   "MAX_WAIT",
3142   "MIN_SLICE",
3143   "MAX_SLICE",
3144   "PAGE_SIZE",
3145   "VERSION_MAJOR",
3146   "VERSION_MINOR",
3147   "VERSION_REVISION",
3148   "MS_COUNT",
3149   "TIME_LOW",
3150   "TIME_HIGH",
3151   "TOTPHYSMEM",
3152   "TOTRESMEM",
3153   "TOTAVAILMEM",
3154   "MAXPRMEM",
3155   "MAXSHMEM",
3156   "TIMER_INTERVAL",
3157   "MAX_COMP_LENGTH",
3158   "FOREGROUND_FS_SESSION",
3159   "FOREGROUND_PROCESS",                 /* Warp 3 toolkit defines up to this */
3160   "NUMPROCESSORS",
3161   "MAXHPRMEM",
3162   "MAXHSHMEM",
3163   "MAXPROCESSES",
3164   "VIRTUALADDRESSLIMIT",
3165   "INT10ENABLED",                       /* From $TOOLKIT-ddk\DDK\video\rel\os2c\include\base\os2\bsedos.h */
3166 };
3167
3168 XS(XS_OS2_SysInfo)
3169 {
3170     dXSARGS;
3171     if (items != 0)
3172         Perl_croak_nocontext("Usage: OS2::SysInfo()");
3173     {
3174         /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */
3175         ULONG   si[C_ARRAY_LENGTH(si_fields) + 10];
3176         APIRET  rc      = NO_ERROR;     /* Return code            */
3177         int i = 0, j = 0, last = QSV_MAX_WARP3;
3178
3179         if (CheckOSError(DosQuerySysInfo(1L, /* Request documented system */
3180                                          last, /* info for Warp 3 */
3181                                          (PVOID)si,
3182                                          sizeof(si))))
3183             croak_with_os2error("DosQuerySysInfo() failed");
3184         while (++last <= C_ARRAY_LENGTH(si)) {
3185             if (CheckOSError(DosQuerySysInfo(last, last, /* One entry only */
3186                                              (PVOID)(si+last-1),
3187                                              sizeof(*si)))) {
3188                 if (Perl_rc != ERROR_INVALID_PARAMETER)
3189                     croak_with_os2error("DosQuerySysInfo() failed");
3190                 break;
3191             }
3192         }
3193         last--;                 /* Count of successfully processed offsets */
3194         EXTEND(SP,2*last);
3195         while (i < last) {
3196             ST(j) = sv_newmortal();
3197             if (i < C_ARRAY_LENGTH(si_fields))
3198                 sv_setpv(ST(j++),  si_fields[i]);
3199             else
3200                 sv_setiv(ST(j++),  i + 1);
3201             ST(j) = sv_newmortal();
3202             sv_setuv(ST(j++), si[i]);
3203             i++;
3204         }
3205         XSRETURN(2 * last);
3206     }
3207 }
3208
3209 XS(XS_OS2_SysInfoFor)
3210 {
3211     dXSARGS;
3212     int count = (items == 2 ? (int)SvIV(ST(1)) : 1);
3213
3214     if (items < 1 || items > 2)
3215         Perl_croak_nocontext("Usage: OS2::SysInfoFor(id[,count])");
3216     {
3217         /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */
3218         ULONG   si[C_ARRAY_LENGTH(si_fields) + 10];
3219         APIRET  rc      = NO_ERROR;     /* Return code            */
3220         int i = 0;
3221         int start = (int)SvIV(ST(0));
3222
3223         if (count > C_ARRAY_LENGTH(si) || count <= 0)
3224             Perl_croak(aTHX_ "unexpected count %d for OS2::SysInfoFor()", count);
3225         if (CheckOSError(DosQuerySysInfo(start,
3226                                          start + count - 1,
3227                                          (PVOID)si,
3228                                          sizeof(si))))
3229             croak_with_os2error("DosQuerySysInfo() failed");
3230         EXTEND(SP,count);
3231         while (i < count) {
3232             ST(i) = sv_newmortal();
3233             sv_setiv(ST(i), si[i]);
3234             i++;
3235         }
3236     }
3237     XSRETURN(count);
3238 }
3239
3240 XS(XS_OS2_BootDrive)
3241 {
3242     dXSARGS;
3243     if (items != 0)
3244         Perl_croak_nocontext("Usage: OS2::BootDrive()");
3245     {
3246         ULONG   si[1] = {0};    /* System Information Data Buffer */
3247         APIRET  rc    = NO_ERROR;       /* Return code            */
3248         char c;
3249         dXSTARG;
3250
3251         if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
3252                                          (PVOID)si, sizeof(si))))
3253             croak_with_os2error("DosQuerySysInfo() failed");
3254         c = 'a' - 1 + si[0];
3255         sv_setpvn(TARG, &c, 1);
3256         XSprePUSH; PUSHTARG;
3257     }
3258     XSRETURN(1);
3259 }
3260
3261 XS(XS_OS2_Beep)
3262 {
3263     dXSARGS;
3264     if (items > 2)                      /* Defaults as for WinAlarm(ERROR) */
3265         Perl_croak_nocontext("Usage: OS2::Beep(freq = 440, ms = 100)");
3266     {
3267         ULONG freq      = (items > 0 ? (ULONG)SvUV(ST(0)) : 440);
3268         ULONG ms        = (items > 1 ? (ULONG)SvUV(ST(1)) : 100);
3269         ULONG rc;
3270
3271         if (CheckOSError(DosBeep(freq, ms)))
3272             croak_with_os2error("SysValues_set()");
3273     }
3274     XSRETURN_YES;
3275 }
3276
3277
3278
3279 XS(XS_OS2_MorphPM)
3280 {
3281     dXSARGS;
3282     if (items != 1)
3283         Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
3284     {
3285         bool  serve = SvOK(ST(0));
3286         unsigned long   pmq = perl_hmq_GET(serve);
3287         dXSTARG;
3288
3289         XSprePUSH; PUSHi((IV)pmq);
3290     }
3291     XSRETURN(1);
3292 }
3293
3294 XS(XS_OS2_UnMorphPM)
3295 {
3296     dXSARGS;
3297     if (items != 1)
3298         Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
3299     {
3300         bool  serve = SvOK(ST(0));
3301
3302         perl_hmq_UNSET(serve);
3303     }
3304     XSRETURN(0);
3305 }
3306
3307 XS(XS_OS2_Serve_Messages)
3308 {
3309     dXSARGS;
3310     if (items != 1)
3311         Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
3312     {
3313         bool  force = SvOK(ST(0));
3314         unsigned long   cnt = Perl_Serve_Messages(force);
3315         dXSTARG;
3316
3317         XSprePUSH; PUSHi((IV)cnt);
3318     }
3319     XSRETURN(1);
3320 }
3321
3322 XS(XS_OS2_Process_Messages)
3323 {
3324     dXSARGS;
3325     if (items < 1 || items > 2)
3326         Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
3327     {
3328         bool  force = SvOK(ST(0));
3329         unsigned long   cnt;
3330         dXSTARG;
3331
3332         if (items == 2) {
3333             I32 cntr;
3334             SV *sv = ST(1);
3335
3336             (void)SvIV(sv);             /* Force SvIVX */
3337             if (!SvIOK(sv))
3338                 Perl_croak_nocontext("Can't upgrade count to IV");
3339             cntr = SvIVX(sv);
3340             cnt =  Perl_Process_Messages(force, &cntr);
3341             SvIVX(sv) = cntr;
3342         } else {
3343             cnt =  Perl_Process_Messages(force, NULL);
3344         }
3345         XSprePUSH; PUSHi((IV)cnt);
3346     }
3347     XSRETURN(1);
3348 }
3349
3350 XS(XS_Cwd_current_drive)
3351 {
3352     dXSARGS;
3353     if (items != 0)
3354         Perl_croak_nocontext("Usage: Cwd::current_drive()");
3355     {
3356         char    RETVAL;
3357         dXSTARG;
3358
3359         RETVAL = current_drive();
3360         sv_setpvn(TARG, (char *)&RETVAL, 1);
3361         XSprePUSH; PUSHTARG;
3362     }
3363     XSRETURN(1);
3364 }
3365
3366 XS(XS_Cwd_sys_chdir)
3367 {
3368     dXSARGS;
3369     if (items != 1)
3370         Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
3371     {
3372         STRLEN n_a;
3373         char *  path = (char *)SvPV(ST(0),n_a);
3374         bool    RETVAL;
3375
3376         RETVAL = sys_chdir(path);
3377         ST(0) = boolSV(RETVAL);
3378         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3379     }
3380     XSRETURN(1);
3381 }
3382
3383 XS(XS_Cwd_change_drive)
3384 {
3385     dXSARGS;
3386     if (items != 1)
3387         Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
3388     {
3389         STRLEN n_a;
3390         char    d = (char)*SvPV(ST(0),n_a);
3391         bool    RETVAL;
3392
3393         RETVAL = change_drive(d);
3394         ST(0) = boolSV(RETVAL);
3395         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3396     }
3397     XSRETURN(1);
3398 }
3399
3400 XS(XS_Cwd_sys_is_absolute)
3401 {
3402     dXSARGS;
3403     if (items != 1)
3404         Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
3405     {
3406         STRLEN n_a;
3407         char *  path = (char *)SvPV(ST(0),n_a);
3408         bool    RETVAL;
3409
3410         RETVAL = sys_is_absolute(path);
3411         ST(0) = boolSV(RETVAL);
3412         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3413     }
3414     XSRETURN(1);
3415 }
3416
3417 XS(XS_Cwd_sys_is_rooted)
3418 {
3419     dXSARGS;
3420     if (items != 1)
3421         Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
3422     {
3423         STRLEN n_a;
3424         char *  path = (char *)SvPV(ST(0),n_a);
3425         bool    RETVAL;
3426
3427         RETVAL = sys_is_rooted(path);
3428         ST(0) = boolSV(RETVAL);
3429         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3430     }
3431     XSRETURN(1);
3432 }
3433
3434 XS(XS_Cwd_sys_is_relative)
3435 {
3436     dXSARGS;
3437     if (items != 1)
3438         Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
3439     {
3440         STRLEN n_a;
3441         char *  path = (char *)SvPV(ST(0),n_a);
3442         bool    RETVAL;
3443
3444         RETVAL = sys_is_relative(path);
3445         ST(0) = boolSV(RETVAL);
3446         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3447     }
3448     XSRETURN(1);
3449 }
3450
3451 XS(XS_Cwd_sys_cwd)
3452 {
3453     dXSARGS;
3454     if (items != 0)
3455         Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
3456     {
3457         char p[MAXPATHLEN];
3458         char *  RETVAL;
3459
3460         /* Can't use TARG, since tainting behaves differently */
3461         RETVAL = _getcwd2(p, MAXPATHLEN);
3462         ST(0) = sv_newmortal();
3463         sv_setpv(ST(0), RETVAL);
3464 #ifndef INCOMPLETE_TAINTS
3465         SvTAINTED_on(ST(0));
3466 #endif
3467     }
3468     XSRETURN(1);
3469 }
3470
3471 XS(XS_Cwd_sys_abspath)
3472 {
3473     dXSARGS;
3474     if (items > 2)
3475         Perl_croak_nocontext("Usage: Cwd::sys_abspath(path = '.', dir = NULL)");
3476     {
3477         STRLEN n_a;
3478         char *  path = items ? (char *)SvPV(ST(0),n_a) : ".";
3479         char *  dir, *s, *t, *e;
3480         char p[MAXPATHLEN];
3481         char *  RETVAL;
3482         int l;
3483         SV *sv;
3484
3485         if (items < 2)
3486             dir = NULL;
3487         else {
3488             dir = (char *)SvPV(ST(1),n_a);
3489         }
3490         if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
3491             path += 2;
3492         }
3493         if (dir == NULL) {
3494             if (_abspath(p, path, MAXPATHLEN) == 0) {
3495                 RETVAL = p;
3496             } else {
3497                 RETVAL = NULL;
3498             }
3499         } else {
3500             /* Absolute with drive: */
3501             if ( sys_is_absolute(path) ) {
3502                 if (_abspath(p, path, MAXPATHLEN) == 0) {
3503                     RETVAL = p;
3504                 } else {
3505                     RETVAL = NULL;
3506                 }
3507             } else if (path[0] == '/' || path[0] == '\\') {
3508                 /* Rooted, but maybe on different drive. */
3509                 if (isALPHA(dir[0]) && dir[1] == ':' ) {
3510                     char p1[MAXPATHLEN];
3511
3512                     /* Need to prepend the drive. */
3513                     p1[0] = dir[0];
3514                     p1[1] = dir[1];
3515                     Copy(path, p1 + 2, strlen(path) + 1, char);
3516                     RETVAL = p;
3517                     if (_abspath(p, p1, MAXPATHLEN) == 0) {
3518                         RETVAL = p;
3519                     } else {
3520                         RETVAL = NULL;
3521                     }
3522                 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
3523                     RETVAL = p;
3524                 } else {
3525                     RETVAL = NULL;
3526                 }
3527             } else {
3528                 /* Either path is relative, or starts with a drive letter. */
3529                 /* If the path starts with a drive letter, then dir is
3530                    relevant only if
3531                    a/b) it is absolute/x:relative on the same drive.
3532                    c)   path is on current drive, and dir is rooted
3533                    In all the cases it is safe to drop the drive part
3534                    of the path. */
3535                 if ( !sys_is_relative(path) ) {
3536                     if ( ( ( sys_is_absolute(dir)
3537                              || (isALPHA(dir[0]) && dir[1] == ':'
3538                                  && strnicmp(dir, path,1) == 0))
3539                            && strnicmp(dir, path,1) == 0)
3540                          || ( !(isALPHA(dir[0]) && dir[1] == ':')
3541                               && toupper(path[0]) == current_drive())) {
3542                         path += 2;
3543                     } else if (_abspath(p, path, MAXPATHLEN) == 0) {
3544                         RETVAL = p; goto done;
3545                     } else {
3546                         RETVAL = NULL; goto done;
3547                     }
3548                 }
3549                 {
3550                     /* Need to prepend the absolute path of dir. */
3551                     char p1[MAXPATHLEN];
3552
3553                     if (_abspath(p1, dir, MAXPATHLEN) == 0) {
3554                         int l = strlen(p1);
3555
3556                         if (p1[ l - 1 ] != '/') {
3557                             p1[ l ] = '/';
3558                             l++;
3559                         }
3560                         Copy(path, p1 + l, strlen(path) + 1, char);
3561                         if (_abspath(p, p1, MAXPATHLEN) == 0) {
3562                             RETVAL = p;
3563                         } else {
3564                             RETVAL = NULL;
3565                         }
3566                     } else {
3567                         RETVAL = NULL;
3568                     }
3569                 }
3570               done:
3571             }
3572         }
3573         if (!RETVAL)
3574             XSRETURN_EMPTY;
3575         /* Backslashes are already converted to slashes. */
3576         /* Remove trailing slashes */
3577         l = strlen(RETVAL);
3578         while (l > 0 && RETVAL[l-1] == '/')
3579             l--;
3580         ST(0) = sv_newmortal();
3581         sv_setpvn( sv = (SV*)ST(0), RETVAL, l);
3582         /* Remove duplicate slashes, skipping the first three, which
3583            may be parts of a server-based path */
3584         s = t = 3 + SvPV_force(sv, n_a);
3585         e = SvEND(sv);
3586         /* Do not worry about multibyte chars here, this would contradict the
3587            eventual UTFization, and currently most other places break too... */
3588         while (s < e) {
3589             if (s[0] == t[-1] && s[0] == '/')
3590                 s++;                            /* Skip duplicate / */
3591             else
3592                 *t++ = *s++;
3593         }
3594         if (t < e) {
3595             *t = 0;
3596             SvCUR_set(sv, t - SvPVX(sv));
3597         }
3598 #ifndef INCOMPLETE_TAINTS
3599         if (!items)
3600             SvTAINTED_on(ST(0));
3601 #endif
3602     }
3603     XSRETURN(1);
3604 }
3605 typedef APIRET (*PELP)(PSZ path, ULONG type);
3606
3607 /* Kernels after 2000/09/15 understand this too: */
3608 #ifndef LIBPATHSTRICT
3609 #  define LIBPATHSTRICT 3
3610 #endif
3611
3612 APIRET
3613 ExtLIBPATH(ULONG ord, PSZ path, IV type, int fatal)
3614 {
3615     ULONG what;
3616     PFN f = loadByOrdinal(ord, fatal);  /* if fatal: load or die! */
3617
3618     if (!f)                             /* Impossible with fatal */
3619         return Perl_rc;
3620     if (type > 0)
3621         what = END_LIBPATH;
3622     else if (type == 0)
3623         what = BEGIN_LIBPATH;
3624     else
3625         what = LIBPATHSTRICT;
3626     return (*(PELP)f)(path, what);
3627 }
3628
3629 #define extLibpath(to,type, fatal)                                      \
3630     (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type), fatal)) ? NULL : (to) )
3631
3632 #define extLibpath_set(p,type, fatal)                                   \
3633     (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type), fatal)))
3634
3635 static void
3636 early_error(char *msg1, char *msg2, char *msg3)
3637 {       /* Buffer overflow detected; there is very little we can do... */
3638     ULONG rc;
3639
3640     DosWrite(2, msg1, strlen(msg1), &rc);
3641     DosWrite(2, msg2, strlen(msg2), &rc);
3642     DosWrite(2, msg3, strlen(msg3), &rc);
3643     DosExit(EXIT_PROCESS, 2);
3644 }
3645
3646 XS(XS_Cwd_extLibpath)
3647 {
3648     dXSARGS;
3649     if (items < 0 || items > 1)
3650         Perl_croak_nocontext("Usage: OS2::extLibpath(type = 0)");
3651     {
3652         IV      type;
3653         char    to[1024];
3654         U32     rc;
3655         char *  RETVAL;
3656         dXSTARG;
3657         STRLEN l;
3658
3659         if (items < 1)
3660             type = 0;
3661         else {
3662             type = SvIV(ST(0));
3663         }
3664
3665         to[0] = 1; to[1] = 0;           /* Sometimes no error reported */
3666         RETVAL = extLibpath(to, type, 1);       /* Make errors fatal */
3667         if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
3668             Perl_croak_nocontext("panic OS2::extLibpath parameter");
3669         l = strlen(to);
3670         if (l >= sizeof(to))
3671             early_error("Buffer overflow while getting BEGIN/ENDLIBPATH: `",
3672                         to, "'\r\n");           /* Will not return */
3673         sv_setpv(TARG, RETVAL);
3674         XSprePUSH; PUSHTARG;
3675     }
3676     XSRETURN(1);
3677 }
3678
3679 XS(XS_Cwd_extLibpath_set)
3680 {
3681     dXSARGS;
3682     if (items < 1 || items > 2)
3683         Perl_croak_nocontext("Usage: OS2::extLibpath_set(s, type = 0)");
3684     {
3685         STRLEN n_a;
3686         char *  s = (char *)SvPV(ST(0),n_a);
3687         IV      type;
3688         U32     rc;
3689         bool    RETVAL;
3690
3691         if (items < 2)
3692             type = 0;
3693         else {
3694             type = SvIV(ST(1));
3695         }
3696
3697         RETVAL = extLibpath_set(s, type, 1);    /* Make errors fatal */
3698         ST(0) = boolSV(RETVAL);
3699         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3700     }
3701     XSRETURN(1);
3702 }
3703
3704 ULONG
3705 fill_extLibpath(int type, char *pre, char *post, int replace, char *msg)
3706 {
3707     char buf[2048], *to = buf, buf1[300], *s;
3708     STRLEN l;
3709     ULONG rc;
3710
3711     if (!pre && !post)
3712         return 0;
3713     if (pre) {
3714         pre = dir_subst(pre, strlen(pre), buf1, sizeof buf1, dir_subst_pathlike, msg);
3715         if (!pre)
3716             return ERROR_INVALID_PARAMETER;
3717         l = strlen(pre);
3718         if (l >= sizeof(buf)/2)
3719             return ERROR_BUFFER_OVERFLOW;
3720         s = pre - 1;
3721         while (*++s)
3722             if (*s == '/')
3723                 *s = '\\';                      /* Be extra causious */
3724         memcpy(to, pre, l);
3725         if (!l || to[l-1] != ';')
3726             to[l++] = ';';
3727         to += l;
3728     }
3729
3730     if (!replace) {
3731       to[0] = 1; to[1] = 0;             /* Sometimes no error reported */
3732       rc = ExtLIBPATH(ORD_DosQueryExtLibpath, to, type, 0);     /* Do not croak */
3733       if (rc)
3734         return rc;
3735       if (to[0] == 1 && to[1] == 0)
3736         return ERROR_INVALID_PARAMETER;
3737       to += strlen(to);
3738       if (buf + sizeof(buf) - 1 <= to)  /* Buffer overflow */
3739         early_error("Buffer overflow while getting BEGIN/ENDLIBPATH: `",
3740                     buf, "'\r\n");              /* Will not return */
3741       if (to > buf && to[-1] != ';')
3742         *to++ = ';';
3743     }
3744     if (post) {
3745         post = dir_subst(post, strlen(post), buf1, sizeof buf1, dir_subst_pathlike, msg);
3746         if (!post)
3747             return ERROR_INVALID_PARAMETER;
3748         l = strlen(post);
3749         if (l + to - buf >= sizeof(buf) - 1)
3750             return ERROR_BUFFER_OVERFLOW;
3751         s = post - 1;
3752         while (*++s)
3753             if (*s == '/')
3754                 *s = '\\';                      /* Be extra causious */
3755         memcpy(to, post, l);
3756         if (!l || to[l-1] != ';')
3757             to[l++] = ';';
3758         to += l;
3759     }
3760     *to = 0;
3761     rc = ExtLIBPATH(ORD_DosSetExtLibpath, buf, type, 0); /* Do not croak */
3762     return rc;
3763 }
3764
3765 /* Input: Address, BufLen
3766 APIRET APIENTRY
3767 DosQueryModFromEIP (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
3768                     ULONG * Offset, ULONG Address);
3769 */
3770
3771 DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP,
3772                         (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
3773                         ULONG * Offset, ULONG Address),
3774                         (hmod, obj, BufLen, Buf, Offset, Address))
3775
3776 static SV*
3777 module_name_at(void *pp, enum module_name_how how)
3778 {
3779     dTHX;
3780     char buf[MAXPATHLEN];
3781     char *p = buf;
3782     HMODULE mod;
3783     ULONG obj, offset, rc, addr = (ULONG)pp;
3784
3785     if (how & mod_name_HMODULE) {
3786         if ((how & ~mod_name_HMODULE) == mod_name_shortname)
3787             Perl_croak(aTHX_ "Can't get short module name from a handle");
3788         mod = (HMODULE)pp;
3789         how &= ~mod_name_HMODULE;
3790     } else if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, addr))
3791         return &PL_sv_undef;
3792     if (how == mod_name_handle)
3793         return newSVuv(mod);
3794     /* Full name... */
3795     if ( how != mod_name_shortname
3796          && CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) )
3797         return &PL_sv_undef;
3798     while (*p) {
3799         if (*p == '\\')
3800             *p = '/';
3801         p++;
3802     }
3803     return newSVpv(buf, 0);
3804 }
3805
3806 static SV*
3807 module_name_of_cv(SV *cv, enum module_name_how how)
3808 {
3809     if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv))) {
3810         dTHX;
3811
3812         if (how & mod_name_C_function)
3813             return module_name_at((void*)SvIV(cv), how & ~mod_name_C_function);
3814         else if (how & mod_name_HMODULE)
3815             return module_name_at((void*)SvIV(cv), how);
3816         Perl_croak(aTHX_ "Not an XSUB reference");
3817     }
3818     return module_name_at(CvXSUB(SvRV(cv)), how);
3819 }
3820
3821 XS(XS_OS2_DLLname)
3822 {
3823     dXSARGS;
3824     if (items > 2)
3825         Perl_croak(aTHX_ "Usage: OS2::DLLname( [ how, [\\&xsub] ] )");
3826     {
3827         SV *    RETVAL;
3828         int     how;
3829
3830         if (items < 1)
3831             how = mod_name_full;
3832         else {
3833             how = (int)SvIV(ST(0));
3834         }
3835         if (items < 2)
3836             RETVAL = module_name(how);
3837         else
3838             RETVAL = module_name_of_cv(ST(1), how);
3839         ST(0) = RETVAL;
3840         sv_2mortal(ST(0));
3841     }
3842     XSRETURN(1);
3843 }
3844
3845 DeclOSFuncByORD(INT, _Dos32QueryHeaderInfo, ORD_Dos32QueryHeaderInfo,
3846                         (ULONG r1, ULONG r2, PVOID buf, ULONG szbuf, ULONG fnum),
3847                         (r1, r2, buf, szbuf, fnum))
3848
3849 XS(XS_OS2__headerInfo)
3850 {
3851     dXSARGS;
3852     if (items > 4 || items < 2)
3853         Perl_croak(aTHX_ "Usage: OS2::_headerInfo(req,size[,handle,[offset]])");
3854     {
3855         ULONG   req = (ULONG)SvIV(ST(0));
3856         STRLEN  size = (STRLEN)SvIV(ST(1)), n_a;
3857         ULONG   handle = (items >= 3 ? (ULONG)SvIV(ST(2)) : 0);
3858         ULONG   offset = (items >= 4 ? (ULONG)SvIV(ST(3)) : 0);
3859
3860         if (size <= 0)
3861             Perl_croak(aTHX_ "OS2::_headerInfo(): unexpected size: %d", (int)size);
3862         ST(0) = newSVpvn("",0);
3863         SvGROW(ST(0), size + 1);
3864         sv_2mortal(ST(0));
3865
3866         if (!_Dos32QueryHeaderInfo(handle, offset, SvPV(ST(0), n_a), size, req))
3867             Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3868                        req, size, handle, offset, os2error(Perl_rc));
3869         SvCUR_set(ST(0), size);
3870         *SvEND(ST(0)) = 0;
3871     }
3872     XSRETURN(1);
3873 }
3874
3875 #define DQHI_QUERYLIBPATHSIZE      4
3876 #define DQHI_QUERYLIBPATH          5
3877
3878 XS(XS_OS2_libPath)
3879 {
3880     dXSARGS;
3881     if (items != 0)
3882         Perl_croak(aTHX_ "Usage: OS2::libPath()");
3883     {
3884         ULONG   size;
3885         STRLEN  n_a;
3886
3887         if (!_Dos32QueryHeaderInfo(0, 0, &size, sizeof(size),
3888                                    DQHI_QUERYLIBPATHSIZE))
3889             Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3890                        DQHI_QUERYLIBPATHSIZE, sizeof(size), 0, 0,
3891                        os2error(Perl_rc));
3892         ST(0) = newSVpvn("",0);
3893         SvGROW(ST(0), size + 1);
3894         sv_2mortal(ST(0));
3895
3896         /* We should be careful: apparently, this entry point does not
3897            pay attention to the size argument, so may overwrite
3898            unrelated data! */
3899         if (!_Dos32QueryHeaderInfo(0, 0, SvPV(ST(0), n_a), size,
3900                                    DQHI_QUERYLIBPATH))
3901             Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3902                        DQHI_QUERYLIBPATH, size, 0, 0, os2error(Perl_rc));
3903         SvCUR_set(ST(0), size);
3904         *SvEND(ST(0)) = 0;
3905     }
3906     XSRETURN(1);
3907 }
3908
3909 #define get_control87()         _control87(0,0)
3910 #define set_control87           _control87
3911
3912 XS(XS_OS2__control87)
3913 {
3914     dXSARGS;
3915     if (items != 2)
3916         Perl_croak(aTHX_ "Usage: OS2::_control87(new,mask)");
3917     {
3918         unsigned        new = (unsigned)SvIV(ST(0));
3919         unsigned        mask = (unsigned)SvIV(ST(1));
3920         unsigned        RETVAL;
3921         dXSTARG;
3922
3923         RETVAL = _control87(new, mask);
3924         XSprePUSH; PUSHi((IV)RETVAL);
3925     }
3926     XSRETURN(1);
3927 }
3928
3929 XS(XS_OS2_mytype)
3930 {
3931     dXSARGS;
3932     int which = 0;
3933
3934     if (items < 0 || items > 1)
3935         Perl_croak(aTHX_ "Usage: OS2::mytype([which])");
3936     if (items == 1)
3937         which = (int)SvIV(ST(0));
3938     {
3939         unsigned        RETVAL;
3940         dXSTARG;
3941
3942         switch (which) {
3943         case 0:
3944             RETVAL = os2_mytype;        /* Reset after fork */
3945             break;
3946         case 1:
3947             RETVAL = os2_mytype_ini;    /* Before any fork */
3948             break;
3949         case 2:
3950             RETVAL = Perl_os2_initial_mode;     /* Before first morphing */
3951             break;
3952         case 3:
3953             RETVAL = my_type();         /* Morphed type */
3954             break;
3955         default:
3956             Perl_croak(aTHX_ "OS2::mytype(which): unknown which=%d", which);
3957         }
3958         XSprePUSH; PUSHi((IV)RETVAL);
3959     }
3960     XSRETURN(1);
3961 }
3962
3963
3964 XS(XS_OS2_mytype_set)
3965 {
3966     dXSARGS;
3967     int type;
3968
3969     if (items == 1)
3970         type = (int)SvIV(ST(0));
3971     else
3972         Perl_croak(aTHX_ "Usage: OS2::mytype_set(type)");
3973     my_type_set(type);
3974     XSRETURN_YES;
3975 }
3976
3977
3978 XS(XS_OS2_get_control87)
3979 {
3980     dXSARGS;
3981     if (items != 0)
3982         Perl_croak(aTHX_ "Usage: OS2::get_control87()");
3983     {
3984         unsigned        RETVAL;
3985         dXSTARG;
3986
3987         RETVAL = get_control87();
3988         XSprePUSH; PUSHi((IV)RETVAL);
3989     }
3990     XSRETURN(1);
3991 }
3992
3993
3994 XS(XS_OS2_set_control87)
3995 {
3996     dXSARGS;
3997     if (items < 0 || items > 2)
3998         Perl_croak(aTHX_ "Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
3999     {
4000         unsigned        new;
4001         unsigned        mask;
4002         unsigned        RETVAL;
4003         dXSTARG;
4004
4005         if (items < 1)
4006             new = MCW_EM;
4007         else {
4008             new = (unsigned)SvIV(ST(0));
4009         }
4010
4011         if (items < 2)
4012             mask = MCW_EM;
4013         else {
4014             mask = (unsigned)SvIV(ST(1));
4015         }
4016
4017         RETVAL = set_control87(new, mask);
4018         XSprePUSH; PUSHi((IV)RETVAL);
4019     }
4020     XSRETURN(1);
4021 }
4022
4023 XS(XS_OS2_incrMaxFHandles)              /* DosSetRelMaxFH */
4024 {
4025     dXSARGS;
4026     if (items < 0 || items > 1)
4027         Perl_croak(aTHX_ "Usage: OS2::incrMaxFHandles(delta = 0)");
4028     {
4029         LONG    delta;
4030         ULONG   RETVAL, rc;
4031         dXSTARG;
4032
4033         if (items < 1)
4034             delta = 0;
4035         else
4036             delta = (LONG)SvIV(ST(0));
4037
4038         if (CheckOSError(DosSetRelMaxFH(&delta, &RETVAL)))
4039             croak_with_os2error("OS2::incrMaxFHandles(): DosSetRelMaxFH() error");
4040         XSprePUSH; PUSHu((UV)RETVAL);
4041     }
4042     XSRETURN(1);
4043 }
4044
4045 /* wait>0: force wait, wait<0: force nowait;
4046    if restore, save/restore flags; otherwise flags are in oflags.
4047
4048    Returns 1 if connected, 0 if not (due to nowait); croaks on error. */
4049 static ULONG
4050 connectNPipe(ULONG hpipe, int wait, ULONG restore, ULONG oflags)
4051 {
4052     ULONG ret = ERROR_INTERRUPT, rc, flags;
4053
4054     if (restore && wait)
4055         os2cp_croak(DosQueryNPHState(hpipe, &oflags), "DosQueryNPHState()");
4056     /* DosSetNPHState fails if more bits than NP_NOWAIT|NP_READMODE_MESSAGE */
4057     oflags &= (NP_NOWAIT | NP_READMODE_MESSAGE);
4058     flags = (oflags & ~NP_NOWAIT) | (wait > 0 ? NP_WAIT : NP_NOWAIT);
4059     /* We know (o)flags unless wait == 0 && restore */
4060     if (wait && (flags != oflags))
4061         os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()");
4062     while (ret == ERROR_INTERRUPT)
4063         ret = DosConnectNPipe(hpipe);
4064     (void)CheckOSError(ret);
4065     if (restore && wait && (flags != oflags))
4066         os2cp_croak(DosSetNPHState(hpipe, oflags), "DosSetNPHState() back");
4067     /* We know flags unless wait == 0 && restore */
4068     if ( ((wait || restore) ? (flags & NP_NOWAIT) : 1)
4069          && (ret == ERROR_PIPE_NOT_CONNECTED) )
4070         return 0;                       /* normal return value */
4071     if (ret == NO_ERROR)
4072         return 1;
4073     croak_with_os2error("DosConnectNPipe()");
4074 }
4075
4076 /* With a lot of manual editing:
4077 NO_OUTPUT ULONG
4078 DosCreateNPipe(PCSZ pszName, OUTLIST HPIPE hpipe, ULONG ulOpenMode, int connect = 1, int count = 1, ULONG ulInbufLength = 8192, ULONG ulOutbufLength = ulInbufLength, ULONG ulPipeMode = count | NP_NOWAIT | NP_TYPE_BYTE | NP_READMODE_BYTE, ULONG ulTimeout = 0)
4079    PREINIT:
4080         ULONG rc;
4081    C_ARGS:
4082         pszName, &hpipe, ulOpenMode, ulPipeMode, ulInbufLength, ulOutbufLength, ulTimeout
4083    POSTCALL:
4084         if (CheckOSError(RETVAL))
4085             croak_with_os2error("OS2::mkpipe() error");
4086 */
4087 XS(XS_OS2_pipe); /* prototype to pass -Wmissing-prototypes */
4088 XS(XS_OS2_pipe)
4089 {
4090     dXSARGS;
4091     if (items < 2 || items > 8)
4092         Perl_croak(aTHX_ "Usage: OS2::pipe(pszName, ulOpenMode, connect= 1, count= 1, ulInbufLength= 8192, ulOutbufLength= ulInbufLength, ulPipeMode= count | NP_NOWAIT | NP_TYPE_BYTE | NP_READMODE_BYTE, ulTimeout= 0)");
4093     {
4094         ULONG   RETVAL;
4095         PCSZ    pszName = ( SvOK(ST(0)) ? (PCSZ)SvPV(ST(0),PL_na) : NULL );
4096         HPIPE   hpipe;
4097         SV      *OpenMode = ST(1);
4098         ULONG   ulOpenMode;
4099         int     connect = 0, count, message_r = 0, message = 0, b = 0;
4100         ULONG   ulInbufLength,  ulOutbufLength, ulPipeMode, ulTimeout, rc;
4101         STRLEN  len;
4102         char    *s, buf[10], *s1, *perltype = Nullch;
4103         PerlIO  *perlio;
4104         double  timeout;
4105
4106         if (!pszName || !*pszName)
4107             Perl_croak(aTHX_ "OS2::pipe(): empty pipe name");
4108         s = SvPV(OpenMode, len);
4109         if (len == 4 && strEQ(s, "wait")) {     /* DosWaitNPipe() */
4110             ULONG ms = 0xFFFFFFFF, ret = ERROR_INTERRUPT; /* Indefinite */
4111
4112             if (items == 3) {
4113                 timeout = (double)SvNV(ST(2));
4114                 ms = timeout * 1000;
4115                 if (timeout < 0)
4116                     ms = 0xFFFFFFFF; /* Indefinite */
4117                 else if (timeout && !ms)
4118                     ms = 1;
4119             } else if (items > 3)
4120                 Perl_croak(aTHX_ "OS2::pipe(): too many arguments for wait-for-connect: %ld", (long)items);
4121
4122             while (ret == ERROR_INTERRUPT)
4123                 ret = DosWaitNPipe(pszName, ms);        /* XXXX Update ms? */
4124             os2cp_croak(ret, "DosWaitNPipe()");
4125             XSRETURN_YES;
4126         }
4127         if (len == 4 && strEQ(s, "call")) {     /* DosCallNPipe() */
4128             ULONG ms = 0xFFFFFFFF, got; /* Indefinite */
4129             STRLEN l;
4130             char *s;
4131             char buf[8192];
4132             STRLEN ll = sizeof(buf);
4133             char *b = buf;
4134
4135             if (items < 3 || items > 5)
4136                 Perl_croak(aTHX_ "usage: OS2::pipe(pszName, 'call', write [, timeout= 0xFFFFFFFF, buffsize = 8192])");
4137             s = SvPV(ST(2), l);
4138             if (items >= 4) {
4139                 timeout = (double)SvNV(ST(3));
4140                 ms = timeout * 1000;
4141                 if (timeout < 0)
4142                     ms = 0xFFFFFFFF; /* Indefinite */
4143                 else if (timeout && !ms)
4144                     ms = 1;
4145             }
4146             if (items >= 5) {
4147                 STRLEN lll = SvUV(ST(4));
4148                 SV *sv = NEWSV(914, lll);
4149
4150                 sv_2mortal(sv);
4151                 ll = lll;
4152                 b = SvPVX(sv);
4153             }
4154
4155             os2cp_croak(DosCallNPipe(pszName, s, l, b, ll, &got, ms),
4156                         "DosCallNPipe()");
4157             XSRETURN_PVN(b, got);
4158         }
4159         s1 = buf;
4160         if (len && len <= 3 && !(*s >= '0' && *s <= '9')) {
4161             int r, w, R, W;
4162
4163             r = strchr(s, 'r') != 0;
4164             w = strchr(s, 'w') != 0;
4165             R = strchr(s, 'R') != 0;
4166             W = strchr(s, 'W') != 0;
4167             b = strchr(s, 'b') != 0;
4168             if (r + w + R + W + b != len || (r && R) || (w && W))
4169                 Perl_croak(aTHX_ "OS2::pipe(): unknown OpenMode argument: `%s'", s);
4170             if ((r || R) && (w || W))
4171                 ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_DUPLEX;
4172             else if (r || R)
4173                 ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_INBOUND;
4174             else
4175                 ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_OUTBOUND;
4176             if (R)
4177                 message = message_r = 1;
4178             if (W)
4179                 message = 1;
4180             else if (w && R)
4181                 Perl_croak(aTHX_ "OS2::pipe(): can't have message read mode for non-message pipes");
4182         } else
4183             ulOpenMode = (ULONG)SvUV(OpenMode); /* ST(1) */
4184
4185         if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX
4186              || (ulOpenMode & 0x3) == NP_ACCESS_INBOUND )
4187             *s1++ = 'r';
4188         if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX )
4189             *s1++ = '+';
4190         if ( (ulOpenMode & 0x3) == NP_ACCESS_OUTBOUND )
4191             *s1++ = 'w';
4192         if (b)
4193             *s1++ = 'b';
4194         *s1 = 0;
4195         if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX )
4196             perltype = "+<&";
4197         else if ( (ulOpenMode & 0x3) == NP_ACCESS_OUTBOUND )
4198             perltype = ">&";
4199         else
4200             perltype = "<&";
4201
4202         if (items < 3)
4203             connect = -1;                       /* no wait */
4204         else if (SvTRUE(ST(2))) {
4205             s = SvPV(ST(2), len);
4206             if (len == 6 && strEQ(s, "nowait"))
4207                 connect = -1;                   /* no wait */
4208             else if (len == 4 && strEQ(s, "wait"))
4209                 connect = 1;                    /* wait */
4210             else
4211                 Perl_croak(aTHX_ "OS2::pipe(): unknown connect argument: `%s'", s);
4212         }
4213
4214         if (items < 4)
4215             count = 1;
4216         else
4217             count = (int)SvIV(ST(3));
4218
4219         if (items < 5)
4220             ulInbufLength = 8192;
4221         else
4222             ulInbufLength = (ULONG)SvUV(ST(4));
4223
4224         if (items < 6)
4225             ulOutbufLength = ulInbufLength;
4226         else
4227             ulOutbufLength = (ULONG)SvUV(ST(5));
4228
4229         if (count < -1 || count == 0 || count >= 255)
4230             Perl_croak(aTHX_ "OS2::pipe(): count should be -1 or between 1 and 254: %ld", (long)count);
4231         if (count < 0 )
4232             count = 255;                /* Unlimited */
4233
4234         ulPipeMode = count;
4235         if (items < 7)
4236             ulPipeMode |= (NP_WAIT
4237                            | (message ? NP_TYPE_MESSAGE : NP_TYPE_BYTE)
4238                            | (message_r ? NP_READMODE_MESSAGE : NP_READMODE_BYTE));
4239         else
4240             ulPipeMode |= (ULONG)SvUV(ST(6));
4241
4242         if (items < 8)
4243             timeout = 0;
4244         else
4245             timeout = (double)SvNV(ST(7));
4246         ulTimeout = timeout * 1000;
4247         if (timeout < 0)
4248             ulTimeout = 0xFFFFFFFF; /* Indefinite */
4249         else if (timeout && !ulTimeout)
4250             ulTimeout = 1;
4251
4252         RETVAL = DosCreateNPipe(pszName, &hpipe, ulOpenMode, ulPipeMode, ulInbufLength, ulOutbufLength, ulTimeout);
4253         if (CheckOSError(RETVAL))
4254             croak_with_os2error("OS2::pipe(): DosCreateNPipe() error");
4255
4256         if (connect)
4257             connectNPipe(hpipe, connect, 1, 0); /* XXXX wait, retval */
4258         hpipe = __imphandle(hpipe);
4259
4260         perlio = PerlIO_fdopen(hpipe, buf);
4261         ST(0) = sv_newmortal();
4262         {
4263             GV *gv = newGVgen("OS2::pipe");
4264             if ( do_open(gv, perltype, strlen(perltype), FALSE, 0, 0, perlio) )
4265                 sv_setsv(ST(0), sv_bless(newRV((SV*)gv), gv_stashpv("IO::Handle",1)));
4266             else
4267                 ST(0) = &PL_sv_undef;
4268         }
4269     }
4270     XSRETURN(1);
4271 }
4272
4273 XS(XS_OS2_pipeCntl); /* prototype to pass -Wmissing-prototypes */
4274 XS(XS_OS2_pipeCntl)
4275 {
4276     dXSARGS;
4277     if (items < 2 || items > 3)
4278         Perl_croak(aTHX_ "Usage: OS2::pipeCntl(pipe, op [, wait])");
4279     {
4280         ULONG   rc;
4281         PerlIO *perlio = IoIFP(sv_2io(ST(0)));
4282         IV      fn = PerlIO_fileno(perlio);
4283         HPIPE   hpipe = (HPIPE)fn;
4284         STRLEN  len;
4285         char    *s = SvPV(ST(1), len);
4286         int     wait = 0, disconnect = 0, connect = 0, message = -1, query = 0;
4287         int     peek = 0, state = 0, info = 0;
4288
4289         if (fn < 0)
4290             Perl_croak(aTHX_ "OS2::pipeCntl(): not a pipe");
4291         if (items == 3)
4292             wait = (SvTRUE(ST(2)) ? 1 : -1);
4293
4294         switch (len) {
4295         case 4:
4296             if (strEQ(s, "byte"))
4297                 message = 0;
4298             else if (strEQ(s, "peek"))
4299                 peek = 1;
4300             else if (strEQ(s, "info"))
4301                 info = 1;
4302             else
4303                 goto unknown;
4304             break;
4305         case 5:
4306             if (strEQ(s, "reset"))
4307                 disconnect = connect = 1;
4308             else if (strEQ(s, "state"))
4309                 query = 1;
4310             else
4311                 goto unknown;
4312             break;
4313         case 7:
4314             if (strEQ(s, "connect"))
4315                 connect = 1;
4316             else if (strEQ(s, "message"))
4317                 message = 1;
4318             else
4319                 goto unknown;
4320             break;
4321         case 9:
4322             if (!strEQ(s, "readstate"))
4323                 goto unknown;
4324             state = 1;
4325             break;
4326         case 10:
4327             if (!strEQ(s, "disconnect"))
4328                 goto unknown;
4329             disconnect = 1;
4330             break;
4331         default:
4332           unknown:
4333             Perl_croak(aTHX_ "OS2::pipeCntl(): unknown argument: `%s'", s);
4334             break;
4335         }
4336
4337         if (items == 3 && !connect)
4338             Perl_croak(aTHX_ "OS2::pipeCntl(): no wait argument for `%s'", s);
4339
4340         XSprePUSH;              /* Do not need arguments any more */
4341         if (disconnect) {
4342             os2cp_croak(DosDisConnectNPipe(hpipe), "OS2::pipeCntl(): DosDisConnectNPipe()");
4343             PerlIO_clearerr(perlio);
4344         }
4345         if (connect) {
4346             if (!connectNPipe(hpipe, wait , 1, 0))
4347                 XSRETURN_IV(-1);
4348         }
4349         if (query) {
4350             ULONG flags;
4351
4352             os2cp_croak(DosQueryNPHState(hpipe, &flags), "DosQueryNPHState()");
4353             XSRETURN_UV(flags);
4354         }
4355         if (peek || state || info) {
4356             ULONG BytesRead, PipeState;
4357             AVAILDATA BytesAvail;
4358
4359             os2cp_croak( DosPeekNPipe(hpipe, NULL, 0, &BytesRead, &BytesAvail,
4360                                       &PipeState), "DosPeekNPipe() for state");
4361             if (state) {
4362                 EXTEND(SP, 3);
4363                 PUSHs(newSVuv(PipeState));
4364                 /*   Bytes (available/in-message) */
4365                 PUSHs(newSViv(BytesAvail.cbpipe));
4366                 PUSHs(newSViv(BytesAvail.cbmessage));
4367                 XSRETURN(3);
4368             } else if (info) {
4369                 /* L S S C C C/Z*
4370                    ID of the (remote) computer
4371                    buffers (out/in)
4372                    instances (max/actual)
4373                  */
4374                 struct pipe_info_t {
4375                     ULONG id;                   /* char id[4]; */
4376                     PIPEINFO pInfo;
4377                     char buf[512];
4378                 } b;
4379                 int size;
4380
4381                 os2cp_croak( DosQueryNPipeInfo(hpipe, 1, &b.pInfo, sizeof(b) - STRUCT_OFFSET(struct pipe_info_t, pInfo)),
4382                              "DosQueryNPipeInfo(1)");
4383                 os2cp_croak( DosQueryNPipeInfo(hpipe, 2, &b.id, sizeof(b.id)),
4384                              "DosQueryNPipeInfo(2)");
4385                 size = b.pInfo.cbName;
4386                 /* Trailing 0 is included in cbName - undocumented; so
4387                    one should always extract with Z* */
4388                 if (size)               /* name length 254 or less */
4389                     size--;
4390                 else
4391                     size = strlen(b.pInfo.szName);
4392                 EXTEND(SP, 6);
4393                 PUSHs(newSVpvn(b.pInfo.szName, size));
4394                 PUSHs(newSVuv(b.id));
4395                 PUSHs(newSViv(b.pInfo.cbOut));
4396                 PUSHs(newSViv(b.pInfo.cbIn));
4397                 PUSHs(newSViv(b.pInfo.cbMaxInst));
4398                 PUSHs(newSViv(b.pInfo.cbCurInst));
4399                 XSRETURN(6);
4400             } else if (BytesAvail.cbpipe == 0) {
4401                 XSRETURN_NO;
4402             } else {
4403                 SV *tmp = NEWSV(914, BytesAvail.cbpipe);
4404                 char *s = SvPVX(tmp);
4405
4406                 sv_2mortal(tmp);
4407                 os2cp_croak( DosPeekNPipe(hpipe, s, BytesAvail.cbpipe, &BytesRead,
4408                                           &BytesAvail, &PipeState), "DosPeekNPipe()");
4409                 SvCUR_set(tmp, BytesRead);
4410                 *SvEND(tmp) = 0;
4411                 SvPOK_on(tmp);
4412                 XSprePUSH; PUSHs(tmp);
4413                 XSRETURN(1);
4414             }
4415         }
4416         if (message > -1) {
4417             ULONG oflags, flags;
4418
4419             os2cp_croak(DosQueryNPHState(hpipe, &oflags), "DosQueryNPHState()");
4420             /* DosSetNPHState fails if more bits than NP_NOWAIT|NP_READMODE_MESSAGE */
4421             oflags &= (NP_NOWAIT | NP_READMODE_MESSAGE);
4422             flags = (oflags & NP_NOWAIT)
4423                 | (message ? NP_READMODE_MESSAGE : NP_READMODE_BYTE);
4424             if (flags != oflags)
4425                 os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()");
4426         }
4427     }
4428     XSRETURN_YES;
4429 }
4430
4431 /*
4432 NO_OUTPUT ULONG
4433 DosOpen(PCSZ pszFileName, OUTLIST HFILE hFile, OUTLIST ULONG ulAction, ULONG ulOpenFlags, ULONG ulOpenMode = OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW, ULONG ulAttribute = FILE_NORMAL, ULONG ulFileSize = 0, PEAOP2 pEABuf = NULL);
4434    PREINIT:
4435         ULONG rc;
4436    C_ARGS:
4437         pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf
4438    POSTCALL:
4439         if (CheckOSError(RETVAL))
4440             croak_with_os2error("OS2::open() error");
4441 */
4442 XS(XS_OS2_open); /* prototype to pass -Wmissing-prototypes */
4443 XS(XS_OS2_open)
4444 {
4445     dXSARGS;
4446     if (items < 2 || items > 6)
4447         Perl_croak(aTHX_ "Usage: OS2::open(pszFileName, ulOpenMode, ulOpenFlags= OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW, ulAttribute= FILE_NORMAL, ulFileSize= 0, pEABuf= NULL)");
4448     {
4449 #line 39 "pipe.xs"
4450         ULONG rc;
4451 #line 113 "pipe.c"
4452         ULONG   RETVAL;
4453         PCSZ    pszFileName = ( SvOK(ST(0)) ? (PCSZ)SvPV(ST(0),PL_na) : NULL );
4454         HFILE   hFile;
4455         ULONG   ulAction;
4456         ULONG   ulOpenMode = (ULONG)SvUV(ST(1));
4457         ULONG   ulOpenFlags;
4458         ULONG   ulAttribute;
4459         ULONG   ulFileSize;
4460         PEAOP2  pEABuf;
4461
4462         if (items < 3)
4463             ulOpenFlags = OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW;
4464         else {
4465             ulOpenFlags = (ULONG)SvUV(ST(2));
4466         }
4467
4468         if (items < 4)
4469             ulAttribute = FILE_NORMAL;
4470         else {
4471             ulAttribute = (ULONG)SvUV(ST(3));
4472         }
4473
4474         if (items < 5)
4475             ulFileSize = 0;
4476         else {
4477             ulFileSize = (ULONG)SvUV(ST(4));
4478         }
4479
4480         if (items < 6)
4481             pEABuf = NULL;
4482         else {
4483             pEABuf = (PEAOP2)SvUV(ST(5));
4484         }
4485
4486         RETVAL = DosOpen(pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf);
4487         if (CheckOSError(RETVAL))
4488             croak_with_os2error("OS2::open() error");
4489         XSprePUSH;      EXTEND(SP,2);
4490         PUSHs(sv_newmortal());
4491         sv_setuv(ST(0), (UV)hFile);
4492         PUSHs(sv_newmortal());
4493         sv_setuv(ST(1), (UV)ulAction);
4494     }
4495     XSRETURN(2);
4496 }
4497
4498 int
4499 Xs_OS2_init(pTHX)
4500 {
4501     char *file = __FILE__;
4502     {
4503         GV *gv;
4504
4505         if (_emx_env & 0x200) { /* OS/2 */
4506             newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
4507             newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
4508             newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
4509             newXS("OS2::extLibpath", XS_Cwd_extLibpath, file);
4510             newXS("OS2::extLibpath_set", XS_Cwd_extLibpath_set, file);
4511         }
4512         newXS("OS2::Error", XS_OS2_Error, file);
4513         newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
4514         newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
4515         newXSproto("OS2::DevCap", XS_OS2_DevCap, file, ";$$");
4516         newXSproto("OS2::SysInfoFor", XS_OS2_SysInfoFor, file, "$;$");
4517         newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
4518         newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
4519         newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
4520         newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
4521         newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
4522         newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
4523         newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
4524         newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
4525         newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
4526         newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
4527         newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
4528         newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
4529         newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
4530         newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
4531         newXS("OS2::replaceModule", XS_OS2_replaceModule, file);
4532         newXS("OS2::perfSysCall", XS_OS2_perfSysCall, file);
4533         newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
4534         newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
4535         newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
4536         newXSproto("OS2::DLLname", XS_OS2_DLLname, file, ";$$");
4537         newXSproto("OS2::mytype", XS_OS2_mytype, file, ";$");
4538         newXSproto("OS2::mytype_set", XS_OS2_mytype_set, file, "$");
4539         newXSproto("OS2::_headerInfo", XS_OS2__headerInfo, file, "$$;$$");
4540         newXSproto("OS2::libPath", XS_OS2_libPath, file, "");
4541         newXSproto("OS2::Timer", XS_OS2_Timer, file, "");
4542         newXSproto("OS2::msCounter", XS_OS2_msCounter, file, "");
4543         newXSproto("OS2::ms_sleep", XS_OS2_ms_sleep, file, "$;$");
4544         newXSproto("OS2::_InfoTable", XS_OS2__InfoTable, file, ";$");
4545         newXSproto("OS2::incrMaxFHandles", XS_OS2_incrMaxFHandles, file, ";$");
4546         newXSproto("OS2::SysValues", XS_OS2_SysValues, file, ";$$");
4547         newXSproto("OS2::SysValues_set", XS_OS2_SysValues_set, file, "$$;$");
4548         newXSproto("OS2::Beep", XS_OS2_Beep, file, ";$$");
4549         newXSproto("OS2::pipe", XS_OS2_pipe, file, "$$;$$$$$$");
4550         newXSproto("OS2::pipeCntl", XS_OS2_pipeCntl, file, "$$;$");
4551         newXSproto("OS2::open", XS_OS2_open, file, "$$;$$$$");
4552         gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
4553         GvMULTI_on(gv);
4554 #ifdef PERL_IS_AOUT
4555         sv_setiv(GvSV(gv), 1);
4556 #endif
4557         gv = gv_fetchpv("OS2::is_static", TRUE, SVt_PV);
4558         GvMULTI_on(gv);
4559 #ifdef PERL_IS_AOUT
4560         sv_setiv(GvSV(gv), 1);
4561 #endif
4562         gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV);
4563         GvMULTI_on(gv);
4564         sv_setiv(GvSV(gv), exe_is_aout());
4565         gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
4566         GvMULTI_on(gv);
4567         sv_setiv(GvSV(gv), _emx_rev);
4568         sv_setpv(GvSV(gv), _emx_vprt);
4569         SvIOK_on(GvSV(gv));
4570         gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
4571         GvMULTI_on(gv);
4572         sv_setiv(GvSV(gv), _emx_env);
4573         gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
4574         GvMULTI_on(gv);
4575         sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
4576         gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV);
4577         GvMULTI_on(gv);
4578         sv_setiv(GvSV(gv), 1);          /* DEFAULT: Show number on syserror */
4579     }
4580     return 0;
4581 }
4582
4583 extern void _emx_init(void*);
4584
4585 static void jmp_out_of_atexit(void);
4586
4587 #define FORCE_EMX_INIT_CONTRACT_ARGV    1
4588 #define FORCE_EMX_INIT_INSTALL_ATEXIT   2
4589
4590 static void
4591 my_emx_init(void *layout) {
4592     static volatile void *old_esp = 0;  /* Cannot be on stack! */
4593
4594     /* Can't just call emx_init(), since it moves the stack pointer */
4595     /* It also busts a lot of registers, so be extra careful */
4596     __asm__(    "pushf\n"
4597                 "pusha\n"
4598                 "movl %%esp, %1\n"
4599                 "push %0\n"
4600                 "call __emx_init\n"
4601                 "movl %1, %%esp\n"
4602                 "popa\n"
4603                 "popf\n" : : "r" (layout), "m" (old_esp)        );
4604 }
4605
4606 struct layout_table_t {
4607     ULONG text_base;
4608     ULONG text_end;
4609     ULONG data_base;
4610     ULONG data_end;
4611     ULONG bss_base;
4612     ULONG bss_end;
4613     ULONG heap_base;
4614     ULONG heap_end;
4615     ULONG heap_brk;
4616     ULONG heap_off;
4617     ULONG os2_dll;
4618     ULONG stack_base;
4619     ULONG stack_end;
4620     ULONG flags;
4621     ULONG reserved[2];
4622     char options[64];
4623 };
4624
4625 static ULONG
4626 my_os_version() {
4627     static ULONG osv_res;               /* Cannot be on stack! */
4628
4629     /* Can't just call __os_version(), since it does not follow C
4630        calling convention: it busts a lot of registers, so be extra careful */
4631     __asm__(    "pushf\n"
4632                 "pusha\n"
4633                 "call ___os_version\n"
4634                 "movl %%eax, %0\n"
4635                 "popa\n"
4636                 "popf\n" : "=m" (osv_res)       );
4637
4638     return osv_res;
4639 }
4640
4641 static void
4642 force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags)
4643 {
4644     /* Calling emx_init() will bust the top of stack: it installs an
4645        exception handler and puts argv data there. */
4646     char *oldarg, *oldenv;
4647     void *oldstackend, *oldstack;
4648     PPIB pib;
4649     PTIB tib;
4650     ULONG rc, error = 0, out;
4651     char buf[512];
4652     static struct layout_table_t layout_table;
4653     struct {
4654         char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */
4655         double alignment1;
4656         EXCEPTIONREGISTRATIONRECORD xreg;
4657     } *newstack;
4658     char *s;
4659
4660     layout_table.os2_dll = (ULONG)&os2_dll_fake;
4661     layout_table.flags   = 0x02000002;  /* flags: application, OMF */
4662
4663     DosGetInfoBlocks(&tib, &pib);
4664     oldarg = pib->pib_pchcmd;
4665     oldenv = pib->pib_pchenv;
4666     oldstack = tib->tib_pstack;
4667     oldstackend = tib->tib_pstacklimit;
4668
4669     if ( (char*)&s < (char*)oldstack + 4*1024
4670          || (char *)oldstackend < (char*)oldstack + 52*1024 )
4671         early_error("It is a lunacy to try to run EMX Perl ",
4672                     "with less than 64K of stack;\r\n",
4673                     "  at least with non-EMX starter...\r\n");
4674
4675     /* Minimize the damage to the stack via reducing the size of argv. */
4676     if (flags & FORCE_EMX_INIT_CONTRACT_ARGV) {
4677         pib->pib_pchcmd = "\0\0";       /* Need 3 concatenated strings */
4678         pib->pib_pchcmd = "\0";         /* Ended by an extra \0. */
4679     }
4680
4681     newstack = alloca(sizeof(*newstack));
4682     /* Emulate the stack probe */
4683     s = ((char*)newstack) + sizeof(*newstack);
4684     while (s > (char*)newstack) {
4685         s[-1] = 0;
4686         s -= 4096;
4687     }
4688
4689     /* Reassigning stack is documented to work */
4690     tib->tib_pstack = (void*)newstack;
4691     tib->tib_pstacklimit = (void*)((char*)newstack + sizeof(*newstack));
4692
4693     /* Can't just call emx_init(), since it moves the stack pointer */
4694     my_emx_init((void*)&layout_table);
4695
4696     /* Remove the exception handler, cannot use it - too low on the stack.
4697        Check whether it is inside the new stack.  */
4698     buf[0] = 0;
4699     if (tib->tib_pexchain >= tib->tib_pstacklimit
4700         || tib->tib_pexchain < tib->tib_pstack) {
4701         error = 1;
4702         sprintf(buf,
4703                 "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n",
4704                 (unsigned long)tib->tib_pstack,
4705                 (unsigned long)tib->tib_pexchain,
4706                 (unsigned long)tib->tib_pstacklimit);
4707         goto finish;
4708     }
4709     if (tib->tib_pexchain != &(newstack->xreg)) {
4710         sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n",
4711                 (unsigned long)tib->tib_pexchain,
4712                 (unsigned long)&(newstack->xreg));
4713     }
4714     rc = DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)tib->tib_pexchain);
4715     if (rc)
4716         sprintf(buf + strlen(buf),
4717                 "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc);
4718
4719     if (preg) {
4720         /* ExceptionRecords should be on stack, in a correct order.  Sigh... */
4721         preg->prev_structure = 0;
4722         preg->ExceptionHandler = _emx_exception;
4723         rc = DosSetExceptionHandler(preg);
4724         if (rc) {
4725             sprintf(buf + strlen(buf),
4726                     "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc);
4727             DosWrite(2, buf, strlen(buf), &out);
4728             emx_exception_init = 1;     /* Do it around spawn*() calls */
4729         }
4730     } else
4731         emx_exception_init = 1;         /* Do it around spawn*() calls */
4732
4733   finish:
4734     /* Restore the damage */
4735     pib->pib_pchcmd = oldarg;
4736     pib->pib_pchcmd = oldenv;
4737     tib->tib_pstacklimit = oldstackend;
4738     tib->tib_pstack = oldstack;
4739     emx_runtime_init = 1;
4740     if (buf[0])
4741         DosWrite(2, buf, strlen(buf), &out);
4742     if (error)
4743         exit(56);
4744 }
4745
4746 static void
4747 jmp_out_of_atexit(void)
4748 {
4749     if (longjmp_at_exit)
4750         longjmp(at_exit_buf, 1);
4751 }
4752
4753 extern void _CRT_term(void);
4754
4755 void
4756 Perl_OS2_term(void **p, int exitstatus, int flags)
4757 {
4758     if (!emx_runtime_secondary)
4759         return;
4760
4761     /* The principal executable is not running the same CRTL, so there
4762        is nobody to shutdown *this* CRTL except us... */
4763     if (flags & FORCE_EMX_DEINIT_EXIT) {
4764         if (p && !emx_exception_init)
4765             DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
4766         /* Do not run the executable's CRTL's termination routines */
4767         exit(exitstatus);               /* Run at-exit, flush buffers, etc */
4768     }
4769     /* Run at-exit list, and jump out at the end */
4770     if ((flags & FORCE_EMX_DEINIT_RUN_ATEXIT) && !setjmp(at_exit_buf)) {
4771         longjmp_at_exit = 1;
4772         exit(exitstatus);               /* The first pass through "if" */
4773     }
4774
4775     /* Get here if we managed to jump out of exit(), or did not run atexit. */
4776     longjmp_at_exit = 0;                /* Maybe exit() is called again? */
4777 #if 0 /* _atexit_n is not exported */
4778     if (flags & FORCE_EMX_DEINIT_RUN_ATEXIT)
4779         _atexit_n = 0;                  /* Remove the atexit() handlers */
4780 #endif
4781     /* Will segfault on program termination if we leave this dangling... */
4782     if (p && !emx_exception_init)
4783         DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
4784     /* Typically there is no need to do this, done from _DLL_InitTerm() */
4785     if (flags & FORCE_EMX_DEINIT_CRT_TERM)
4786         _CRT_term();                    /* Flush buffers, etc. */
4787     /* Now it is a good time to call exit() in the caller's CRTL... */
4788 }
4789
4790 #include <emx/startup.h>
4791
4792 extern ULONG __os_version();            /* See system.doc */
4793
4794 void
4795 check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
4796 {
4797     ULONG v_crt, v_emx, count = 0, rc = NO_ERROR, rc1, maybe_inited = 0;
4798     static HMTX hmtx_emx_init = NULLHANDLE;
4799     static int emx_init_done = 0;
4800
4801     /*  If _environ is not set, this code sits in a DLL which
4802         uses a CRT DLL which not compatible with the executable's
4803         CRT library.  Some parts of the DLL are not initialized.
4804      */
4805     if (_environ != NULL)
4806         return;                         /* Properly initialized */
4807
4808     /* It is not DOS, so we may use OS/2 API now */
4809     /* Some data we manipulate is static; protect ourselves from
4810        calling the same API from a different thread. */
4811     DosEnterMustComplete(&count);
4812
4813     rc1 = DosEnterCritSec();
4814     if (!hmtx_emx_init)
4815         rc = DosCreateMutexSem(NULL, &hmtx_emx_init, 0, TRUE); /*Create owned*/
4816     else
4817         maybe_inited = 1;
4818
4819     if (rc != NO_ERROR)
4820         hmtx_emx_init = NULLHANDLE;
4821
4822     if (rc1 == NO_ERROR)
4823         DosExitCritSec();
4824     DosExitMustComplete(&count);
4825
4826     while (maybe_inited) { /* Other thread did or is doing the same now */
4827         if (emx_init_done)
4828             return;
4829         rc = DosRequestMutexSem(hmtx_emx_init,
4830                                 (ULONG) SEM_INDEFINITE_WAIT);  /* Timeout (none) */
4831         if (rc == ERROR_INTERRUPT)
4832             continue;
4833         if (rc != NO_ERROR) {
4834             char buf[80];
4835             ULONG out;
4836
4837             sprintf(buf,
4838                     "panic: EMX backdoor init: DosRequestMutexSem error: %lu=%#lx\n", rc, rc);
4839             DosWrite(2, buf, strlen(buf), &out);
4840             return;
4841         }
4842         DosReleaseMutexSem(hmtx_emx_init);
4843         return;
4844     }
4845
4846     /*  If the executable does not use EMX.DLL, EMX.DLL is not completely
4847         initialized either.  Uninitialized EMX.DLL returns 0 in the low
4848         nibble of __os_version().  */
4849     v_emx = my_os_version();
4850
4851     /*  _osmajor and _osminor are normally set in _DLL_InitTerm of CRT DLL
4852         (=>_CRT_init=>_entry2) via a call to __os_version(), then
4853         reset when the EXE initialization code calls _text=>_init=>_entry2.
4854         The first time they are wrongly set to 0; the second time the
4855         EXE initialization code had already called emx_init=>initialize1
4856         which correctly set version_major, version_minor used by
4857         __os_version().  */
4858     v_crt = (_osmajor | _osminor);
4859
4860     if ((_emx_env & 0x200) && !(v_emx & 0xFFFF)) {      /* OS/2, EMX uninit. */
4861         force_init_emx_runtime( preg,
4862                                 FORCE_EMX_INIT_CONTRACT_ARGV
4863                                 | FORCE_EMX_INIT_INSTALL_ATEXIT );
4864         emx_wasnt_initialized = 1;
4865         /* Update CRTL data basing on now-valid EMX runtime data */
4866         if (!v_crt) {           /* The only wrong data are the versions. */
4867             v_emx = my_os_version();                    /* *Now* it works */
4868             *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */
4869             *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF;
4870         }
4871     }
4872     emx_runtime_secondary = 1;
4873     /* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */
4874     atexit(jmp_out_of_atexit);          /* Allow run of atexit() w/o exit()  */
4875
4876     if (env == NULL) {                  /* Fetch from the process info block */
4877         int c = 0;
4878         PPIB pib;
4879         PTIB tib;
4880         char *e, **ep;
4881
4882         DosGetInfoBlocks(&tib, &pib);
4883         e = pib->pib_pchenv;
4884         while (*e) {                    /* Get count */
4885             c++;
4886             e = e + strlen(e) + 1;
4887         }
4888         Newx(env, c + 1, char*);
4889         ep = env;
4890         e = pib->pib_pchenv;
4891         while (c--) {
4892             *ep++ = e;
4893             e = e + strlen(e) + 1;
4894         }
4895         *ep = NULL;
4896     }
4897     _environ = _org_environ = env;
4898     emx_init_done = 1;
4899     if (hmtx_emx_init)
4900         DosReleaseMutexSem(hmtx_emx_init);
4901 }
4902
4903 #define ENTRY_POINT 0x10000
4904
4905 static int
4906 exe_is_aout(void)
4907 {
4908     struct layout_table_t *layout;
4909     if (emx_wasnt_initialized)
4910         return 0;
4911     /* Now we know that the principal executable is an EMX application
4912        - unless somebody did already play with delayed initialization... */
4913     /* With EMX applications to determine whether it is AOUT one needs
4914        to examine the start of the executable to find "layout" */
4915     if ( *(unsigned char*)ENTRY_POINT != 0x68           /* PUSH n */
4916          || *(unsigned char*)(ENTRY_POINT+5) != 0xe8    /* CALL */
4917          || *(unsigned char*)(ENTRY_POINT+10) != 0xeb   /* JMP */
4918          || *(unsigned char*)(ENTRY_POINT+12) != 0xe8)  /* CALL */
4919         return 0;                                       /* ! EMX executable */
4920     /* Fix alignment */
4921     Copy((char*)(ENTRY_POINT+1), &layout, 1, struct layout_table_t*);
4922     return !(layout->flags & 2);
4923 }
4924
4925 void
4926 Perl_OS2_init(char **env)
4927 {
4928     Perl_OS2_init3(env, 0, 0);
4929 }
4930
4931 void
4932 Perl_OS2_init3(char **env, void **preg, int flags)
4933 {
4934     char *shell, *s;
4935     ULONG rc;
4936
4937     _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
4938     MALLOC_INIT;
4939
4940     check_emx_runtime(env, (EXCEPTIONREGISTRATIONRECORD *)preg);
4941
4942     settmppath();
4943     OS2_Perl_data.xs_init = &Xs_OS2_init;
4944     if (perl_sh_installed) {
4945         int l = strlen(perl_sh_installed);
4946
4947         Newx(PL_sh_path, l + 1, char);
4948         memcpy(PL_sh_path, perl_sh_installed, l + 1);
4949     } else if ( (shell = getenv("PERL_SH_DRIVE")) ) {
4950         Newx(PL_sh_path, strlen(SH_PATH) + 1, char);
4951         strcpy(PL_sh_path, SH_PATH);
4952         PL_sh_path[0] = shell[0];
4953     } else if ( (shell = getenv("PERL_SH_DIR")) ) {
4954         int l = strlen(shell), i;
4955
4956         while (l && (shell[l-1] == '/' || shell[l-1] == '\\'))
4957             l--;
4958         Newx(PL_sh_path, l + 8, char);
4959         strncpy(PL_sh_path, shell, l);
4960         strcpy(PL_sh_path + l, "/sh.exe");
4961         for (i = 0; i < l; i++) {
4962             if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
4963         }
4964     }
4965 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
4966     MUTEX_INIT(&start_thread_mutex);
4967     MUTEX_INIT(&perlos2_state_mutex);
4968 #endif
4969     os2_mytype = my_type();             /* Do it before morphing.  Needed? */
4970     os2_mytype_ini = os2_mytype;
4971     Perl_os2_initial_mode = -1;         /* Uninit */
4972
4973     s = getenv("PERL_BEGINLIBPATH");
4974     if (s)
4975       rc = fill_extLibpath(0, s, NULL, 1, "PERL_BEGINLIBPATH");
4976     else
4977       rc = fill_extLibpath(0, getenv("PERL_PRE_BEGINLIBPATH"), getenv("PERL_POST_BEGINLIBPATH"), 0, "PERL_(PRE/POST)_BEGINLIBPATH");
4978     if (!rc) {
4979         s = getenv("PERL_ENDLIBPATH");
4980         if (s)
4981             rc = fill_extLibpath(1, s, NULL, 1, "PERL_ENDLIBPATH");
4982         else
4983             rc = fill_extLibpath(1, getenv("PERL_PRE_ENDLIBPATH"), getenv("PERL_POST_ENDLIBPATH"), 0, "PERL_(PRE/POST)_ENDLIBPATH");
4984     }
4985     if (rc) {
4986         char buf[1024];
4987
4988         snprintf(buf, sizeof buf, "Error setting BEGIN/ENDLIBPATH: %s\n",
4989                  os2error(rc));
4990         DosWrite(2, buf, strlen(buf), &rc);
4991         exit(2);
4992     }
4993
4994     _emxload_env("PERL_EMXLOAD_SECS");
4995     /* Some DLLs reset FP flags on load.  We may have been linked with them */
4996     _control87(MCW_EM, MCW_EM);
4997 }
4998
4999 int
5000 fd_ok(int fd)
5001 {
5002     static ULONG max_fh = 0;
5003
5004     if (!(_emx_env & 0x200)) return 1;          /* not OS/2. */
5005     if (fd >= max_fh) {                         /* Renew */
5006         LONG delta = 0;
5007
5008         if (DosSetRelMaxFH(&delta, &max_fh))    /* Assume it OK??? */
5009             return 1;
5010     }
5011     return fd < max_fh;
5012 }
5013
5014 /* Kernels up to Oct 2003 trap on (invalid) dup(max_fh); [off-by-one + double fault].  */
5015 int
5016 dup2(int from, int to)
5017 {
5018     if (fd_ok(from < to ? to : from))
5019         return _dup2(from, to);
5020     errno = EBADF;
5021     return -1;
5022 }
5023
5024 int
5025 dup(int from)
5026 {
5027     if (fd_ok(from))
5028         return _dup(from);
5029     errno = EBADF;
5030     return -1;
5031 }
5032
5033 #undef tmpnam
5034 #undef tmpfile
5035
5036 char *
5037 my_tmpnam (char *str)
5038 {
5039     char *p = getenv("TMP"), *tpath;
5040
5041     if (!p) p = getenv("TEMP");
5042     tpath = tempnam(p, "pltmp");
5043     if (str && tpath) {
5044         strcpy(str, tpath);
5045         return str;
5046     }
5047     return tpath;
5048 }
5049
5050 FILE *
5051 my_tmpfile ()
5052 {
5053     struct stat s;
5054
5055     stat(".", &s);
5056     if (s.st_mode & S_IWOTH) {
5057         return tmpfile();
5058     }
5059     return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
5060                                              grants TMP. */
5061 }
5062
5063 #undef rmdir
5064
5065 /* EMX flavors do not tolerate trailing slashes.  t/op/mkdir.t has many
5066    trailing slashes, so we need to support this as well. */
5067
5068 int
5069 my_rmdir (__const__ char *s)
5070 {
5071     char b[MAXPATHLEN];
5072     char *buf = b;
5073     STRLEN l = strlen(s);
5074     int rc;
5075
5076     if (s[l-1] == '/' || s[l-1] == '\\') {      /* EMX mkdir fails... */
5077         if (l >= sizeof b)
5078             Newx(buf, l + 1, char);
5079         strcpy(buf,s);
5080         while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
5081             l--;
5082         buf[l] = 0;
5083         s = buf;
5084     }
5085     rc = rmdir(s);
5086     if (b != buf)
5087         Safefree(buf);
5088     return rc;
5089 }
5090
5091 #undef mkdir
5092
5093 int
5094 my_mkdir (__const__ char *s, long perm)
5095 {
5096     char b[MAXPATHLEN];
5097     char *buf = b;
5098     STRLEN l = strlen(s);
5099     int rc;
5100
5101     if (s[l-1] == '/' || s[l-1] == '\\') {      /* EMX mkdir fails... */
5102         if (l >= sizeof b)
5103             Newx(buf, l + 1, char);
5104         strcpy(buf,s);
5105         while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
5106             l--;
5107         buf[l] = 0;
5108         s = buf;
5109     }
5110     rc = mkdir(s, perm);
5111     if (b != buf)
5112         Safefree(buf);
5113     return rc;
5114 }
5115
5116 #undef flock
5117
5118 /* This code was contributed by Rocco Caputo. */
5119 int
5120 my_flock(int handle, int o)
5121 {
5122   FILELOCK      rNull, rFull;
5123   ULONG         timeout, handle_type, flag_word;
5124   APIRET        rc;
5125   int           blocking, shared;
5126   static int    use_my_flock = -1;
5127
5128   if (use_my_flock == -1) {
5129    MUTEX_LOCK(&perlos2_state_mutex);
5130    if (use_my_flock == -1) {
5131     char *s = getenv("USE_PERL_FLOCK");
5132     if (s)
5133         use_my_flock = atoi(s);
5134     else
5135         use_my_flock = 1;
5136    }
5137    MUTEX_UNLOCK(&perlos2_state_mutex);
5138   }
5139   if (!(_emx_env & 0x200) || !use_my_flock)
5140     return flock(handle, o);    /* Delegate to EMX. */
5141
5142                                         /* is this a file? */
5143   if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
5144       (handle_type & 0xFF))
5145   {
5146     errno = EBADF;
5147     return -1;
5148   }
5149                                         /* set lock/unlock ranges */
5150   rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
5151   rFull.lRange = 0x7FFFFFFF;
5152                                         /* set timeout for blocking */
5153   timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
5154                                         /* shared or exclusive? */
5155   shared = (o & LOCK_SH) ? 1 : 0;
5156                                         /* do not block the unlock */
5157   if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
5158     rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
5159     switch (rc) {
5160       case 0:
5161         errno = 0;
5162         return 0;
5163       case ERROR_INVALID_HANDLE:
5164         errno = EBADF;
5165         return -1;
5166       case ERROR_SHARING_BUFFER_EXCEEDED:
5167         errno = ENOLCK;
5168         return -1;
5169       case ERROR_LOCK_VIOLATION:
5170         break;                          /* not an error */
5171       case ERROR_INVALID_PARAMETER:
5172       case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
5173       case ERROR_READ_LOCKS_NOT_SUPPORTED:
5174         errno = EINVAL;
5175         return -1;
5176       case ERROR_INTERRUPT:
5177         errno = EINTR;
5178         return -1;
5179       default:
5180         errno = EINVAL;
5181         return -1;
5182     }
5183   }
5184                                         /* lock may block */
5185   if (o & (LOCK_SH | LOCK_EX)) {
5186                                         /* for blocking operations */
5187     for (;;) {
5188       rc =
5189         DosSetFileLocks(
5190                 handle,
5191                 &rNull,
5192                 &rFull,
5193                 timeout,
5194                 shared
5195         );
5196       switch (rc) {
5197         case 0:
5198           errno = 0;
5199           return 0;
5200         case ERROR_INVALID_HANDLE:
5201           errno = EBADF;
5202           return -1;
5203         case ERROR_SHARING_BUFFER_EXCEEDED:
5204           errno = ENOLCK;
5205           return -1;
5206         case ERROR_LOCK_VIOLATION:
5207           if (!blocking) {
5208             errno = EWOULDBLOCK;
5209             return -1;
5210           }
5211           break;
5212         case ERROR_INVALID_PARAMETER:
5213         case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
5214         case ERROR_READ_LOCKS_NOT_SUPPORTED:
5215           errno = EINVAL;
5216           return -1;
5217         case ERROR_INTERRUPT:
5218           errno = EINTR;
5219           return -1;
5220         default:
5221           errno = EINVAL;
5222           return -1;
5223       }
5224                                         /* give away timeslice */
5225       DosSleep(1);
5226     }
5227   }
5228
5229   errno = 0;
5230   return 0;
5231 }
5232
5233 static int
5234 use_my_pwent(void)
5235 {
5236   if (_my_pwent == -1) {
5237     char *s = getenv("USE_PERL_PWENT");
5238     if (s)
5239         _my_pwent = atoi(s);
5240     else
5241         _my_pwent = 1;
5242   }
5243   return _my_pwent;
5244 }
5245
5246 #undef setpwent
5247 #undef getpwent
5248 #undef endpwent
5249
5250 void
5251 my_setpwent(void)
5252 {
5253   if (!use_my_pwent()) {
5254     setpwent();                 /* Delegate to EMX. */
5255     return;
5256   }
5257   pwent_cnt = 0;
5258 }
5259
5260 void
5261 my_endpwent(void)
5262 {
5263   if (!use_my_pwent()) {
5264     endpwent();                 /* Delegate to EMX. */
5265     return;
5266   }
5267 }
5268
5269 struct passwd *
5270 my_getpwent (void)
5271 {
5272   if (!use_my_pwent())
5273     return getpwent();                  /* Delegate to EMX. */
5274   if (pwent_cnt++)
5275     return 0;                           /* Return one entry only */
5276   return getpwuid(0);
5277 }
5278
5279 void
5280 setgrent(void)
5281 {
5282   grent_cnt = 0;
5283 }
5284
5285 void
5286 endgrent(void)
5287 {
5288 }
5289
5290 struct group *
5291 getgrent (void)
5292 {
5293   if (grent_cnt++)
5294     return 0;                           /* Return one entry only */
5295   return getgrgid(0);
5296 }
5297
5298 #undef getpwuid
5299 #undef getpwnam
5300
5301 /* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */
5302 static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
5303
5304 static struct passwd *
5305 passw_wrap(struct passwd *p)
5306 {
5307     char *s;
5308
5309     if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
5310         return p;
5311     pw = *p;
5312     s = getenv("PW_PASSWD");
5313     if (!s)
5314         s = (char*)pw_p;                /* Make match impossible */
5315
5316     pw.pw_passwd = s;
5317     return &pw;
5318 }
5319
5320 struct passwd *
5321 my_getpwuid (uid_t id)
5322 {
5323     return passw_wrap(getpwuid(id));
5324 }
5325
5326 struct passwd *
5327 my_getpwnam (__const__ char *n)
5328 {
5329     return passw_wrap(getpwnam(n));
5330 }
5331
5332 char *
5333 gcvt_os2 (double value, int digits, char *buffer)
5334 {
5335   double absv = value > 0 ? value : -value;
5336   /* EMX implementation is lousy between 0.1 and 0.0001 (uses exponents below
5337      0.1), 1-digit stuff is ok below 0.001; multi-digit below 0.0001. */
5338   int buggy;
5339
5340   absv *= 10000;
5341   buggy = (absv < 1000 && (absv >= 10 || (absv > 1 && floor(absv) != absv)));
5342
5343   if (buggy) {
5344     char pat[12];
5345
5346     sprintf(pat, "%%.%dg", digits);
5347     sprintf(buffer, pat, value);
5348     return buffer;
5349   }
5350   return gcvt (value, digits, buffer);
5351 }
5352
5353 #undef fork
5354 int fork_with_resources()
5355 {
5356 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
5357   dTHX;
5358   void *ctx = PERL_GET_CONTEXT;
5359 #endif
5360   unsigned fpflag = _control87(0,0);
5361   int rc = fork();
5362
5363   if (rc == 0) {                        /* child */
5364 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
5365     ALLOC_THREAD_KEY;                   /* Acquire the thread-local memory */
5366     PERL_SET_CONTEXT(ctx);              /* Reinit the thread-local memory */
5367 #endif
5368
5369     {                                   /* Reload loaded-on-demand DLLs */
5370         struct dll_handle_t *dlls = dll_handles;
5371
5372         while (dlls->modname) {
5373             char dllname[260], fail[260];
5374             ULONG rc;
5375
5376             if (!dlls->handle) {        /* Was not loaded */
5377                 dlls++;
5378                 continue;
5379             }
5380             /* It was loaded in the parent.  We need to reload it. */
5381
5382             rc = DosQueryModuleName(dlls->handle, sizeof(dllname), dllname);
5383             if (rc) {
5384                 Perl_warn_nocontext("Can't find DLL name for the module `%s' by the handle %d, rc=%lu=%#lx",
5385                                     dlls->modname, (int)dlls->handle, rc, rc);
5386                 dlls++;
5387                 continue;
5388             }
5389             rc = DosLoadModule(fail, sizeof fail, dllname, &dlls->handle);
5390             if (rc)
5391                 Perl_warn_nocontext("Can't load DLL `%s', possible problematic module `%s'",
5392                                     dllname, fail);
5393             dlls++;
5394         }
5395     }
5396
5397     {                                   /* Support message queue etc. */
5398         os2_mytype = my_type();
5399         /* Apparently, subprocesses (in particular, fork()) do not
5400            inherit the morphed state, so os2_mytype is the same as
5401            os2_mytype_ini. */
5402
5403         if (Perl_os2_initial_mode != -1
5404             && Perl_os2_initial_mode != os2_mytype) {
5405                                         /* XXXX ??? */
5406         }
5407     }
5408     if (Perl_HAB_set)
5409         (void)_obtain_Perl_HAB;
5410     if (Perl_hmq_refcnt) {
5411         if (my_type() != 3)
5412             my_type_set(3);
5413         Create_HMQ(Perl_hmq_servers != 0,
5414                    "Cannot create a message queue on fork");
5415     }
5416
5417     /* We may have loaded some modules */
5418     _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
5419   }
5420   return rc;
5421 }
5422
5423 /* APIRET  APIENTRY DosGetInfoSeg(PSEL pselGlobal, PSEL pselLocal); */
5424
5425 ULONG _THUNK_FUNCTION(Dos16GetInfoSeg)(USHORT *pGlobal, USHORT *pLocal);
5426
5427 APIRET  APIENTRY
5428 myDosGetInfoSeg(PGINFOSEG *pGlobal, PLINFOSEG *pLocal)
5429 {
5430     APIRET rc;
5431     USHORT gSel, lSel;          /* Will not cross 64K boundary */
5432
5433     rc = ((USHORT)
5434           (_THUNK_PROLOG (4+4);
5435            _THUNK_FLAT (&gSel);
5436            _THUNK_FLAT (&lSel);
5437            _THUNK_CALL (Dos16GetInfoSeg)));
5438     if (rc)
5439         return rc;
5440     *pGlobal = MAKEPGINFOSEG(gSel);
5441     *pLocal  = MAKEPLINFOSEG(lSel);
5442     return rc;
5443 }
5444
5445 static void
5446 GetInfoTables(void)
5447 {
5448     ULONG rc = 0;
5449
5450     MUTEX_LOCK(&perlos2_state_mutex);
5451     if (!gTable)
5452       rc = myDosGetInfoSeg(&gTable, &lTable);
5453     MUTEX_UNLOCK(&perlos2_state_mutex);
5454     os2cp_croak(rc, "Dos16GetInfoSeg");
5455 }
5456
5457 ULONG
5458 msCounter(void)
5459 {                               /* XXXX Is not lTable thread-specific? */
5460   if (!gTable)
5461     GetInfoTables();
5462   return gTable->SIS_MsCount;
5463 }
5464
5465 ULONG
5466 InfoTable(int local)
5467 {
5468   if (!gTable)
5469     GetInfoTables();
5470   return local ? (ULONG)lTable : (ULONG)gTable;
5471 }