os2/os2.c

   1 #define INCL_DOS
   2 #define INCL_NOPM
   3 #define INCL_DOSFILEMGR
   4 #define INCL_DOSMEMMGR
   5 #define INCL_DOSERRORS
   6 #include <os2.h>
   7
   8 /*
   9  * Various Unix compatibility functions for OS/2
  10  */
  11
  12 #include <stdio.h>
  13 #include <errno.h>
  14 #include <limits.h>
  15 #include <process.h>
  16 #include <fcntl.h>
  17
  18 #include "EXTERN.h"
  19 #include "perl.h"
  20
  21 #ifdef USE_THREADS
  22
  23 typedef void (*emx_startroutine)(void *);
  24 typedef void* (*pthreads_startroutine)(void *);
  25
  26 enum pthreads_state {
  27     pthreads_st_none = 0,
  28     pthreads_st_run,
  29     pthreads_st_exited,
  30     pthreads_st_detached,
  31     pthreads_st_waited,
  32 };
  33 const char *pthreads_states[] = {
  34     "uninit",
  35     "running",
  36     "exited",
  37     "detached",
  38     "waited for",
  39 };
  40
  41 typedef struct {
  42     void *status;
  43     perl_cond cond;
  44     enum pthreads_state state;
  45 } thread_join_t;
  46
  47 thread_join_t *thread_join_data;
  48 int thread_join_count;
  49 perl_mutex start_thread_mutex;
  50
  51 int
  52 pthread_join(perl_os_thread tid, void **status)
  53 {
  54     MUTEX_LOCK(&start_thread_mutex);
  55     switch (thread_join_data[tid].state) {
  56     case pthreads_st_exited:
  57         thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
  58         MUTEX_UNLOCK(&start_thread_mutex);
  59         *status = thread_join_data[tid].status;
  60         break;
  61     case pthreads_st_waited:
  62         MUTEX_UNLOCK(&start_thread_mutex);
  63         croak("join with a thread with a waiter");
  64         break;
  65     case pthreads_st_run:
  66         thread_join_data[tid].state = pthreads_st_waited;
  67         COND_INIT(&thread_join_data[tid].cond);
  68         MUTEX_UNLOCK(&start_thread_mutex);
  69         COND_WAIT(&thread_join_data[tid].cond, NULL);
  70         COND_DESTROY(&thread_join_data[tid].cond);
  71         thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
  72         *status = thread_join_data[tid].status;
  73         break;
  74     default:
  75         MUTEX_UNLOCK(&start_thread_mutex);
  76         croak("join: unknown thread state: '%s'",
  77               pthreads_states[thread_join_data[tid].state]);
  78         break;
  79     }
  80     return 0;
  81 }
  82
  83 void
  84 pthread_startit(void *arg)
  85 {
  86     /* Thread is already started, we need to transfer control only */
  87     pthreads_startroutine start_routine = *((pthreads_startroutine*)arg);
  88     int tid = pthread_self();
  89     void *retval;
  90
  91     arg = ((void**)arg)[1];
  92     if (tid >= thread_join_count) {
  93         int oc = thread_join_count;
  94
  95         thread_join_count = tid + 5 + tid/5;
  96         if (thread_join_data) {
  97             Renew(thread_join_data, thread_join_count, thread_join_t);
  98             Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
  99         } else {
 100             Newz(1323, thread_join_data, thread_join_count, thread_join_t);
 101         }
 102     }
 103     if (thread_join_data[tid].state != pthreads_st_none)
 104         croak("attempt to reuse thread id %i", tid);
 105     thread_join_data[tid].state = pthreads_st_run;
 106     /* Now that we copied/updated the guys, we may release the caller... */
 107     MUTEX_UNLOCK(&start_thread_mutex);
 108     thread_join_data[tid].status = (*start_routine)(arg);
 109     switch (thread_join_data[tid].state) {
 110     case pthreads_st_waited:
 111         COND_SIGNAL(&thread_join_data[tid].cond);
 112         break;
 113     default:
 114         thread_join_data[tid].state = pthreads_st_exited;
 115         break;
 116     }
 117 }
 118
 119 int
 120 pthread_create(perl_os_thread *tid, const pthread_attr_t *attr,
 121                void *(*start_routine)(void*), void *arg)
 122 {
 123     void *args[2];
 124
 125     args[0] = (void*)start_routine;
 126     args[1] = arg;
 127
 128     MUTEX_LOCK(&start_thread_mutex);
 129     *tid = _beginthread(pthread_startit, /*stack*/ NULL,
 130                         /*stacksize*/ 10*1024*1024, (void*)args);
 131     MUTEX_LOCK(&start_thread_mutex);
 132     MUTEX_UNLOCK(&start_thread_mutex);
 133     return *tid ? 0 : EINVAL;
 134 }
 135
 136 int
 137 pthread_detach(perl_os_thread tid)
 138 {
 139     MUTEX_LOCK(&start_thread_mutex);
 140     switch (thread_join_data[tid].state) {
 141     case pthreads_st_waited:
 142         MUTEX_UNLOCK(&start_thread_mutex);
 143         croak("detach on a thread with a waiter");
 144         break;
 145     case pthreads_st_run:
 146         thread_join_data[tid].state = pthreads_st_detached;
 147         MUTEX_UNLOCK(&start_thread_mutex);
 148         break;
 149     default:
 150         MUTEX_UNLOCK(&start_thread_mutex);
 151         croak("detach: unknown thread state: '%s'",
 152               pthreads_states[thread_join_data[tid].state]);
 153         break;
 154     }
 155     return 0;
 156 }
 157
 158 /* This is a very bastardized version: */
 159 int
 160 os2_cond_wait(perl_cond *c, perl_mutex *m)
 161 {
 162     int rc;
 163     if ((rc = DosResetEventSem(*c,&na)) && (rc != ERROR_ALREADY_RESET))
 164         croak("panic: COND_WAIT-reset: rc=%i", rc);
 165     if (m) MUTEX_UNLOCK(m);
 166     if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
 167         && (rc != ERROR_INTERRUPT))
 168         croak("panic: COND_WAIT: rc=%i", rc);
 169     if (rc == ERROR_INTERRUPT)
 170         errno = EINTR;
 171     if (m) MUTEX_LOCK(m);
 172 }
 173 #endif
 174
 175 /*****************************************************************************/
 176 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
 177 static PFN ExtFCN[2];                   /* Labeled by ord below. */
 178 static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
 179 #define ORD_QUERY_ELP   0
 180 #define ORD_SET_ELP     1
 181
 182 APIRET
 183 loadByOrd(ULONG ord)
 184 {
 185     if (ExtFCN[ord] == NULL) {
 186         static HMODULE hdosc = 0;
 187         BYTE buf[20];
 188         PFN fcn;
 189         APIRET rc;
 190
 191         if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf,
 192                                                   "doscalls", &hdosc)))
 193             || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
 194             die("This version of OS/2 does not support doscalls.%i",
 195                 loadOrd[ord]);
 196         ExtFCN[ord] = fcn;
 197     }
 198     if ((long)ExtFCN[ord] == -1) die("panic queryaddr");
 199 }
 200
 201 /* priorities */
 202 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
 203                                                self inverse. */
 204 #define QSS_INI_BUFFER 1024
 205
 206 PQTOPLEVEL
 207 get_sysinfo(ULONG pid, ULONG flags)
 208 {
 209     char *pbuffer;
 210     ULONG rc, buf_len = QSS_INI_BUFFER;
 211
 212     New(1322, pbuffer, buf_len, char);
 213     /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
 214     rc = QuerySysState(flags, pid, pbuffer, buf_len);
 215     while (rc == ERROR_BUFFER_OVERFLOW) {
 216         Renew(pbuffer, buf_len *= 2, char);
 217         rc = QuerySysState(flags, pid, pbuffer, buf_len);
 218     }
 219     if (rc) {
 220         FillOSError(rc);
 221         Safefree(pbuffer);
 222         return 0;
 223     }
 224     return (PQTOPLEVEL)pbuffer;
 225 }
 226
 227 #define PRIO_ERR 0x1111
 228
 229 static ULONG
 230 sys_prio(pid)
 231 {
 232   ULONG prio;
 233   PQTOPLEVEL psi;
 234
 235   psi = get_sysinfo(pid, QSS_PROCESS);
 236   if (!psi) {
 237       return PRIO_ERR;
 238   }
 239   if (pid != psi->procdata->pid) {
 240       Safefree(psi);
 241       croak("panic: wrong pid in sysinfo");
 242   }
 243   prio = psi->procdata->threads->priority;
 244   Safefree(psi);
 245   return prio;
 246 }
 247
 248 int
 249 setpriority(int which, int pid, int val)
 250 {
 251   ULONG rc, prio;
 252   PQTOPLEVEL psi;
 253
 254   prio = sys_prio(pid);
 255
 256   if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
 257   if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
 258       /* Do not change class. */
 259       return CheckOSError(DosSetPriority((pid < 0)
 260                                          ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
 261                                          0,
 262                                          (32 - val) % 32 - (prio & 0xFF),
 263                                          abs(pid)))
 264       ? -1 : 0;
 265   } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
 266       /* Documentation claims one can change both class and basevalue,
 267        * but I find it wrong. */
 268       /* Change class, but since delta == 0 denotes absolute 0, correct. */
 269       if (CheckOSError(DosSetPriority((pid < 0)
 270                                       ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
 271                                       priors[(32 - val) >> 5] + 1,
 272                                       0,
 273                                       abs(pid))))
 274           return -1;
 275       if ( ((32 - val) % 32) == 0 ) return 0;
 276       return CheckOSError(DosSetPriority((pid < 0)
 277                                          ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
 278                                          0,
 279                                          (32 - val) % 32,
 280                                          abs(pid)))
 281           ? -1 : 0;
 282   }
 283 /*   else return CheckOSError(DosSetPriority((pid < 0)  */
 284 /*                                        ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
 285 /*                                        priors[(32 - val) >> 5] + 1,  */
 286 /*                                        (32 - val) % 32 - (prio & 0xFF),  */
 287 /*                                        abs(pid))) */
 288 /*       ? -1 : 0; */
 289 }
 290
 291 int
 292 getpriority(int which /* ignored */, int pid)
 293 {
 294   TIB *tib;
 295   PIB *pib;
 296   ULONG rc, ret;
 297
 298   if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
 299   /* DosGetInfoBlocks has old priority! */
 300 /*   if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
 301 /*   if (pid != pib->pib_ulpid) { */
 302   ret = sys_prio(pid);
 303   if (ret == PRIO_ERR) {
 304       return -1;
 305   }
 306 /*   } else */
 307 /*       ret = tib->tib_ptib2->tib2_ulpri; */
 308   return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
 309 }
 310
 311 /*****************************************************************************/
 312 /* spawn */
 313
 314 /* There is no big sense to make it thread-specific, since signals
 315    are delivered to thread 1 only.  XXXX Maybe make it into an array? */
 316 static int spawn_pid;
 317 static int spawn_killed;
 318
 319 static Signal_t
 320 spawn_sighandler(int sig)
 321 {
 322     /* Some programs do not arrange for the keyboard signals to be
 323        delivered to them.  We need to deliver the signal manually. */
 324     /* We may get a signal only if
 325        a) kid does not receive keyboard signal: deliver it;
 326        b) kid already died, and we get a signal.  We may only hope
 327           that the pid number was not reused.
 328      */
 329
 330     if (spawn_killed)
 331         sig = SIGKILL;                  /* Try harder. */
 332     kill(spawn_pid, sig);
 333     spawn_killed = 1;
 334 }
 335
 336 static int
 337 result(int flag, int pid)
 338 {
 339         int r, status;
 340         Signal_t (*ihand)();     /* place to save signal during system() */
 341         Signal_t (*qhand)();     /* place to save signal during system() */
 342 #ifndef __EMX__
 343         RESULTCODES res;
 344         int rpid;
 345 #endif
 346
 347         if (pid < 0 || flag != 0)
 348                 return pid;
 349
 350 #ifdef __EMX__
 351         spawn_pid = pid;
 352         spawn_killed = 0;
 353         ihand = rsignal(SIGINT, &spawn_sighandler);
 354         qhand = rsignal(SIGQUIT, &spawn_sighandler);
 355         do {
 356             r = wait4pid(pid, &status, 0);
 357         } while (r == -1 && errno == EINTR);
 358         rsignal(SIGINT, ihand);
 359         rsignal(SIGQUIT, qhand);
 360
 361         statusvalue = (U16)status;
 362         if (r < 0)
 363                 return -1;
 364         return status & 0xFFFF;
 365 #else
 366         ihand = rsignal(SIGINT, SIG_IGN);
 367         r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
 368         rsignal(SIGINT, ihand);
 369         statusvalue = res.codeResult << 8 | res.codeTerminate;
 370         if (r)
 371                 return -1;
 372         return statusvalue;
 373 #endif
 374 }
 375
 376 #define EXECF_SPAWN 0
 377 #define EXECF_EXEC 1
 378 #define EXECF_TRUEEXEC 2
 379 #define EXECF_SPAWN_NOWAIT 3
 380
 381 /* Spawn/exec a program, revert to shell if needed. */
 382 /* global Argv[] contains arguments. */
 383
 384 int
 385 do_spawn_ve(really, flag, execf, inicmd)
 386 SV *really;
 387 U32 flag;
 388 U32 execf;
 389 char *inicmd;
 390 {
 391     dTHR;
 392         int trueflag = flag;
 393         int rc, pass = 1, err;
 394         char *tmps;
 395         char buf[256], *s = 0;
 396         char *args[4];
 397         static char * fargs[4]
 398             = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
 399         char **argsp = fargs;
 400         char nargs = 4;
 401
 402         if (flag == P_WAIT)
 403                 flag = P_NOWAIT;
 404
 405       retry:
 406         if (strEQ(Argv[0],"/bin/sh"))
 407             Argv[0] = sh_path;
 408
 409         if (Argv[0][0] != '/' && Argv[0][0] != '\\'
 410             && !(Argv[0][0] && Argv[0][1] == ':'
 411                  && (Argv[0][2] == '/' || Argv[0][2] != '\\'))
 412             ) /* will spawnvp use PATH? */
 413             TAINT_ENV();        /* testing IFS here is overkill, probably */
 414         /* We should check PERL_SH* and PERLLIB_* as well? */
 415         if (!really || !*(tmps = SvPV(really, na)))
 416             tmps = Argv[0];
 417 #if 0
 418         rc = result(trueflag, spawnvp(flag,tmps,Argv));
 419 #else
 420         if (execf == EXECF_TRUEEXEC)
 421             rc = execvp(tmps,Argv);
 422         else if (execf == EXECF_EXEC)
 423             rc = spawnvp(trueflag | P_OVERLAY,tmps,Argv);
 424         else if (execf == EXECF_SPAWN_NOWAIT)
 425             rc = spawnvp(trueflag | P_NOWAIT,tmps,Argv);
 426         else                            /* EXECF_SPAWN */
 427             rc = result(trueflag,
 428                         spawnvp(trueflag | P_NOWAIT,tmps,Argv));
 429 #endif
 430         if (rc < 0 && pass == 1
 431             && (tmps == Argv[0])) { /* Cannot transfer `really' via shell. */
 432             err = errno;
 433             if (err == ENOENT || err == ENOEXEC) {
 434                 /* No such file, or is a script. */
 435                 /* Try adding script extensions to the file name, and
 436                    search on PATH. */
 437                 char *scr = find_script(Argv[0], TRUE, NULL, 0);
 438
 439                 if (scr) {
 440                     FILE *file = fopen(scr, "r");
 441                     char *s = 0, *s1;
 442
 443                     Argv[0] = scr;
 444                     if (!file)
 445                         goto panic_file;
 446                     if (!fgets(buf, sizeof buf, file)) {
 447                         fclose(file);
 448                         goto panic_file;
 449                     }
 450                     if (fclose(file) != 0) { /* Failure */
 451                       panic_file:
 452                         warn("Error reading \"%s\": %s",
 453                              scr, Strerror(errno));
 454                         buf[0] = 0;     /* Not #! */
 455                         goto doshell_args;
 456                     }
 457                     if (buf[0] == '#') {
 458                         if (buf[1] == '!')
 459                             s = buf + 2;
 460                     } else if (buf[0] == 'e') {
 461                         if (strnEQ(buf, "extproc", 7)
 462                             && isSPACE(buf[7]))
 463                             s = buf + 8;
 464                     } else if (buf[0] == 'E') {
 465                         if (strnEQ(buf, "EXTPROC", 7)
 466                             && isSPACE(buf[7]))
 467                             s = buf + 8;
 468                     }
 469                     if (!s) {
 470                         buf[0] = 0;     /* Not #! */
 471                         goto doshell_args;
 472                     }
 473
 474                     s1 = s;
 475                     nargs = 0;
 476                     argsp = args;
 477                     while (1) {
 478                         /* Do better than pdksh: allow a few args,
 479                            strip trailing whitespace.  */
 480                         while (isSPACE(*s))
 481                             s++;
 482                         if (*s == 0)
 483                             break;
 484                         if (nargs == 4) {
 485                             nargs = -1;
 486                             break;
 487                         }
 488                         args[nargs++] = s;
 489                         while (*s && !isSPACE(*s))
 490                             s++;
 491                         if (*s == 0)
 492                             break;
 493                         *s++ = 0;
 494                     }
 495                     if (nargs == -1) {
 496                         warn("Too many args on %.*s line of \"%s\"",
 497                              s1 - buf, buf, scr);
 498                         nargs = 4;
 499                         argsp = fargs;
 500                     }
 501                   doshell_args:
 502                     {
 503                         char **a = Argv;
 504                         char *exec_args[2];
 505
 506                         if (!buf[0] && file) { /* File without magic */
 507                             /* In fact we tried all what pdksh would
 508                                try.  There is no point in calling
 509                                pdksh, we may just emulate its logic. */
 510                             char *shell = getenv("EXECSHELL");
 511                             char *shell_opt = NULL;
 512
 513                             if (!shell) {
 514                                 char *s;
 515
 516                                 shell_opt = "/c";
 517                                 shell = getenv("OS2_SHELL");
 518                                 if (inicmd) { /* No spaces at start! */
 519                                     s = inicmd;
 520                                     while (*s && !isSPACE(*s)) {
 521                                         if (*s++ = '/') {
 522                                             inicmd = NULL; /* Cannot use */
 523                                             break;
 524                                         }
 525                                     }
 526                                 }
 527                                 if (!inicmd) {
 528                                     s = Argv[0];
 529                                     while (*s) {
 530                                         /* Dosish shells will choke on slashes
 531                                            in paths, fortunately, this is
 532                                            important for zeroth arg only. */
 533                                         if (*s == '/')
 534                                             *s = '\\';
 535                                         s++;
 536                                     }
 537                                 }
 538                             }
 539                             /* If EXECSHELL is set, we do not set */
 540
 541                             if (!shell)
 542                                 shell = ((_emx_env & 0x200)
 543                                          ? "c:/os2/cmd.exe"
 544                                          : "c:/command.com");
 545                             nargs = shell_opt ? 2 : 1;  /* shell file args */
 546                             exec_args[0] = shell;
 547                             exec_args[1] = shell_opt;
 548                             argsp = exec_args;
 549                             if (nargs == 2 && inicmd) {
 550                                 /* Use the original cmd line */
 551                                 /* XXXX This is good only until we refuse
 552                                         quoted arguments... */
 553                                 Argv[0] = inicmd;
 554                                 Argv[1] = Nullch;
 555                             }
 556                         } else if (!buf[0] && inicmd) { /* No file */
 557                             /* Start with the original cmdline. */
 558                             /* XXXX This is good only until we refuse
 559                                     quoted arguments... */
 560
 561                             Argv[0] = inicmd;
 562                             Argv[1] = Nullch;
 563                             nargs = 2;  /* shell -c */
 564                         }
 565
 566                         while (a[1])            /* Get to the end */
 567                             a++;
 568                         a++;                    /* Copy finil NULL too */
 569                         while (a >= Argv) {
 570                             *(a + nargs) = *a;  /* Argv was preallocated to be
 571                                                    long enough. */
 572                             a--;
 573                         }
 574                         while (nargs-- >= 0)
 575                             Argv[nargs] = argsp[nargs];
 576                         /* Enable pathless exec if #! (as pdksh). */
 577                         pass = (buf[0] == '#' ? 2 : 3);
 578                         goto retry;
 579                     }
 580                 }
 581                 /* Not found: restore errno */
 582                 errno = err;
 583             }
 584         } else if (rc < 0 && pass == 2 && err == ENOENT) { /* File not found */
 585             char *no_dir = strrchr(Argv[0], '/');
 586
 587             /* Do as pdksh port does: if not found with /, try without
 588                path. */
 589             if (no_dir) {
 590                 Argv[0] = no_dir + 1;
 591                 pass++;
 592                 goto retry;
 593             }
 594         }
 595         if (rc < 0 && dowarn)
 596             warn("Can't %s \"%s\": %s\n",
 597                  ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
 598                   ? "spawn" : "exec"),
 599                  Argv[0], Strerror(err));
 600         if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
 601             && ((trueflag & 0xFF) == P_WAIT))
 602             rc = 255 << 8; /* Emulate the fork(). */
 603
 604     return rc;
 605 }
 606
 607 /* Array spawn.  */
 608 int
 609 do_aspawn(really,mark,sp)
 610 SV *really;
 611 register SV **mark;
 612 register SV **sp;
 613 {
 614     dTHR;
 615     register char **a;
 616     char *tmps = NULL;
 617     int rc;
 618     int flag = P_WAIT, trueflag, err, secondtry = 0;
 619
 620     if (sp > mark) {
 621         New(1301,Argv, sp - mark + 3, char*);
 622         a = Argv;
 623
 624         if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
 625                 ++mark;
 626                 flag = SvIVx(*mark);
 627         }
 628
 629         while (++mark <= sp) {
 630             if (*mark)
 631                 *a++ = SvPVx(*mark, na);
 632             else
 633                 *a++ = "";
 634         }
 635         *a = Nullch;
 636
 637         rc = do_spawn_ve(really, flag, EXECF_SPAWN, NULL);
 638     } else
 639         rc = -1;
 640     do_execfree();
 641     return rc;
 642 }
 643
 644 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
 645 int
 646 do_spawn2(cmd, execf)
 647 char *cmd;
 648 int execf;
 649 {
 650     register char **a;
 651     register char *s;
 652     char flags[10];
 653     char *shell, *copt, *news = NULL;
 654     int rc, err, seenspace = 0;
 655     char fullcmd[MAXNAMLEN + 1];
 656
 657 #ifdef TRYSHELL
 658     if ((shell = getenv("EMXSHELL")) != NULL)
 659         copt = "-c";
 660     else if ((shell = getenv("SHELL")) != NULL)
 661         copt = "-c";
 662     else if ((shell = getenv("COMSPEC")) != NULL)
 663         copt = "/C";
 664     else
 665         shell = "cmd.exe";
 666 #else
 667     /* Consensus on perl5-porters is that it is _very_ important to
 668        have a shell which will not change between computers with the
 669        same architecture, to avoid "action on a distance".
 670        And to have simple build, this shell should be sh. */
 671     shell = sh_path;
 672     copt = "-c";
 673 #endif
 674
 675     while (*cmd && isSPACE(*cmd))
 676         cmd++;
 677
 678     if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
 679         STRLEN l = strlen(sh_path);
 680
 681         New(1302, news, strlen(cmd) - 7 + l + 1, char);
 682         strcpy(news, sh_path);
 683         strcpy(news + l, cmd + 7);
 684         cmd = news;
 685     }
 686
 687     /* save an extra exec if possible */
 688     /* see if there are shell metacharacters in it */
 689
 690     if (*cmd == '.' && isSPACE(cmd[1]))
 691         goto doshell;
 692
 693     if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
 694         goto doshell;
 695
 696     for (s = cmd; *s && isALPHA(*s); s++) ;     /* catch VAR=val gizmo */
 697     if (*s == '=')
 698         goto doshell;
 699
 700     for (s = cmd; *s; s++) {
 701         if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
 702             if (*s == '\n' && s[1] == '\0') {
 703                 *s = '\0';
 704                 break;
 705             } else if (*s == '\\' && !seenspace) {
 706                 continue;               /* Allow backslashes in names */
 707             }
 708             /* We do not convert this to do_spawn_ve since shell
 709                should be smart enough to start itself gloriously. */
 710           doshell:
 711             if (execf == EXECF_TRUEEXEC)
 712                 rc = execl(shell,shell,copt,cmd,(char*)0);
 713             else if (execf == EXECF_EXEC)
 714                 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
 715             else if (execf == EXECF_SPAWN_NOWAIT)
 716                 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
 717             else {
 718                 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
 719                 rc = result(P_WAIT,
 720                             spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
 721                 if (rc < 0 && dowarn)
 722                     warn("Can't %s \"%s\": %s",
 723                          (execf == EXECF_SPAWN ? "spawn" : "exec"),
 724                          shell, Strerror(errno));
 725                 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
 726             }
 727             if (news)
 728                 Safefree(news);
 729             return rc;
 730         } else if (*s == ' ' || *s == '\t') {
 731             seenspace = 1;
 732         }
 733     }
 734
 735     /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
 736     New(1303,Argv, (s - cmd + 11) / 2, char*);
 737     Cmd = savepvn(cmd, s-cmd);
 738     a = Argv;
 739     for (s = Cmd; *s;) {
 740         while (*s && isSPACE(*s)) s++;
 741         if (*s)
 742             *(a++) = s;
 743         while (*s && !isSPACE(*s)) s++;
 744         if (*s)
 745             *s++ = '\0';
 746     }
 747     *a = Nullch;
 748     if (Argv[0])
 749         rc = do_spawn_ve(NULL, 0, execf, cmd);
 750     else
 751         rc = -1;
 752     if (news)
 753         Safefree(news);
 754     do_execfree();
 755     return rc;
 756 }
 757
 758 int
 759 do_spawn(cmd)
 760 char *cmd;
 761 {
 762     return do_spawn2(cmd, EXECF_SPAWN);
 763 }
 764
 765 int
 766 do_spawn_nowait(cmd)
 767 char *cmd;
 768 {
 769     return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
 770 }
 771
 772 bool
 773 do_exec(cmd)
 774 char *cmd;
 775 {
 776     return do_spawn2(cmd, EXECF_EXEC);
 777 }
 778
 779 bool
 780 os2exec(cmd)
 781 char *cmd;
 782 {
 783     return do_spawn2(cmd, EXECF_TRUEEXEC);
 784 }
 785
 786 PerlIO *
 787 my_syspopen(cmd,mode)
 788 char    *cmd;
 789 char    *mode;
 790 {
 791 #ifndef USE_POPEN
 792
 793     int p[2];
 794     register I32 this, that, newfd;
 795     register I32 pid, rc;
 796     PerlIO *res;
 797     SV *sv;
 798
 799     /* `this' is what we use in the parent, `that' in the child. */
 800     this = (*mode == 'w');
 801     that = !this;
 802     if (tainting) {
 803         taint_env();
 804         taint_proper("Insecure %s%s", "EXEC");
 805     }
 806     if (pipe(p) < 0)
 807         return Nullfp;
 808     /* Now we need to spawn the child. */
 809     newfd = dup(*mode == 'r');          /* Preserve std* */
 810     if (p[that] != (*mode == 'r')) {
 811         dup2(p[that], *mode == 'r');
 812         close(p[that]);
 813     }
 814     /* Where is `this' and newfd now? */
 815     fcntl(p[this], F_SETFD, FD_CLOEXEC);
 816     fcntl(newfd, F_SETFD, FD_CLOEXEC);
 817     pid = do_spawn_nowait(cmd);
 818     if (newfd != (*mode == 'r')) {
 819         dup2(newfd, *mode == 'r');      /* Return std* back. */
 820         close(newfd);
 821     }
 822     if (p[that] == (*mode == 'r'))
 823         close(p[that]);
 824     if (pid == -1) {
 825         close(p[this]);
 826         return NULL;
 827     }
 828     if (p[that] < p[this]) {
 829         dup2(p[this], p[that]);
 830         close(p[this]);
 831         p[this] = p[that];
 832     }
 833     sv = *av_fetch(fdpid,p[this],TRUE);
 834     (void)SvUPGRADE(sv,SVt_IV);
 835     SvIVX(sv) = pid;
 836     forkprocess = pid;
 837     return PerlIO_fdopen(p[this], mode);
 838
 839 #else  /* USE_POPEN */
 840
 841     PerlIO *res;
 842     SV *sv;
 843
 844 #  ifdef TRYSHELL
 845     res = popen(cmd, mode);
 846 #  else
 847     char *shell = getenv("EMXSHELL");
 848
 849     my_setenv("EMXSHELL", sh_path);
 850     res = popen(cmd, mode);
 851     my_setenv("EMXSHELL", shell);
 852 #  endif
 853     sv = *av_fetch(fdpid, PerlIO_fileno(res), TRUE);
 854     (void)SvUPGRADE(sv,SVt_IV);
 855     SvIVX(sv) = -1;                     /* A cooky. */
 856     return res;
 857
 858 #endif /* USE_POPEN */
 859
 860 }
 861
 862 /******************************************************************/
 863
 864 #ifndef HAS_FORK
 865 int
 866 fork(void)
 867 {
 868     die(no_func, "Unsupported function fork");
 869     errno = EINVAL;
 870     return -1;
 871 }
 872 #endif
 873
 874 /*******************************************************************/
 875 /* not implemented in EMX 0.9a */
 876
 877 void *  ctermid(x)      { return 0; }
 878
 879 #ifdef MYTTYNAME /* was not in emx0.9a */
 880 void *  ttyname(x)      { return 0; }
 881 #endif
 882
 883 /******************************************************************/
 884 /* my socket forwarders - EMX lib only provides static forwarders */
 885
 886 static HMODULE htcp = 0;
 887
 888 static void *
 889 tcp0(char *name)
 890 {
 891     static BYTE buf[20];
 892     PFN fcn;
 893
 894     if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
 895     if (!htcp)
 896         DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
 897     if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
 898         return (void *) ((void * (*)(void)) fcn) ();
 899     return 0;
 900 }
 901
 902 static void
 903 tcp1(char *name, int arg)
 904 {
 905     static BYTE buf[20];
 906     PFN fcn;
 907
 908     if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
 909     if (!htcp)
 910         DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
 911     if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
 912         ((void (*)(int)) fcn) (arg);
 913 }
 914
 915 void *  gethostent()    { return tcp0("GETHOSTENT");  }
 916 void *  getnetent()     { return tcp0("GETNETENT");   }
 917 void *  getprotoent()   { return tcp0("GETPROTOENT"); }
 918 void *  getservent()    { return tcp0("GETSERVENT");  }
 919 void    sethostent(x)   { tcp1("SETHOSTENT",  x); }
 920 void    setnetent(x)    { tcp1("SETNETENT",   x); }
 921 void    setprotoent(x)  { tcp1("SETPROTOENT", x); }
 922 void    setservent(x)   { tcp1("SETSERVENT",  x); }
 923 void    endhostent()    { tcp0("ENDHOSTENT");  }
 924 void    endnetent()     { tcp0("ENDNETENT");   }
 925 void    endprotoent()   { tcp0("ENDPROTOENT"); }
 926 void    endservent()    { tcp0("ENDSERVENT");  }
 927
 928 /*****************************************************************************/
 929 /* not implemented in C Set++ */
 930
 931 #ifndef __EMX__
 932 int     setuid(x)       { errno = EINVAL; return -1; }
 933 int     setgid(x)       { errno = EINVAL; return -1; }
 934 #endif
 935
 936 /*****************************************************************************/
 937 /* stat() hack for char/block device */
 938
 939 #if OS2_STAT_HACK
 940
 941     /* First attempt used DosQueryFSAttach which crashed the system when
 942        used with 5.001. Now just look for /dev/. */
 943
 944 int
 945 os2_stat(char *name, struct stat *st)
 946 {
 947     static int ino = SHRT_MAX;
 948
 949     if (stricmp(name, "/dev/con") != 0
 950      && stricmp(name, "/dev/tty") != 0)
 951         return stat(name, st);
 952
 953     memset(st, 0, sizeof *st);
 954     st->st_mode = S_IFCHR|0666;
 955     st->st_ino = (ino-- & 0x7FFF);
 956     st->st_nlink = 1;
 957     return 0;
 958 }
 959
 960 #endif
 961
 962 #ifdef USE_PERL_SBRK
 963
 964 /* SBRK() emulation, mostly moved to malloc.c. */
 965
 966 void *
 967 sys_alloc(int size) {
 968     void *got;
 969     APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
 970
 971     if (rc == ERROR_NOT_ENOUGH_MEMORY) {
 972         return (void *) -1;
 973     } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
 974     return got;
 975 }
 976
 977 #endif /* USE_PERL_SBRK */
 978
 979 /* tmp path */
 980
 981 char *tmppath = TMPPATH1;
 982
 983 void
 984 settmppath()
 985 {
 986     char *p = getenv("TMP"), *tpath;
 987     int len;
 988
 989     if (!p) p = getenv("TEMP");
 990     if (!p) return;
 991     len = strlen(p);
 992     tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
 993     strcpy(tpath, p);
 994     tpath[len] = '/';
 995     strcpy(tpath + len + 1, TMPPATH1);
 996     tmppath = tpath;
 997 }
 998
 999 #include "XSUB.h"
