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