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