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