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