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