1000
1001 XS(XS_File__Copy_syscopy)
1002 {
1003     dXSARGS;
1004     if (items < 2 || items > 3)
1005         croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
1006     {
1007         char *  src = (char *)SvPV(ST(0),na);
1008         char *  dst = (char *)SvPV(ST(1),na);
1009         U32     flag;
1010         int     RETVAL, rc;
1011
1012         if (items < 3)
1013             flag = 0;
1014         else {
1015             flag = (unsigned long)SvIV(ST(2));
1016         }
1017
1018         RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1019         ST(0) = sv_newmortal();
1020         sv_setiv(ST(0), (IV)RETVAL);
1021     }
1022     XSRETURN(1);
1023 }
1024
1025 char *
1026 mod2fname(sv)
1027      SV   *sv;
1028 {
1029     static char fname[9];
1030     int pos = 6, len, avlen;
1031     unsigned int sum = 0;
1032     AV  *av;
1033     SV  *svp;
1034     char *s;
1035
1036     if (!SvROK(sv)) croak("Not a reference given to mod2fname");
1037     sv = SvRV(sv);
1038     if (SvTYPE(sv) != SVt_PVAV)
1039       croak("Not array reference given to mod2fname");
1040
1041     avlen = av_len((AV*)sv);
1042     if (avlen < 0)
1043       croak("Empty array reference given to mod2fname");
1044
1045     s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
1046     strncpy(fname, s, 8);
1047     len = strlen(s);
1048     if (len < 6) pos = len;
1049     while (*s) {
1050         sum = 33 * sum + *(s++);        /* Checksumming first chars to
1051                                          * get the capitalization into c.s. */
1052     }
1053     avlen --;
1054     while (avlen >= 0) {
1055         s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
1056         while (*s) {
1057             sum = 33 * sum + *(s++);    /* 7 is primitive mod 13. */
1058         }
1059         avlen --;
1060     }
1061 #ifdef USE_THREADS
1062     sum++;                              /* Avoid conflict of DLLs in memory. */
1063 #endif
1064     fname[pos] = 'A' + (sum % 26);
1065     fname[pos + 1] = 'A' + (sum / 26 % 26);
1066     fname[pos + 2] = '\0';
1067     return (char *)fname;
1068 }
1069
1070 XS(XS_DynaLoader_mod2fname)
1071 {
1072     dXSARGS;
1073     if (items != 1)
1074         croak("Usage: DynaLoader::mod2fname(sv)");
1075     {
1076         SV *    sv = ST(0);
1077         char *  RETVAL;
1078
1079         RETVAL = mod2fname(sv);
1080         ST(0) = sv_newmortal();
1081         sv_setpv((SV*)ST(0), RETVAL);
1082     }
1083     XSRETURN(1);
1084 }
1085
1086 char *
1087 os2error(int rc)
1088 {
1089         static char buf[300];
1090         ULONG len;
1091
1092         if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1093         if (rc == 0)
1094                 return NULL;
1095         if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1096                 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1097         else
1098                 buf[len] = '\0';
1099         return buf;
1100 }
1101
1102 char *
1103 perllib_mangle(char *s, unsigned int l)
1104 {
1105     static char *newp, *oldp;
1106     static int newl, oldl, notfound;
1107     static char ret[STATIC_FILE_LENGTH+1];
1108
1109     if (!newp && !notfound) {
1110         newp = getenv("PERLLIB_PREFIX");
1111         if (newp) {
1112             char *s;
1113
1114             oldp = newp;
1115             while (*newp && !isSPACE(*newp) && *newp != ';') {
1116                 newp++; oldl++;         /* Skip digits. */
1117             }
1118             while (*newp && (isSPACE(*newp) || *newp == ';')) {
1119                 newp++;                 /* Skip whitespace. */
1120             }
1121             newl = strlen(newp);
1122             if (newl == 0 || oldl == 0) {
1123                 die("Malformed PERLLIB_PREFIX");
1124             }
1125             strcpy(ret, newp);
1126             s = ret;
1127             while (*s) {
1128                 if (*s == '\\') *s = '/';
1129                 s++;
1130             }
1131         } else {
1132             notfound = 1;
1133         }
1134     }
1135     if (!newp) {
1136         return s;
1137     }
1138     if (l == 0) {
1139         l = strlen(s);
1140     }
1141     if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1142         return s;
1143     }
1144     if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1145         die("Malformed PERLLIB_PREFIX");
1146     }
1147     strcpy(ret + newl, s + oldl);
1148     return ret;
1149 }
1150
1151 extern void dlopen();
1152 void *fakedl = &dlopen;         /* Pull in dynaloading part. */
1153
1154 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1155                                 && ((path)[2] == '/' || (path)[2] == '\\'))
1156 #define sys_is_rooted _fnisabs
1157 #define sys_is_relative _fnisrel
1158 #define current_drive _getdrive
1159
1160 #undef chdir                            /* Was _chdir2. */
1161 #define sys_chdir(p) (chdir(p) == 0)
1162 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1163
1164 XS(XS_Cwd_current_drive)
1165 {
1166     dXSARGS;
1167     if (items != 0)
1168         croak("Usage: Cwd::current_drive()");
1169     {
1170         char    RETVAL;
1171
1172         RETVAL = current_drive();
1173         ST(0) = sv_newmortal();
1174         sv_setpvn(ST(0), (char *)&RETVAL, 1);
1175     }
1176     XSRETURN(1);
1177 }
1178
1179 XS(XS_Cwd_sys_chdir)
1180 {
1181     dXSARGS;
1182     if (items != 1)
1183         croak("Usage: Cwd::sys_chdir(path)");
1184     {
1185         char *  path = (char *)SvPV(ST(0),na);
1186         bool    RETVAL;
1187
1188         RETVAL = sys_chdir(path);
1189         ST(0) = boolSV(RETVAL);
1190         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1191     }
1192     XSRETURN(1);
1193 }
1194
1195 XS(XS_Cwd_change_drive)
1196 {
1197     dXSARGS;
1198     if (items != 1)
1199         croak("Usage: Cwd::change_drive(d)");
1200     {
1201         char    d = (char)*SvPV(ST(0),na);
1202         bool    RETVAL;
1203
1204         RETVAL = change_drive(d);
1205         ST(0) = boolSV(RETVAL);
1206         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1207     }
1208     XSRETURN(1);
1209 }
1210
1211 XS(XS_Cwd_sys_is_absolute)
1212 {
1213     dXSARGS;
1214     if (items != 1)
1215         croak("Usage: Cwd::sys_is_absolute(path)");
1216     {
1217         char *  path = (char *)SvPV(ST(0),na);
1218         bool    RETVAL;
1219
1220         RETVAL = sys_is_absolute(path);
1221         ST(0) = boolSV(RETVAL);
1222         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1223     }
1224     XSRETURN(1);
1225 }
1226
1227 XS(XS_Cwd_sys_is_rooted)
1228 {
1229     dXSARGS;
1230     if (items != 1)
1231         croak("Usage: Cwd::sys_is_rooted(path)");
1232     {
1233         char *  path = (char *)SvPV(ST(0),na);
1234         bool    RETVAL;
1235
1236         RETVAL = sys_is_rooted(path);
1237         ST(0) = boolSV(RETVAL);
1238         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1239     }
1240     XSRETURN(1);
1241 }
1242
1243 XS(XS_Cwd_sys_is_relative)
1244 {
1245     dXSARGS;
1246     if (items != 1)
1247         croak("Usage: Cwd::sys_is_relative(path)");
1248     {
1249         char *  path = (char *)SvPV(ST(0),na);
1250         bool    RETVAL;
1251
1252         RETVAL = sys_is_relative(path);
1253         ST(0) = boolSV(RETVAL);
1254         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1255     }
1256     XSRETURN(1);
1257 }
1258
1259 XS(XS_Cwd_sys_cwd)
1260 {
1261     dXSARGS;
1262     if (items != 0)
1263         croak("Usage: Cwd::sys_cwd()");
1264     {
1265         char p[MAXPATHLEN];
1266         char *  RETVAL;
1267         RETVAL = _getcwd2(p, MAXPATHLEN);
1268         ST(0) = sv_newmortal();
1269         sv_setpv((SV*)ST(0), RETVAL);
1270     }
1271     XSRETURN(1);
1272 }
1273
1274 XS(XS_Cwd_sys_abspath)
1275 {
1276     dXSARGS;
1277     if (items < 1 || items > 2)
1278         croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
1279     {
1280         char *  path = (char *)SvPV(ST(0),na);
1281         char *  dir;
1282         char p[MAXPATHLEN];
1283         char *  RETVAL;
1284
1285         if (items < 2)
1286             dir = NULL;
1287         else {
1288             dir = (char *)SvPV(ST(1),na);
1289         }
1290         if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1291             path += 2;
1292         }
1293         if (dir == NULL) {
1294             if (_abspath(p, path, MAXPATHLEN) == 0) {
1295                 RETVAL = p;
1296             } else {
1297                 RETVAL = NULL;
1298             }
1299         } else {
1300             /* Absolute with drive: */
1301             if ( sys_is_absolute(path) ) {
1302                 if (_abspath(p, path, MAXPATHLEN) == 0) {
1303                     RETVAL = p;
1304                 } else {
1305                     RETVAL = NULL;
1306                 }
1307             } else if (path[0] == '/' || path[0] == '\\') {
1308                 /* Rooted, but maybe on different drive. */
1309                 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1310                     char p1[MAXPATHLEN];
1311
1312                     /* Need to prepend the drive. */
1313                     p1[0] = dir[0];
1314                     p1[1] = dir[1];
1315                     Copy(path, p1 + 2, strlen(path) + 1, char);
1316                     RETVAL = p;
1317                     if (_abspath(p, p1, MAXPATHLEN) == 0) {
1318                         RETVAL = p;
1319                     } else {
1320                         RETVAL = NULL;
1321                     }
1322                 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1323                     RETVAL = p;
1324                 } else {
1325                     RETVAL = NULL;
1326                 }
1327             } else {
1328                 /* Either path is relative, or starts with a drive letter. */
1329                 /* If the path starts with a drive letter, then dir is
1330                    relevant only if
1331                    a/b) it is absolute/x:relative on the same drive.
1332                    c)   path is on current drive, and dir is rooted
1333                    In all the cases it is safe to drop the drive part
1334                    of the path. */
1335                 if ( !sys_is_relative(path) ) {
1336                     int is_drived;
1337
1338                     if ( ( ( sys_is_absolute(dir)
1339                              || (isALPHA(dir[0]) && dir[1] == ':'
1340                                  && strnicmp(dir, path,1) == 0))
1341                            && strnicmp(dir, path,1) == 0)
1342                          || ( !(isALPHA(dir[0]) && dir[1] == ':')
1343                               && toupper(path[0]) == current_drive())) {
1344                         path += 2;
1345                     } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1346                         RETVAL = p; goto done;
1347                     } else {
1348                         RETVAL = NULL; goto done;
1349                     }
1350                 }
1351                 {
1352                     /* Need to prepend the absolute path of dir. */
1353                     char p1[MAXPATHLEN];
1354
1355                     if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1356                         int l = strlen(p1);
1357
1358                         if (p1[ l - 1 ] != '/') {
1359                             p1[ l ] = '/';
1360                             l++;
1361                         }
1362                         Copy(path, p1 + l, strlen(path) + 1, char);
1363                         if (_abspath(p, p1, MAXPATHLEN) == 0) {
1364                             RETVAL = p;
1365                         } else {
1366                             RETVAL = NULL;
1367                         }
1368                     } else {
1369                         RETVAL = NULL;
1370                     }
1371                 }
1372               done:
1373             }
1374         }
1375         ST(0) = sv_newmortal();
1376         sv_setpv((SV*)ST(0), RETVAL);
1377     }
1378     XSRETURN(1);
1379 }
1380 typedef APIRET (*PELP)(PSZ path, ULONG type);
1381
1382 APIRET
1383 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1384 {
1385     loadByOrd(ord);                     /* Guarantied to load or die! */
1386     return (*(PELP)ExtFCN[ord])(path, type);
1387 }
1388
1389 #define extLibpath(type)                                                \
1390     (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH   \
1391                                                  : BEGIN_LIBPATH)))     \
1392      ? NULL : to )
1393
1394 #define extLibpath_set(p,type)                                  \
1395     (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH   \
1396                                                  : BEGIN_LIBPATH))))
1397
1398 XS(XS_Cwd_extLibpath)
1399 {
1400     dXSARGS;
1401     if (items < 0 || items > 1)
1402         croak("Usage: Cwd::extLibpath(type = 0)");
1403     {
1404         bool    type;
1405         char    to[1024];
1406         U32     rc;
1407         char *  RETVAL;
1408
1409         if (items < 1)
1410             type = 0;
1411         else {
1412             type = (int)SvIV(ST(0));
1413         }
1414
1415         RETVAL = extLibpath(type);
1416         ST(0) = sv_newmortal();
1417         sv_setpv((SV*)ST(0), RETVAL);
1418     }
1419     XSRETURN(1);
1420 }
1421
1422 XS(XS_Cwd_extLibpath_set)
1423 {
1424     dXSARGS;
1425     if (items < 1 || items > 2)
1426         croak("Usage: Cwd::extLibpath_set(s, type = 0)");
1427     {
1428         char *  s = (char *)SvPV(ST(0),na);
1429         bool    type;
1430         U32     rc;
1431         bool    RETVAL;
1432
1433         if (items < 2)
1434             type = 0;
1435         else {
1436             type = (int)SvIV(ST(1));
1437         }
1438
1439         RETVAL = extLibpath_set(s, type);
1440         ST(0) = boolSV(RETVAL);
1441         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1442     }
1443     XSRETURN(1);
1444 }
1445
1446 int
1447 Xs_OS2_init()
1448 {
1449     char *file = __FILE__;
1450     {
1451         GV *gv;
1452
1453         if (_emx_env & 0x200) { /* OS/2 */
1454             newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
1455             newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
1456             newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
1457         }
1458         newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
1459         newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
1460         newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
1461         newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
1462         newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
1463         newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
1464         newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
1465         newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
1466         newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
1467         gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
1468         GvMULTI_on(gv);
1469 #ifdef PERL_IS_AOUT
1470         sv_setiv(GvSV(gv), 1);
1471 #endif
1472     }
1473 }
1474
1475 OS2_Perl_data_t OS2_Perl_data;
1476
1477 void
1478 Perl_OS2_init(char **env)
1479 {
1480     char *shell;
1481
1482     MALLOC_INIT;
1483     settmppath();
1484     OS2_Perl_data.xs_init = &Xs_OS2_init;
1485     if (environ == NULL) {
1486         environ = env;
1487     }
1488     if ( (shell = getenv("PERL_SH_DRIVE")) ) {
1489         New(1304, sh_path, strlen(SH_PATH) + 1, char);
1490         strcpy(sh_path, SH_PATH);
1491         sh_path[0] = shell[0];
1492     } else if ( (shell = getenv("PERL_SH_DIR")) ) {
1493         int l = strlen(shell), i;
1494         if (shell[l-1] == '/' || shell[l-1] == '\\') {
1495             l--;
1496         }
1497         New(1304, sh_path, l + 8, char);
1498         strncpy(sh_path, shell, l);
1499         strcpy(sh_path + l, "/sh.exe");
1500         for (i = 0; i < l; i++) {
1501             if (sh_path[i] == '\\') sh_path[i] = '/';
1502         }
1503     }
1504     MUTEX_INIT(&start_thread_mutex);
1505 }
1506
1507 #undef tmpnam
1508 #undef tmpfile
1509
1510 char *
1511 my_tmpnam (char *str)
1512 {
1513     char *p = getenv("TMP"), *tpath;
1514     int len;
1515
1516     if (!p) p = getenv("TEMP");
1517     tpath = tempnam(p, "pltmp");
1518     if (str && tpath) {
1519         strcpy(str, tpath);
1520         return str;
1521     }
1522     return tpath;
1523 }
1524
1525 FILE *
1526 my_tmpfile ()
1527 {
1528     struct stat s;
1529
1530     stat(".", &s);
1531     if (s.st_mode & S_IWOTH) {
1532         return tmpfile();
1533     }
1534     return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
1535                                              grants TMP. */
1536 }
1537
1538 #undef flock
1539
1540 /* This code was contributed by Rocco Caputo. */
1541 int
1542 my_flock(int handle, int o)
1543 {
1544   FILELOCK      rNull, rFull;
1545   ULONG         timeout, handle_type, flag_word;
1546   APIRET        rc;
1547   int           blocking, shared;
1548   static int    use_my = -1;
1549
1550   if (use_my == -1) {
1551     char *s = getenv("USE_PERL_FLOCK");
1552     if (s)
1553         use_my = atoi(s);
1554     else
1555         use_my = 1;
1556   }
1557   if (!(_emx_env & 0x200) || !use_my)
1558     return flock(handle, o);    /* Delegate to EMX. */
1559
1560                                         // is this a file?
1561   if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
1562       (handle_type & 0xFF))
1563   {
1564     errno = EBADF;
1565     return -1;
1566   }
1567                                         // set lock/unlock ranges
1568   rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
1569   rFull.lRange = 0x7FFFFFFF;
1570                                         // set timeout for blocking
1571   timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
1572                                         // shared or exclusive?
1573   shared = (o & LOCK_SH) ? 1 : 0;
1574                                         // do not block the unlock
1575   if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
1576     rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
1577     switch (rc) {
1578       case 0:
1579         errno = 0;
1580         return 0;
1581       case ERROR_INVALID_HANDLE:
1582         errno = EBADF;
1583         return -1;
1584       case ERROR_SHARING_BUFFER_EXCEEDED:
1585         errno = ENOLCK;
1586         return -1;
1587       case ERROR_LOCK_VIOLATION:
1588         break;                          // not an error
1589       case ERROR_INVALID_PARAMETER:
1590       case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1591       case ERROR_READ_LOCKS_NOT_SUPPORTED:
1592         errno = EINVAL;
1593         return -1;
1594       case ERROR_INTERRUPT:
1595         errno = EINTR;
1596         return -1;
1597       default:
1598         errno = EINVAL;
1599         return -1;
1600     }
1601   }
1602                                         // lock may block
1603   if (o & (LOCK_SH | LOCK_EX)) {
1604                                         // for blocking operations
1605     for (;;) {
1606       rc =
1607         DosSetFileLocks(
1608                 handle,
1609                 &rNull,
1610                 &rFull,
1611                 timeout,
1612                 shared
1613         );
1614       switch (rc) {
1615         case 0:
1616           errno = 0;
1617           return 0;
1618         case ERROR_INVALID_HANDLE:
1619           errno = EBADF;
1620           return -1;
1621         case ERROR_SHARING_BUFFER_EXCEEDED:
1622           errno = ENOLCK;
1623           return -1;
1624         case ERROR_LOCK_VIOLATION:
1625           if (!blocking) {
1626             errno = EWOULDBLOCK;
1627             return -1;
1628           }
1629           break;
1630         case ERROR_INVALID_PARAMETER:
1631         case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1632         case ERROR_READ_LOCKS_NOT_SUPPORTED:
1633           errno = EINVAL;
1634           return -1;
1635         case ERROR_INTERRUPT:
1636           errno = EINTR;
1637           return -1;
1638         default:
1639           errno = EINVAL;
1640           return -1;
1641       }
1642                                         // give away timeslice
1643       DosSleep(1);
1644     }
1645   }
1646
1647   errno = 0;
1648   return 0;
1649 }