os2/os2.c

   1 #define INCL_DOS
   2 #define INCL_NOPM
   3 #define INCL_DOSFILEMGR
   4 #define INCL_DOSMEMMGR
   5 #define INCL_DOSERRORS
   6 /* These 3 are needed for compile if os2.h includes os2tk.h, not os2emx.h */
   7 #define INCL_DOSPROCESS
   8 #define SPU_DISABLESUPPRESSION          0
   9 #define SPU_ENABLESUPPRESSION           1
  10 #include <os2.h>
  11 #include "dlfcn.h"
  12
  13 #include <sys/uflags.h>
  14
  15 /*
  16  * Various Unix compatibility functions for OS/2
  17  */
  18
  19 #include <stdio.h>
  20 #include <errno.h>
  21 #include <limits.h>
  22 #include <process.h>
  23 #include <fcntl.h>
  24
  25 #define PERLIO_NOT_STDIO 0
  26
  27 #include "EXTERN.h"
  28 #include "perl.h"
  29
  30 #ifdef USE_THREADS
  31
  32 typedef void (*emx_startroutine)(void *);
  33 typedef void* (*pthreads_startroutine)(void *);
  34
  35 enum pthreads_state {
  36     pthreads_st_none = 0,
  37     pthreads_st_run,
  38     pthreads_st_exited,
  39     pthreads_st_detached,
  40     pthreads_st_waited,
  41 };
  42 const char *pthreads_states[] = {
  43     "uninit",
  44     "running",
  45     "exited",
  46     "detached",
  47     "waited for",
  48 };
  49
  50 typedef struct {
  51     void *status;
  52     perl_cond cond;
  53     enum pthreads_state state;
  54 } thread_join_t;
  55
  56 thread_join_t *thread_join_data;
  57 int thread_join_count;
  58 perl_mutex start_thread_mutex;
  59
  60 int
  61 pthread_join(perl_os_thread tid, void **status)
  62 {
  63     MUTEX_LOCK(&start_thread_mutex);
  64     switch (thread_join_data[tid].state) {
  65     case pthreads_st_exited:
  66         thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
  67         MUTEX_UNLOCK(&start_thread_mutex);
  68         *status = thread_join_data[tid].status;
  69         break;
  70     case pthreads_st_waited:
  71         MUTEX_UNLOCK(&start_thread_mutex);
  72         Perl_croak_nocontext("join with a thread with a waiter");
  73         break;
  74     case pthreads_st_run:
  75         thread_join_data[tid].state = pthreads_st_waited;
  76         COND_INIT(&thread_join_data[tid].cond);
  77         MUTEX_UNLOCK(&start_thread_mutex);
  78         COND_WAIT(&thread_join_data[tid].cond, NULL);
  79         COND_DESTROY(&thread_join_data[tid].cond);
  80         thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
  81         *status = thread_join_data[tid].status;
  82         break;
  83     default:
  84         MUTEX_UNLOCK(&start_thread_mutex);
  85         Perl_croak_nocontext("join: unknown thread state: '%s'",
  86               pthreads_states[thread_join_data[tid].state]);
  87         break;
  88     }
  89     return 0;
  90 }
  91
  92 void
  93 pthread_startit(void *arg)
  94 {
  95     /* Thread is already started, we need to transfer control only */
  96     pthreads_startroutine start_routine = *((pthreads_startroutine*)arg);
  97     int tid = pthread_self();
  98     void *retval;
  99
 100     arg = ((void**)arg)[1];
 101     if (tid >= thread_join_count) {
 102         int oc = thread_join_count;
 103
 104         thread_join_count = tid + 5 + tid/5;
 105         if (thread_join_data) {
 106             Renew(thread_join_data, thread_join_count, thread_join_t);
 107             Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
 108         } else {
 109             Newz(1323, thread_join_data, thread_join_count, thread_join_t);
 110         }
 111     }
 112     if (thread_join_data[tid].state != pthreads_st_none)
 113         Perl_croak_nocontext("attempt to reuse thread id %i", tid);
 114     thread_join_data[tid].state = pthreads_st_run;
 115     /* Now that we copied/updated the guys, we may release the caller... */
 116     MUTEX_UNLOCK(&start_thread_mutex);
 117     thread_join_data[tid].status = (*start_routine)(arg);
 118     switch (thread_join_data[tid].state) {
 119     case pthreads_st_waited:
 120         COND_SIGNAL(&thread_join_data[tid].cond);
 121         break;
 122     default:
 123         thread_join_data[tid].state = pthreads_st_exited;
 124         break;
 125     }
 126 }
 127
 128 int
 129 pthread_create(perl_os_thread *tid, const pthread_attr_t *attr,
 130                void *(*start_routine)(void*), void *arg)
 131 {
 132     void *args[2];
 133
 134     args[0] = (void*)start_routine;
 135     args[1] = arg;
 136
 137     MUTEX_LOCK(&start_thread_mutex);
 138     *tid = _beginthread(pthread_startit, /*stack*/ NULL,
 139                         /*stacksize*/ 10*1024*1024, (void*)args);
 140     MUTEX_LOCK(&start_thread_mutex);
 141     MUTEX_UNLOCK(&start_thread_mutex);
 142     return *tid ? 0 : EINVAL;
 143 }
 144
 145 int
 146 pthread_detach(perl_os_thread tid)
 147 {
 148     MUTEX_LOCK(&start_thread_mutex);
 149     switch (thread_join_data[tid].state) {
 150     case pthreads_st_waited:
 151         MUTEX_UNLOCK(&start_thread_mutex);
 152         Perl_croak_nocontext("detach on a thread with a waiter");
 153         break;
 154     case pthreads_st_run:
 155         thread_join_data[tid].state = pthreads_st_detached;
 156         MUTEX_UNLOCK(&start_thread_mutex);
 157         break;
 158     default:
 159         MUTEX_UNLOCK(&start_thread_mutex);
 160         Perl_croak_nocontext("detach: unknown thread state: '%s'",
 161               pthreads_states[thread_join_data[tid].state]);
 162         break;
 163     }
 164     return 0;
 165 }
 166
 167 /* This is a very bastardized version: */
 168 int
 169 os2_cond_wait(perl_cond *c, perl_mutex *m)
 170 {
 171     int rc;
 172     STRLEN n_a;
 173     if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET))
 174         Perl_croak_nocontext("panic: COND_WAIT-reset: rc=%i", rc);
 175     if (m) MUTEX_UNLOCK(m);
 176     if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
 177         && (rc != ERROR_INTERRUPT))
 178         Perl_croak_nocontext("panic: COND_WAIT: rc=%i", rc);
 179     if (rc == ERROR_INTERRUPT)
 180         errno = EINTR;
 181     if (m) MUTEX_LOCK(m);
 182 }
 183 #endif
 184
 185 /*****************************************************************************/
 186 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
 187 static PFN ExtFCN[2];                   /* Labeled by ord below. */
 188 static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
 189 #define ORD_QUERY_ELP   0
 190 #define ORD_SET_ELP     1
 191 struct PMWIN_entries_t PMWIN_entries;
 192
 193 HMODULE
 194 loadModule(char *modname)
 195 {
 196     HMODULE h = (HMODULE)dlopen(modname, 0);
 197     if (!h)
 198         Perl_croak_nocontext("Error loading module '%s': %s",
 199                              modname, dlerror());
 200     return h;
 201 }
 202
 203 APIRET
 204 loadByOrd(char *modname, ULONG ord)
 205 {
 206     if (ExtFCN[ord] == NULL) {
 207         static HMODULE hdosc = 0;
 208         BYTE buf[20];
 209         PFN fcn;
 210         APIRET rc;
 211
 212
 213         if (!hdosc) {
 214             hdosc = loadModule(modname);
 215             if (CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
 216                 Perl_croak_nocontext(
 217                         "This version of OS/2 does not support %s.%i",
 218                         modname, loadOrd[ord]);
 219         }
 220         ExtFCN[ord] = fcn;
 221     }
 222     if ((long)ExtFCN[ord] == -1)
 223         Perl_croak_nocontext("panic queryaddr");
 224 }
 225
 226 void
 227 init_PMWIN_entries(void)
 228 {
 229     static HMODULE hpmwin = 0;
 230     static const int ords[] = {
 231         763,                            /* Initialize */
 232         716,                            /* CreateMsgQueue */
 233         726,                            /* DestroyMsgQueue */
 234         918,                            /* PeekMsg */
 235         915,                            /* GetMsg */
 236         912,                            /* DispatchMsg */
 237         753,                            /* GetLastError */
 238         705,                            /* CancelShutdown */
 239     };
 240     BYTE buf[20];
 241     int i = 0;
 242     unsigned long rc;
 243
 244     if (hpmwin)
 245         return;
 246
 247     hpmwin = loadModule("pmwin");
 248     while (i < sizeof(ords)/sizeof(int)) {
 249         if (CheckOSError(DosQueryProcAddr(hpmwin, ords[i], NULL,
 250                                           ((PFN*)&PMWIN_entries)+i)))
 251             Perl_croak_nocontext("This version of OS/2 does not support pmwin.%d", ords[i]);
 252         i++;
 253     }
 254 }
 255
 256
 257 /* priorities */
 258 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
 259                                                self inverse. */
 260 #define QSS_INI_BUFFER 1024
 261
 262 PQTOPLEVEL
 263 get_sysinfo(ULONG pid, ULONG flags)
 264 {
 265     char *pbuffer;
 266     ULONG rc, buf_len = QSS_INI_BUFFER;
 267
 268     New(1322, pbuffer, buf_len, char);
 269     /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
 270     rc = QuerySysState(flags, pid, pbuffer, buf_len);
 271     while (rc == ERROR_BUFFER_OVERFLOW) {
 272         Renew(pbuffer, buf_len *= 2, char);
 273         rc = QuerySysState(flags, pid, pbuffer, buf_len);
 274     }
 275     if (rc) {
 276         FillOSError(rc);
 277         Safefree(pbuffer);
 278         return 0;
 279     }
 280     return (PQTOPLEVEL)pbuffer;
 281 }
 282
 283 #define PRIO_ERR 0x1111
 284
 285 static ULONG
 286 sys_prio(pid)
 287 {
 288   ULONG prio;
 289   PQTOPLEVEL psi;
 290
 291   psi = get_sysinfo(pid, QSS_PROCESS);
 292   if (!psi) {
 293       return PRIO_ERR;
 294   }
 295   if (pid != psi->procdata->pid) {
 296       Safefree(psi);
 297       Perl_croak_nocontext("panic: wrong pid in sysinfo");
 298   }
 299   prio = psi->procdata->threads->priority;
 300   Safefree(psi);
 301   return prio;
 302 }
 303
 304 int
 305 setpriority(int which, int pid, int val)
 306 {
 307   ULONG rc, prio;
 308   PQTOPLEVEL psi;
 309
 310   prio = sys_prio(pid);
 311
 312   if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
 313   if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
 314       /* Do not change class. */
 315       return CheckOSError(DosSetPriority((pid < 0)
 316                                          ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
 317                                          0,
 318                                          (32 - val) % 32 - (prio & 0xFF),
 319                                          abs(pid)))
 320       ? -1 : 0;
 321   } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
 322       /* Documentation claims one can change both class and basevalue,
 323        * but I find it wrong. */
 324       /* Change class, but since delta == 0 denotes absolute 0, correct. */
 325       if (CheckOSError(DosSetPriority((pid < 0)
 326                                       ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
 327                                       priors[(32 - val) >> 5] + 1,
 328                                       0,
 329                                       abs(pid))))
 330           return -1;
 331       if ( ((32 - val) % 32) == 0 ) return 0;
 332       return CheckOSError(DosSetPriority((pid < 0)
 333                                          ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
 334                                          0,
 335                                          (32 - val) % 32,
 336                                          abs(pid)))
 337           ? -1 : 0;
 338   }
 339 /*   else return CheckOSError(DosSetPriority((pid < 0)  */
 340 /*                                        ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
 341 /*                                        priors[(32 - val) >> 5] + 1,  */
 342 /*                                        (32 - val) % 32 - (prio & 0xFF),  */
 343 /*                                        abs(pid))) */
 344 /*       ? -1 : 0; */
 345 }
 346
 347 int
 348 getpriority(int which /* ignored */, int pid)
 349 {
 350   TIB *tib;
 351   PIB *pib;
 352   ULONG rc, ret;
 353
 354   if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
 355   /* DosGetInfoBlocks has old priority! */
 356 /*   if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
 357 /*   if (pid != pib->pib_ulpid) { */
 358   ret = sys_prio(pid);
 359   if (ret == PRIO_ERR) {
 360       return -1;
 361   }
 362 /*   } else */
 363 /*       ret = tib->tib_ptib2->tib2_ulpri; */
 364   return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
 365 }
 366
 367 /*****************************************************************************/
 368 /* spawn */
 369
 370 /* There is no big sense to make it thread-specific, since signals
 371    are delivered to thread 1 only.  XXXX Maybe make it into an array? */
 372 static int spawn_pid;
 373 static int spawn_killed;
 374
 375 static Signal_t
 376 spawn_sighandler(int sig)
 377 {
 378     /* Some programs do not arrange for the keyboard signals to be
 379        delivered to them.  We need to deliver the signal manually. */
 380     /* We may get a signal only if
 381        a) kid does not receive keyboard signal: deliver it;
 382        b) kid already died, and we get a signal.  We may only hope
 383           that the pid number was not reused.
 384      */
 385
 386     if (spawn_killed)
 387         sig = SIGKILL;                  /* Try harder. */
 388     kill(spawn_pid, sig);
 389     spawn_killed = 1;
 390 }
 391
 392 static int
 393 result(pTHX_ int flag, int pid)
 394 {
 395         int r, status;
 396         Signal_t (*ihand)();     /* place to save signal during system() */
 397         Signal_t (*qhand)();     /* place to save signal during system() */
 398 #ifndef __EMX__
 399         RESULTCODES res;
 400         int rpid;
 401 #endif
 402
 403         if (pid < 0 || flag != 0)
 404                 return pid;
 405
 406 #ifdef __EMX__
 407         spawn_pid = pid;
 408         spawn_killed = 0;
 409         ihand = rsignal(SIGINT, &spawn_sighandler);
 410         qhand = rsignal(SIGQUIT, &spawn_sighandler);
 411         do {
 412             r = wait4pid(pid, &status, 0);
 413         } while (r == -1 && errno == EINTR);
 414         rsignal(SIGINT, ihand);
 415         rsignal(SIGQUIT, qhand);
 416
 417         PL_statusvalue = (U16)status;
 418         if (r < 0)
 419                 return -1;
 420         return status & 0xFFFF;
 421 #else
 422         ihand = rsignal(SIGINT, SIG_IGN);
 423         r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
 424         rsignal(SIGINT, ihand);
 425         PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
 426         if (r)
 427                 return -1;
 428         return PL_statusvalue;
 429 #endif
 430 }
 431
 432 #define EXECF_SPAWN 0
 433 #define EXECF_EXEC 1
 434 #define EXECF_TRUEEXEC 2
 435 #define EXECF_SPAWN_NOWAIT 3
 436 #define EXECF_SPAWN_BYFLAG 4
 437
 438 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
 439
 440 static int
 441 my_type()
 442 {
 443     int rc;
 444     TIB *tib;
 445     PIB *pib;
 446
 447     if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
 448     if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
 449         return -1;
 450
 451     return (pib->pib_ultype);
 452 }
 453
 454 static ULONG
 455 file_type(char *path)
 456 {
 457     int rc;
 458     ULONG apptype;
 459
 460     if (!(_emx_env & 0x200))
 461         Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */
 462     if (CheckOSError(DosQueryAppType(path, &apptype))) {
 463         switch (rc) {
 464         case ERROR_FILE_NOT_FOUND:
 465         case ERROR_PATH_NOT_FOUND:
 466             return -1;
 467         case ERROR_ACCESS_DENIED:       /* Directory with this name found? */
 468             return -3;
 469         default:                        /* Found, but not an
 470                                            executable, or some other
 471                                            read error. */
 472             return -2;
 473         }
 474     }
 475     return apptype;
 476 }
 477
 478 static ULONG os2_mytype;
 479
 480 /* Spawn/exec a program, revert to shell if needed. */
 481 /* global PL_Argv[] contains arguments. */
 482
 483 int
 484 do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
 485 {
 486         int trueflag = flag;
 487         int rc, pass = 1;
 488         char *tmps;
 489         char buf[256], *s = 0, scrbuf[280];
 490         char *args[4];
 491         static char * fargs[4]
 492             = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
 493         char **argsp = fargs;
 494         char nargs = 4;
 495         int force_shell;
 496         int new_stderr = -1, nostderr = 0, fl_stderr;
 497         STRLEN n_a;
 498
 499         if (flag == P_WAIT)
 500                 flag = P_NOWAIT;
 501
 502       retry:
 503         if (strEQ(PL_Argv[0],"/bin/sh"))
 504             PL_Argv[0] = PL_sh_path;
 505
 506         if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\'
 507             && !(PL_Argv[0][0] && PL_Argv[0][1] == ':'
 508                  && (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\'))
 509             ) /* will spawnvp use PATH? */
 510             TAINT_ENV();        /* testing IFS here is overkill, probably */
 511         /* We should check PERL_SH* and PERLLIB_* as well? */
 512         if (!really || !*(tmps = SvPV(really, n_a)))
 513             tmps = PL_Argv[0];
 514
 515       reread:
 516         force_shell = 0;
 517         if (_emx_env & 0x200) { /* OS/2. */
 518             int type = file_type(tmps);
 519           type_again:
 520             if (type == -1) {           /* Not found */
 521                 errno = ENOENT;
 522                 rc = -1;
 523                 goto do_script;
 524             }
 525             else if (type == -2) {              /* Not an EXE */
 526                 errno = ENOEXEC;
 527                 rc = -1;
 528                 goto do_script;
 529             }
 530             else if (type == -3) {              /* Is a directory? */
 531                 /* Special-case this */
 532                 char tbuf[512];
 533                 int l = strlen(tmps);
 534
 535                 if (l + 5 <= sizeof tbuf) {
 536                     strcpy(tbuf, tmps);
 537                     strcpy(tbuf + l, ".exe");
 538                     type = file_type(tbuf);
 539                     if (type >= -3)
 540                         goto type_again;
 541                 }
 542
 543                 errno = ENOEXEC;
 544                 rc = -1;
 545                 goto do_script;
 546             }
 547             switch (type & 7) {
 548                 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
 549             case FAPPTYP_WINDOWAPI:
 550             {
 551                 if (os2_mytype != 3) {  /* not PM */
 552                     if (flag == P_NOWAIT)
 553                         flag = P_PM;
 554                     else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION)
 555                         Perl_warner(aTHX_ WARN_EXEC, "Starting PM process with flag=%d, mytype=%d",
 556                              flag, os2_mytype);
 557                 }
 558             }
 559             break;
 560             case FAPPTYP_NOTWINDOWCOMPAT:
 561             {
 562                 if (os2_mytype != 0) {  /* not full screen */
 563                     if (flag == P_NOWAIT)
 564                         flag = P_SESSION;
 565                     else if ((flag & 7) != P_SESSION)
 566                         Perl_warner(aTHX_ WARN_EXEC, "Starting Full Screen process with flag=%d, mytype=%d",
 567                              flag, os2_mytype);
 568                 }
 569             }
 570             break;
 571             case FAPPTYP_NOTSPEC:
 572                 /* Let the shell handle this... */
 573                 force_shell = 1;
 574                 goto doshell_args;
 575                 break;
 576             }
 577         }
 578
 579         if (addflag) {
 580             addflag = 0;
 581             new_stderr = dup(2);                /* Preserve stderr */
 582             if (new_stderr == -1) {
 583                 if (errno == EBADF)
 584                     nostderr = 1;
 585                 else {
 586                     rc = -1;
 587                     goto finish;
 588                 }
 589             } else
 590                 fl_stderr = fcntl(2, F_GETFD);
 591             rc = dup2(1,2);
 592             if (rc == -1)
 593                 goto finish;
 594             fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
 595         }
 596
 597 #if 0
 598         rc = result(aTHX_ trueflag, spawnvp(flag,tmps,PL_Argv));
 599 #else
 600         if (execf == EXECF_TRUEEXEC)
 601             rc = execvp(tmps,PL_Argv);
 602         else if (execf == EXECF_EXEC)
 603             rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
 604         else if (execf == EXECF_SPAWN_NOWAIT)
 605             rc = spawnvp(flag,tmps,PL_Argv);
 606         else                            /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
 607             rc = result(aTHX_ trueflag,
 608                         spawnvp(flag,tmps,PL_Argv));
 609 #endif
 610         if (rc < 0 && pass == 1
 611             && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
 612               do_script:
 613             {
 614             int err = errno;
 615
 616             if (err == ENOENT || err == ENOEXEC) {
 617                 /* No such file, or is a script. */
 618                 /* Try adding script extensions to the file name, and
 619                    search on PATH. */
 620                 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
 621
 622                 if (scr) {
 623                     PerlIO *file;
 624                     SSize_t rd;
 625                     char *s = 0, *s1, *s2;
 626                     int l;
 627
 628                     l = strlen(scr);
 629
 630                     if (l >= sizeof scrbuf) {
 631                        Safefree(scr);
 632                      longbuf:
 633                        Perl_warner(aTHX_ WARN_EXEC, "Size of scriptname too big: %d", l);
 634                        rc = -1;
 635                        goto finish;
 636                     }
 637                     strcpy(scrbuf, scr);
 638                     Safefree(scr);
 639                     scr = scrbuf;
 640
 641                     file = PerlIO_open(scr, "r");
 642                     PL_Argv[0] = scr;
 643                     if (!file)
 644                         goto panic_file;
 645
 646                     rd = PerlIO_read(file, buf, sizeof buf-1);
 647                     buf[rd]='\0';
 648                     if ((s2 = strchr(buf, '\n')) != NULL) *++s2 = '\0';
 649
 650                     if (!rd) { /* Empty... */
 651                         buf[0] = 0;
 652                         PerlIO_close(file);
 653                         /* Special case: maybe from -Zexe build, so
 654                            there is an executable around (contrary to
 655                            documentation, DosQueryAppType sometimes (?)
 656                            does not append ".exe", so we could have
 657                            reached this place). */
 658                         if (l + 5 < sizeof scrbuf) {
 659                             strcpy(scrbuf + l, ".exe");
 660                             if (PerlLIO_stat(scrbuf,&PL_statbuf) >= 0
 661                                 && !S_ISDIR(PL_statbuf.st_mode)) {
 662                                 /* Found */
 663                                 tmps = scr;
 664                                 pass++;
 665                                 goto reread;
 666                             } else
 667                                 scrbuf[l] = 0;
 668                         } else
 669                             goto longbuf;
 670                     }
 671                     if (PerlIO_close(file) != 0) { /* Failure */
 672                       panic_file:
 673                         Perl_warner(aTHX_ WARN_EXEC, "Error reading \"%s\": %s",
 674                              scr, Strerror(errno));
 675                         buf[0] = 0;     /* Not #! */
 676                         goto doshell_args;
 677                     }
 678                     if (buf[0] == '#') {
 679                         if (buf[1] == '!')
 680                             s = buf + 2;
 681                     } else if (buf[0] == 'e') {
 682                         if (strnEQ(buf, "extproc", 7)
 683                             && isSPACE(buf[7]))
 684                             s = buf + 8;
 685                     } else if (buf[0] == 'E') {
 686                         if (strnEQ(buf, "EXTPROC", 7)
 687                             && isSPACE(buf[7]))
 688                             s = buf + 8;
 689                     }
 690                     if (!s) {
 691                         buf[0] = 0;     /* Not #! */
 692                         goto doshell_args;
 693                     }
 694
 695                     s1 = s;
 696                     nargs = 0;
 697                     argsp = args;
 698                     while (1) {
 699                         /* Do better than pdksh: allow a few args,
 700                            strip trailing whitespace.  */
 701                         while (isSPACE(*s))
 702                             s++;
 703                         if (*s == 0)
 704                             break;
 705                         if (nargs == 4) {
 706                             nargs = -1;
 707                             break;
 708                         }
 709                         args[nargs++] = s;
 710                         while (*s && !isSPACE(*s))
 711                             s++;
 712                         if (*s == 0)
 713                             break;
 714                         *s++ = 0;
 715                     }
 716                     if (nargs == -1) {
 717                         Perl_warner(aTHX_ WARN_EXEC, "Too many args on %.*s line of \"%s\"",
 718                              s1 - buf, buf, scr);
 719                         nargs = 4;
 720                         argsp = fargs;
 721                     }
 722                   doshell_args:
 723                     {
 724                         char **a = PL_Argv;
 725                         char *exec_args[2];
 726
 727                         if (force_shell
 728                             || (!buf[0] && file)) { /* File without magic */
 729                             /* In fact we tried all what pdksh would
 730                                try.  There is no point in calling
 731                                pdksh, we may just emulate its logic. */
 732                             char *shell = getenv("EXECSHELL");
 733                             char *shell_opt = NULL;
 734
 735                             if (!shell) {
 736                                 char *s;
 737
 738                                 shell_opt = "/c";
 739                                 shell = getenv("OS2_SHELL");
 740                                 if (inicmd) { /* No spaces at start! */
 741                                     s = inicmd;
 742                                     while (*s && !isSPACE(*s)) {
 743                                         if (*s++ = '/') {
 744                                             inicmd = NULL; /* Cannot use */
 745                                             break;
 746                                         }
 747                                     }
 748                                 }
 749                                 if (!inicmd) {
 750                                     s = PL_Argv[0];
 751                                     while (*s) {
 752                                         /* Dosish shells will choke on slashes
 753                                            in paths, fortunately, this is
 754                                            important for zeroth arg only. */
 755                                         if (*s == '/')
 756                                             *s = '\\';
 757                                         s++;
 758                                     }
 759                                 }
 760                             }
 761                             /* If EXECSHELL is set, we do not set */
 762
 763                             if (!shell)
 764                                 shell = ((_emx_env & 0x200)
 765                                          ? "c:/os2/cmd.exe"
 766                                          : "c:/command.com");
 767                             nargs = shell_opt ? 2 : 1;  /* shell file args */
 768                             exec_args[0] = shell;
 769                             exec_args[1] = shell_opt;
 770                             argsp = exec_args;
 771                             if (nargs == 2 && inicmd) {
 772                                 /* Use the original cmd line */
 773                                 /* XXXX This is good only until we refuse
 774                                         quoted arguments... */
 775                                 PL_Argv[0] = inicmd;
 776                                 PL_Argv[1] = Nullch;
 777                             }
 778                         } else if (!buf[0] && inicmd) { /* No file */
 779                             /* Start with the original cmdline. */
 780                             /* XXXX This is good only until we refuse
 781                                     quoted arguments... */
 782
 783                             PL_Argv[0] = inicmd;
 784                             PL_Argv[1] = Nullch;
 785                             nargs = 2;  /* shell -c */
 786                         }
 787
 788                         while (a[1])            /* Get to the end */
 789                             a++;
 790                         a++;                    /* Copy finil NULL too */
 791                         while (a >= PL_Argv) {
 792                             *(a + nargs) = *a;  /* PL_Argv was preallocated to be
 793                                                    long enough. */
 794                             a--;
 795                         }
 796                         while (--nargs >= 0)
 797                             PL_Argv[nargs] = argsp[nargs];
 798                         /* Enable pathless exec if #! (as pdksh). */
 799                         pass = (buf[0] == '#' ? 2 : 3);
 800                         goto retry;
 801                     }
 802                 }
 803                 /* Not found: restore errno */
 804                 errno = err;
 805             }
 806           }
 807         } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
 808             char *no_dir = strrchr(PL_Argv[0], '/');
 809
 810             /* Do as pdksh port does: if not found with /, try without
 811                path. */
 812             if (no_dir) {
 813                 PL_Argv[0] = no_dir + 1;
 814                 pass++;
 815                 goto retry;
 816             }
 817         }
 818         if (rc < 0 && ckWARN(WARN_EXEC))
 819             Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s\n",
 820                  ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
 821                   ? "spawn" : "exec"),
 822                  PL_Argv[0], Strerror(errno));
 823         if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
 824             && ((trueflag & 0xFF) == P_WAIT))
 825             rc = -1;
 826
 827   finish:
 828     if (new_stderr != -1) {     /* How can we use error codes? */
 829         dup2(new_stderr, 2);
 830         close(new_stderr);
 831         fcntl(2, F_SETFD, fl_stderr);
 832     } else if (nostderr)
 833        close(2);
 834     return rc;
 835 }
 836
 837 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
 838 int
 839 do_spawn3(pTHX_ char *cmd, int execf, int flag)
 840 {
 841     register char **a;
 842     register char *s;
 843     char flags[10];
 844     char *shell, *copt, *news = NULL;
 845     int rc, err, seenspace = 0, mergestderr = 0;
 846     char fullcmd[MAXNAMLEN + 1];
 847
 848 #ifdef TRYSHELL
 849     if ((shell = getenv("EMXSHELL")) != NULL)
 850         copt = "-c";
 851     else if ((shell = getenv("SHELL")) != NULL)
 852         copt = "-c";
 853     else if ((shell = getenv("COMSPEC")) != NULL)
 854         copt = "/C";
 855     else
 856         shell = "cmd.exe";
 857 #else
 858     /* Consensus on perl5-porters is that it is _very_ important to
 859        have a shell which will not change between computers with the
 860        same architecture, to avoid "action on a distance".
 861        And to have simple build, this shell should be sh. */
 862     shell = PL_sh_path;
 863     copt = "-c";
 864 #endif
 865
 866     while (*cmd && isSPACE(*cmd))
 867         cmd++;
 868
 869     if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
 870         STRLEN l = strlen(PL_sh_path);
 871
 872         New(1302, news, strlen(cmd) - 7 + l + 1, char);
 873         strcpy(news, PL_sh_path);
 874         strcpy(news + l, cmd + 7);
 875         cmd = news;
 876     }
 877
 878     /* save an extra exec if possible */
 879     /* see if there are shell metacharacters in it */
 880
 881     if (*cmd == '.' && isSPACE(cmd[1]))
 882         goto doshell;
 883
 884     if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
 885         goto doshell;
 886
 887     for (s = cmd; *s && isALPHA(*s); s++) ;     /* catch VAR=val gizmo */
 888     if (*s == '=')
 889         goto doshell;
 890
 891     for (s = cmd; *s; s++) {
 892         if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
 893             if (*s == '\n' && s[1] == '\0') {
 894                 *s = '\0';
 895                 break;
 896             } else if (*s == '\\' && !seenspace) {
 897                 continue;               /* Allow backslashes in names */
 898             } else if (*s == '>' && s >= cmd + 3
 899                         && s[-1] == '2' && s[1] == '&' && s[2] == '1'
 900                         && isSPACE(s[-2]) ) {
 901                 char *t = s + 3;
 902
 903                 while (*t && isSPACE(*t))
 904                     t++;
 905                 if (!*t) {
 906                     s[-2] = '\0';
 907                     mergestderr = 1;
 908                     break;              /* Allow 2>&1 as the last thing */
 909                 }
 910             }
 911             /* We do not convert this to do_spawn_ve since shell
 912                should be smart enough to start itself gloriously. */
 913           doshell:
 914             if (execf == EXECF_TRUEEXEC)
 915                 rc = execl(shell,shell,copt,cmd,(char*)0);
 916             else if (execf == EXECF_EXEC)
 917                 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
 918             else if (execf == EXECF_SPAWN_NOWAIT)
 919                 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
 920             else if (execf == EXECF_SPAWN_BYFLAG)
 921                 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
 922             else {
 923                 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
 924                 rc = result(aTHX_ P_WAIT,
 925                             spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
 926                 if (rc < 0 && ckWARN(WARN_EXEC))
 927                     Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s",
 928                          (execf == EXECF_SPAWN ? "spawn" : "exec"),
 929                          shell, Strerror(errno));
 930                 if (rc < 0)
 931                     rc = -1;
 932             }
 933             if (news)
 934                 Safefree(news);
 935             return rc;
 936         } else if (*s == ' ' || *s == '\t') {
 937             seenspace = 1;
 938         }
 939     }
 940
 941     /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
 942     New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
 943     PL_Cmd = savepvn(cmd, s-cmd);
 944     a = PL_Argv;
 945     for (s = PL_Cmd; *s;) {
 946         while (*s && isSPACE(*s)) s++;
 947         if (*s)
 948             *(a++) = s;
 949         while (*s && !isSPACE(*s)) s++;
 950         if (*s)
 951             *s++ = '\0';
 952     }
 953     *a = Nullch;
 954     if (PL_Argv[0])
 955         rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr);
 956     else
 957         rc = -1;
 958     if (news)
 959         Safefree(news);
 960     do_execfree();
 961     return rc;
 962 }
 963
 964 /* Array spawn.  */
 965 int
 966 os2_do_aspawn(pTHX_ SV *really, register SV **mark, register SV **sp)
 967 {
 968     register char **a;
 969     int rc;
 970     int flag = P_WAIT, flag_set = 0;
 971     STRLEN n_a;
 972
 973     if (sp > mark) {
 974         New(1301,PL_Argv, sp - mark + 3, char*);
 975         a = PL_Argv;
 976
 977         if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
 978                 ++mark;
 979                 flag = SvIVx(*mark);
 980                 flag_set = 1;
 981
 982         }
 983
 984         while (++mark <= sp) {
 985             if (*mark)
 986                 *a++ = SvPVx(*mark, n_a);
 987             else
 988                 *a++ = "";
 989         }
 990         *a = Nullch;
 991
 992         if (flag_set && (a == PL_Argv + 1)) { /* One arg? */
 993             rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
 994         } else
 995             rc = do_spawn_ve(aTHX_ really, flag, EXECF_SPAWN, NULL, 0);
 996     } else
 997         rc = -1;
 998     do_execfree();
 999     return rc;
