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