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