1000 }
1001
1002 int
1003 os2_do_spawn(pTHX_ char *cmd)
1004 {
1005     return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
1006 }
1007
1008 int
1009 do_spawn_nowait(pTHX_ char *cmd)
1010 {
1011     return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
1012 }
1013
1014 bool
1015 Perl_do_exec(pTHX_ char *cmd)
1016 {
1017     do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
1018     return FALSE;
1019 }
1020
1021 bool
1022 os2exec(pTHX_ char *cmd)
1023 {
1024     return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
1025 }
1026
1027 PerlIO *
1028 my_syspopen(pTHX_ char *cmd, char *mode)
1029 {
1030 #ifndef USE_POPEN
1031
1032     int p[2];
1033     register I32 this, that, newfd;
1034     register I32 pid, rc;
1035     PerlIO *res;
1036     SV *sv;
1037     int fh_fl;
1038
1039     /* `this' is what we use in the parent, `that' in the child. */
1040     this = (*mode == 'w');
1041     that = !this;
1042     if (PL_tainting) {
1043         taint_env();
1044         taint_proper("Insecure %s%s", "EXEC");
1045     }
1046     if (pipe(p) < 0)
1047         return Nullfp;
1048     /* Now we need to spawn the child. */
1049     if (p[this] == (*mode == 'r')) {    /* if fh 0/1 was initially closed. */
1050         int new = dup(p[this]);
1051
1052         if (new == -1)
1053             goto closepipes;
1054         close(p[this]);
1055         p[this] = new;
1056     }
1057     newfd = dup(*mode == 'r');          /* Preserve std* */
1058     if (newfd == -1) {
1059         /* This cannot happen due to fh being bad after pipe(), since
1060            pipe() should have created fh 0 and 1 even if they were
1061            initially closed.  But we closed p[this] before.  */
1062         if (errno != EBADF) {
1063           closepipes:
1064             close(p[0]);
1065             close(p[1]);
1066             return Nullfp;
1067         }
1068     } else
1069         fh_fl = fcntl(*mode == 'r', F_GETFD);
1070     if (p[that] != (*mode == 'r')) {    /* if fh 0/1 was initially closed. */
1071         dup2(p[that], *mode == 'r');
1072         close(p[that]);
1073     }
1074     /* Where is `this' and newfd now? */
1075     fcntl(p[this], F_SETFD, FD_CLOEXEC);
1076     if (newfd != -1)
1077         fcntl(newfd, F_SETFD, FD_CLOEXEC);
1078     pid = do_spawn_nowait(aTHX_ cmd);
1079     if (newfd == -1)
1080         close(*mode == 'r');            /* It was closed initially */
1081     else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
1082         dup2(newfd, *mode == 'r');      /* Return std* back. */
1083         close(newfd);
1084         fcntl(*mode == 'r', F_SETFD, fh_fl);
1085     } else
1086         fcntl(*mode == 'r', F_SETFD, fh_fl);
1087     if (p[that] == (*mode == 'r'))
1088         close(p[that]);
1089     if (pid == -1) {
1090         close(p[this]);
1091         return Nullfp;
1092     }
1093     if (p[that] < p[this]) {            /* Make fh as small as possible */
1094         dup2(p[this], p[that]);
1095         close(p[this]);
1096         p[this] = p[that];
1097     }
1098     sv = *av_fetch(PL_fdpid,p[this],TRUE);
1099     (void)SvUPGRADE(sv,SVt_IV);
1100     SvIVX(sv) = pid;
1101     PL_forkprocess = pid;
1102     return PerlIO_fdopen(p[this], mode);
1103
1104 #else  /* USE_POPEN */
1105
1106     PerlIO *res;
1107     SV *sv;
1108
1109 #  ifdef TRYSHELL
1110     res = popen(cmd, mode);
1111 #  else
1112     char *shell = getenv("EMXSHELL");
1113
1114     my_setenv("EMXSHELL", PL_sh_path);
1115     res = popen(cmd, mode);
1116     my_setenv("EMXSHELL", shell);
1117 #  endif
1118     sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1119     (void)SvUPGRADE(sv,SVt_IV);
1120     SvIVX(sv) = -1;                     /* A cooky. */
1121     return res;
1122
1123 #endif /* USE_POPEN */
1124
1125 }
1126
1127 /******************************************************************/
1128
1129 #ifndef HAS_FORK
1130 int
1131 fork(void)
1132 {
1133     Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
1134     errno = EINVAL;
1135     return -1;
1136 }
1137 #endif
1138
1139 /*******************************************************************/
1140 /* not implemented in EMX 0.9d */
1141
1142 char *  ctermid(char *s)        { return 0; }
1143
1144 #ifdef MYTTYNAME /* was not in emx0.9a */
1145 void *  ttyname(x)      { return 0; }
1146 #endif
1147
1148 /******************************************************************/
1149 /* my socket forwarders - EMX lib only provides static forwarders */
1150
1151 static HMODULE htcp = 0;
1152
1153 static void *
1154 tcp0(char *name)
1155 {
1156     PFN fcn;
1157
1158     if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */
1159     if (!htcp)
1160         htcp = loadModule("tcp32dll");
1161     if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1162         return (void *) ((void * (*)(void)) fcn) ();
1163     return 0;
1164 }
1165
1166 static void
1167 tcp1(char *name, int arg)
1168 {
1169     static BYTE buf[20];
1170     PFN fcn;
1171
1172     if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */
1173     if (!htcp)
1174         DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1175     if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1176         ((void (*)(int)) fcn) (arg);
1177 }
1178
1179 struct hostent *        gethostent()    { return tcp0("GETHOSTENT");  }
1180 struct netent *         getnetent()     { return tcp0("GETNETENT");   }
1181 struct protoent *       getprotoent()   { return tcp0("GETPROTOENT"); }
1182 struct servent *        getservent()    { return tcp0("GETSERVENT");  }
1183
1184 void    sethostent(x)   { tcp1("SETHOSTENT",  x); }
1185 void    setnetent(x)    { tcp1("SETNETENT",   x); }
1186 void    setprotoent(x)  { tcp1("SETPROTOENT", x); }
1187 void    setservent(x)   { tcp1("SETSERVENT",  x); }
1188 void    endhostent()    { tcp0("ENDHOSTENT");  }
1189 void    endnetent()     { tcp0("ENDNETENT");   }
1190 void    endprotoent()   { tcp0("ENDPROTOENT"); }
1191 void    endservent()    { tcp0("ENDSERVENT");  }
1192
1193 /*****************************************************************************/
1194 /* not implemented in C Set++ */
1195
1196 #ifndef __EMX__
1197 int     setuid(x)       { errno = EINVAL; return -1; }
1198 int     setgid(x)       { errno = EINVAL; return -1; }
1199 #endif
1200
1201 /*****************************************************************************/
1202 /* stat() hack for char/block device */
1203
1204 #if OS2_STAT_HACK
1205
1206     /* First attempt used DosQueryFSAttach which crashed the system when
1207        used with 5.001. Now just look for /dev/. */
1208
1209 int
1210 os2_stat(char *name, struct stat *st)
1211 {
1212     static int ino = SHRT_MAX;
1213
1214     if (stricmp(name, "/dev/con") != 0
1215      && stricmp(name, "/dev/tty") != 0)
1216         return stat(name, st);
1217
1218     memset(st, 0, sizeof *st);
1219     st->st_mode = S_IFCHR|0666;
1220     st->st_ino = (ino-- & 0x7FFF);
1221     st->st_nlink = 1;
1222     return 0;
1223 }
1224
1225 #endif
1226
1227 #ifdef USE_PERL_SBRK
1228
1229 /* SBRK() emulation, mostly moved to malloc.c. */
1230
1231 void *
1232 sys_alloc(int size) {
1233     void *got;
1234     APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1235
1236     if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1237         return (void *) -1;
1238     } else if ( rc )
1239         Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
1240     return got;
1241 }
1242
1243 #endif /* USE_PERL_SBRK */
1244
1245 /* tmp path */
1246
1247 char *tmppath = TMPPATH1;
1248
1249 void
1250 settmppath()
1251 {
1252     char *p = getenv("TMP"), *tpath;
1253     int len;
1254
1255     if (!p) p = getenv("TEMP");
1256     if (!p) return;
1257     len = strlen(p);
1258     tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1259     if (tpath) {
1260         strcpy(tpath, p);
1261         tpath[len] = '/';
1262         strcpy(tpath + len + 1, TMPPATH1);
1263         tmppath = tpath;
1264     }
1265 }
1266
1267 #include "XSUB.h"
1268
1269 XS(XS_File__Copy_syscopy)
1270 {
1271     dXSARGS;
1272     if (items < 2 || items > 3)
1273         Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
1274     {
1275         STRLEN n_a;
1276         char *  src = (char *)SvPV(ST(0),n_a);
1277         char *  dst = (char *)SvPV(ST(1),n_a);
1278         U32     flag;
1279         int     RETVAL, rc;
1280
1281         if (items < 3)
1282             flag = 0;
1283         else {
1284             flag = (unsigned long)SvIV(ST(2));
1285         }
1286
1287         RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1288         ST(0) = sv_newmortal();
1289         sv_setiv(ST(0), (IV)RETVAL);
1290     }
1291     XSRETURN(1);
1292 }
1293
1294 #include "patchlevel.h"
1295
1296 char *
1297 mod2fname(pTHX_ SV *sv)
1298 {
1299     static char fname[9];
1300     int pos = 6, len, avlen;
1301     unsigned int sum = 0;
1302     AV  *av;
1303     SV  *svp;
1304     char *s;
1305     STRLEN n_a;
1306
1307     if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
1308     sv = SvRV(sv);
1309     if (SvTYPE(sv) != SVt_PVAV)
1310       Perl_croak_nocontext("Not array reference given to mod2fname");
1311
1312     avlen = av_len((AV*)sv);
1313     if (avlen < 0)
1314       Perl_croak_nocontext("Empty array reference given to mod2fname");
1315
1316     s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1317     strncpy(fname, s, 8);
1318     len = strlen(s);
1319     if (len < 6) pos = len;
1320     while (*s) {
1321         sum = 33 * sum + *(s++);        /* Checksumming first chars to
1322                                          * get the capitalization into c.s. */
1323     }
1324     avlen --;
1325     while (avlen >= 0) {
1326         s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1327         while (*s) {
1328             sum = 33 * sum + *(s++);    /* 7 is primitive mod 13. */
1329         }
1330         avlen --;
1331     }
1332 #ifdef USE_THREADS
1333     sum++;                              /* Avoid conflict of DLLs in memory. */
1334 #endif
1335     sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2;  /*  */
1336     fname[pos] = 'A' + (sum % 26);
1337     fname[pos + 1] = 'A' + (sum / 26 % 26);
1338     fname[pos + 2] = '\0';
1339     return (char *)fname;
1340 }
1341
1342 XS(XS_DynaLoader_mod2fname)
1343 {
1344     dXSARGS;
1345     if (items != 1)
1346         Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
1347     {
1348         SV *    sv = ST(0);
1349         char *  RETVAL;
1350
1351         RETVAL = mod2fname(aTHX_ sv);
1352         ST(0) = sv_newmortal();
1353         sv_setpv((SV*)ST(0), RETVAL);
1354     }
1355     XSRETURN(1);
1356 }
1357
1358 char *
1359 os2error(int rc)
1360 {
1361         static char buf[300];
1362         ULONG len;
1363
1364         if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1365         if (rc == 0)
1366                 return NULL;
1367         if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1368                 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1369         else {
1370                 buf[len] = '\0';
1371                 if (len && buf[len - 1] == '\n')
1372                         buf[--len] = 0;
1373                 if (len && buf[len - 1] == '\r')
1374                         buf[--len] = 0;
1375                 if (len && buf[len - 1] == '.')
1376                         buf[--len] = 0;
1377         }
1378         return buf;
1379 }
1380
1381 char *
1382 os2_execname(pTHX)
1383 {
1384   char buf[300], *p, *o = PL_origargv[0], ok = 1;
1385
1386   if (_execname(buf, sizeof buf) != 0)
1387         return o;
1388   p = buf;
1389   while (*p) {
1390     if (*p == '\\')
1391         *p = '/';
1392     if (*p == '/') {
1393         if (ok && *o != '/' && *o != '\\')
1394             ok = 0;
1395     } else if (ok && tolower(*o) != tolower(*p))
1396         ok = 0;
1397     p++;
1398     o++;
1399   }
1400   if (ok) { /* PL_origargv[0] matches the real name.  Use PL_origargv[0]: */
1401      strcpy(buf, PL_origargv[0]);       /* _execname() is always uppercased */
1402      p = buf;
1403      while (*p) {
1404        if (*p == '\\')
1405            *p = '/';
1406        p++;
1407      }
1408   }
1409   p = savepv(buf);
1410   SAVEFREEPV(p);
1411   return p;
1412 }
1413
1414 char *
1415 perllib_mangle(char *s, unsigned int l)
1416 {
1417     static char *newp, *oldp;
1418     static int newl, oldl, notfound;
1419     static char ret[STATIC_FILE_LENGTH+1];
1420
1421     if (!newp && !notfound) {
1422         newp = getenv("PERLLIB_PREFIX");
1423         if (newp) {
1424             char *s;
1425
1426             oldp = newp;
1427             while (*newp && !isSPACE(*newp) && *newp != ';') {
1428                 newp++; oldl++;         /* Skip digits. */
1429             }
1430             while (*newp && (isSPACE(*newp) || *newp == ';')) {
1431                 newp++;                 /* Skip whitespace. */
1432             }
1433             newl = strlen(newp);
1434             if (newl == 0 || oldl == 0) {
1435                 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1436             }
1437             strcpy(ret, newp);
1438             s = ret;
1439             while (*s) {
1440                 if (*s == '\\') *s = '/';
1441                 s++;
1442             }
1443         } else {
1444             notfound = 1;
1445         }
1446     }
1447     if (!newp) {
1448         return s;
1449     }
1450     if (l == 0) {
1451         l = strlen(s);
1452     }
1453     if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1454         return s;
1455     }
1456     if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1457         Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1458     }
1459     strcpy(ret + newl, s + oldl);
1460     return ret;
1461 }
1462
1463 unsigned long
1464 Perl_hab_GET()                  /* Needed if perl.h cannot be included */
1465 {
1466     return perl_hab_GET();
1467 }
1468
1469 HMQ
1470 Perl_Register_MQ(int serve)
1471 {
1472     PPIB pib;
1473     PTIB tib;
1474
1475     if (Perl_os2_initial_mode++)
1476         return Perl_hmq;
1477     DosGetInfoBlocks(&tib, &pib);
1478     Perl_os2_initial_mode = pib->pib_ultype;
1479     /* Try morphing into a PM application. */
1480     if (pib->pib_ultype != 3)           /* 2 is VIO */
1481         pib->pib_ultype = 3;            /* 3 is PM */
1482     init_PMWIN_entries();
1483     /* 64 messages if before OS/2 3.0, ignored otherwise */
1484     Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1485     if (!Perl_hmq) {
1486         static int cnt;
1487
1488         SAVEINT(cnt);                   /* Allow catch()ing. */
1489         if (cnt++)
1490             _exit(188);                 /* Panic can try to create a window. */
1491         Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application");
1492     }
1493     if (serve) {
1494         if ( Perl_hmq_servers <= 0      /* Safe to inform us on shutdown, */
1495              && Perl_hmq_refcnt > 0 )   /* this was switched off before... */
1496             (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0);
1497         Perl_hmq_servers++;
1498     } else if (!Perl_hmq_servers)       /* Do not inform us on shutdown */
1499         (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
1500     Perl_hmq_refcnt++;
1501     return Perl_hmq;
1502 }
1503
1504 int
1505 Perl_Serve_Messages(int force)
1506 {
1507     int cnt = 0;
1508     QMSG msg;
1509
1510     if (Perl_hmq_servers > 0 && !force)
1511         return 0;
1512     if (Perl_hmq_refcnt <= 0)
1513         Perl_croak_nocontext("No message queue");
1514     while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1515         cnt++;
1516         if (msg.msg == WM_QUIT)
1517             Perl_croak_nocontext("QUITing...");
1518         (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1519     }
1520     return cnt;
1521 }
1522
1523 int
1524 Perl_Process_Messages(int force, I32 *cntp)
1525 {
1526     QMSG msg;
1527
1528     if (Perl_hmq_servers > 0 && !force)
1529         return 0;
1530     if (Perl_hmq_refcnt <= 0)
1531         Perl_croak_nocontext("No message queue");
1532     while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1533         if (cntp)
1534             (*cntp)++;
1535         (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1536         if (msg.msg == WM_DESTROY)
1537             return -1;
1538         if (msg.msg == WM_CREATE)
1539             return +1;
1540     }
1541     Perl_croak_nocontext("QUITing...");
1542 }
1543
1544 void
1545 Perl_Deregister_MQ(int serve)
1546 {
1547     PPIB pib;
1548     PTIB tib;
1549
1550     if (serve)
1551         Perl_hmq_servers--;
1552     if (--Perl_hmq_refcnt <= 0) {
1553         init_PMWIN_entries();                   /* To be extra safe */
1554         (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1555         Perl_hmq = 0;
1556         /* Try morphing back from a PM application. */
1557         DosGetInfoBlocks(&tib, &pib);
1558         if (pib->pib_ultype == 3)               /* 3 is PM */
1559             pib->pib_ultype = Perl_os2_initial_mode;
1560         else
1561             Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
1562                  pib->pib_ultype);
1563     } else if (serve && Perl_hmq_servers <= 0)  /* Last server exited */
1564         (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
1565 }
1566
1567 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1568                                 && ((path)[2] == '/' || (path)[2] == '\\'))
1569 #define sys_is_rooted _fnisabs
1570 #define sys_is_relative _fnisrel
1571 #define current_drive _getdrive
1572
1573 #undef chdir                            /* Was _chdir2. */
1574 #define sys_chdir(p) (chdir(p) == 0)
1575 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1576
1577 static int DOS_harderr_state = -1;
1578
1579 XS(XS_OS2_Error)
1580 {
1581     dXSARGS;
1582     if (items != 2)
1583         Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
1584     {
1585         int     arg1 = SvIV(ST(0));
1586         int     arg2 = SvIV(ST(1));
1587         int     a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1588                      | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1589         int     RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1590         unsigned long rc;
1591
1592         if (CheckOSError(DosError(a)))
1593             Perl_croak_nocontext("DosError(%d) failed", a);
1594         ST(0) = sv_newmortal();
1595         if (DOS_harderr_state >= 0)
1596             sv_setiv(ST(0), DOS_harderr_state);
1597         DOS_harderr_state = RETVAL;
1598     }
1599     XSRETURN(1);
1600 }
1601
1602 static signed char DOS_suppression_state = -1;
1603
1604 XS(XS_OS2_Errors2Drive)
1605 {
1606     dXSARGS;
1607     if (items != 1)
1608         Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
1609     {
1610         STRLEN n_a;
1611         SV  *sv = ST(0);
1612         int     suppress = SvOK(sv);
1613         char    *s = suppress ? SvPV(sv, n_a) : NULL;
1614         char    drive = (s ? *s : 0);
1615         unsigned long rc;
1616
1617         if (suppress && !isALPHA(drive))
1618             Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
1619         if (CheckOSError(DosSuppressPopUps((suppress
1620                                             ? SPU_ENABLESUPPRESSION
1621                                             : SPU_DISABLESUPPRESSION),
1622                                            drive)))
1623             Perl_croak_nocontext("DosSuppressPopUps(%c) failed", drive);
1624         ST(0) = sv_newmortal();
1625         if (DOS_suppression_state > 0)
1626             sv_setpvn(ST(0), &DOS_suppression_state, 1);
1627         else if (DOS_suppression_state == 0)
1628             sv_setpvn(ST(0), "", 0);
1629         DOS_suppression_state = drive;
1630     }
1631     XSRETURN(1);
1632 }
1633
1634 static const char * const si_fields[QSV_MAX] = {
1635   "MAX_PATH_LENGTH",
1636   "MAX_TEXT_SESSIONS",
1637   "MAX_PM_SESSIONS",
1638   "MAX_VDM_SESSIONS",
1639   "BOOT_DRIVE",
1640   "DYN_PRI_VARIATION",
1641   "MAX_WAIT",
1642   "MIN_SLICE",
1643   "MAX_SLICE",
1644   "PAGE_SIZE",
1645   "VERSION_MAJOR",
1646   "VERSION_MINOR",
1647   "VERSION_REVISION",
1648   "MS_COUNT",
1649   "TIME_LOW",
1650   "TIME_HIGH",
1651   "TOTPHYSMEM",
1652   "TOTRESMEM",
1653   "TOTAVAILMEM",
1654   "MAXPRMEM",
1655   "MAXSHMEM",
1656   "TIMER_INTERVAL",
1657   "MAX_COMP_LENGTH",
1658   "FOREGROUND_FS_SESSION",
1659   "FOREGROUND_PROCESS"
1660 };
1661
1662 XS(XS_OS2_SysInfo)
1663 {
1664     dXSARGS;
1665     if (items != 0)
1666         Perl_croak_nocontext("Usage: OS2::SysInfo()");
1667     {
1668         ULONG   si[QSV_MAX] = {0};      /* System Information Data Buffer */
1669         APIRET  rc      = NO_ERROR;     /* Return code            */
1670         int i = 0, j = 0;
1671
1672         if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
1673                                          QSV_MAX, /* information */
1674                                          (PVOID)si,
1675                                          sizeof(si))))
1676             Perl_croak_nocontext("DosQuerySysInfo() failed");
1677         EXTEND(SP,2*QSV_MAX);
1678         while (i < QSV_MAX) {
1679             ST(j) = sv_newmortal();
1680             sv_setpv(ST(j++), si_fields[i]);
1681             ST(j) = sv_newmortal();
1682             sv_setiv(ST(j++), si[i]);
1683             i++;
1684         }
1685     }
1686     XSRETURN(2 * QSV_MAX);
1687 }
1688
1689 XS(XS_OS2_BootDrive)
1690 {
1691     dXSARGS;
1692     if (items != 0)
1693         Perl_croak_nocontext("Usage: OS2::BootDrive()");
1694     {
1695         ULONG   si[1] = {0};    /* System Information Data Buffer */
1696         APIRET  rc    = NO_ERROR;       /* Return code            */
1697         char c;
1698
1699         if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
1700                                          (PVOID)si, sizeof(si))))
1701             Perl_croak_nocontext("DosQuerySysInfo() failed");
1702         ST(0) = sv_newmortal();
1703         c = 'a' - 1 + si[0];
1704         sv_setpvn(ST(0), &c, 1);
1705     }
1706     XSRETURN(1);
1707 }
1708
1709 XS(XS_OS2_MorphPM)
1710 {
1711     dXSARGS;
1712     if (items != 1)
1713         Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
1714     {
1715         bool  serve = SvOK(ST(0));
1716         unsigned long   pmq = perl_hmq_GET(serve);
1717
1718         ST(0) = sv_newmortal();
1719         sv_setiv(ST(0), pmq);
1720     }
1721     XSRETURN(1);
1722 }
1723
1724 XS(XS_OS2_UnMorphPM)
1725 {
1726     dXSARGS;
1727     if (items != 1)
1728         Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
1729     {
1730         bool  serve = SvOK(ST(0));
1731
1732         perl_hmq_UNSET(serve);
1733     }
1734     XSRETURN(0);
1735 }
1736
1737 XS(XS_OS2_Serve_Messages)
1738 {
1739     dXSARGS;
1740     if (items != 1)
1741         Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
1742     {
1743         bool  force = SvOK(ST(0));
1744         unsigned long   cnt = Perl_Serve_Messages(force);
1745
1746         ST(0) = sv_newmortal();
1747         sv_setiv(ST(0), cnt);
1748     }
1749     XSRETURN(1);
1750 }
1751
1752 XS(XS_OS2_Process_Messages)
1753 {
1754     dXSARGS;
1755     if (items < 1 || items > 2)
1756         Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
1757     {
1758         bool  force = SvOK(ST(0));
1759         unsigned long   cnt;
1760
1761         if (items == 2) {
1762             I32 cntr;
1763             SV *sv = ST(1);
1764             int fake = SvIV(sv);        /* Force SvIVX */
1765
1766             if (!SvIOK(sv))
1767                 Perl_croak_nocontext("Can't upgrade count to IV");
1768             cntr = SvIVX(sv);
1769             cnt =  Perl_Process_Messages(force, &cntr);
1770             SvIVX(sv) = cntr;
1771         } else {
1772             cnt =  Perl_Process_Messages(force, NULL);
1773         }
1774         ST(0) = sv_newmortal();
1775         sv_setiv(ST(0), cnt);
1776     }
1777     XSRETURN(1);
1778 }
1779
1780 XS(XS_Cwd_current_drive)
1781 {
1782     dXSARGS;
1783     if (items != 0)
1784         Perl_croak_nocontext("Usage: Cwd::current_drive()");
1785     {
1786         char    RETVAL;
1787
1788         RETVAL = current_drive();
1789         ST(0) = sv_newmortal();
1790         sv_setpvn(ST(0), (char *)&RETVAL, 1);
1791     }
1792     XSRETURN(1);
1793 }
1794
1795 XS(XS_Cwd_sys_chdir)
1796 {
1797     dXSARGS;
1798     if (items != 1)
1799         Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
1800     {
1801         STRLEN n_a;
1802         char *  path = (char *)SvPV(ST(0),n_a);
1803         bool    RETVAL;
1804
1805         RETVAL = sys_chdir(path);
1806         ST(0) = boolSV(RETVAL);
1807         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1808     }
1809     XSRETURN(1);
1810 }
1811
1812 XS(XS_Cwd_change_drive)
1813 {
1814     dXSARGS;
1815     if (items != 1)
1816         Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
1817     {
1818         STRLEN n_a;
1819         char    d = (char)*SvPV(ST(0),n_a);
1820         bool    RETVAL;
1821
1822         RETVAL = change_drive(d);
1823         ST(0) = boolSV(RETVAL);
1824         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1825     }
1826     XSRETURN(1);
1827 }
1828
1829 XS(XS_Cwd_sys_is_absolute)
1830 {
1831     dXSARGS;
1832     if (items != 1)
1833         Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
1834     {
1835         STRLEN n_a;
1836         char *  path = (char *)SvPV(ST(0),n_a);
1837         bool    RETVAL;
1838
1839         RETVAL = sys_is_absolute(path);
1840         ST(0) = boolSV(RETVAL);
1841         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1842     }
1843     XSRETURN(1);
1844 }
1845
1846 XS(XS_Cwd_sys_is_rooted)
1847 {
1848     dXSARGS;
1849     if (items != 1)
1850         Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
1851     {
1852         STRLEN n_a;
1853         char *  path = (char *)SvPV(ST(0),n_a);
1854         bool    RETVAL;
1855
1856         RETVAL = sys_is_rooted(path);
1857         ST(0) = boolSV(RETVAL);
1858         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1859     }
1860     XSRETURN(1);
1861 }
1862
1863 XS(XS_Cwd_sys_is_relative)
1864 {
1865     dXSARGS;
1866     if (items != 1)
1867         Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
1868     {
1869         STRLEN n_a;
1870         char *  path = (char *)SvPV(ST(0),n_a);
1871         bool    RETVAL;
1872
1873         RETVAL = sys_is_relative(path);
1874         ST(0) = boolSV(RETVAL);
1875         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1876     }
1877     XSRETURN(1);
1878 }
1879
1880 XS(XS_Cwd_sys_cwd)
1881 {
1882     dXSARGS;
1883     if (items != 0)
1884         Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
1885     {
1886         char p[MAXPATHLEN];
1887         char *  RETVAL;
1888         RETVAL = _getcwd2(p, MAXPATHLEN);
1889         ST(0) = sv_newmortal();
1890         sv_setpv((SV*)ST(0), RETVAL);
1891     }
1892     XSRETURN(1);
1893 }
1894
1895 XS(XS_Cwd_sys_abspath)
1896 {
1897     dXSARGS;
1898     if (items < 1 || items > 2)
1899         Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
1900     {
1901         STRLEN n_a;
1902         char *  path = (char *)SvPV(ST(0),n_a);
1903         char *  dir;
1904         char p[MAXPATHLEN];
1905         char *  RETVAL;
1906
1907         if (items < 2)
1908             dir = NULL;
1909         else {
1910             dir = (char *)SvPV(ST(1),n_a);
1911         }
1912         if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1913             path += 2;
1914         }
1915         if (dir == NULL) {
1916             if (_abspath(p, path, MAXPATHLEN) == 0) {
1917                 RETVAL = p;
1918             } else {
1919                 RETVAL = NULL;
1920             }
1921         } else {
1922             /* Absolute with drive: */
1923             if ( sys_is_absolute(path) ) {
1924                 if (_abspath(p, path, MAXPATHLEN) == 0) {
1925                     RETVAL = p;
1926                 } else {
1927                     RETVAL = NULL;
1928                 }
1929             } else if (path[0] == '/' || path[0] == '\\') {
1930                 /* Rooted, but maybe on different drive. */
1931                 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1932                     char p1[MAXPATHLEN];
1933
1934                     /* Need to prepend the drive. */
1935                     p1[0] = dir[0];
1936                     p1[1] = dir[1];
1937                     Copy(path, p1 + 2, strlen(path) + 1, char);
1938                     RETVAL = p;
1939                     if (_abspath(p, p1, MAXPATHLEN) == 0) {
1940                         RETVAL = p;
1941                     } else {
1942                         RETVAL = NULL;
1943                     }
1944                 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1945                     RETVAL = p;
1946                 } else {
1947                     RETVAL = NULL;
1948                 }
1949             } else {
1950                 /* Either path is relative, or starts with a drive letter. */
1951                 /* If the path starts with a drive letter, then dir is
1952                    relevant only if
1953                    a/b) it is absolute/x:relative on the same drive.
1954                    c)   path is on current drive, and dir is rooted
1955                    In all the cases it is safe to drop the drive part
1956                    of the path. */
1957                 if ( !sys_is_relative(path) ) {
1958                     int is_drived;
1959
1960                     if ( ( ( sys_is_absolute(dir)
1961                              || (isALPHA(dir[0]) && dir[1] == ':'
1962                                  && strnicmp(dir, path,1) == 0))
1963                            && strnicmp(dir, path,1) == 0)
1964                          || ( !(isALPHA(dir[0]) && dir[1] == ':')
1965                               && toupper(path[0]) == current_drive())) {
1966                         path += 2;
1967                     } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1968                         RETVAL = p; goto done;
1969                     } else {
1970                         RETVAL = NULL; goto done;
1971                     }
1972                 }
1973                 {
1974                     /* Need to prepend the absolute path of dir. */
1975                     char p1[MAXPATHLEN];
1976
1977                     if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1978                         int l = strlen(p1);
1979
1980                         if (p1[ l - 1 ] != '/') {
1981                             p1[ l ] = '/';
1982                             l++;
1983                         }
1984                         Copy(path, p1 + l, strlen(path) + 1, char);
1985                         if (_abspath(p, p1, MAXPATHLEN) == 0) {
1986                             RETVAL = p;
1987                         } else {
1988                             RETVAL = NULL;
1989                         }
1990                     } else {
1991                         RETVAL = NULL;
1992                     }
1993                 }
1994               done:
1995             }
1996         }
1997         ST(0) = sv_newmortal();
1998         sv_setpv((SV*)ST(0), RETVAL);
1999     }
2000     XSRETURN(1);
2001 }
2002 typedef APIRET (*PELP)(PSZ path, ULONG type);
2003
2004 APIRET
2005 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
2006 {
2007     loadByOrd("doscalls",ord);          /* Guarantied to load or die! */
2008     return (*(PELP)ExtFCN[ord])(path, type);
2009 }
2010
2011 #define extLibpath(type)                                                \
2012     (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH   \
2013                                                  : BEGIN_LIBPATH)))     \
2014      ? NULL : to )
2015
2016 #define extLibpath_set(p,type)                                  \
2017     (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH   \
2018                                                  : BEGIN_LIBPATH))))
2019
2020 XS(XS_Cwd_extLibpath)
2021 {
2022     dXSARGS;
2023     if (items < 0 || items > 1)
2024         Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
2025     {
2026         bool    type;
2027         char    to[1024];
2028         U32     rc;
2029         char *  RETVAL;
2030
2031         if (items < 1)
2032             type = 0;
2033         else {
2034             type = (int)SvIV(ST(0));
2035         }
2036
2037         RETVAL = extLibpath(type);
2038         ST(0) = sv_newmortal();
2039         sv_setpv((SV*)ST(0), RETVAL);
2040     }
2041     XSRETURN(1);
2042 }
2043
2044 XS(XS_Cwd_extLibpath_set)
2045 {
2046     dXSARGS;
2047     if (items < 1 || items > 2)
2048         Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
2049     {
2050         STRLEN n_a;
2051         char *  s = (char *)SvPV(ST(0),n_a);
2052         bool    type;
2053         U32     rc;
2054         bool    RETVAL;
2055
2056         if (items < 2)
2057             type = 0;
2058         else {
2059             type = (int)SvIV(ST(1));
2060         }
2061
2062         RETVAL = extLibpath_set(s, type);
2063         ST(0) = boolSV(RETVAL);
2064         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2065     }
2066     XSRETURN(1);
2067 }
2068
2069 #define get_control87()         _control87(0,0)
2070 #define set_control87           _control87
2071
2072 XS(XS_OS2__control87)
2073 {
2074     dXSARGS;
2075     if (items != 2)
2076         croak("Usage: OS2::_control87(new,mask)");
2077     {
2078         unsigned        new = (unsigned)SvIV(ST(0));
2079         unsigned        mask = (unsigned)SvIV(ST(1));
2080         unsigned        RETVAL;
2081
2082         RETVAL = _control87(new, mask);
2083         ST(0) = sv_newmortal();
2084         sv_setiv(ST(0), (IV)RETVAL);
2085     }
2086     XSRETURN(1);
2087 }
2088
2089 XS(XS_OS2_get_control87)
2090 {
2091     dXSARGS;
2092     if (items != 0)
2093         croak("Usage: OS2::get_control87()");
2094     {
2095         unsigned        RETVAL;
2096
2097         RETVAL = get_control87();
2098         ST(0) = sv_newmortal();
2099         sv_setiv(ST(0), (IV)RETVAL);
2100     }
2101     XSRETURN(1);
2102 }
2103
2104
2105 XS(XS_OS2_set_control87)
2106 {
2107     dXSARGS;
2108     if (items < 0 || items > 2)
2109         croak("Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
2110     {
2111         unsigned        new;
2112         unsigned        mask;
2113         unsigned        RETVAL;
2114
2115         if (items < 1)
2116             new = MCW_EM;
2117         else {
2118             new = (unsigned)SvIV(ST(0));
2119         }
2120
2121         if (items < 2)
2122             mask = MCW_EM;
2123         else {
2124             mask = (unsigned)SvIV(ST(1));
2125         }
2126
2127         RETVAL = set_control87(new, mask);
2128         ST(0) = sv_newmortal();
2129         sv_setiv(ST(0), (IV)RETVAL);
2130     }
2131     XSRETURN(1);
2132 }
2133
2134 int
2135 Xs_OS2_init(pTHX)
2136 {
2137     char *file = __FILE__;
2138     {
2139         GV *gv;
2140
2141         if (_emx_env & 0x200) { /* OS/2 */
2142             newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2143             newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2144             newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2145         }
2146         newXS("OS2::Error", XS_OS2_Error, file);
2147         newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2148         newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2149         newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2150         newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2151         newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2152         newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2153         newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
2154         newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2155         newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2156         newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2157         newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2158         newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2159         newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2160         newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2161         newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2162         newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
2163         newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
2164         newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
2165         newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
2166         gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2167         GvMULTI_on(gv);
2168 #ifdef PERL_IS_AOUT
2169         sv_setiv(GvSV(gv), 1);
2170 #endif
2171         gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2172         GvMULTI_on(gv);
2173         sv_setiv(GvSV(gv), _emx_rev);
2174         sv_setpv(GvSV(gv), _emx_vprt);
2175         SvIOK_on(GvSV(gv));
2176         gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2177         GvMULTI_on(gv);
2178         sv_setiv(GvSV(gv), _emx_env);
2179         gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2180         GvMULTI_on(gv);
2181         sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
2182     }
2183 }
2184
2185 OS2_Perl_data_t OS2_Perl_data;
2186
2187 void
2188 Perl_OS2_init(char **env)
2189 {
2190     char *shell;
2191
2192     MALLOC_INIT;
2193     settmppath();
2194     OS2_Perl_data.xs_init = &Xs_OS2_init;
2195     _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
2196     if (environ == NULL && env) {
2197         environ = env;
2198     }
2199     if ( (shell = getenv("PERL_SH_DRIVE")) ) {
2200         New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2201         strcpy(PL_sh_path, SH_PATH);
2202         PL_sh_path[0] = shell[0];
2203     } else if ( (shell = getenv("PERL_SH_DIR")) ) {
2204         int l = strlen(shell), i;
2205         if (shell[l-1] == '/' || shell[l-1] == '\\') {
2206             l--;
2207         }
2208         New(1304, PL_sh_path, l + 8, char);
2209         strncpy(PL_sh_path, shell, l);
2210         strcpy(PL_sh_path + l, "/sh.exe");
2211         for (i = 0; i < l; i++) {
2212             if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2213         }
2214     }
2215     MUTEX_INIT(&start_thread_mutex);
2216     os2_mytype = my_type();             /* Do it before morphing.  Needed? */
2217     /* Some DLLs reset FP flags on load.  We may have been linked with them */
2218     _control87(MCW_EM, MCW_EM);
2219 }
2220
2221 #undef tmpnam
2222 #undef tmpfile
2223
2224 char *
2225 my_tmpnam (char *str)
2226 {
2227     char *p = getenv("TMP"), *tpath;
2228     int len;
2229
2230     if (!p) p = getenv("TEMP");
2231     tpath = tempnam(p, "pltmp");
2232     if (str && tpath) {
2233         strcpy(str, tpath);
2234         return str;
2235     }
2236     return tpath;
2237 }
2238
2239 FILE *
2240 my_tmpfile ()
2241 {
2242     struct stat s;
2243
2244     stat(".", &s);
2245     if (s.st_mode & S_IWOTH) {
2246         return tmpfile();
2247     }
2248     return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2249                                              grants TMP. */
2250 }
2251
2252 #undef rmdir
2253
2254 int
2255 my_rmdir (__const__ char *s)
2256 {
2257     char buf[MAXPATHLEN];
2258     STRLEN l = strlen(s);
2259
2260     if (s[l-1] == '/' || s[l-1] == '\\') {      /* EMX rmdir fails... */
2261         strcpy(buf,s);
2262         buf[l - 1] = 0;
2263         s = buf;
2264     }
2265     return rmdir(s);
2266 }
2267
2268 #undef mkdir
2269
2270 int
2271 my_mkdir (__const__ char *s, long perm)
2272 {
2273     char buf[MAXPATHLEN];
2274     STRLEN l = strlen(s);
2275
2276     if (s[l-1] == '/' || s[l-1] == '\\') {      /* EMX mkdir fails... */
2277         strcpy(buf,s);
2278         buf[l - 1] = 0;
2279         s = buf;
2280     }
2281     return mkdir(s, perm);
2282 }
2283
2284 #undef flock
2285
2286 /* This code was contributed by Rocco Caputo. */
2287 int
2288 my_flock(int handle, int o)
2289 {
2290   FILELOCK      rNull, rFull;
2291   ULONG         timeout, handle_type, flag_word;
2292   APIRET        rc;
2293   int           blocking, shared;
2294   static int    use_my = -1;
2295
2296   if (use_my == -1) {
2297     char *s = getenv("USE_PERL_FLOCK");
2298     if (s)
2299         use_my = atoi(s);
2300     else
2301         use_my = 1;
2302   }
2303   if (!(_emx_env & 0x200) || !use_my)
2304     return flock(handle, o);    /* Delegate to EMX. */
2305
2306                                         // is this a file?
2307   if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2308       (handle_type & 0xFF))
2309   {
2310     errno = EBADF;
2311     return -1;
2312   }
2313                                         // set lock/unlock ranges
2314   rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2315   rFull.lRange = 0x7FFFFFFF;
2316                                         // set timeout for blocking
2317   timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2318                                         // shared or exclusive?
2319   shared = (o & LOCK_SH) ? 1 : 0;
2320                                         // do not block the unlock
2321   if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2322     rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2323     switch (rc) {
2324       case 0:
2325         errno = 0;
2326         return 0;
2327       case ERROR_INVALID_HANDLE:
2328         errno = EBADF;
2329         return -1;
2330       case ERROR_SHARING_BUFFER_EXCEEDED:
2331         errno = ENOLCK;
2332         return -1;
2333       case ERROR_LOCK_VIOLATION:
2334         break;                          // not an error
2335       case ERROR_INVALID_PARAMETER:
2336       case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2337       case ERROR_READ_LOCKS_NOT_SUPPORTED:
2338         errno = EINVAL;
2339         return -1;
2340       case ERROR_INTERRUPT:
2341         errno = EINTR;
2342         return -1;
2343       default:
2344         errno = EINVAL;
2345         return -1;
2346     }
2347   }
2348                                         // lock may block
2349   if (o & (LOCK_SH | LOCK_EX)) {
2350                                         // for blocking operations
2351     for (;;) {
2352       rc =
2353         DosSetFileLocks(
2354                 handle,
2355                 &rNull,
2356                 &rFull,
2357                 timeout,
2358                 shared
2359         );
2360       switch (rc) {
2361         case 0:
2362           errno = 0;
2363           return 0;
2364         case ERROR_INVALID_HANDLE:
2365           errno = EBADF;
2366           return -1;
2367         case ERROR_SHARING_BUFFER_EXCEEDED:
2368           errno = ENOLCK;
2369           return -1;
2370         case ERROR_LOCK_VIOLATION:
2371           if (!blocking) {
2372             errno = EWOULDBLOCK;
2373             return -1;
2374           }
2375           break;
2376         case ERROR_INVALID_PARAMETER:
2377         case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2378         case ERROR_READ_LOCKS_NOT_SUPPORTED:
2379           errno = EINVAL;
2380           return -1;
2381         case ERROR_INTERRUPT:
2382           errno = EINTR;
2383           return -1;
2384         default:
2385           errno = EINVAL;
2386           return -1;
2387       }
2388                                         // give away timeslice
2389       DosSleep(1);
2390     }
2391   }
2392
2393   errno = 0;
2394   return 0;
2395 }