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 < 1 || items > 2)
2953         Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
2954     {
2955         STRLEN n_a;
2956         char *  path = (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     }
3077     XSRETURN(1);
3078 }
3079 typedef APIRET (*PELP)(PSZ path, ULONG type);
3080
3081 /* Kernels after 2000/09/15 understand this too: */
3082 #ifndef LIBPATHSTRICT
3083 #  define LIBPATHSTRICT 3
3084 #endif
3085
3086 APIRET
3087 ExtLIBPATH(ULONG ord, PSZ path, IV type)
3088 {
3089     ULONG what;
3090     PFN f = loadByOrdinal(ord, 1);      /* Guarantied to load or die! */
3091
3092     if (type > 0)
3093         what = END_LIBPATH;
3094     else if (type == 0)
3095         what = BEGIN_LIBPATH;
3096     else
3097         what = LIBPATHSTRICT;
3098     return (*(PELP)f)(path, what);
3099 }
3100
3101 #define extLibpath(to,type)                                             \
3102     (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type))) ? NULL : (to) )
3103
3104 #define extLibpath_set(p,type)                                  \
3105     (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type))))
3106
3107 XS(XS_Cwd_extLibpath)
3108 {
3109     dXSARGS;
3110     if (items < 0 || items > 1)
3111         Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
3112     {
3113         IV      type;
3114         char    to[1024];
3115         U32     rc;
3116         char *  RETVAL;
3117         dXSTARG;
3118
3119         if (items < 1)
3120             type = 0;
3121         else {
3122             type = SvIV(ST(0));
3123         }
3124
3125         to[0] = 1; to[1] = 0;           /* Sometimes no error reported */
3126         RETVAL = extLibpath(to, type);
3127         if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
3128             Perl_croak_nocontext("panic Cwd::extLibpath parameter");
3129         sv_setpv(TARG, RETVAL);
3130         XSprePUSH; PUSHTARG;
3131     }
3132     XSRETURN(1);
3133 }
3134
3135 XS(XS_Cwd_extLibpath_set)
3136 {
3137     dXSARGS;
3138     if (items < 1 || items > 2)
3139         Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
3140     {
3141         STRLEN n_a;
3142         char *  s = (char *)SvPV(ST(0),n_a);
3143         IV      type;
3144         U32     rc;
3145         bool    RETVAL;
3146
3147         if (items < 2)
3148             type = 0;
3149         else {
3150             type = SvIV(ST(1));
3151         }
3152
3153         RETVAL = extLibpath_set(s, type);
3154         ST(0) = boolSV(RETVAL);
3155         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3156     }
3157     XSRETURN(1);
3158 }
3159
3160 /* Input: Address, BufLen
3161 APIRET APIENTRY
3162 DosQueryModFromEIP (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
3163                     ULONG * Offset, ULONG Address);
3164 */
3165
3166 DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP,
3167                         (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
3168                         ULONG * Offset, ULONG Address),
3169                         (hmod, obj, BufLen, Buf, Offset, Address))
3170
3171 enum module_name_how { mod_name_handle, mod_name_shortname, mod_name_full,
3172   mod_name_C_function = 0x100, mod_name_HMODULE = 0x200};
3173
3174 static SV*
3175 module_name_at(void *pp, enum module_name_how how)
3176 {
3177     dTHX;
3178     char buf[MAXPATHLEN];
3179     char *p = buf;
3180     HMODULE mod;
3181     ULONG obj, offset, rc, addr = (ULONG)pp;
3182
3183     if (how & mod_name_HMODULE) {
3184         if ((how & ~mod_name_HMODULE) == mod_name_shortname)
3185             Perl_croak(aTHX_ "Can't get short module name from a handle");
3186         mod = (HMODULE)pp;
3187         how &= ~mod_name_HMODULE;
3188     } else if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, addr))
3189         return &PL_sv_undef;
3190     if (how == mod_name_handle)
3191         return newSVuv(mod);
3192     /* Full name... */
3193     if ( how != mod_name_shortname
3194          && CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) )
3195         return &PL_sv_undef;
3196     while (*p) {
3197         if (*p == '\\')
3198             *p = '/';
3199         p++;
3200     }
3201     return newSVpv(buf, 0);
3202 }
3203
3204 static SV*
3205 module_name_of_cv(SV *cv, enum module_name_how how)
3206 {
3207     if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv))) {
3208         dTHX;
3209
3210         if (how & mod_name_C_function)
3211             return module_name_at((void*)SvIV(cv), how & ~mod_name_C_function);
3212         else if (how & mod_name_HMODULE)
3213             return module_name_at((void*)SvIV(cv), how);
3214         Perl_croak(aTHX_ "Not an XSUB reference");
3215     }
3216     return module_name_at(CvXSUB(SvRV(cv)), how);
3217 }
3218
3219 /* Find module name to which *this* subroutine is compiled */
3220 #define module_name(how)        module_name_at(&module_name_at, how)
3221
3222 XS(XS_OS2_DLLname)
3223 {
3224     dXSARGS;
3225     if (items > 2)
3226         Perl_croak(aTHX_ "Usage: OS2::DLLname( [ how, [\\&xsub] ] )");
3227     {
3228         SV *    RETVAL;
3229         int     how;
3230
3231         if (items < 1)
3232             how = mod_name_full;
3233         else {
3234             how = (int)SvIV(ST(0));
3235         }
3236         if (items < 2)
3237             RETVAL = module_name(how);
3238         else
3239             RETVAL = module_name_of_cv(ST(1), how);
3240         ST(0) = RETVAL;
3241         sv_2mortal(ST(0));
3242     }
3243     XSRETURN(1);
3244 }
3245
3246 DeclOSFuncByORD(INT, _Dos32QueryHeaderInfo, ORD_Dos32QueryHeaderInfo,
3247                         (ULONG r1, ULONG r2, PVOID buf, ULONG szbuf, ULONG fnum),
3248                         (r1, r2, buf, szbuf, fnum))
3249
3250 XS(XS_OS2__headerInfo)
3251 {
3252     dXSARGS;
3253     if (items > 4 || items < 2)
3254         Perl_croak(aTHX_ "Usage: OS2::_headerInfo(req,size[,handle,[offset]])");
3255     {
3256         ULONG   req = (ULONG)SvIV(ST(0));
3257         STRLEN  size = (STRLEN)SvIV(ST(1)), n_a;
3258         ULONG   handle = (items >= 3 ? (ULONG)SvIV(ST(2)) : 0);
3259         ULONG   offset = (items >= 4 ? (ULONG)SvIV(ST(3)) : 0);
3260
3261         if (size <= 0)
3262             Perl_croak(aTHX_ "OS2::_headerInfo(): unexpected size: %d", (int)size);
3263         ST(0) = newSVpvn("",0);
3264         SvGROW(ST(0), size + 1);
3265         sv_2mortal(ST(0));
3266
3267         if (!_Dos32QueryHeaderInfo(handle, offset, SvPV(ST(0), n_a), size, req))
3268             Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3269                        req, size, handle, offset, os2error(Perl_rc));
3270         SvCUR_set(ST(0), size);
3271         *SvEND(ST(0)) = 0;
3272     }
3273     XSRETURN(1);
3274 }
3275
3276 #define DQHI_QUERYLIBPATHSIZE      4
3277 #define DQHI_QUERYLIBPATH          5
3278
3279 XS(XS_OS2_libPath)
3280 {
3281     dXSARGS;
3282     if (items != 0)
3283         Perl_croak(aTHX_ "Usage: OS2::libPath()");
3284     {
3285         ULONG   size;
3286         STRLEN  n_a;
3287
3288         if (!_Dos32QueryHeaderInfo(0, 0, &size, sizeof(size),
3289                                    DQHI_QUERYLIBPATHSIZE))
3290             Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3291                        DQHI_QUERYLIBPATHSIZE, sizeof(size), 0, 0,
3292                        os2error(Perl_rc));
3293         ST(0) = newSVpvn("",0);
3294         SvGROW(ST(0), size + 1);
3295         sv_2mortal(ST(0));
3296
3297         /* We should be careful: apparently, this entry point does not
3298            pay attention to the size argument, so may overwrite
3299            unrelated data! */
3300         if (!_Dos32QueryHeaderInfo(0, 0, SvPV(ST(0), n_a), size,
3301                                    DQHI_QUERYLIBPATH))
3302             Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3303                        DQHI_QUERYLIBPATH, size, 0, 0, os2error(Perl_rc));
3304         SvCUR_set(ST(0), size);
3305         *SvEND(ST(0)) = 0;
3306     }
3307     XSRETURN(1);
3308 }
3309
3310 #define get_control87()         _control87(0,0)
3311 #define set_control87           _control87
3312
3313 XS(XS_OS2__control87)
3314 {
3315     dXSARGS;
3316     if (items != 2)
3317         Perl_croak(aTHX_ "Usage: OS2::_control87(new,mask)");
3318     {
3319         unsigned        new = (unsigned)SvIV(ST(0));
3320         unsigned        mask = (unsigned)SvIV(ST(1));
3321         unsigned        RETVAL;
3322         dXSTARG;
3323
3324         RETVAL = _control87(new, mask);
3325         XSprePUSH; PUSHi((IV)RETVAL);
3326     }
3327     XSRETURN(1);
3328 }
3329
3330 XS(XS_OS2_mytype)
3331 {
3332     dXSARGS;
3333     int which = 0;
3334
3335     if (items < 0 || items > 1)
3336         Perl_croak(aTHX_ "Usage: OS2::mytype([which])");
3337     if (items == 1)
3338         which = (int)SvIV(ST(0));
3339     {
3340         unsigned        RETVAL;
3341         dXSTARG;
3342
3343         switch (which) {
3344         case 0:
3345             RETVAL = os2_mytype;        /* Reset after fork */
3346             break;
3347         case 1:
3348             RETVAL = os2_mytype_ini;    /* Before any fork */
3349             break;
3350         case 2:
3351             RETVAL = Perl_os2_initial_mode;     /* Before first morphing */
3352             break;
3353         case 3:
3354             RETVAL = my_type();         /* Morphed type */
3355             break;
3356         default:
3357             Perl_croak(aTHX_ "OS2::mytype(which): unknown which=%d", which);
3358         }
3359         XSprePUSH; PUSHi((IV)RETVAL);
3360     }
3361     XSRETURN(1);
3362 }
3363
3364
3365 XS(XS_OS2_mytype_set)
3366 {
3367     dXSARGS;
3368     int type;
3369
3370     if (items == 1)
3371         type = (int)SvIV(ST(0));
3372     else
3373         Perl_croak(aTHX_ "Usage: OS2::mytype_set(type)");
3374     my_type_set(type);
3375     XSRETURN_EMPTY;
3376 }
3377
3378
3379 XS(XS_OS2_get_control87)
3380 {
3381     dXSARGS;
3382     if (items != 0)
3383         Perl_croak(aTHX_ "Usage: OS2::get_control87()");
3384     {
3385         unsigned        RETVAL;
3386         dXSTARG;
3387
3388         RETVAL = get_control87();
3389         XSprePUSH; PUSHi((IV)RETVAL);
3390     }
3391     XSRETURN(1);
3392 }
3393
3394
3395 XS(XS_OS2_set_control87)
3396 {
3397     dXSARGS;
3398     if (items < 0 || items > 2)
3399         Perl_croak(aTHX_ "Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
3400     {
3401         unsigned        new;
3402         unsigned        mask;
3403         unsigned        RETVAL;
3404         dXSTARG;
3405
3406         if (items < 1)
3407             new = MCW_EM;
3408         else {
3409             new = (unsigned)SvIV(ST(0));
3410         }
3411
3412         if (items < 2)
3413             mask = MCW_EM;
3414         else {
3415             mask = (unsigned)SvIV(ST(1));
3416         }
3417
3418         RETVAL = set_control87(new, mask);
3419         XSprePUSH; PUSHi((IV)RETVAL);
3420     }
3421     XSRETURN(1);
3422 }
3423
3424 XS(XS_OS2_incrMaxFHandles)              /* DosSetRelMaxFH */
3425 {
3426     dXSARGS;
3427     if (items < 0 || items > 1)
3428         Perl_croak(aTHX_ "Usage: OS2::incrMaxFHandles(delta = 0)");
3429     {
3430         LONG    delta;
3431         ULONG   RETVAL, rc;
3432         dXSTARG;
3433
3434         if (items < 1)
3435             delta = 0;
3436         else
3437             delta = (LONG)SvIV(ST(0));
3438
3439         if (CheckOSError(DosSetRelMaxFH(&delta, &RETVAL)))
3440             croak_with_os2error("OS2::incrMaxFHandles(): DosSetRelMaxFH() error");
3441         XSprePUSH; PUSHu((UV)RETVAL);
3442     }
3443     XSRETURN(1);
3444 }
3445
3446 int
3447 Xs_OS2_init(pTHX)
3448 {
3449     char *file = __FILE__;
3450     {
3451         GV *gv;
3452
3453         if (_emx_env & 0x200) { /* OS/2 */
3454             newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
3455             newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
3456             newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
3457         }
3458         newXS("OS2::Error", XS_OS2_Error, file);
3459         newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
3460         newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
3461         newXSproto("OS2::DevCap", XS_OS2_DevCap, file, ";$$");
3462         newXSproto("OS2::SysInfoFor", XS_OS2_SysInfoFor, file, "$;$");
3463         newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
3464         newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
3465         newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
3466         newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
3467         newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
3468         newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
3469         newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
3470         newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
3471         newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
3472         newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
3473         newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
3474         newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
3475         newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
3476         newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
3477         newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
3478         newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
3479         newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
3480         newXSproto("OS2::DLLname", XS_OS2_DLLname, file, ";$$");
3481         newXSproto("OS2::mytype", XS_OS2_mytype, file, ";$");
3482         newXSproto("OS2::mytype_set", XS_OS2_mytype_set, file, "$");
3483         newXSproto("OS2::_headerInfo", XS_OS2__headerInfo, file, "$$;$$");
3484         newXSproto("OS2::libPath", XS_OS2_libPath, file, "");
3485         newXSproto("OS2::Timer", XS_OS2_Timer, file, "");
3486         newXSproto("OS2::incrMaxFHandles", XS_OS2_incrMaxFHandles, file, ";$");
3487         newXSproto("OS2::SysValues", XS_OS2_SysValues, file, ";$$");
3488         newXSproto("OS2::SysValues_set", XS_OS2_SysValues_set, file, "$$;$");
3489         newXSproto("OS2::Beep", XS_OS2_Beep, file, ";$$");
3490         gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
3491         GvMULTI_on(gv);
3492 #ifdef PERL_IS_AOUT
3493         sv_setiv(GvSV(gv), 1);
3494 #endif
3495         gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV);
3496         GvMULTI_on(gv);
3497         sv_setiv(GvSV(gv), exe_is_aout());
3498         gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
3499         GvMULTI_on(gv);
3500         sv_setiv(GvSV(gv), _emx_rev);
3501         sv_setpv(GvSV(gv), _emx_vprt);
3502         SvIOK_on(GvSV(gv));
3503         gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
3504         GvMULTI_on(gv);
3505         sv_setiv(GvSV(gv), _emx_env);
3506         gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
3507         GvMULTI_on(gv);
3508         sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
3509         gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV);
3510         GvMULTI_on(gv);
3511         sv_setiv(GvSV(gv), 1);          /* DEFAULT: Show number on syserror */
3512     }
3513     return 0;
3514 }
3515
3516 extern void _emx_init(void*);
3517
3518 static void jmp_out_of_atexit(void);
3519
3520 #define FORCE_EMX_INIT_CONTRACT_ARGV    1
3521 #define FORCE_EMX_INIT_INSTALL_ATEXIT   2
3522
3523 static void
3524 my_emx_init(void *layout) {
3525     static volatile void *old_esp = 0;  /* Cannot be on stack! */
3526
3527     /* Can't just call emx_init(), since it moves the stack pointer */
3528     /* It also busts a lot of registers, so be extra careful */
3529     __asm__(    "pushf\n"
3530                 "pusha\n"
3531                 "movl %%esp, %1\n"
3532                 "push %0\n"
3533                 "call __emx_init\n"
3534                 "movl %1, %%esp\n"
3535                 "popa\n"
3536                 "popf\n" : : "r" (layout), "m" (old_esp)        );
3537 }
3538
3539 struct layout_table_t {
3540     ULONG text_base;
3541     ULONG text_end;
3542     ULONG data_base;
3543     ULONG data_end;
3544     ULONG bss_base;
3545     ULONG bss_end;
3546     ULONG heap_base;
3547     ULONG heap_end;
3548     ULONG heap_brk;
3549     ULONG heap_off;
3550     ULONG os2_dll;
3551     ULONG stack_base;
3552     ULONG stack_end;
3553     ULONG flags;
3554     ULONG reserved[2];
3555     char options[64];
3556 };
3557
3558 static ULONG
3559 my_os_version() {
3560     static ULONG osv_res;               /* Cannot be on stack! */
3561
3562     /* Can't just call __os_version(), since it does not follow C
3563        calling convention: it busts a lot of registers, so be extra careful */
3564     __asm__(    "pushf\n"
3565                 "pusha\n"
3566                 "call ___os_version\n"
3567                 "movl %%eax, %0\n"
3568                 "popa\n"
3569                 "popf\n" : "=m" (osv_res)       );
3570
3571     return osv_res;
3572 }
3573
3574 static void
3575 force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags)
3576 {
3577     /* Calling emx_init() will bust the top of stack: it installs an
3578        exception handler and puts argv data there. */
3579     char *oldarg, *oldenv;
3580     void *oldstackend, *oldstack;
3581     PPIB pib;
3582     PTIB tib;
3583     ULONG rc, error = 0, out;
3584     char buf[512];
3585     static struct layout_table_t layout_table;
3586     struct {
3587         char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */
3588         double alignment1;
3589         EXCEPTIONREGISTRATIONRECORD xreg;
3590     } *newstack;
3591     char *s;
3592
3593     layout_table.os2_dll = (ULONG)&os2_dll_fake;
3594     layout_table.flags   = 0x02000002;  /* flags: application, OMF */
3595
3596     DosGetInfoBlocks(&tib, &pib);
3597     oldarg = pib->pib_pchcmd;
3598     oldenv = pib->pib_pchenv;
3599     oldstack = tib->tib_pstack;
3600     oldstackend = tib->tib_pstacklimit;
3601
3602     /* Minimize the damage to the stack via reducing the size of argv. */
3603     if (flags & FORCE_EMX_INIT_CONTRACT_ARGV) {
3604         pib->pib_pchcmd = "\0\0";       /* Need 3 concatenated strings */
3605         pib->pib_pchcmd = "\0";         /* Ended by an extra \0. */
3606     }
3607
3608     newstack = alloca(sizeof(*newstack));
3609     /* Emulate the stack probe */
3610     s = ((char*)newstack) + sizeof(*newstack);
3611     while (s > (char*)newstack) {
3612         s[-1] = 0;
3613         s -= 4096;
3614     }
3615
3616     /* Reassigning stack is documented to work */
3617     tib->tib_pstack = (void*)newstack;
3618     tib->tib_pstacklimit = (void*)((char*)newstack + sizeof(*newstack));
3619
3620     /* Can't just call emx_init(), since it moves the stack pointer */
3621     my_emx_init((void*)&layout_table);
3622
3623     /* Remove the exception handler, cannot use it - too low on the stack.
3624        Check whether it is inside the new stack.  */
3625     buf[0] = 0;
3626     if (tib->tib_pexchain >= tib->tib_pstacklimit
3627         || tib->tib_pexchain < tib->tib_pstack) {
3628         error = 1;
3629         sprintf(buf,
3630                 "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n",
3631                 (unsigned long)tib->tib_pstack,
3632                 (unsigned long)tib->tib_pexchain,
3633                 (unsigned long)tib->tib_pstacklimit);
3634         goto finish;
3635     }
3636     if (tib->tib_pexchain != &(newstack->xreg)) {
3637         sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n",
3638                 (unsigned long)tib->tib_pexchain,
3639                 (unsigned long)&(newstack->xreg));
3640     }
3641     rc = DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)tib->tib_pexchain);
3642     if (rc)
3643         sprintf(buf + strlen(buf),
3644                 "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc);
3645
3646     if (preg) {
3647         /* ExceptionRecords should be on stack, in a correct order.  Sigh... */
3648         preg->prev_structure = 0;
3649         preg->ExceptionHandler = _emx_exception;
3650         rc = DosSetExceptionHandler(preg);
3651         if (rc) {
3652             sprintf(buf + strlen(buf),
3653                     "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc);
3654             DosWrite(2, buf, strlen(buf), &out);
3655             emx_exception_init = 1;     /* Do it around spawn*() calls */
3656         }
3657     } else
3658         emx_exception_init = 1;         /* Do it around spawn*() calls */
3659
3660   finish:
3661     /* Restore the damage */
3662     pib->pib_pchcmd = oldarg;
3663     pib->pib_pchcmd = oldenv;
3664     tib->tib_pstacklimit = oldstackend;
3665     tib->tib_pstack = oldstack;
3666     emx_runtime_init = 1;
3667     if (buf[0])
3668         DosWrite(2, buf, strlen(buf), &out);
3669     if (error)
3670         exit(56);
3671 }
3672
3673 static void
3674 jmp_out_of_atexit(void)
3675 {
3676     if (longjmp_at_exit)
3677         longjmp(at_exit_buf, 1);
3678 }
3679
3680 extern void _CRT_term(void);
3681
3682 void
3683 Perl_OS2_term(void **p, int exitstatus, int flags)
3684 {
3685     if (!emx_runtime_secondary)
3686         return;
3687
3688     /* The principal executable is not running the same CRTL, so there
3689        is nobody to shutdown *this* CRTL except us... */
3690     if (flags & FORCE_EMX_DEINIT_EXIT) {
3691         if (p && !emx_exception_init)
3692             DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
3693         /* Do not run the executable's CRTL's termination routines */
3694         exit(exitstatus);               /* Run at-exit, flush buffers, etc */
3695     }
3696     /* Run at-exit list, and jump out at the end */
3697     if ((flags & FORCE_EMX_DEINIT_RUN_ATEXIT) && !setjmp(at_exit_buf)) {
3698         longjmp_at_exit = 1;
3699         exit(exitstatus);               /* The first pass through "if" */
3700     }
3701
3702     /* Get here if we managed to jump out of exit(), or did not run atexit. */
3703     longjmp_at_exit = 0;                /* Maybe exit() is called again? */
3704 #if 0 /* _atexit_n is not exported */
3705     if (flags & FORCE_EMX_DEINIT_RUN_ATEXIT)
3706         _atexit_n = 0;                  /* Remove the atexit() handlers */
3707 #endif
3708     /* Will segfault on program termination if we leave this dangling... */
3709     if (p && !emx_exception_init)
3710         DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
3711     /* Typically there is no need to do this, done from _DLL_InitTerm() */
3712     if (flags & FORCE_EMX_DEINIT_CRT_TERM)
3713         _CRT_term();                    /* Flush buffers, etc. */
3714     /* Now it is a good time to call exit() in the caller's CRTL... */
3715 }
3716
3717 #include <emx/startup.h>
3718
3719 extern ULONG __os_version();            /* See system.doc */
3720
3721 void
3722 check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
3723 {
3724     ULONG v_crt, v_emx, count = 0, rc, rc1, maybe_inited = 0;
3725     static HMTX hmtx_emx_init = NULLHANDLE;
3726     static int emx_init_done = 0;
3727
3728     /*  If _environ is not set, this code sits in a DLL which
3729         uses a CRT DLL which not compatible with the executable's
3730         CRT library.  Some parts of the DLL are not initialized.
3731      */
3732     if (_environ != NULL)
3733         return;                         /* Properly initialized */
3734
3735     /* It is not DOS, so we may use OS/2 API now */
3736     /* Some data we manipulate is static; protect ourselves from
3737        calling the same API from a different thread. */
3738     DosEnterMustComplete(&count);
3739
3740     rc1 = DosEnterCritSec();
3741     if (!hmtx_emx_init)
3742         rc = DosCreateMutexSem(NULL, &hmtx_emx_init, 0, TRUE); /*Create owned*/
3743     else
3744         maybe_inited = 1;
3745
3746     if (rc != NO_ERROR)
3747         hmtx_emx_init = NULLHANDLE;
3748
3749     if (rc1 == NO_ERROR)
3750         DosExitCritSec();
3751     DosExitMustComplete(&count);
3752
3753     while (maybe_inited) { /* Other thread did or is doing the same now */
3754         if (emx_init_done)
3755             return;
3756         rc = DosRequestMutexSem(hmtx_emx_init,
3757                                 (ULONG) SEM_INDEFINITE_WAIT);  /* Timeout (none) */
3758         if (rc == ERROR_INTERRUPT)
3759             continue;
3760         if (rc != NO_ERROR) {
3761             char buf[80];
3762             ULONG out;
3763
3764             sprintf(buf,
3765                     "panic: EMX backdoor init: DosRequestMutexSem error: %lu=%#lx\n", rc, rc);
3766             DosWrite(2, buf, strlen(buf), &out);
3767             return;
3768         }
3769         DosReleaseMutexSem(hmtx_emx_init);
3770         return;
3771     }
3772
3773     /*  If the executable does not use EMX.DLL, EMX.DLL is not completely
3774         initialized either.  Uninitialized EMX.DLL returns 0 in the low
3775         nibble of __os_version().  */
3776     v_emx = my_os_version();
3777
3778     /*  _osmajor and _osminor are normally set in _DLL_InitTerm of CRT DLL
3779         (=>_CRT_init=>_entry2) via a call to __os_version(), then
3780         reset when the EXE initialization code calls _text=>_init=>_entry2.
3781         The first time they are wrongly set to 0; the second time the
3782         EXE initialization code had already called emx_init=>initialize1
3783         which correctly set version_major, version_minor used by
3784         __os_version().  */
3785     v_crt = (_osmajor | _osminor);
3786
3787     if ((_emx_env & 0x200) && !(v_emx & 0xFFFF)) {      /* OS/2, EMX uninit. */
3788         force_init_emx_runtime( preg,
3789                                 FORCE_EMX_INIT_CONTRACT_ARGV
3790                                 | FORCE_EMX_INIT_INSTALL_ATEXIT );
3791         emx_wasnt_initialized = 1;
3792         /* Update CRTL data basing on now-valid EMX runtime data */
3793         if (!v_crt) {           /* The only wrong data are the versions. */
3794             v_emx = my_os_version();                    /* *Now* it works */
3795             *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */
3796             *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF;
3797         }
3798     }
3799     emx_runtime_secondary = 1;
3800     /* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */
3801     atexit(jmp_out_of_atexit);          /* Allow run of atexit() w/o exit()  */
3802
3803     if (env == NULL) {                  /* Fetch from the process info block */
3804         int c = 0;
3805         PPIB pib;
3806         PTIB tib;
3807         char *e, **ep;
3808
3809         DosGetInfoBlocks(&tib, &pib);
3810         e = pib->pib_pchenv;
3811         while (*e) {                    /* Get count */
3812             c++;
3813             e = e + strlen(e) + 1;
3814         }
3815         New(1307, env, c + 1, char*);
3816         ep = env;
3817         e = pib->pib_pchenv;
3818         while (c--) {
3819             *ep++ = e;
3820             e = e + strlen(e) + 1;
3821         }
3822         *ep = NULL;
3823     }
3824     _environ = _org_environ = env;
3825     emx_init_done = 1;
3826     if (hmtx_emx_init)
3827         DosReleaseMutexSem(hmtx_emx_init);
3828 }
3829
3830 #define ENTRY_POINT 0x10000
3831
3832 static int
3833 exe_is_aout(void)
3834 {
3835     struct layout_table_t *layout;
3836     if (emx_wasnt_initialized)
3837         return 0;
3838     /* Now we know that the principal executable is an EMX application
3839        - unless somebody did already play with delayed initialization... */
3840     /* With EMX applications to determine whether it is AOUT one needs
3841        to examine the start of the executable to find "layout" */
3842     if ( *(unsigned char*)ENTRY_POINT != 0x68           /* PUSH n */
3843          || *(unsigned char*)(ENTRY_POINT+5) != 0xe8    /* CALL */
3844          || *(unsigned char*)(ENTRY_POINT+10) != 0xeb   /* JMP */
3845          || *(unsigned char*)(ENTRY_POINT+12) != 0xe8)  /* CALL */
3846         return 0;                                       /* ! EMX executable */
3847     /* Fix alignment */
3848     Copy((char*)(ENTRY_POINT+1), &layout, 1, struct layout_table_t*);
3849     return !(layout->flags & 2);
3850 }
3851
3852 void
3853 Perl_OS2_init(char **env)
3854 {
3855     Perl_OS2_init3(env, 0, 0);
3856 }
3857
3858 void
3859 Perl_OS2_init3(char **env, void **preg, int flags)
3860 {
3861     char *shell;
3862
3863     _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
3864     MALLOC_INIT;
3865
3866     check_emx_runtime(env, (EXCEPTIONREGISTRATIONRECORD *)preg);
3867
3868     settmppath();
3869     OS2_Perl_data.xs_init = &Xs_OS2_init;
3870     if ( (shell = getenv("PERL_SH_DRIVE")) ) {
3871         New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
3872         strcpy(PL_sh_path, SH_PATH);
3873         PL_sh_path[0] = shell[0];
3874     } else if ( (shell = getenv("PERL_SH_DIR")) ) {
3875         int l = strlen(shell), i;
3876         if (shell[l-1] == '/' || shell[l-1] == '\\') {
3877             l--;
3878         }
3879         New(1304, PL_sh_path, l + 8, char);
3880         strncpy(PL_sh_path, shell, l);
3881         strcpy(PL_sh_path + l, "/sh.exe");
3882         for (i = 0; i < l; i++) {
3883             if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
3884         }
3885     }
3886 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
3887     MUTEX_INIT(&start_thread_mutex);
3888     MUTEX_INIT(&perlos2_state_mutex);
3889 #endif
3890     os2_mytype = my_type();             /* Do it before morphing.  Needed? */
3891     os2_mytype_ini = os2_mytype;
3892     Perl_os2_initial_mode = -1;         /* Uninit */
3893     /* Some DLLs reset FP flags on load.  We may have been linked with them */
3894     _control87(MCW_EM, MCW_EM);
3895 }
3896
3897 #undef tmpnam
3898 #undef tmpfile
3899
3900 char *
3901 my_tmpnam (char *str)
3902 {
3903     char *p = getenv("TMP"), *tpath;
3904
3905     if (!p) p = getenv("TEMP");
3906     tpath = tempnam(p, "pltmp");
3907     if (str && tpath) {
3908         strcpy(str, tpath);
3909         return str;
3910     }
3911     return tpath;
3912 }
3913
3914 FILE *
3915 my_tmpfile ()
3916 {
3917     struct stat s;
3918
3919     stat(".", &s);
3920     if (s.st_mode & S_IWOTH) {
3921         return tmpfile();
3922     }
3923     return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
3924                                              grants TMP. */
3925 }
3926
3927 #undef rmdir
3928
3929 /* EMX flavors do not tolerate trailing slashes.  t/op/mkdir.t has many
3930    trailing slashes, so we need to support this as well. */
3931
3932 int
3933 my_rmdir (__const__ char *s)
3934 {
3935     char b[MAXPATHLEN];
3936     char *buf = b;
3937     STRLEN l = strlen(s);
3938     int rc;
3939
3940     if (s[l-1] == '/' || s[l-1] == '\\') {      /* EMX mkdir fails... */
3941         if (l >= sizeof b)
3942             New(1305, buf, l + 1, char);
3943         strcpy(buf,s);
3944         while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
3945             l--;
3946         buf[l] = 0;
3947         s = buf;
3948     }
3949     rc = rmdir(s);
3950     if (b != buf)
3951         Safefree(buf);
3952     return rc;
3953 }
3954
3955 #undef mkdir
3956
3957 int
3958 my_mkdir (__const__ char *s, long perm)
3959 {
3960     char b[MAXPATHLEN];
3961     char *buf = b;
3962     STRLEN l = strlen(s);
3963     int rc;
3964
3965     if (s[l-1] == '/' || s[l-1] == '\\') {      /* EMX mkdir fails... */
3966         if (l >= sizeof b)
3967             New(1305, buf, l + 1, char);
3968         strcpy(buf,s);
3969         while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
3970             l--;
3971         buf[l] = 0;
3972         s = buf;
3973     }
3974     rc = mkdir(s, perm);
3975     if (b != buf)
3976         Safefree(buf);
3977     return rc;
3978 }
3979
3980 #undef flock
3981
3982 /* This code was contributed by Rocco Caputo. */
3983 int
3984 my_flock(int handle, int o)
3985 {
3986   FILELOCK      rNull, rFull;
3987   ULONG         timeout, handle_type, flag_word;
3988   APIRET        rc;
3989   int           blocking, shared;
3990   static int    use_my_flock = -1;
3991
3992   if (use_my_flock == -1) {
3993    MUTEX_LOCK(&perlos2_state_mutex);
3994    if (use_my_flock == -1) {
3995     char *s = getenv("USE_PERL_FLOCK");
3996     if (s)
3997         use_my_flock = atoi(s);
3998     else
3999         use_my_flock = 1;
4000    }
4001    MUTEX_UNLOCK(&perlos2_state_mutex);
4002   }
4003   if (!(_emx_env & 0x200) || !use_my_flock)
4004     return flock(handle, o);    /* Delegate to EMX. */
4005
4006                                         /* is this a file? */
4007   if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
4008       (handle_type & 0xFF))
4009   {
4010     errno = EBADF;
4011     return -1;
4012   }
4013                                         /* set lock/unlock ranges */
4014   rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
4015   rFull.lRange = 0x7FFFFFFF;
4016                                         /* set timeout for blocking */
4017   timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
4018                                         /* shared or exclusive? */
4019   shared = (o & LOCK_SH) ? 1 : 0;
4020                                         /* do not block the unlock */
4021   if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
4022     rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
4023     switch (rc) {
4024       case 0:
4025         errno = 0;
4026         return 0;
4027       case ERROR_INVALID_HANDLE:
4028         errno = EBADF;
4029         return -1;
4030       case ERROR_SHARING_BUFFER_EXCEEDED:
4031         errno = ENOLCK;
4032         return -1;
4033       case ERROR_LOCK_VIOLATION:
4034         break;                          /* not an error */
4035       case ERROR_INVALID_PARAMETER:
4036       case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
4037       case ERROR_READ_LOCKS_NOT_SUPPORTED:
4038         errno = EINVAL;
4039         return -1;
4040       case ERROR_INTERRUPT:
4041         errno = EINTR;
4042         return -1;
4043       default:
4044         errno = EINVAL;
4045         return -1;
4046     }
4047   }
4048                                         /* lock may block */
4049   if (o & (LOCK_SH | LOCK_EX)) {
4050                                         /* for blocking operations */
4051     for (;;) {
4052       rc =
4053         DosSetFileLocks(
4054                 handle,
4055                 &rNull,
4056                 &rFull,
4057                 timeout,
4058                 shared
4059         );
4060       switch (rc) {
4061         case 0:
4062           errno = 0;
4063           return 0;
4064         case ERROR_INVALID_HANDLE:
4065           errno = EBADF;
4066           return -1;
4067         case ERROR_SHARING_BUFFER_EXCEEDED:
4068           errno = ENOLCK;
4069           return -1;
4070         case ERROR_LOCK_VIOLATION:
4071           if (!blocking) {
4072             errno = EWOULDBLOCK;
4073             return -1;
4074           }
4075           break;
4076         case ERROR_INVALID_PARAMETER:
4077         case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
4078         case ERROR_READ_LOCKS_NOT_SUPPORTED:
4079           errno = EINVAL;
4080           return -1;
4081         case ERROR_INTERRUPT:
4082           errno = EINTR;
4083           return -1;
4084         default:
4085           errno = EINVAL;
4086           return -1;
4087       }
4088                                         /* give away timeslice */
4089       DosSleep(1);
4090     }
4091   }
4092
4093   errno = 0;
4094   return 0;
4095 }
4096
4097 static int
4098 use_my_pwent(void)
4099 {
4100   if (_my_pwent == -1) {
4101     char *s = getenv("USE_PERL_PWENT");
4102     if (s)
4103         _my_pwent = atoi(s);
4104     else
4105         _my_pwent = 1;
4106   }
4107   return _my_pwent;
4108 }
4109
4110 #undef setpwent
4111 #undef getpwent
4112 #undef endpwent
4113
4114 void
4115 my_setpwent(void)
4116 {
4117   if (!use_my_pwent()) {
4118     setpwent();                 /* Delegate to EMX. */
4119     return;
4120   }
4121   pwent_cnt = 0;
4122 }
4123
4124 void
4125 my_endpwent(void)
4126 {
4127   if (!use_my_pwent()) {
4128     endpwent();                 /* Delegate to EMX. */
4129     return;
4130   }
4131 }
4132
4133 struct passwd *
4134 my_getpwent (void)
4135 {
4136   if (!use_my_pwent())
4137     return getpwent();                  /* Delegate to EMX. */
4138   if (pwent_cnt++)
4139     return 0;                           /* Return one entry only */
4140   return getpwuid(0);
4141 }
4142
4143 void
4144 setgrent(void)
4145 {
4146   grent_cnt = 0;
4147 }
4148
4149 void
4150 endgrent(void)
4151 {
4152 }
4153
4154 struct group *
4155 getgrent (void)
4156 {
4157   if (grent_cnt++)
4158     return 0;                           /* Return one entry only */
4159   return getgrgid(0);
4160 }
4161
4162 #undef getpwuid
4163 #undef getpwnam
4164
4165 /* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */
4166 static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
4167
4168 static struct passwd *
4169 passw_wrap(struct passwd *p)
4170 {
4171     char *s;
4172
4173     if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
4174         return p;
4175     pw = *p;
4176     s = getenv("PW_PASSWD");
4177     if (!s)
4178         s = (char*)pw_p;                /* Make match impossible */
4179
4180     pw.pw_passwd = s;
4181     return &pw;
4182 }
4183
4184 struct passwd *
4185 my_getpwuid (uid_t id)
4186 {
4187     return passw_wrap(getpwuid(id));
4188 }
4189
4190 struct passwd *
4191 my_getpwnam (__const__ char *n)
4192 {
4193     return passw_wrap(getpwnam(n));
4194 }
4195
4196 char *
4197 gcvt_os2 (double value, int digits, char *buffer)
4198 {
4199   double absv = value > 0 ? value : -value;
4200   /* EMX implementation is lousy between 0.1 and 0.0001 (uses exponents below
4201      0.1), 1-digit stuff is ok below 0.001; multi-digit below 0.0001. */
4202   int buggy;
4203
4204   absv *= 10000;
4205   buggy = (absv < 1000 && (absv >= 10 || (absv > 1 && floor(absv) != absv)));
4206
4207   if (buggy) {
4208     char pat[12];
4209
4210     sprintf(pat, "%%.%dg", digits);
4211     sprintf(buffer, pat, value);
4212     return buffer;
4213   }
4214   return gcvt (value, digits, buffer);
4215 }
4216
4217 #undef fork
4218 int fork_with_resources()
4219 {
4220 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
4221   dTHX;
4222   void *ctx = PERL_GET_CONTEXT;
4223 #endif
4224   unsigned fpflag = _control87(0,0);
4225   int rc = fork();
4226
4227   if (rc == 0) {                        /* child */
4228 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
4229     ALLOC_THREAD_KEY;                   /* Acquire the thread-local memory */
4230     PERL_SET_CONTEXT(ctx);              /* Reinit the thread-local memory */
4231 #endif
4232
4233     {                                   /* Reload loaded-on-demand DLLs */
4234         struct dll_handle_t *dlls = dll_handles;
4235
4236         while (dlls->modname) {
4237             char dllname[260], fail[260];
4238             ULONG rc;
4239
4240             if (!dlls->handle) {        /* Was not loaded */
4241                 dlls++;
4242                 continue;
4243             }
4244             /* It was loaded in the parent.  We need to reload it. */
4245
4246             rc = DosQueryModuleName(dlls->handle, sizeof(dllname), dllname);
4247             if (rc) {
4248                 Perl_warn_nocontext("Can't find DLL name for the module `%s' by the handle %d, rc=%lu=%#lx",
4249                                     dlls->modname, (int)dlls->handle, rc, rc);
4250                 dlls++;
4251                 continue;
4252             }
4253             rc = DosLoadModule(fail, sizeof fail, dllname, &dlls->handle);
4254             if (rc)
4255                 Perl_warn_nocontext("Can't load DLL `%s', possible problematic module `%s'",
4256                                     dllname, fail);
4257             dlls++;
4258         }
4259     }
4260
4261     {                                   /* Support message queue etc. */
4262         os2_mytype = my_type();
4263         /* Apparently, subprocesses (in particular, fork()) do not
4264            inherit the morphed state, so os2_mytype is the same as
4265            os2_mytype_ini. */
4266
4267         if (Perl_os2_initial_mode != -1
4268             && Perl_os2_initial_mode != os2_mytype) {
4269                                         /* XXXX ??? */
4270         }
4271     }
4272     if (Perl_HAB_set)
4273         (void)_obtain_Perl_HAB;
4274     if (Perl_hmq_refcnt) {
4275         if (my_type() != 3)
4276             my_type_set(3);
4277         Create_HMQ(Perl_hmq_servers != 0,
4278                    "Cannot create a message queue on fork");
4279     }
4280
4281     /* We may have loaded some modules */
4282     _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
4283   }
4284   return rc;
4285 }
4286