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