os2/os2.c

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