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