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