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