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 #ifndef HAS_GETHOSTENT          /* Older versions of EMX did not have it... */
1166 void *  gethostent()    { return tcp0("GETHOSTENT");  }
1167 void *  getnetent()     { return tcp0("GETNETENT");   }
1168 void *  getprotoent()   { return tcp0("GETPROTOENT"); }
1169 void *  getservent()    { return tcp0("GETSERVENT");  }
1170 #endif
1171
1172 void    sethostent(x)   { tcp1("SETHOSTENT",  x); }
1173 void    setnetent(x)    { tcp1("SETNETENT",   x); }
1174 void    setprotoent(x)  { tcp1("SETPROTOENT", x); }
1175 void    setservent(x)   { tcp1("SETSERVENT",  x); }
1176 void    endhostent()    { tcp0("ENDHOSTENT");  }
1177 void    endnetent()     { tcp0("ENDNETENT");   }
1178 void    endprotoent()   { tcp0("ENDPROTOENT"); }
1179 void    endservent()    { tcp0("ENDSERVENT");  }
1180
1181 /*****************************************************************************/
1182 /* not implemented in C Set++ */
1183
1184 #ifndef __EMX__
1185 int     setuid(x)       { errno = EINVAL; return -1; }
1186 int     setgid(x)       { errno = EINVAL; return -1; }
1187 #endif
1188
1189 /*****************************************************************************/
1190 /* stat() hack for char/block device */
1191
1192 #if OS2_STAT_HACK
1193
1194     /* First attempt used DosQueryFSAttach which crashed the system when
1195        used with 5.001. Now just look for /dev/. */
1196
1197 int
1198 os2_stat(char *name, struct stat *st)
1199 {
1200     static int ino = SHRT_MAX;
1201
1202     if (stricmp(name, "/dev/con") != 0
1203      && stricmp(name, "/dev/tty") != 0)
1204         return stat(name, st);
1205
1206     memset(st, 0, sizeof *st);
1207     st->st_mode = S_IFCHR|0666;
1208     st->st_ino = (ino-- & 0x7FFF);
1209     st->st_nlink = 1;
1210     return 0;
1211 }
1212
1213 #endif
1214
1215 #ifdef USE_PERL_SBRK
1216
1217 /* SBRK() emulation, mostly moved to malloc.c. */
1218
1219 void *
1220 sys_alloc(int size) {
1221     void *got;
1222     APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1223
1224     if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1225         return (void *) -1;
1226     } else if ( rc )
1227         Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
1228     return got;
1229 }
1230
1231 #endif /* USE_PERL_SBRK */
1232
1233 /* tmp path */
1234
1235 char *tmppath = TMPPATH1;
1236
1237 void
1238 settmppath()
1239 {
1240     char *p = getenv("TMP"), *tpath;
1241     int len;
1242
1243     if (!p) p = getenv("TEMP");
1244     if (!p) return;
1245     len = strlen(p);
1246     tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1247     if (tpath) {
1248         strcpy(tpath, p);
1249         tpath[len] = '/';
1250         strcpy(tpath + len + 1, TMPPATH1);
1251         tmppath = tpath;
1252     }
1253 }
1254
1255 #include "XSUB.h"
1256
1257 XS(XS_File__Copy_syscopy)
1258 {
1259     dXSARGS;
1260     if (items < 2 || items > 3)
1261         Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
1262     {
1263         STRLEN n_a;
1264         char *  src = (char *)SvPV(ST(0),n_a);
1265         char *  dst = (char *)SvPV(ST(1),n_a);
1266         U32     flag;
1267         int     RETVAL, rc;
1268
1269         if (items < 3)
1270             flag = 0;
1271         else {
1272             flag = (unsigned long)SvIV(ST(2));
1273         }
1274
1275         RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1276         ST(0) = sv_newmortal();
1277         sv_setiv(ST(0), (IV)RETVAL);
1278     }
1279     XSRETURN(1);
1280 }
1281
1282 #include "patchlevel.h"
1283
1284 char *
1285 mod2fname(pTHX_ SV *sv)
1286 {
1287     static char fname[9];
1288     int pos = 6, len, avlen;
1289     unsigned int sum = 0;
1290     AV  *av;
1291     SV  *svp;
1292     char *s;
1293     STRLEN n_a;
1294
1295     if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
1296     sv = SvRV(sv);
1297     if (SvTYPE(sv) != SVt_PVAV)
1298       Perl_croak_nocontext("Not array reference given to mod2fname");
1299
1300     avlen = av_len((AV*)sv);
1301     if (avlen < 0)
1302       Perl_croak_nocontext("Empty array reference given to mod2fname");
1303
1304     s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1305     strncpy(fname, s, 8);
1306     len = strlen(s);
1307     if (len < 6) pos = len;
1308     while (*s) {
1309         sum = 33 * sum + *(s++);        /* Checksumming first chars to
1310                                          * get the capitalization into c.s. */
1311     }
1312     avlen --;
1313     while (avlen >= 0) {
1314         s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1315         while (*s) {
1316             sum = 33 * sum + *(s++);    /* 7 is primitive mod 13. */
1317         }
1318         avlen --;
1319     }
1320 #ifdef USE_THREADS
1321     sum++;                              /* Avoid conflict of DLLs in memory. */
1322 #endif
1323     sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2;  /*  */
1324     fname[pos] = 'A' + (sum % 26);
1325     fname[pos + 1] = 'A' + (sum / 26 % 26);
1326     fname[pos + 2] = '\0';
1327     return (char *)fname;
1328 }
1329
1330 XS(XS_DynaLoader_mod2fname)
1331 {
1332     dXSARGS;
1333     if (items != 1)
1334         Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
1335     {
1336         SV *    sv = ST(0);
1337         char *  RETVAL;
1338
1339         RETVAL = mod2fname(aTHX_ sv);
1340         ST(0) = sv_newmortal();
1341         sv_setpv((SV*)ST(0), RETVAL);
1342     }
1343     XSRETURN(1);
1344 }
1345
1346 char *
1347 os2error(int rc)
1348 {
1349         static char buf[300];
1350         ULONG len;
1351
1352         if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1353         if (rc == 0)
1354                 return NULL;
1355         if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1356                 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1357         else {
1358                 buf[len] = '\0';
1359                 if (len && buf[len - 1] == '\n')
1360                         buf[--len] = 0;
1361                 if (len && buf[len - 1] == '\r')
1362                         buf[--len] = 0;
1363                 if (len && buf[len - 1] == '.')
1364                         buf[--len] = 0;
1365         }
1366         return buf;
1367 }
1368
1369 char *
1370 os2_execname(pTHX)
1371 {
1372   char buf[300], *p;
1373
1374   if (_execname(buf, sizeof buf) != 0)
1375         return PL_origargv[0];
1376   p = buf;
1377   while (*p) {
1378     if (*p == '\\')
1379         *p = '/';
1380     p++;
1381   }
1382   p = savepv(buf);
1383   SAVEFREEPV(p);
1384   return p;
1385 }
1386
1387 char *
1388 perllib_mangle(char *s, unsigned int l)
1389 {
1390     static char *newp, *oldp;
1391     static int newl, oldl, notfound;
1392     static char ret[STATIC_FILE_LENGTH+1];
1393
1394     if (!newp && !notfound) {
1395         newp = getenv("PERLLIB_PREFIX");
1396         if (newp) {
1397             char *s;
1398
1399             oldp = newp;
1400             while (*newp && !isSPACE(*newp) && *newp != ';') {
1401                 newp++; oldl++;         /* Skip digits. */
1402             }
1403             while (*newp && (isSPACE(*newp) || *newp == ';')) {
1404                 newp++;                 /* Skip whitespace. */
1405             }
1406             newl = strlen(newp);
1407             if (newl == 0 || oldl == 0) {
1408                 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1409             }
1410             strcpy(ret, newp);
1411             s = ret;
1412             while (*s) {
1413                 if (*s == '\\') *s = '/';
1414                 s++;
1415             }
1416         } else {
1417             notfound = 1;
1418         }
1419     }
1420     if (!newp) {
1421         return s;
1422     }
1423     if (l == 0) {
1424         l = strlen(s);
1425     }
1426     if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1427         return s;
1428     }
1429     if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1430         Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1431     }
1432     strcpy(ret + newl, s + oldl);
1433     return ret;
1434 }
1435
1436 unsigned long
1437 Perl_hab_GET()                  /* Needed if perl.h cannot be included */
1438 {
1439     return perl_hab_GET();
1440 }
1441
1442 HMQ
1443 Perl_Register_MQ(int serve)
1444 {
1445     PPIB pib;
1446     PTIB tib;
1447
1448     if (Perl_os2_initial_mode++)
1449         return Perl_hmq;
1450     DosGetInfoBlocks(&tib, &pib);
1451     Perl_os2_initial_mode = pib->pib_ultype;
1452     Perl_hmq_refcnt = 1;
1453     /* Try morphing into a PM application. */
1454     if (pib->pib_ultype != 3)           /* 2 is VIO */
1455         pib->pib_ultype = 3;            /* 3 is PM */
1456     init_PMWIN_entries();
1457     /* 64 messages if before OS/2 3.0, ignored otherwise */
1458     Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1459     if (!Perl_hmq) {
1460         static int cnt;
1461         if (cnt++)
1462             _exit(188);                 /* Panic can try to create a window. */
1463         Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application");
1464     }
1465     return Perl_hmq;
1466 }
1467
1468 int
1469 Perl_Serve_Messages(int force)
1470 {
1471     int cnt = 0;
1472     QMSG msg;
1473
1474     if (Perl_hmq_servers && !force)
1475         return 0;
1476     if (!Perl_hmq_refcnt)
1477         Perl_croak_nocontext("No message queue");
1478     while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1479         cnt++;
1480         if (msg.msg == WM_QUIT)
1481             Perl_croak_nocontext("QUITing...");
1482         (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1483     }
1484     return cnt;
1485 }
1486
1487 int
1488 Perl_Process_Messages(int force, I32 *cntp)
1489 {
1490     QMSG msg;
1491
1492     if (Perl_hmq_servers && !force)
1493         return 0;
1494     if (!Perl_hmq_refcnt)
1495         Perl_croak_nocontext("No message queue");
1496     while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1497         if (cntp)
1498             (*cntp)++;
1499         (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1500         if (msg.msg == WM_DESTROY)
1501             return -1;
1502         if (msg.msg == WM_CREATE)
1503             return +1;
1504     }
1505     Perl_croak_nocontext("QUITing...");
1506 }
1507
1508 void
1509 Perl_Deregister_MQ(int serve)
1510 {
1511     PPIB pib;
1512     PTIB tib;
1513
1514     if (--Perl_hmq_refcnt == 0) {
1515         (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1516         Perl_hmq = 0;
1517         /* Try morphing back from a PM application. */
1518         if (pib->pib_ultype == 3)               /* 3 is PM */
1519             pib->pib_ultype = Perl_os2_initial_mode;
1520         else
1521             Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
1522                  pib->pib_ultype);
1523     }
1524 }
1525
1526 extern void dlopen();
1527 void *fakedl = &dlopen;         /* Pull in dynaloading part. */
1528
1529 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1530                                 && ((path)[2] == '/' || (path)[2] == '\\'))
1531 #define sys_is_rooted _fnisabs
1532 #define sys_is_relative _fnisrel
1533 #define current_drive _getdrive
1534
1535 #undef chdir                            /* Was _chdir2. */
1536 #define sys_chdir(p) (chdir(p) == 0)
1537 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1538
1539 static int DOS_harderr_state = -1;
1540
1541 XS(XS_OS2_Error)
1542 {
1543     dXSARGS;
1544     if (items != 2)
1545         Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
1546     {
1547         int     arg1 = SvIV(ST(0));
1548         int     arg2 = SvIV(ST(1));
1549         int     a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1550                      | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1551         int     RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1552         unsigned long rc;
1553
1554         if (CheckOSError(DosError(a)))
1555             Perl_croak_nocontext("DosError(%d) failed", a);
1556         ST(0) = sv_newmortal();
1557         if (DOS_harderr_state >= 0)
1558             sv_setiv(ST(0), DOS_harderr_state);
1559         DOS_harderr_state = RETVAL;
1560     }
1561     XSRETURN(1);
1562 }
1563
1564 static signed char DOS_suppression_state = -1;
1565
1566 XS(XS_OS2_Errors2Drive)
1567 {
1568     dXSARGS;
1569     if (items != 1)
1570         Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
1571     {
1572         STRLEN n_a;
1573         SV  *sv = ST(0);
1574         int     suppress = SvOK(sv);
1575         char    *s = suppress ? SvPV(sv, n_a) : NULL;
1576         char    drive = (s ? *s : 0);
1577         unsigned long rc;
1578
1579         if (suppress && !isALPHA(drive))
1580             Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
1581         if (CheckOSError(DosSuppressPopUps((suppress
1582                                             ? SPU_ENABLESUPPRESSION
1583                                             : SPU_DISABLESUPPRESSION),
1584                                            drive)))
1585             Perl_croak_nocontext("DosSuppressPopUps(%c) failed", drive);
1586         ST(0) = sv_newmortal();
1587         if (DOS_suppression_state > 0)
1588             sv_setpvn(ST(0), &DOS_suppression_state, 1);
1589         else if (DOS_suppression_state == 0)
1590             sv_setpvn(ST(0), "", 0);
1591         DOS_suppression_state = drive;
1592     }
1593     XSRETURN(1);
1594 }
1595
1596 static const char * const si_fields[QSV_MAX] = {
1597   "MAX_PATH_LENGTH",
1598   "MAX_TEXT_SESSIONS",
1599   "MAX_PM_SESSIONS",
1600   "MAX_VDM_SESSIONS",
1601   "BOOT_DRIVE",
1602   "DYN_PRI_VARIATION",
1603   "MAX_WAIT",
1604   "MIN_SLICE",
1605   "MAX_SLICE",
1606   "PAGE_SIZE",
1607   "VERSION_MAJOR",
1608   "VERSION_MINOR",
1609   "VERSION_REVISION",
1610   "MS_COUNT",
1611   "TIME_LOW",
1612   "TIME_HIGH",
1613   "TOTPHYSMEM",
1614   "TOTRESMEM",
1615   "TOTAVAILMEM",
1616   "MAXPRMEM",
1617   "MAXSHMEM",
1618   "TIMER_INTERVAL",
1619   "MAX_COMP_LENGTH",
1620   "FOREGROUND_FS_SESSION",
1621   "FOREGROUND_PROCESS"
1622 };
1623
1624 XS(XS_OS2_SysInfo)
1625 {
1626     dXSARGS;
1627     if (items != 0)
1628         Perl_croak_nocontext("Usage: OS2::SysInfo()");
1629     {
1630         ULONG   si[QSV_MAX] = {0};      /* System Information Data Buffer */
1631         APIRET  rc      = NO_ERROR;     /* Return code            */
1632         int i = 0, j = 0;
1633
1634         if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
1635                                          QSV_MAX, /* information */
1636                                          (PVOID)si,
1637                                          sizeof(si))))
1638             Perl_croak_nocontext("DosQuerySysInfo() failed");
1639         EXTEND(SP,2*QSV_MAX);
1640         while (i < QSV_MAX) {
1641             ST(j) = sv_newmortal();
1642             sv_setpv(ST(j++), si_fields[i]);
1643             ST(j) = sv_newmortal();
1644             sv_setiv(ST(j++), si[i]);
1645             i++;
1646         }
1647     }
1648     XSRETURN(2 * QSV_MAX);
1649 }
1650
1651 XS(XS_OS2_BootDrive)
1652 {
1653     dXSARGS;
1654     if (items != 0)
1655         Perl_croak_nocontext("Usage: OS2::BootDrive()");
1656     {
1657         ULONG   si[1] = {0};    /* System Information Data Buffer */
1658         APIRET  rc    = NO_ERROR;       /* Return code            */
1659         char c;
1660
1661         if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
1662                                          (PVOID)si, sizeof(si))))
1663             Perl_croak_nocontext("DosQuerySysInfo() failed");
1664         ST(0) = sv_newmortal();
1665         c = 'a' - 1 + si[0];
1666         sv_setpvn(ST(0), &c, 1);
1667     }
1668     XSRETURN(1);
1669 }
1670
1671 XS(XS_OS2_MorphPM)
1672 {
1673     dXSARGS;
1674     if (items != 1)
1675         Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
1676     {
1677         bool  serve = SvOK(ST(0));
1678         unsigned long   pmq = perl_hmq_GET(serve);
1679
1680         ST(0) = sv_newmortal();
1681         sv_setiv(ST(0), pmq);
1682     }
1683     XSRETURN(1);
1684 }
1685
1686 XS(XS_OS2_UnMorphPM)
1687 {
1688     dXSARGS;
1689     if (items != 1)
1690         Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
1691     {
1692         bool  serve = SvOK(ST(0));
1693
1694         perl_hmq_UNSET(serve);
1695     }
1696     XSRETURN(0);
1697 }
1698
1699 XS(XS_OS2_Serve_Messages)
1700 {
1701     dXSARGS;
1702     if (items != 1)
1703         Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
1704     {
1705         bool  force = SvOK(ST(0));
1706         unsigned long   cnt = Perl_Serve_Messages(force);
1707
1708         ST(0) = sv_newmortal();
1709         sv_setiv(ST(0), cnt);
1710     }
1711     XSRETURN(1);
1712 }
1713
1714 XS(XS_OS2_Process_Messages)
1715 {
1716     dXSARGS;
1717     if (items < 1 || items > 2)
1718         Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
1719     {
1720         bool  force = SvOK(ST(0));
1721         unsigned long   cnt;
1722
1723         if (items == 2) {
1724             I32 cntr;
1725             SV *sv = ST(1);
1726             int fake = SvIV(sv);        /* Force SvIVX */
1727
1728             if (!SvIOK(sv))
1729                 Perl_croak_nocontext("Can't upgrade count to IV");
1730             cntr = SvIVX(sv);
1731             cnt =  Perl_Process_Messages(force, &cntr);
1732             SvIVX(sv) = cntr;
1733         } else {
1734             cnt =  Perl_Process_Messages(force, NULL);
1735         }
1736         ST(0) = sv_newmortal();
1737         sv_setiv(ST(0), cnt);
1738     }
1739     XSRETURN(1);
1740 }
1741
1742 XS(XS_Cwd_current_drive)
1743 {
1744     dXSARGS;
1745     if (items != 0)
1746         Perl_croak_nocontext("Usage: Cwd::current_drive()");
1747     {
1748         char    RETVAL;
1749
1750         RETVAL = current_drive();
1751         ST(0) = sv_newmortal();
1752         sv_setpvn(ST(0), (char *)&RETVAL, 1);
1753     }
1754     XSRETURN(1);
1755 }
1756
1757 XS(XS_Cwd_sys_chdir)
1758 {
1759     dXSARGS;
1760     if (items != 1)
1761         Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
1762     {
1763         STRLEN n_a;
1764         char *  path = (char *)SvPV(ST(0),n_a);
1765         bool    RETVAL;
1766
1767         RETVAL = sys_chdir(path);
1768         ST(0) = boolSV(RETVAL);
1769         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1770     }
1771     XSRETURN(1);
1772 }
1773
1774 XS(XS_Cwd_change_drive)
1775 {
1776     dXSARGS;
1777     if (items != 1)
1778         Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
1779     {
1780         STRLEN n_a;
1781         char    d = (char)*SvPV(ST(0),n_a);
1782         bool    RETVAL;
1783
1784         RETVAL = change_drive(d);
1785         ST(0) = boolSV(RETVAL);
1786         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1787     }
1788     XSRETURN(1);
1789 }
1790
1791 XS(XS_Cwd_sys_is_absolute)
1792 {
1793     dXSARGS;
1794     if (items != 1)
1795         Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
1796     {
1797         STRLEN n_a;
1798         char *  path = (char *)SvPV(ST(0),n_a);
1799         bool    RETVAL;
1800
1801         RETVAL = sys_is_absolute(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_sys_is_rooted)
1809 {
1810     dXSARGS;
1811     if (items != 1)
1812         Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
1813     {
1814         STRLEN n_a;
1815         char *  path = (char *)SvPV(ST(0),n_a);
1816         bool    RETVAL;
1817
1818         RETVAL = sys_is_rooted(path);
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_relative)
1826 {
1827     dXSARGS;
1828     if (items != 1)
1829         Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
1830     {
1831         STRLEN n_a;
1832         char *  path = (char *)SvPV(ST(0),n_a);
1833         bool    RETVAL;
1834
1835         RETVAL = sys_is_relative(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_cwd)
1843 {
1844     dXSARGS;
1845     if (items != 0)
1846         Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
1847     {
1848         char p[MAXPATHLEN];
1849         char *  RETVAL;
1850         RETVAL = _getcwd2(p, MAXPATHLEN);
1851         ST(0) = sv_newmortal();
1852         sv_setpv((SV*)ST(0), RETVAL);
1853     }
1854     XSRETURN(1);
1855 }
1856
1857 XS(XS_Cwd_sys_abspath)
1858 {
1859     dXSARGS;
1860     if (items < 1 || items > 2)
1861         Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
1862     {
1863         STRLEN n_a;
1864         char *  path = (char *)SvPV(ST(0),n_a);
1865         char *  dir;
1866         char p[MAXPATHLEN];
1867         char *  RETVAL;
1868
1869         if (items < 2)
1870             dir = NULL;
1871         else {
1872             dir = (char *)SvPV(ST(1),n_a);
1873         }
1874         if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1875             path += 2;
1876         }
1877         if (dir == NULL) {
1878             if (_abspath(p, path, MAXPATHLEN) == 0) {
1879                 RETVAL = p;
1880             } else {
1881                 RETVAL = NULL;
1882             }
1883         } else {
1884             /* Absolute with drive: */
1885             if ( sys_is_absolute(path) ) {
1886                 if (_abspath(p, path, MAXPATHLEN) == 0) {
1887                     RETVAL = p;
1888                 } else {
1889                     RETVAL = NULL;
1890                 }
1891             } else if (path[0] == '/' || path[0] == '\\') {
1892                 /* Rooted, but maybe on different drive. */
1893                 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1894                     char p1[MAXPATHLEN];
1895
1896                     /* Need to prepend the drive. */
1897                     p1[0] = dir[0];
1898                     p1[1] = dir[1];
1899                     Copy(path, p1 + 2, strlen(path) + 1, char);
1900                     RETVAL = p;
1901                     if (_abspath(p, p1, MAXPATHLEN) == 0) {
1902                         RETVAL = p;
1903                     } else {
1904                         RETVAL = NULL;
1905                     }
1906                 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1907                     RETVAL = p;
1908                 } else {
1909                     RETVAL = NULL;
1910                 }
1911             } else {
1912                 /* Either path is relative, or starts with a drive letter. */
1913                 /* If the path starts with a drive letter, then dir is
1914                    relevant only if
1915                    a/b) it is absolute/x:relative on the same drive.
1916                    c)   path is on current drive, and dir is rooted
1917                    In all the cases it is safe to drop the drive part
1918                    of the path. */
1919                 if ( !sys_is_relative(path) ) {
1920                     int is_drived;
1921
1922                     if ( ( ( sys_is_absolute(dir)
1923                              || (isALPHA(dir[0]) && dir[1] == ':'
1924                                  && strnicmp(dir, path,1) == 0))
1925                            && strnicmp(dir, path,1) == 0)
1926                          || ( !(isALPHA(dir[0]) && dir[1] == ':')
1927                               && toupper(path[0]) == current_drive())) {
1928                         path += 2;
1929                     } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1930                         RETVAL = p; goto done;
1931                     } else {
1932                         RETVAL = NULL; goto done;
1933                     }
1934                 }
1935                 {
1936                     /* Need to prepend the absolute path of dir. */
1937                     char p1[MAXPATHLEN];
1938
1939                     if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1940                         int l = strlen(p1);
1941
1942                         if (p1[ l - 1 ] != '/') {
1943                             p1[ l ] = '/';
1944                             l++;
1945                         }
1946                         Copy(path, p1 + l, strlen(path) + 1, char);
1947                         if (_abspath(p, p1, MAXPATHLEN) == 0) {
1948                             RETVAL = p;
1949                         } else {
1950                             RETVAL = NULL;
1951                         }
1952                     } else {
1953                         RETVAL = NULL;
1954                     }
1955                 }
1956               done:
1957             }
1958         }
1959         ST(0) = sv_newmortal();
1960         sv_setpv((SV*)ST(0), RETVAL);
1961     }
1962     XSRETURN(1);
1963 }
1964 typedef APIRET (*PELP)(PSZ path, ULONG type);
1965
1966 APIRET
1967 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1968 {
1969     loadByOrd("doscalls",ord);          /* Guarantied to load or die! */
1970     return (*(PELP)ExtFCN[ord])(path, type);
1971 }
1972
1973 #define extLibpath(type)                                                \
1974     (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH   \
1975                                                  : BEGIN_LIBPATH)))     \
1976      ? NULL : to )
1977
1978 #define extLibpath_set(p,type)                                  \
1979     (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH   \
1980                                                  : BEGIN_LIBPATH))))
1981
1982 XS(XS_Cwd_extLibpath)
1983 {
1984     dXSARGS;
1985     if (items < 0 || items > 1)
1986         Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
1987     {
1988         bool    type;
1989         char    to[1024];
1990         U32     rc;
1991         char *  RETVAL;
1992
1993         if (items < 1)
1994             type = 0;
1995         else {
1996             type = (int)SvIV(ST(0));
1997         }
1998
1999         RETVAL = extLibpath(type);
2000         ST(0) = sv_newmortal();
2001         sv_setpv((SV*)ST(0), RETVAL);
2002     }
2003     XSRETURN(1);
2004 }
2005
2006 XS(XS_Cwd_extLibpath_set)
2007 {
2008     dXSARGS;
2009     if (items < 1 || items > 2)
2010         Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
2011     {
2012         STRLEN n_a;
2013         char *  s = (char *)SvPV(ST(0),n_a);
2014         bool    type;
2015         U32     rc;
2016         bool    RETVAL;
2017
2018         if (items < 2)
2019             type = 0;
2020         else {
2021             type = (int)SvIV(ST(1));
2022         }
2023
2024         RETVAL = extLibpath_set(s, type);
2025         ST(0) = boolSV(RETVAL);
2026         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2027     }
2028     XSRETURN(1);
2029 }
2030
2031 int
2032 Xs_OS2_init(pTHX)
2033 {
2034     char *file = __FILE__;
2035     {
2036         GV *gv;
2037
2038         if (_emx_env & 0x200) { /* OS/2 */
2039             newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2040             newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2041             newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2042         }
2043         newXS("OS2::Error", XS_OS2_Error, file);
2044         newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2045         newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2046         newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2047         newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2048         newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2049         newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2050         newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
2051         newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2052         newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2053         newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2054         newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2055         newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2056         newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2057         newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2058         newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2059         newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
2060         gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2061         GvMULTI_on(gv);
2062 #ifdef PERL_IS_AOUT
2063         sv_setiv(GvSV(gv), 1);
2064 #endif
2065         gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2066         GvMULTI_on(gv);
2067         sv_setiv(GvSV(gv), _emx_rev);
2068         sv_setpv(GvSV(gv), _emx_vprt);
2069         SvIOK_on(GvSV(gv));
2070         gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2071         GvMULTI_on(gv);
2072         sv_setiv(GvSV(gv), _emx_env);
2073         gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2074         GvMULTI_on(gv);
2075         sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
2076     }
2077 }
2078
2079 OS2_Perl_data_t OS2_Perl_data;
2080
2081 void
2082 Perl_OS2_init(char **env)
2083 {
2084     char *shell;
2085
2086     MALLOC_INIT;
2087     settmppath();
2088     OS2_Perl_data.xs_init = &Xs_OS2_init;
2089     _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
2090     if (environ == NULL && env) {
2091         environ = env;
2092     }
2093     if ( (shell = getenv("PERL_SH_DRIVE")) ) {
2094         New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2095         strcpy(PL_sh_path, SH_PATH);
2096         PL_sh_path[0] = shell[0];
2097     } else if ( (shell = getenv("PERL_SH_DIR")) ) {
2098         int l = strlen(shell), i;
2099         if (shell[l-1] == '/' || shell[l-1] == '\\') {
2100             l--;
2101         }
2102         New(1304, PL_sh_path, l + 8, char);
2103         strncpy(PL_sh_path, shell, l);
2104         strcpy(PL_sh_path + l, "/sh.exe");
2105         for (i = 0; i < l; i++) {
2106             if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2107         }
2108     }
2109     MUTEX_INIT(&start_thread_mutex);
2110     os2_mytype = my_type();             /* Do it before morphing.  Needed? */
2111 }
2112
2113 #undef tmpnam
2114 #undef tmpfile
2115
2116 char *
2117 my_tmpnam (char *str)
2118 {
2119     char *p = getenv("TMP"), *tpath;
2120     int len;
2121
2122     if (!p) p = getenv("TEMP");
2123     tpath = tempnam(p, "pltmp");
2124     if (str && tpath) {
2125         strcpy(str, tpath);
2126         return str;
2127     }
2128     return tpath;
2129 }
2130
2131 FILE *
2132 my_tmpfile ()
2133 {
2134     struct stat s;
2135
2136     stat(".", &s);
2137     if (s.st_mode & S_IWOTH) {
2138         return tmpfile();
2139     }
2140     return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2141                                              grants TMP. */
2142 }
2143
2144 #undef flock
2145
2146 /* This code was contributed by Rocco Caputo. */
2147 int
2148 my_flock(int handle, int o)
2149 {
2150   FILELOCK      rNull, rFull;
2151   ULONG         timeout, handle_type, flag_word;
2152   APIRET        rc;
2153   int           blocking, shared;
2154   static int    use_my = -1;
2155
2156   if (use_my == -1) {
2157     char *s = getenv("USE_PERL_FLOCK");
2158     if (s)
2159         use_my = atoi(s);
2160     else
2161         use_my = 1;
2162   }
2163   if (!(_emx_env & 0x200) || !use_my)
2164     return flock(handle, o);    /* Delegate to EMX. */
2165
2166                                         // is this a file?
2167   if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2168       (handle_type & 0xFF))
2169   {
2170     errno = EBADF;
2171     return -1;
2172   }
2173                                         // set lock/unlock ranges
2174   rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2175   rFull.lRange = 0x7FFFFFFF;
2176                                         // set timeout for blocking
2177   timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2178                                         // shared or exclusive?
2179   shared = (o & LOCK_SH) ? 1 : 0;
2180                                         // do not block the unlock
2181   if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2182     rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2183     switch (rc) {
2184       case 0:
2185         errno = 0;
2186         return 0;
2187       case ERROR_INVALID_HANDLE:
2188         errno = EBADF;
2189         return -1;
2190       case ERROR_SHARING_BUFFER_EXCEEDED:
2191         errno = ENOLCK;
2192         return -1;
2193       case ERROR_LOCK_VIOLATION:
2194         break;                          // not an error
2195       case ERROR_INVALID_PARAMETER:
2196       case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2197       case ERROR_READ_LOCKS_NOT_SUPPORTED:
2198         errno = EINVAL;
2199         return -1;
2200       case ERROR_INTERRUPT:
2201         errno = EINTR;
2202         return -1;
2203       default:
2204         errno = EINVAL;
2205         return -1;
2206     }
2207   }
2208                                         // lock may block
2209   if (o & (LOCK_SH | LOCK_EX)) {
2210                                         // for blocking operations
2211     for (;;) {
2212       rc =
2213         DosSetFileLocks(
2214                 handle,
2215                 &rNull,
2216                 &rFull,
2217                 timeout,
2218                 shared
2219         );
2220       switch (rc) {
2221         case 0:
2222           errno = 0;
2223           return 0;
2224         case ERROR_INVALID_HANDLE:
2225           errno = EBADF;
2226           return -1;
2227         case ERROR_SHARING_BUFFER_EXCEEDED:
2228           errno = ENOLCK;
2229           return -1;
2230         case ERROR_LOCK_VIOLATION:
2231           if (!blocking) {
2232             errno = EWOULDBLOCK;
2233             return -1;
2234           }
2235           break;
2236         case ERROR_INVALID_PARAMETER:
2237         case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2238         case ERROR_READ_LOCKS_NOT_SUPPORTED:
2239           errno = EINVAL;
2240           return -1;
2241         case ERROR_INTERRUPT:
2242           errno = EINTR;
2243           return -1;
2244         default:
2245           errno = EINVAL;
2246           return -1;
2247       }
2248                                         // give away timeslice
2249       DosSleep(1);
2250     }
2251   }
2252
2253   errno = 0;
2254   return 0;
2255 }