os2/os2.c

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