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
1360         if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1361         if (rc == 0)
1362                 return NULL;
1363         if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1364                 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1365         else {
1366                 buf[len] = '\0';
1367                 if (len && buf[len - 1] == '\n')
1368                         buf[--len] = 0;
1369                 if (len && buf[len - 1] == '\r')
1370                         buf[--len] = 0;
1371                 if (len && buf[len - 1] == '.')
1372                         buf[--len] = 0;
1373         }
1374         return buf;
1375 }
1376
1377 char *
1378 os2_execname(pTHX)
1379 {
1380   char buf[300], *p, *o = PL_origargv[0], ok = 1;
1381
1382   if (_execname(buf, sizeof buf) != 0)
1383         return o;
1384   p = buf;
1385   while (*p) {
1386     if (*p == '\\')
1387         *p = '/';
1388     if (*p == '/') {
1389         if (ok && *o != '/' && *o != '\\')
1390             ok = 0;
1391     } else if (ok && tolower(*o) != tolower(*p))
1392         ok = 0;
1393     p++;
1394     o++;
1395   }
1396   if (ok) { /* PL_origargv[0] matches the real name.  Use PL_origargv[0]: */
1397      strcpy(buf, PL_origargv[0]);       /* _execname() is always uppercased */
1398      p = buf;
1399      while (*p) {
1400        if (*p == '\\')
1401            *p = '/';
1402        p++;
1403      }
1404   }
1405   p = savepv(buf);
1406   SAVEFREEPV(p);
1407   return p;
1408 }
1409
1410 char *
1411 perllib_mangle(char *s, unsigned int l)
1412 {
1413     static char *newp, *oldp;
1414     static int newl, oldl, notfound;
1415     static char ret[STATIC_FILE_LENGTH+1];
1416
1417     if (!newp && !notfound) {
1418         newp = getenv("PERLLIB_PREFIX");
1419         if (newp) {
1420             char *s;
1421
1422             oldp = newp;
1423             while (*newp && !isSPACE(*newp) && *newp != ';') {
1424                 newp++; oldl++;         /* Skip digits. */
1425             }
1426             while (*newp && (isSPACE(*newp) || *newp == ';')) {
1427                 newp++;                 /* Skip whitespace. */
1428             }
1429             newl = strlen(newp);
1430             if (newl == 0 || oldl == 0) {
1431                 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1432             }
1433             strcpy(ret, newp);
1434             s = ret;
1435             while (*s) {
1436                 if (*s == '\\') *s = '/';
1437                 s++;
1438             }
1439         } else {
1440             notfound = 1;
1441         }
1442     }
1443     if (!newp) {
1444         return s;
1445     }
1446     if (l == 0) {
1447         l = strlen(s);
1448     }
1449     if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1450         return s;
1451     }
1452     if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1453         Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1454     }
1455     strcpy(ret + newl, s + oldl);
1456     return ret;
1457 }
1458
1459 unsigned long
1460 Perl_hab_GET()                  /* Needed if perl.h cannot be included */
1461 {
1462     return perl_hab_GET();
1463 }
1464
1465 HMQ
1466 Perl_Register_MQ(int serve)
1467 {
1468     PPIB pib;
1469     PTIB tib;
1470
1471     if (Perl_os2_initial_mode++)
1472         return Perl_hmq;
1473     DosGetInfoBlocks(&tib, &pib);
1474     Perl_os2_initial_mode = pib->pib_ultype;
1475     /* Try morphing into a PM application. */
1476     if (pib->pib_ultype != 3)           /* 2 is VIO */
1477         pib->pib_ultype = 3;            /* 3 is PM */
1478     init_PMWIN_entries();
1479     /* 64 messages if before OS/2 3.0, ignored otherwise */
1480     Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1481     if (!Perl_hmq) {
1482         static int cnt;
1483
1484         SAVEINT(cnt);                   /* Allow catch()ing. */
1485         if (cnt++)
1486             _exit(188);                 /* Panic can try to create a window. */
1487         Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application");
1488     }
1489     if (serve) {
1490         if ( Perl_hmq_servers <= 0      /* Safe to inform us on shutdown, */
1491              && Perl_hmq_refcnt > 0 )   /* this was switched off before... */
1492             (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0);
1493         Perl_hmq_servers++;
1494     } else if (!Perl_hmq_servers)       /* Do not inform us on shutdown */
1495         (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
1496     Perl_hmq_refcnt++;
1497     return Perl_hmq;
1498 }
1499
1500 int
1501 Perl_Serve_Messages(int force)
1502 {
1503     int cnt = 0;
1504     QMSG msg;
1505
1506     if (Perl_hmq_servers > 0 && !force)
1507         return 0;
1508     if (Perl_hmq_refcnt <= 0)
1509         Perl_croak_nocontext("No message queue");
1510     while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1511         cnt++;
1512         if (msg.msg == WM_QUIT)
1513             Perl_croak_nocontext("QUITing...");
1514         (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1515     }
1516     return cnt;
1517 }
1518
1519 int
1520 Perl_Process_Messages(int force, I32 *cntp)
1521 {
1522     QMSG msg;
1523
1524     if (Perl_hmq_servers > 0 && !force)
1525         return 0;
1526     if (Perl_hmq_refcnt <= 0)
1527         Perl_croak_nocontext("No message queue");
1528     while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1529         if (cntp)
1530             (*cntp)++;
1531         (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1532         if (msg.msg == WM_DESTROY)
1533             return -1;
1534         if (msg.msg == WM_CREATE)
1535             return +1;
1536     }
1537     Perl_croak_nocontext("QUITing...");
1538 }
1539
1540 void
1541 Perl_Deregister_MQ(int serve)
1542 {
1543     PPIB pib;
1544     PTIB tib;
1545
1546     if (serve)
1547         Perl_hmq_servers--;
1548     if (--Perl_hmq_refcnt <= 0) {
1549         init_PMWIN_entries();                   /* To be extra safe */
1550         (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1551         Perl_hmq = 0;
1552         /* Try morphing back from a PM application. */
1553         DosGetInfoBlocks(&tib, &pib);
1554         if (pib->pib_ultype == 3)               /* 3 is PM */
1555             pib->pib_ultype = Perl_os2_initial_mode;
1556         else
1557             Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
1558                  pib->pib_ultype);
1559     } else if (serve && Perl_hmq_servers <= 0)  /* Last server exited */
1560         (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
1561 }
1562
1563 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1564                                 && ((path)[2] == '/' || (path)[2] == '\\'))
1565 #define sys_is_rooted _fnisabs
1566 #define sys_is_relative _fnisrel
1567 #define current_drive _getdrive
1568
1569 #undef chdir                            /* Was _chdir2. */
1570 #define sys_chdir(p) (chdir(p) == 0)
1571 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1572
1573 static int DOS_harderr_state = -1;
1574
1575 XS(XS_OS2_Error)
1576 {
1577     dXSARGS;
1578     if (items != 2)
1579         Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
1580     {
1581         int     arg1 = SvIV(ST(0));
1582         int     arg2 = SvIV(ST(1));
1583         int     a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1584                      | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1585         int     RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1586         unsigned long rc;
1587
1588         if (CheckOSError(DosError(a)))
1589             Perl_croak_nocontext("DosError(%d) failed", a);
1590         ST(0) = sv_newmortal();
1591         if (DOS_harderr_state >= 0)
1592             sv_setiv(ST(0), DOS_harderr_state);
1593         DOS_harderr_state = RETVAL;
1594     }
1595     XSRETURN(1);
1596 }
1597
1598 static signed char DOS_suppression_state = -1;
1599
1600 XS(XS_OS2_Errors2Drive)
1601 {
1602     dXSARGS;
1603     if (items != 1)
1604         Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
1605     {
1606         STRLEN n_a;
1607         SV  *sv = ST(0);
1608         int     suppress = SvOK(sv);
1609         char    *s = suppress ? SvPV(sv, n_a) : NULL;
1610         char    drive = (s ? *s : 0);
1611         unsigned long rc;
1612
1613         if (suppress && !isALPHA(drive))
1614             Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
1615         if (CheckOSError(DosSuppressPopUps((suppress
1616                                             ? SPU_ENABLESUPPRESSION
1617                                             : SPU_DISABLESUPPRESSION),
1618                                            drive)))
1619             Perl_croak_nocontext("DosSuppressPopUps(%c) failed", drive);
1620         ST(0) = sv_newmortal();
1621         if (DOS_suppression_state > 0)
1622             sv_setpvn(ST(0), &DOS_suppression_state, 1);
1623         else if (DOS_suppression_state == 0)
1624             sv_setpvn(ST(0), "", 0);
1625         DOS_suppression_state = drive;
1626     }
1627     XSRETURN(1);
1628 }
1629
1630 static const char * const si_fields[QSV_MAX] = {
1631   "MAX_PATH_LENGTH",
1632   "MAX_TEXT_SESSIONS",
1633   "MAX_PM_SESSIONS",
1634   "MAX_VDM_SESSIONS",
1635   "BOOT_DRIVE",
1636   "DYN_PRI_VARIATION",
1637   "MAX_WAIT",
1638   "MIN_SLICE",
1639   "MAX_SLICE",
1640   "PAGE_SIZE",
1641   "VERSION_MAJOR",
1642   "VERSION_MINOR",
1643   "VERSION_REVISION",
1644   "MS_COUNT",
1645   "TIME_LOW",
1646   "TIME_HIGH",
1647   "TOTPHYSMEM",
1648   "TOTRESMEM",
1649   "TOTAVAILMEM",
1650   "MAXPRMEM",
1651   "MAXSHMEM",
1652   "TIMER_INTERVAL",
1653   "MAX_COMP_LENGTH",
1654   "FOREGROUND_FS_SESSION",
1655   "FOREGROUND_PROCESS"
1656 };
1657
1658 XS(XS_OS2_SysInfo)
1659 {
1660     dXSARGS;
1661     if (items != 0)
1662         Perl_croak_nocontext("Usage: OS2::SysInfo()");
1663     {
1664         ULONG   si[QSV_MAX] = {0};      /* System Information Data Buffer */
1665         APIRET  rc      = NO_ERROR;     /* Return code            */
1666         int i = 0, j = 0;
1667
1668         if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
1669                                          QSV_MAX, /* information */
1670                                          (PVOID)si,
1671                                          sizeof(si))))
1672             Perl_croak_nocontext("DosQuerySysInfo() failed");
1673         EXTEND(SP,2*QSV_MAX);
1674         while (i < QSV_MAX) {
1675             ST(j) = sv_newmortal();
1676             sv_setpv(ST(j++), si_fields[i]);
1677             ST(j) = sv_newmortal();
1678             sv_setiv(ST(j++), si[i]);
1679             i++;
1680         }
1681     }
1682     XSRETURN(2 * QSV_MAX);
1683 }
1684
1685 XS(XS_OS2_BootDrive)
1686 {
1687     dXSARGS;
1688     if (items != 0)
1689         Perl_croak_nocontext("Usage: OS2::BootDrive()");
1690     {
1691         ULONG   si[1] = {0};    /* System Information Data Buffer */
1692         APIRET  rc    = NO_ERROR;       /* Return code            */
1693         char c;
1694
1695         if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
1696                                          (PVOID)si, sizeof(si))))
1697             Perl_croak_nocontext("DosQuerySysInfo() failed");
1698         ST(0) = sv_newmortal();
1699         c = 'a' - 1 + si[0];
1700         sv_setpvn(ST(0), &c, 1);
1701     }
1702     XSRETURN(1);
1703 }
1704
1705 XS(XS_OS2_MorphPM)
1706 {
1707     dXSARGS;
1708     if (items != 1)
1709         Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
1710     {
1711         bool  serve = SvOK(ST(0));
1712         unsigned long   pmq = perl_hmq_GET(serve);
1713
1714         ST(0) = sv_newmortal();
1715         sv_setiv(ST(0), pmq);
1716     }
1717     XSRETURN(1);
1718 }
1719
1720 XS(XS_OS2_UnMorphPM)
1721 {
1722     dXSARGS;
1723     if (items != 1)
1724         Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
1725     {
1726         bool  serve = SvOK(ST(0));
1727
1728         perl_hmq_UNSET(serve);
1729     }
1730     XSRETURN(0);
1731 }
1732
1733 XS(XS_OS2_Serve_Messages)
1734 {
1735     dXSARGS;
1736     if (items != 1)
1737         Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
1738     {
1739         bool  force = SvOK(ST(0));
1740         unsigned long   cnt = Perl_Serve_Messages(force);
1741
1742         ST(0) = sv_newmortal();
1743         sv_setiv(ST(0), cnt);
1744     }
1745     XSRETURN(1);
1746 }
1747
1748 XS(XS_OS2_Process_Messages)
1749 {
1750     dXSARGS;
1751     if (items < 1 || items > 2)
1752         Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
1753     {
1754         bool  force = SvOK(ST(0));
1755         unsigned long   cnt;
1756
1757         if (items == 2) {
1758             I32 cntr;
1759             SV *sv = ST(1);
1760
1761             (void)SvIV(sv);             /* Force SvIVX */
1762             if (!SvIOK(sv))
1763                 Perl_croak_nocontext("Can't upgrade count to IV");
1764             cntr = SvIVX(sv);
1765             cnt =  Perl_Process_Messages(force, &cntr);
1766             SvIVX(sv) = cntr;
1767         } else {
1768             cnt =  Perl_Process_Messages(force, NULL);
1769         }
1770         ST(0) = sv_newmortal();
1771         sv_setiv(ST(0), cnt);
1772     }
1773     XSRETURN(1);
1774 }
1775
1776 XS(XS_Cwd_current_drive)
1777 {
1778     dXSARGS;
1779     if (items != 0)
1780         Perl_croak_nocontext("Usage: Cwd::current_drive()");
1781     {
1782         char    RETVAL;
1783
1784         RETVAL = current_drive();
1785         ST(0) = sv_newmortal();
1786         sv_setpvn(ST(0), (char *)&RETVAL, 1);
1787     }
1788     XSRETURN(1);
1789 }
1790
1791 XS(XS_Cwd_sys_chdir)
1792 {
1793     dXSARGS;
1794     if (items != 1)
1795         Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
1796     {
1797         STRLEN n_a;
1798         char *  path = (char *)SvPV(ST(0),n_a);
1799         bool    RETVAL;
1800
1801         RETVAL = sys_chdir(path);
1802         ST(0) = boolSV(RETVAL);
1803         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1804     }
1805     XSRETURN(1);
1806 }
1807
1808 XS(XS_Cwd_change_drive)
1809 {
1810     dXSARGS;
1811     if (items != 1)
1812         Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
1813     {
1814         STRLEN n_a;
1815         char    d = (char)*SvPV(ST(0),n_a);
1816         bool    RETVAL;
1817
1818         RETVAL = change_drive(d);
1819         ST(0) = boolSV(RETVAL);
1820         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1821     }
1822     XSRETURN(1);
1823 }
1824
1825 XS(XS_Cwd_sys_is_absolute)
1826 {
1827     dXSARGS;
1828     if (items != 1)
1829         Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
1830     {
1831         STRLEN n_a;
1832         char *  path = (char *)SvPV(ST(0),n_a);
1833         bool    RETVAL;
1834
1835         RETVAL = sys_is_absolute(path);
1836         ST(0) = boolSV(RETVAL);
1837         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1838     }
1839     XSRETURN(1);
1840 }
1841
1842 XS(XS_Cwd_sys_is_rooted)
1843 {
1844     dXSARGS;
1845     if (items != 1)
1846         Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
1847     {
1848         STRLEN n_a;
1849         char *  path = (char *)SvPV(ST(0),n_a);
1850         bool    RETVAL;
1851
1852         RETVAL = sys_is_rooted(path);
1853         ST(0) = boolSV(RETVAL);
1854         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1855     }
1856     XSRETURN(1);
1857 }
1858
1859 XS(XS_Cwd_sys_is_relative)
1860 {
1861     dXSARGS;
1862     if (items != 1)
1863         Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
1864     {
1865         STRLEN n_a;
1866         char *  path = (char *)SvPV(ST(0),n_a);
1867         bool    RETVAL;
1868
1869         RETVAL = sys_is_relative(path);
1870         ST(0) = boolSV(RETVAL);
1871         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1872     }
1873     XSRETURN(1);
1874 }
1875
1876 XS(XS_Cwd_sys_cwd)
1877 {
1878     dXSARGS;
1879     if (items != 0)
1880         Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
1881     {
1882         char p[MAXPATHLEN];
1883         char *  RETVAL;
1884         RETVAL = _getcwd2(p, MAXPATHLEN);
1885         ST(0) = sv_newmortal();
1886         sv_setpv((SV*)ST(0), RETVAL);
1887     }
1888     XSRETURN(1);
1889 }
1890
1891 XS(XS_Cwd_sys_abspath)
1892 {
1893     dXSARGS;
1894     if (items < 1 || items > 2)
1895         Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
1896     {
1897         STRLEN n_a;
1898         char *  path = (char *)SvPV(ST(0),n_a);
1899         char *  dir;
1900         char p[MAXPATHLEN];
1901         char *  RETVAL;
1902
1903         if (items < 2)
1904             dir = NULL;
1905         else {
1906             dir = (char *)SvPV(ST(1),n_a);
1907         }
1908         if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1909             path += 2;
1910         }
1911         if (dir == NULL) {
1912             if (_abspath(p, path, MAXPATHLEN) == 0) {
1913                 RETVAL = p;
1914             } else {
1915                 RETVAL = NULL;
1916             }
1917         } else {
1918             /* Absolute with drive: */
1919             if ( sys_is_absolute(path) ) {
1920                 if (_abspath(p, path, MAXPATHLEN) == 0) {
1921                     RETVAL = p;
1922                 } else {
1923                     RETVAL = NULL;
1924                 }
1925             } else if (path[0] == '/' || path[0] == '\\') {
1926                 /* Rooted, but maybe on different drive. */
1927                 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1928                     char p1[MAXPATHLEN];
1929
1930                     /* Need to prepend the drive. */
1931                     p1[0] = dir[0];
1932                     p1[1] = dir[1];
1933                     Copy(path, p1 + 2, strlen(path) + 1, char);
1934                     RETVAL = p;
1935                     if (_abspath(p, p1, MAXPATHLEN) == 0) {
1936                         RETVAL = p;
1937                     } else {
1938                         RETVAL = NULL;
1939                     }
1940                 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1941                     RETVAL = p;
1942                 } else {
1943                     RETVAL = NULL;
1944                 }
1945             } else {
1946                 /* Either path is relative, or starts with a drive letter. */
1947                 /* If the path starts with a drive letter, then dir is
1948                    relevant only if
1949                    a/b) it is absolute/x:relative on the same drive.
1950                    c)   path is on current drive, and dir is rooted
1951                    In all the cases it is safe to drop the drive part
1952                    of the path. */
1953                 if ( !sys_is_relative(path) ) {
1954                     if ( ( ( sys_is_absolute(dir)
1955                              || (isALPHA(dir[0]) && dir[1] == ':'
1956                                  && strnicmp(dir, path,1) == 0))
1957                            && strnicmp(dir, path,1) == 0)
1958                          || ( !(isALPHA(dir[0]) && dir[1] == ':')
1959                               && toupper(path[0]) == current_drive())) {
1960                         path += 2;
1961                     } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1962                         RETVAL = p; goto done;
1963                     } else {
1964                         RETVAL = NULL; goto done;
1965                     }
1966                 }
1967                 {
1968                     /* Need to prepend the absolute path of dir. */
1969                     char p1[MAXPATHLEN];
1970
1971                     if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1972                         int l = strlen(p1);
1973
1974                         if (p1[ l - 1 ] != '/') {
1975                             p1[ l ] = '/';
1976                             l++;
1977                         }
1978                         Copy(path, p1 + l, strlen(path) + 1, char);
1979                         if (_abspath(p, p1, MAXPATHLEN) == 0) {
1980                             RETVAL = p;
1981                         } else {
1982                             RETVAL = NULL;
1983                         }
1984                     } else {
1985                         RETVAL = NULL;
1986                     }
1987                 }
1988               done:
1989             }
1990         }
1991         ST(0) = sv_newmortal();
1992         sv_setpv((SV*)ST(0), RETVAL);
1993     }
1994     XSRETURN(1);
1995 }
1996 typedef APIRET (*PELP)(PSZ path, ULONG type);
1997
1998 /* Kernels after 2000/09/15 understand this too: */
1999 #ifndef LIBPATHSTRICT
2000 #  define LIBPATHSTRICT 3
2001 #endif
2002
2003 APIRET
2004 ExtLIBPATH(ULONG ord, PSZ path, IV type)
2005 {
2006     ULONG what;
2007
2008     loadByOrd("doscalls",ord);          /* Guarantied to load or die! */
2009     if (type > 0)
2010         what = END_LIBPATH;
2011     else if (type == 0)
2012         what = BEGIN_LIBPATH;
2013     else
2014         what = LIBPATHSTRICT;
2015     return (*(PELP)ExtFCN[ord])(path, what);
2016 }
2017
2018 #define extLibpath(to,type)                                             \
2019     (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, (to), (type))) ? NULL : (to) )
2020
2021 #define extLibpath_set(p,type)                                  \
2022     (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), (type))))
2023
2024 XS(XS_Cwd_extLibpath)
2025 {
2026     dXSARGS;
2027     if (items < 0 || items > 1)
2028         Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
2029     {
2030         IV      type;
2031         char    to[1024];
2032         U32     rc;
2033         char *  RETVAL;
2034
2035         if (items < 1)
2036             type = 0;
2037         else {
2038             type = SvIV(ST(0));
2039         }
2040
2041         to[0] = 1; to[1] = 0;           /* Sometimes no error reported */
2042         RETVAL = extLibpath(to, type);
2043         if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
2044             Perl_croak_nocontext("panic Cwd::extLibpath parameter");
2045         ST(0) = sv_newmortal();
2046         sv_setpv((SV*)ST(0), RETVAL);
2047     }
2048     XSRETURN(1);
2049 }
2050
2051 XS(XS_Cwd_extLibpath_set)
2052 {
2053     dXSARGS;
2054     if (items < 1 || items > 2)
2055         Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
2056     {
2057         STRLEN n_a;
2058         char *  s = (char *)SvPV(ST(0),n_a);
2059         IV      type;
2060         U32     rc;
2061         bool    RETVAL;
2062
2063         if (items < 2)
2064             type = 0;
2065         else {
2066             type = SvIV(ST(1));
2067         }
2068
2069         RETVAL = extLibpath_set(s, type);
2070         ST(0) = boolSV(RETVAL);
2071         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2072     }
2073     XSRETURN(1);
2074 }
2075
2076 #define get_control87()         _control87(0,0)
2077 #define set_control87           _control87
2078
2079 XS(XS_OS2__control87)
2080 {
2081     dXSARGS;
2082     if (items != 2)
2083         croak("Usage: OS2::_control87(new,mask)");
2084     {
2085         unsigned        new = (unsigned)SvIV(ST(0));
2086         unsigned        mask = (unsigned)SvIV(ST(1));
2087         unsigned        RETVAL;
2088
2089         RETVAL = _control87(new, mask);
2090         ST(0) = sv_newmortal();
2091         sv_setiv(ST(0), (IV)RETVAL);
2092     }
2093     XSRETURN(1);
2094 }
2095
2096 XS(XS_OS2_get_control87)
2097 {
2098     dXSARGS;
2099     if (items != 0)
2100         croak("Usage: OS2::get_control87()");
2101     {
2102         unsigned        RETVAL;
2103
2104         RETVAL = get_control87();
2105         ST(0) = sv_newmortal();
2106         sv_setiv(ST(0), (IV)RETVAL);
2107     }
2108     XSRETURN(1);
2109 }
2110
2111
2112 XS(XS_OS2_set_control87)
2113 {
2114     dXSARGS;
2115     if (items < 0 || items > 2)
2116         croak("Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
2117     {
2118         unsigned        new;
2119         unsigned        mask;
2120         unsigned        RETVAL;
2121
2122         if (items < 1)
2123             new = MCW_EM;
2124         else {
2125             new = (unsigned)SvIV(ST(0));
2126         }
2127
2128         if (items < 2)
2129             mask = MCW_EM;
2130         else {
2131             mask = (unsigned)SvIV(ST(1));
2132         }
2133
2134         RETVAL = set_control87(new, mask);
2135         ST(0) = sv_newmortal();
2136         sv_setiv(ST(0), (IV)RETVAL);
2137     }
2138     XSRETURN(1);
2139 }
2140
2141 int
2142 Xs_OS2_init(pTHX)
2143 {
2144     char *file = __FILE__;
2145     {
2146         GV *gv;
2147
2148         if (_emx_env & 0x200) { /* OS/2 */
2149             newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2150             newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2151             newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2152         }
2153         newXS("OS2::Error", XS_OS2_Error, file);
2154         newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2155         newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2156         newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2157         newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2158         newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2159         newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2160         newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
2161         newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2162         newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2163         newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2164         newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2165         newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2166         newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2167         newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2168         newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2169         newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
2170         newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
2171         newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
2172         newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
2173         gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2174         GvMULTI_on(gv);
2175 #ifdef PERL_IS_AOUT
2176         sv_setiv(GvSV(gv), 1);
2177 #endif
2178         gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2179         GvMULTI_on(gv);
2180         sv_setiv(GvSV(gv), _emx_rev);
2181         sv_setpv(GvSV(gv), _emx_vprt);
2182         SvIOK_on(GvSV(gv));
2183         gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2184         GvMULTI_on(gv);
2185         sv_setiv(GvSV(gv), _emx_env);
2186         gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2187         GvMULTI_on(gv);
2188         sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
2189     }
2190     return 0;
2191 }
2192
2193 OS2_Perl_data_t OS2_Perl_data;
2194
2195 void
2196 Perl_OS2_init(char **env)
2197 {
2198     char *shell;
2199
2200     MALLOC_INIT;
2201     settmppath();
2202     OS2_Perl_data.xs_init = &Xs_OS2_init;
2203     _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
2204     if (environ == NULL && env) {
2205         environ = env;
2206     }
2207     if ( (shell = getenv("PERL_SH_DRIVE")) ) {
2208         New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2209         strcpy(PL_sh_path, SH_PATH);
2210         PL_sh_path[0] = shell[0];
2211     } else if ( (shell = getenv("PERL_SH_DIR")) ) {
2212         int l = strlen(shell), i;
2213         if (shell[l-1] == '/' || shell[l-1] == '\\') {
2214             l--;
2215         }
2216         New(1304, PL_sh_path, l + 8, char);
2217         strncpy(PL_sh_path, shell, l);
2218         strcpy(PL_sh_path + l, "/sh.exe");
2219         for (i = 0; i < l; i++) {
2220             if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2221         }
2222     }
2223     MUTEX_INIT(&start_thread_mutex);
2224     os2_mytype = my_type();             /* Do it before morphing.  Needed? */
2225     /* Some DLLs reset FP flags on load.  We may have been linked with them */
2226     _control87(MCW_EM, MCW_EM);
2227 }
2228
2229 #undef tmpnam
2230 #undef tmpfile
2231
2232 char *
2233 my_tmpnam (char *str)
2234 {
2235     char *p = getenv("TMP"), *tpath;
2236
2237     if (!p) p = getenv("TEMP");
2238     tpath = tempnam(p, "pltmp");
2239     if (str && tpath) {
2240         strcpy(str, tpath);
2241         return str;
2242     }
2243     return tpath;
2244 }
2245
2246 FILE *
2247 my_tmpfile ()
2248 {
2249     struct stat s;
2250
2251     stat(".", &s);
2252     if (s.st_mode & S_IWOTH) {
2253         return tmpfile();
2254     }
2255     return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2256                                              grants TMP. */
2257 }
2258
2259 #undef rmdir
2260
2261 int
2262 my_rmdir (__const__ char *s)
2263 {
2264     char buf[MAXPATHLEN];
2265     STRLEN l = strlen(s);
2266
2267     if (s[l-1] == '/' || s[l-1] == '\\') {      /* EMX rmdir fails... */
2268         strcpy(buf,s);
2269         buf[l - 1] = 0;
2270         s = buf;
2271     }
2272     return rmdir(s);
2273 }
2274
2275 #undef mkdir
2276
2277 int
2278 my_mkdir (__const__ char *s, long perm)
2279 {
2280     char buf[MAXPATHLEN];
2281     STRLEN l = strlen(s);
2282
2283     if (s[l-1] == '/' || s[l-1] == '\\') {      /* EMX mkdir fails... */
2284         strcpy(buf,s);
2285         buf[l - 1] = 0;
2286         s = buf;
2287     }
2288     return mkdir(s, perm);
2289 }
2290
2291 #undef flock
2292
2293 /* This code was contributed by Rocco Caputo. */
2294 int
2295 my_flock(int handle, int o)
2296 {
2297   FILELOCK      rNull, rFull;
2298   ULONG         timeout, handle_type, flag_word;
2299   APIRET        rc;
2300   int           blocking, shared;
2301   static int    use_my = -1;
2302
2303   if (use_my == -1) {
2304     char *s = getenv("USE_PERL_FLOCK");
2305     if (s)
2306         use_my = atoi(s);
2307     else
2308         use_my = 1;
2309   }
2310   if (!(_emx_env & 0x200) || !use_my)
2311     return flock(handle, o);    /* Delegate to EMX. */
2312
2313                                         // is this a file?
2314   if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2315       (handle_type & 0xFF))
2316   {
2317     errno = EBADF;
2318     return -1;
2319   }
2320                                         // set lock/unlock ranges
2321   rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2322   rFull.lRange = 0x7FFFFFFF;
2323                                         // set timeout for blocking
2324   timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2325                                         // shared or exclusive?
2326   shared = (o & LOCK_SH) ? 1 : 0;
2327                                         // do not block the unlock
2328   if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2329     rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2330     switch (rc) {
2331       case 0:
2332         errno = 0;
2333         return 0;
2334       case ERROR_INVALID_HANDLE:
2335         errno = EBADF;
2336         return -1;
2337       case ERROR_SHARING_BUFFER_EXCEEDED:
2338         errno = ENOLCK;
2339         return -1;
2340       case ERROR_LOCK_VIOLATION:
2341         break;                          // not an error
2342       case ERROR_INVALID_PARAMETER:
2343       case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2344       case ERROR_READ_LOCKS_NOT_SUPPORTED:
2345         errno = EINVAL;
2346         return -1;
2347       case ERROR_INTERRUPT:
2348         errno = EINTR;
2349         return -1;
2350       default:
2351         errno = EINVAL;
2352         return -1;
2353     }
2354   }
2355                                         // lock may block
2356   if (o & (LOCK_SH | LOCK_EX)) {
2357                                         // for blocking operations
2358     for (;;) {
2359       rc =
2360         DosSetFileLocks(
2361                 handle,
2362                 &rNull,
2363                 &rFull,
2364                 timeout,
2365                 shared
2366         );
2367       switch (rc) {
2368         case 0:
2369           errno = 0;
2370           return 0;
2371         case ERROR_INVALID_HANDLE:
2372           errno = EBADF;
2373           return -1;
2374         case ERROR_SHARING_BUFFER_EXCEEDED:
2375           errno = ENOLCK;
2376           return -1;
2377         case ERROR_LOCK_VIOLATION:
2378           if (!blocking) {
2379             errno = EWOULDBLOCK;
2380             return -1;
2381           }
2382           break;
2383         case ERROR_INVALID_PARAMETER:
2384         case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2385         case ERROR_READ_LOCKS_NOT_SUPPORTED:
2386           errno = EINVAL;
2387           return -1;
2388         case ERROR_INTERRUPT:
2389           errno = EINTR;
2390           return -1;
2391         default:
2392           errno = EINVAL;
2393           return -1;
2394       }
2395                                         // give away timeslice
2396       DosSleep(1);
2397     }
2398   }
2399
2400   errno = 0;
2401   return 0;
2402 }
2403
2404 static int pwent_cnt;
2405 static int _my_pwent = -1;
2406
2407 static int
2408 use_my_pwent(void)
2409 {
2410   if (_my_pwent == -1) {
2411     char *s = getenv("USE_PERL_PWENT");
2412     if (s)
2413         _my_pwent = atoi(s);
2414     else
2415         _my_pwent = 1;
2416   }
2417   return _my_pwent;
2418 }
2419
2420 #undef setpwent
2421 #undef getpwent
2422 #undef endpwent
2423
2424 void
2425 my_setpwent(void)
2426 {
2427   if (!use_my_pwent()) {
2428     setpwent();                 /* Delegate to EMX. */
2429     return;
2430   }
2431   pwent_cnt = 0;
2432 }
2433
2434 void
2435 my_endpwent(void)
2436 {
2437   if (!use_my_pwent()) {
2438     endpwent();                 /* Delegate to EMX. */
2439     return;
2440   }
2441 }
2442
2443 struct passwd *
2444 my_getpwent (void)
2445 {
2446   if (!use_my_pwent())
2447     return getpwent();                  /* Delegate to EMX. */
2448   if (pwent_cnt++)
2449     return 0;                           // Return one entry only
2450   return getpwuid(0);
2451 }
2452
2453 static int grent_cnt;
2454
2455 void
2456 setgrent(void)
2457 {
2458   grent_cnt = 0;
2459 }
2460
2461 void
2462 endgrent(void)
2463 {
2464 }
2465
2466 struct group *
2467 getgrent (void)
2468 {
2469   if (grent_cnt++)
2470     return 0;                           // Return one entry only
2471   return getgrgid(0);
2472 }
2473
2474 #undef getpwuid
2475 #undef getpwnam
2476
2477 /* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */
2478 static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
2479
2480 static struct passwd *
2481 passw_wrap(struct passwd *p)
2482 {
2483     static struct passwd pw;
2484     char *s;
2485
2486     if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
2487         return p;
2488     pw = *p;
2489     s = getenv("PW_PASSWD");
2490     if (!s)
2491         s = (char*)pw_p;                /* Make match impossible */
2492
2493     pw.pw_passwd = s;
2494     return &pw;
2495 }
2496
2497 struct passwd *
2498 my_getpwuid (uid_t id)
2499 {
2500     return passw_wrap(getpwuid(id));
2501 }
2502
2503 struct passwd *
2504 my_getpwnam (__const__ char *n)
2505 {
2506     return passw_wrap(getpwnam(n));
2507 }