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