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