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,&PL_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         PL_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         PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
 370         if (r)
 371                 return -1;
 372         return PL_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 PL_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;
 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(PL_Argv[0],"/bin/sh"))
 407             PL_Argv[0] = PL_sh_path;
 408
 409         if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\'
 410             && !(PL_Argv[0][0] && PL_Argv[0][1] == ':'
 411                  && (PL_Argv[0][2] == '/' || PL_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, PL_na)))
 416             tmps = PL_Argv[0];
 417 #if 0
 418         rc = result(trueflag, spawnvp(flag,tmps,PL_Argv));
 419 #else
 420         if (execf == EXECF_TRUEEXEC)
 421             rc = execvp(tmps,PL_Argv);
 422         else if (execf == EXECF_EXEC)
 423             rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
 424         else if (execf == EXECF_SPAWN_NOWAIT)
 425             rc = spawnvp(trueflag | P_NOWAIT,tmps,PL_Argv);
 426         else                            /* EXECF_SPAWN */
 427             rc = result(trueflag,
 428                         spawnvp(trueflag | P_NOWAIT,tmps,PL_Argv));
 429 #endif
 430         if (rc < 0 && pass == 1
 431             && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
 432             int err = errno;
 433
 434             if (err == ENOENT || err == ENOEXEC) {
 435                 /* No such file, or is a script. */
 436                 /* Try adding script extensions to the file name, and
 437                    search on PATH. */
 438                 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
 439
 440                 if (scr) {
 441                     FILE *file = fopen(scr, "r");
 442                     char *s = 0, *s1;
 443
 444                     PL_Argv[0] = scr;
 445                     if (!file)
 446                         goto panic_file;
 447                     if (!fgets(buf, sizeof buf, file)) {
 448                         fclose(file);
 449                         goto panic_file;
 450                     }
 451                     if (fclose(file) != 0) { /* Failure */
 452                       panic_file:
 453                         warn("Error reading \"%s\": %s",
 454                              scr, Strerror(errno));
 455                         buf[0] = 0;     /* Not #! */
 456                         goto doshell_args;
 457                     }
 458                     if (buf[0] == '#') {
 459                         if (buf[1] == '!')
 460                             s = buf + 2;
 461                     } else if (buf[0] == 'e') {
 462                         if (strnEQ(buf, "extproc", 7)
 463                             && isSPACE(buf[7]))
 464                             s = buf + 8;
 465                     } else if (buf[0] == 'E') {
 466                         if (strnEQ(buf, "EXTPROC", 7)
 467                             && isSPACE(buf[7]))
 468                             s = buf + 8;
 469                     }
 470                     if (!s) {
 471                         buf[0] = 0;     /* Not #! */
 472                         goto doshell_args;
 473                     }
 474
 475                     s1 = s;
 476                     nargs = 0;
 477                     argsp = args;
 478                     while (1) {
 479                         /* Do better than pdksh: allow a few args,
 480                            strip trailing whitespace.  */
 481                         while (isSPACE(*s))
 482                             s++;
 483                         if (*s == 0)
 484                             break;
 485                         if (nargs == 4) {
 486                             nargs = -1;
 487                             break;
 488                         }
 489                         args[nargs++] = s;
 490                         while (*s && !isSPACE(*s))
 491                             s++;
 492                         if (*s == 0)
 493                             break;
 494                         *s++ = 0;
 495                     }
 496                     if (nargs == -1) {
 497                         warn("Too many args on %.*s line of \"%s\"",
 498                              s1 - buf, buf, scr);
 499                         nargs = 4;
 500                         argsp = fargs;
 501                     }
 502                   doshell_args:
 503                     {
 504                         char **a = PL_Argv;
 505                         char *exec_args[2];
 506
 507                         if (!buf[0] && file) { /* File without magic */
 508                             /* In fact we tried all what pdksh would
 509                                try.  There is no point in calling
 510                                pdksh, we may just emulate its logic. */
 511                             char *shell = getenv("EXECSHELL");
 512                             char *shell_opt = NULL;
 513
 514                             if (!shell) {
 515                                 char *s;
 516
 517                                 shell_opt = "/c";
 518                                 shell = getenv("OS2_SHELL");
 519                                 if (inicmd) { /* No spaces at start! */
 520                                     s = inicmd;
 521                                     while (*s && !isSPACE(*s)) {
 522                                         if (*s++ = '/') {
 523                                             inicmd = NULL; /* Cannot use */
 524                                             break;
 525                                         }
 526                                     }
 527                                 }
 528                                 if (!inicmd) {
 529                                     s = PL_Argv[0];
 530                                     while (*s) {
 531                                         /* Dosish shells will choke on slashes
 532                                            in paths, fortunately, this is
 533                                            important for zeroth arg only. */
 534                                         if (*s == '/')
 535                                             *s = '\\';
 536                                         s++;
 537                                     }
 538                                 }
 539                             }
 540                             /* If EXECSHELL is set, we do not set */
 541
 542                             if (!shell)
 543                                 shell = ((_emx_env & 0x200)
 544                                          ? "c:/os2/cmd.exe"
 545                                          : "c:/command.com");
 546                             nargs = shell_opt ? 2 : 1;  /* shell file args */
 547                             exec_args[0] = shell;
 548                             exec_args[1] = shell_opt;
 549                             argsp = exec_args;
 550                             if (nargs == 2 && inicmd) {
 551                                 /* Use the original cmd line */
 552                                 /* XXXX This is good only until we refuse
 553                                         quoted arguments... */
 554                                 PL_Argv[0] = inicmd;
 555                                 PL_Argv[1] = Nullch;
 556                             }
 557                         } else if (!buf[0] && inicmd) { /* No file */
 558                             /* Start with the original cmdline. */
 559                             /* XXXX This is good only until we refuse
 560                                     quoted arguments... */
 561
 562                             PL_Argv[0] = inicmd;
 563                             PL_Argv[1] = Nullch;
 564                             nargs = 2;  /* shell -c */
 565                         }
 566
 567                         while (a[1])            /* Get to the end */
 568                             a++;
 569                         a++;                    /* Copy finil NULL too */
 570                         while (a >= PL_Argv) {
 571                             *(a + nargs) = *a;  /* PL_Argv was preallocated to be
 572                                                    long enough. */
 573                             a--;
 574                         }
 575                         while (nargs-- >= 0)
 576                             PL_Argv[nargs] = argsp[nargs];
 577                         /* Enable pathless exec if #! (as pdksh). */
 578                         pass = (buf[0] == '#' ? 2 : 3);
 579                         goto retry;
 580                     }
 581                 }
 582                 /* Not found: restore errno */
 583                 errno = err;
 584             }
 585         } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
 586             char *no_dir = strrchr(PL_Argv[0], '/');
 587
 588             /* Do as pdksh port does: if not found with /, try without
 589                path. */
 590             if (no_dir) {
 591                 PL_Argv[0] = no_dir + 1;
 592                 pass++;
 593                 goto retry;
 594             }
 595         }
 596         if (rc < 0 && PL_dowarn)
 597             warn("Can't %s \"%s\": %s\n",
 598                  ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
 599                   ? "spawn" : "exec"),
 600                  PL_Argv[0], Strerror(errno));
 601         if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
 602             && ((trueflag & 0xFF) == P_WAIT))
 603             rc = 255 << 8; /* Emulate the fork(). */
 604
 605     return rc;
 606 }
 607
 608 /* Array spawn.  */
 609 int
 610 do_aspawn(really,mark,sp)
 611 SV *really;
 612 register SV **mark;
 613 register SV **sp;
 614 {
 615     dTHR;
 616     register char **a;
 617     char *tmps = NULL;
 618     int rc;
 619     int flag = P_WAIT, trueflag, err, secondtry = 0;
 620
 621     if (sp > mark) {
 622         New(1301,PL_Argv, sp - mark + 3, char*);
 623         a = PL_Argv;
 624
 625         if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
 626                 ++mark;
 627                 flag = SvIVx(*mark);
 628         }
 629
 630         while (++mark <= sp) {
 631             if (*mark)
 632                 *a++ = SvPVx(*mark, PL_na);
 633             else
 634                 *a++ = "";
 635         }
 636         *a = Nullch;
 637
 638         rc = do_spawn_ve(really, flag, EXECF_SPAWN, NULL);
 639     } else
 640         rc = -1;
 641     do_execfree();
 642     return rc;
 643 }
 644
 645 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
 646 int
 647 do_spawn2(cmd, execf)
 648 char *cmd;
 649 int execf;
 650 {
 651     register char **a;
 652     register char *s;
 653     char flags[10];
 654     char *shell, *copt, *news = NULL;
 655     int rc, err, seenspace = 0;
 656     char fullcmd[MAXNAMLEN + 1];
 657
 658 #ifdef TRYSHELL
 659     if ((shell = getenv("EMXSHELL")) != NULL)
 660         copt = "-c";
 661     else if ((shell = getenv("SHELL")) != NULL)
 662         copt = "-c";
 663     else if ((shell = getenv("COMSPEC")) != NULL)
 664         copt = "/C";
 665     else
 666         shell = "cmd.exe";
 667 #else
 668     /* Consensus on perl5-porters is that it is _very_ important to
 669        have a shell which will not change between computers with the
 670        same architecture, to avoid "action on a distance".
 671        And to have simple build, this shell should be sh. */
 672     shell = PL_sh_path;
 673     copt = "-c";
 674 #endif
 675
 676     while (*cmd && isSPACE(*cmd))
 677         cmd++;
 678
 679     if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
 680         STRLEN l = strlen(PL_sh_path);
 681
 682         New(1302, news, strlen(cmd) - 7 + l + 1, char);
 683         strcpy(news, PL_sh_path);
 684         strcpy(news + l, cmd + 7);
 685         cmd = news;
 686     }
 687
 688     /* save an extra exec if possible */
 689     /* see if there are shell metacharacters in it */
 690
 691     if (*cmd == '.' && isSPACE(cmd[1]))
 692         goto doshell;
 693
 694     if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
 695         goto doshell;
 696
 697     for (s = cmd; *s && isALPHA(*s); s++) ;     /* catch VAR=val gizmo */
 698     if (*s == '=')
 699         goto doshell;
 700
 701     for (s = cmd; *s; s++) {
 702         if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
 703             if (*s == '\n' && s[1] == '\0') {
 704                 *s = '\0';
 705                 break;
 706             } else if (*s == '\\' && !seenspace) {
 707                 continue;               /* Allow backslashes in names */
 708             }
 709             /* We do not convert this to do_spawn_ve since shell
 710                should be smart enough to start itself gloriously. */
 711           doshell:
 712             if (execf == EXECF_TRUEEXEC)
 713                 rc = execl(shell,shell,copt,cmd,(char*)0);
 714             else if (execf == EXECF_EXEC)
 715                 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
 716             else if (execf == EXECF_SPAWN_NOWAIT)
 717                 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
 718             else {
 719                 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
 720                 rc = result(P_WAIT,
 721                             spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
 722                 if (rc < 0 && PL_dowarn)
 723                     warn("Can't %s \"%s\": %s",
 724                          (execf == EXECF_SPAWN ? "spawn" : "exec"),
 725                          shell, Strerror(errno));
 726                 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
 727             }
 728             if (news)
 729                 Safefree(news);
 730             return rc;
 731         } else if (*s == ' ' || *s == '\t') {
 732             seenspace = 1;
 733         }
 734     }
 735
 736     /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
 737     New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
 738     PL_Cmd = savepvn(cmd, s-cmd);
 739     a = PL_Argv;
 740     for (s = PL_Cmd; *s;) {
 741         while (*s && isSPACE(*s)) s++;
 742         if (*s)
 743             *(a++) = s;
 744         while (*s && !isSPACE(*s)) s++;
 745         if (*s)
 746             *s++ = '\0';
 747     }
 748     *a = Nullch;
 749     if (PL_Argv[0])
 750         rc = do_spawn_ve(NULL, 0, execf, cmd);
 751     else
 752         rc = -1;
 753     if (news)
 754         Safefree(news);
 755     do_execfree();
 756     return rc;
 757 }
 758
 759 int
 760 do_spawn(cmd)
 761 char *cmd;
 762 {
 763     return do_spawn2(cmd, EXECF_SPAWN);
 764 }
 765
 766 int
 767 do_spawn_nowait(cmd)
 768 char *cmd;
 769 {
 770     return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
 771 }
 772
 773 bool
 774 do_exec(cmd)
 775 char *cmd;
 776 {
 777     return do_spawn2(cmd, EXECF_EXEC);
 778 }
 779
 780 bool
 781 os2exec(cmd)
 782 char *cmd;
 783 {
 784     return do_spawn2(cmd, EXECF_TRUEEXEC);
 785 }
 786
 787 PerlIO *
 788 my_syspopen(cmd,mode)
 789 char    *cmd;
 790 char    *mode;
 791 {
 792 #ifndef USE_POPEN
 793
 794     int p[2];
 795     register I32 this, that, newfd;
 796     register I32 pid, rc;
 797     PerlIO *res;
 798     SV *sv;
 799
 800     /* `this' is what we use in the parent, `that' in the child. */
 801     this = (*mode == 'w');
 802     that = !this;
 803     if (PL_tainting) {
 804         taint_env();
 805         taint_proper("Insecure %s%s", "EXEC");
 806     }
 807     if (pipe(p) < 0)
 808         return Nullfp;
 809     /* Now we need to spawn the child. */
 810     newfd = dup(*mode == 'r');          /* Preserve std* */
 811     if (p[that] != (*mode == 'r')) {
 812         dup2(p[that], *mode == 'r');
 813         close(p[that]);
 814     }
 815     /* Where is `this' and newfd now? */
 816     fcntl(p[this], F_SETFD, FD_CLOEXEC);
 817     fcntl(newfd, F_SETFD, FD_CLOEXEC);
 818     pid = do_spawn_nowait(cmd);
 819     if (newfd != (*mode == 'r')) {
 820         dup2(newfd, *mode == 'r');      /* Return std* back. */
 821         close(newfd);
 822     }
 823     if (p[that] == (*mode == 'r'))
 824         close(p[that]);
 825     if (pid == -1) {
 826         close(p[this]);
 827         return NULL;
 828     }
 829     if (p[that] < p[this]) {
 830         dup2(p[this], p[that]);
 831         close(p[this]);
 832         p[this] = p[that];
 833     }
 834     sv = *av_fetch(PL_fdpid,p[this],TRUE);
 835     (void)SvUPGRADE(sv,SVt_IV);
 836     SvIVX(sv) = pid;
 837     PL_forkprocess = pid;
 838     return PerlIO_fdopen(p[this], mode);
 839
 840 #else  /* USE_POPEN */
 841
 842     PerlIO *res;
 843     SV *sv;
 844
 845 #  ifdef TRYSHELL
 846     res = popen(cmd, mode);
 847 #  else
 848     char *shell = getenv("EMXSHELL");
 849
 850     my_setenv("EMXSHELL", PL_sh_path);
 851     res = popen(cmd, mode);
 852     my_setenv("EMXSHELL", shell);
 853 #  endif
 854     sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
 855     (void)SvUPGRADE(sv,SVt_IV);
 856     SvIVX(sv) = -1;                     /* A cooky. */
 857     return res;
 858
 859 #endif /* USE_POPEN */
 860
 861 }
 862
 863 /******************************************************************/
 864
 865 #ifndef HAS_FORK
 866 int
 867 fork(void)
 868 {
 869     die(no_func, "Unsupported function fork");
 870     errno = EINVAL;
 871     return -1;
 872 }
 873 #endif
 874
 875 /*******************************************************************/
 876 /* not implemented in EMX 0.9a */
 877
 878 void *  ctermid(x)      { return 0; }
 879
 880 #ifdef MYTTYNAME /* was not in emx0.9a */
 881 void *  ttyname(x)      { return 0; }
 882 #endif
 883
 884 /******************************************************************/
 885 /* my socket forwarders - EMX lib only provides static forwarders */
 886
 887 static HMODULE htcp = 0;
 888
 889 static void *
 890 tcp0(char *name)
 891 {
 892     static BYTE buf[20];
 893     PFN fcn;
 894
 895     if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
 896     if (!htcp)
 897         DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
 898     if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
 899         return (void *) ((void * (*)(void)) fcn) ();
 900     return 0;
 901 }
 902
 903 static void
 904 tcp1(char *name, int arg)
 905 {
 906     static BYTE buf[20];
 907     PFN fcn;
 908
 909     if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
 910     if (!htcp)
 911         DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
 912     if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
 913         ((void (*)(int)) fcn) (arg);
 914 }
 915
 916 void *  gethostent()    { return tcp0("GETHOSTENT");  }
 917 void *  getnetent()     { return tcp0("GETNETENT");   }
 918 void *  getprotoent()   { return tcp0("GETPROTOENT"); }
 919 void *  getservent()    { return tcp0("GETSERVENT");  }
 920 void    sethostent(x)   { tcp1("SETHOSTENT",  x); }
 921 void    setnetent(x)    { tcp1("SETNETENT",   x); }
 922 void    setprotoent(x)  { tcp1("SETPROTOENT", x); }
 923 void    setservent(x)   { tcp1("SETSERVENT",  x); }
 924 void    endhostent()    { tcp0("ENDHOSTENT");  }
 925 void    endnetent()     { tcp0("ENDNETENT");   }
 926 void    endprotoent()   { tcp0("ENDPROTOENT"); }
 927 void    endservent()    { tcp0("ENDSERVENT");  }
 928
 929 /*****************************************************************************/
 930 /* not implemented in C Set++ */
 931
 932 #ifndef __EMX__
 933 int     setuid(x)       { errno = EINVAL; return -1; }
 934 int     setgid(x)       { errno = EINVAL; return -1; }
 935 #endif
 936
 937 /*****************************************************************************/
 938 /* stat() hack for char/block device */
 939
 940 #if OS2_STAT_HACK
 941
 942     /* First attempt used DosQueryFSAttach which crashed the system when
 943        used with 5.001. Now just look for /dev/. */
 944
 945 int
 946 os2_stat(char *name, struct stat *st)
 947 {
 948     static int ino = SHRT_MAX;
 949
 950     if (stricmp(name, "/dev/con") != 0
 951      && stricmp(name, "/dev/tty") != 0)
 952         return stat(name, st);
 953
 954     memset(st, 0, sizeof *st);
 955     st->st_mode = S_IFCHR|0666;
 956     st->st_ino = (ino-- & 0x7FFF);
 957     st->st_nlink = 1;
 958     return 0;
 959 }
 960
 961 #endif
 962
 963 #ifdef USE_PERL_SBRK
 964
 965 /* SBRK() emulation, mostly moved to malloc.c. */
 966
 967 void *
 968 sys_alloc(int size) {
 969     void *got;
 970     APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
 971
 972     if (rc == ERROR_NOT_ENOUGH_MEMORY) {
 973         return (void *) -1;
 974     } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
 975     return got;
 976 }
 977
 978 #endif /* USE_PERL_SBRK */
 979
 980 /* tmp path */
 981
 982 char *tmppath = TMPPATH1;
 983
 984 void
 985 settmppath()
 986 {
 987     char *p = getenv("TMP"), *tpath;
 988     int len;
 989
 990     if (!p) p = getenv("TEMP");
 991     if (!p) return;
 992     len = strlen(p);
 993     tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
 994     strcpy(tpath, p);
 995     tpath[len] = '/';
 996     strcpy(tpath + len + 1, TMPPATH1);
 997     tmppath = tpath;
 998 }
 999
1000 #include "XSUB.h"
1001
1002 XS(XS_File__Copy_syscopy)
1003 {
1004     dXSARGS;
1005     if (items < 2 || items > 3)
1006         croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
1007     {
1008         char *  src = (char *)SvPV(ST(0),PL_na);
1009         char *  dst = (char *)SvPV(ST(1),PL_na);
1010         U32     flag;
1011         int     RETVAL, rc;
1012
1013         if (items < 3)
1014             flag = 0;
1015         else {
1016             flag = (unsigned long)SvIV(ST(2));
1017         }
1018
1019         RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1020         ST(0) = sv_newmortal();
1021         sv_setiv(ST(0), (IV)RETVAL);
1022     }
1023     XSRETURN(1);
1024 }
1025
1026 char *
1027 mod2fname(sv)
1028      SV   *sv;
1029 {
1030     static char fname[9];
1031     int pos = 6, len, avlen;
1032     unsigned int sum = 0;
1033     AV  *av;
1034     SV  *svp;
1035     char *s;
1036
1037     if (!SvROK(sv)) croak("Not a reference given to mod2fname");
1038     sv = SvRV(sv);
1039     if (SvTYPE(sv) != SVt_PVAV)
1040       croak("Not array reference given to mod2fname");
1041
1042     avlen = av_len((AV*)sv);
1043     if (avlen < 0)
1044       croak("Empty array reference given to mod2fname");
1045
1046     s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), PL_na);
1047     strncpy(fname, s, 8);
1048     len = strlen(s);
1049     if (len < 6) pos = len;
1050     while (*s) {
1051         sum = 33 * sum + *(s++);        /* Checksumming first chars to
1052                                          * get the capitalization into c.s. */
1053     }
1054     avlen --;
1055     while (avlen >= 0) {
1056         s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), PL_na);
1057         while (*s) {
1058             sum = 33 * sum + *(s++);    /* 7 is primitive mod 13. */
1059         }
1060         avlen --;
1061     }
1062 #ifdef USE_THREADS
1063     sum++;                              /* Avoid conflict of DLLs in memory. */
1064 #endif
1065     fname[pos] = 'A' + (sum % 26);
1066     fname[pos + 1] = 'A' + (sum / 26 % 26);
1067     fname[pos + 2] = '\0';
1068     return (char *)fname;
1069 }
1070
1071 XS(XS_DynaLoader_mod2fname)
1072 {
1073     dXSARGS;
1074     if (items != 1)
1075         croak("Usage: DynaLoader::mod2fname(sv)");
1076     {
1077         SV *    sv = ST(0);
1078         char *  RETVAL;
1079
1080         RETVAL = mod2fname(sv);
1081         ST(0) = sv_newmortal();
1082         sv_setpv((SV*)ST(0), RETVAL);
1083     }
1084     XSRETURN(1);
1085 }
1086
1087 char *
1088 os2error(int rc)
1089 {
1090         static char buf[300];
1091         ULONG len;
1092
1093         if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1094         if (rc == 0)
1095                 return NULL;
1096         if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1097                 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1098         else
1099                 buf[len] = '\0';
1100         return buf;
1101 }
1102
1103 char *
1104 perllib_mangle(char *s, unsigned int l)
1105 {
1106     static char *newp, *oldp;
1107     static int newl, oldl, notfound;
1108     static char ret[STATIC_FILE_LENGTH+1];
1109
1110     if (!newp && !notfound) {
1111         newp = getenv("PERLLIB_PREFIX");
1112         if (newp) {
1113             char *s;
1114
1115             oldp = newp;
1116             while (*newp && !isSPACE(*newp) && *newp != ';') {
1117                 newp++; oldl++;         /* Skip digits. */
1118             }
1119             while (*newp && (isSPACE(*newp) || *newp == ';')) {
1120                 newp++;                 /* Skip whitespace. */
1121             }
1122             newl = strlen(newp);
1123             if (newl == 0 || oldl == 0) {
1124                 die("Malformed PERLLIB_PREFIX");
1125             }
1126             strcpy(ret, newp);
1127             s = ret;
1128             while (*s) {
1129                 if (*s == '\\') *s = '/';
1130                 s++;
1131             }
1132         } else {
1133             notfound = 1;
1134         }
1135     }
1136     if (!newp) {
1137         return s;
1138     }
1139     if (l == 0) {
1140         l = strlen(s);
1141     }
1142     if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1143         return s;
1144     }
1145     if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1146         die("Malformed PERLLIB_PREFIX");
1147     }
1148     strcpy(ret + newl, s + oldl);
1149     return ret;
1150 }
1151
1152 extern void dlopen();
1153 void *fakedl = &dlopen;         /* Pull in dynaloading part. */
1154
1155 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1156                                 && ((path)[2] == '/' || (path)[2] == '\\'))
1157 #define sys_is_rooted _fnisabs
1158 #define sys_is_relative _fnisrel
1159 #define current_drive _getdrive
1160
1161 #undef chdir                            /* Was _chdir2. */
1162 #define sys_chdir(p) (chdir(p) == 0)
1163 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1164
1165 XS(XS_Cwd_current_drive)
1166 {
1167     dXSARGS;
1168     if (items != 0)
1169         croak("Usage: Cwd::current_drive()");
1170     {
1171         char    RETVAL;
1172
1173         RETVAL = current_drive();
1174         ST(0) = sv_newmortal();
1175         sv_setpvn(ST(0), (char *)&RETVAL, 1);
1176     }
1177     XSRETURN(1);
1178 }
1179
1180 XS(XS_Cwd_sys_chdir)
1181 {
1182     dXSARGS;
1183     if (items != 1)
1184         croak("Usage: Cwd::sys_chdir(path)");
1185     {
1186         char *  path = (char *)SvPV(ST(0),PL_na);
1187         bool    RETVAL;
1188
1189         RETVAL = sys_chdir(path);
1190         ST(0) = boolSV(RETVAL);
1191         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1192     }
1193     XSRETURN(1);
1194 }
1195
1196 XS(XS_Cwd_change_drive)
1197 {
1198     dXSARGS;
1199     if (items != 1)
1200         croak("Usage: Cwd::change_drive(d)");
1201     {
1202         char    d = (char)*SvPV(ST(0),PL_na);
1203         bool    RETVAL;
1204
1205         RETVAL = change_drive(d);
1206         ST(0) = boolSV(RETVAL);
1207         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1208     }
1209     XSRETURN(1);
1210 }
1211
1212 XS(XS_Cwd_sys_is_absolute)
1213 {
1214     dXSARGS;
1215     if (items != 1)
1216         croak("Usage: Cwd::sys_is_absolute(path)");
1217     {
1218         char *  path = (char *)SvPV(ST(0),PL_na);
1219         bool    RETVAL;
1220
1221         RETVAL = sys_is_absolute(path);
1222         ST(0) = boolSV(RETVAL);
1223         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1224     }
1225     XSRETURN(1);
1226 }
1227
1228 XS(XS_Cwd_sys_is_rooted)
1229 {
1230     dXSARGS;
1231     if (items != 1)
1232         croak("Usage: Cwd::sys_is_rooted(path)");
1233     {
1234         char *  path = (char *)SvPV(ST(0),PL_na);
1235         bool    RETVAL;
1236
1237         RETVAL = sys_is_rooted(path);
1238         ST(0) = boolSV(RETVAL);
1239         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1240     }
1241     XSRETURN(1);
1242 }
1243
1244 XS(XS_Cwd_sys_is_relative)
1245 {
1246     dXSARGS;
1247     if (items != 1)
1248         croak("Usage: Cwd::sys_is_relative(path)");
1249     {
1250         char *  path = (char *)SvPV(ST(0),PL_na);
1251         bool    RETVAL;
1252
1253         RETVAL = sys_is_relative(path);
1254         ST(0) = boolSV(RETVAL);
1255         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1256     }
1257     XSRETURN(1);
1258 }
1259
1260 XS(XS_Cwd_sys_cwd)
1261 {
1262     dXSARGS;
1263     if (items != 0)
1264         croak("Usage: Cwd::sys_cwd()");
1265     {
1266         char p[MAXPATHLEN];
1267         char *  RETVAL;
1268         RETVAL = _getcwd2(p, MAXPATHLEN);
1269         ST(0) = sv_newmortal();
1270         sv_setpv((SV*)ST(0), RETVAL);
1271     }
1272     XSRETURN(1);
1273 }
1274
1275 XS(XS_Cwd_sys_abspath)
1276 {
1277     dXSARGS;
1278     if (items < 1 || items > 2)
1279         croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
1280     {
1281         char *  path = (char *)SvPV(ST(0),PL_na);
1282         char *  dir;
1283         char p[MAXPATHLEN];
1284         char *  RETVAL;
1285
1286         if (items < 2)
1287             dir = NULL;
1288         else {
1289             dir = (char *)SvPV(ST(1),PL_na);
1290         }
1291         if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1292             path += 2;
1293         }
1294         if (dir == NULL) {
1295             if (_abspath(p, path, MAXPATHLEN) == 0) {
1296                 RETVAL = p;
1297             } else {
1298                 RETVAL = NULL;
1299             }
1300         } else {
1301             /* Absolute with drive: */
1302             if ( sys_is_absolute(path) ) {
1303                 if (_abspath(p, path, MAXPATHLEN) == 0) {
1304                     RETVAL = p;
1305                 } else {
1306                     RETVAL = NULL;
1307                 }
1308             } else if (path[0] == '/' || path[0] == '\\') {
1309                 /* Rooted, but maybe on different drive. */
1310                 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1311                     char p1[MAXPATHLEN];
1312
1313                     /* Need to prepend the drive. */
1314                     p1[0] = dir[0];
1315                     p1[1] = dir[1];
1316                     Copy(path, p1 + 2, strlen(path) + 1, char);
1317                     RETVAL = p;
1318                     if (_abspath(p, p1, MAXPATHLEN) == 0) {
1319                         RETVAL = p;
1320                     } else {
1321                         RETVAL = NULL;
1322                     }
1323                 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1324                     RETVAL = p;
1325                 } else {
1326                     RETVAL = NULL;
1327                 }
1328             } else {
1329                 /* Either path is relative, or starts with a drive letter. */
1330                 /* If the path starts with a drive letter, then dir is
1331                    relevant only if
1332                    a/b) it is absolute/x:relative on the same drive.
1333                    c)   path is on current drive, and dir is rooted
1334                    In all the cases it is safe to drop the drive part
1335                    of the path. */
1336                 if ( !sys_is_relative(path) ) {
1337                     int is_drived;
1338
1339                     if ( ( ( sys_is_absolute(dir)
1340                              || (isALPHA(dir[0]) && dir[1] == ':'
1341                                  && strnicmp(dir, path,1) == 0))
1342                            && strnicmp(dir, path,1) == 0)
1343                          || ( !(isALPHA(dir[0]) && dir[1] == ':')
1344                               && toupper(path[0]) == current_drive())) {
1345                         path += 2;
1346                     } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1347                         RETVAL = p; goto done;
1348                     } else {
1349                         RETVAL = NULL; goto done;
1350                     }
1351                 }
1352                 {
1353                     /* Need to prepend the absolute path of dir. */
1354                     char p1[MAXPATHLEN];
1355
1356                     if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1357                         int l = strlen(p1);
1358
1359                         if (p1[ l - 1 ] != '/') {
1360                             p1[ l ] = '/';
1361                             l++;
1362                         }
1363                         Copy(path, p1 + l, strlen(path) + 1, char);
1364                         if (_abspath(p, p1, MAXPATHLEN) == 0) {
1365                             RETVAL = p;
1366                         } else {
1367                             RETVAL = NULL;
1368                         }
1369                     } else {
1370                         RETVAL = NULL;
1371                     }
1372                 }
1373               done:
1374             }
1375         }
1376         ST(0) = sv_newmortal();
1377         sv_setpv((SV*)ST(0), RETVAL);
1378     }
1379     XSRETURN(1);
1380 }
1381 typedef APIRET (*PELP)(PSZ path, ULONG type);
1382
1383 APIRET
1384 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1385 {
1386     loadByOrd(ord);                     /* Guarantied to load or die! */
1387     return (*(PELP)ExtFCN[ord])(path, type);
1388 }
1389
1390 #define extLibpath(type)                                                \
1391     (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH   \
1392                                                  : BEGIN_LIBPATH)))     \
1393      ? NULL : to )
1394
1395 #define extLibpath_set(p,type)                                  \
1396     (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH   \
1397                                                  : BEGIN_LIBPATH))))
1398
1399 XS(XS_Cwd_extLibpath)
1400 {
1401     dXSARGS;
1402     if (items < 0 || items > 1)
1403         croak("Usage: Cwd::extLibpath(type = 0)");
1404     {
1405         bool    type;
1406         char    to[1024];
1407         U32     rc;
1408         char *  RETVAL;
1409
1410         if (items < 1)
1411             type = 0;
1412         else {
1413             type = (int)SvIV(ST(0));
1414         }
1415
1416         RETVAL = extLibpath(type);
1417         ST(0) = sv_newmortal();
1418         sv_setpv((SV*)ST(0), RETVAL);
1419     }
1420     XSRETURN(1);
1421 }
1422
1423 XS(XS_Cwd_extLibpath_set)
1424 {
1425     dXSARGS;
1426     if (items < 1 || items > 2)
1427         croak("Usage: Cwd::extLibpath_set(s, type = 0)");
1428     {
1429         char *  s = (char *)SvPV(ST(0),PL_na);
1430         bool    type;
1431         U32     rc;
1432         bool    RETVAL;
1433
1434         if (items < 2)
1435             type = 0;
1436         else {
1437             type = (int)SvIV(ST(1));
1438         }
1439
1440         RETVAL = extLibpath_set(s, type);
1441         ST(0) = boolSV(RETVAL);
1442         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1443     }
1444     XSRETURN(1);
1445 }
1446
1447 int
1448 Xs_OS2_init()
1449 {
1450     char *file = __FILE__;
1451     {
1452         GV *gv;
1453
1454         if (_emx_env & 0x200) { /* OS/2 */
1455             newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
1456             newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
1457             newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
1458         }
1459         newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
1460         newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
1461         newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
1462         newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
1463         newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
1464         newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
1465         newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
1466         newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
1467         newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
1468         gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
1469         GvMULTI_on(gv);
1470 #ifdef PERL_IS_AOUT
1471         sv_setiv(GvSV(gv), 1);
1472 #endif
1473     }
1474 }
1475
1476 OS2_Perl_data_t OS2_Perl_data;
1477
1478 void
1479 Perl_OS2_init(char **env)
1480 {
1481     char *shell;
1482
1483     MALLOC_INIT;
1484     settmppath();
1485     OS2_Perl_data.xs_init = &Xs_OS2_init;
1486     if (environ == NULL) {
1487         environ = env;
1488     }
1489     if ( (shell = getenv("PERL_SH_DRIVE")) ) {
1490         New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
1491         strcpy(PL_sh_path, SH_PATH);
1492         PL_sh_path[0] = shell[0];
1493     } else if ( (shell = getenv("PERL_SH_DIR")) ) {
1494         int l = strlen(shell), i;
1495         if (shell[l-1] == '/' || shell[l-1] == '\\') {
1496             l--;
1497         }
1498         New(1304, PL_sh_path, l + 8, char);
1499         strncpy(PL_sh_path, shell, l);
1500         strcpy(PL_sh_path + l, "/sh.exe");
1501         for (i = 0; i < l; i++) {
1502             if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
1503         }
1504     }
1505     MUTEX_INIT(&start_thread_mutex);
1506 }
1507
1508 #undef tmpnam
1509 #undef tmpfile
1510
1511 char *
1512 my_tmpnam (char *str)
1513 {
1514     char *p = getenv("TMP"), *tpath;
1515     int len;
1516
1517     if (!p) p = getenv("TEMP");
1518     tpath = tempnam(p, "pltmp");
1519     if (str && tpath) {
1520         strcpy(str, tpath);
1521         return str;
1522     }
1523     return tpath;
1524 }
1525
1526 FILE *
1527 my_tmpfile ()
1528 {
1529     struct stat s;
1530
1531     stat(".", &s);
1532     if (s.st_mode & S_IWOTH) {
1533         return tmpfile();
1534     }
1535     return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
1536                                              grants TMP. */
1537 }
1538
1539 #undef flock
1540
1541 /* This code was contributed by Rocco Caputo. */
1542 int
1543 my_flock(int handle, int o)
1544 {
1545   FILELOCK      rNull, rFull;
1546   ULONG         timeout, handle_type, flag_word;
1547   APIRET        rc;
1548   int           blocking, shared;
1549   static int    use_my = -1;
1550
1551   if (use_my == -1) {
1552     char *s = getenv("USE_PERL_FLOCK");
1553     if (s)
1554         use_my = atoi(s);
1555     else
1556         use_my = 1;
1557   }
1558   if (!(_emx_env & 0x200) || !use_my)
1559     return flock(handle, o);    /* Delegate to EMX. */
1560
1561                                         // is this a file?
1562   if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
1563       (handle_type & 0xFF))
1564   {
1565     errno = EBADF;
1566     return -1;
1567   }
1568                                         // set lock/unlock ranges
1569   rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
1570   rFull.lRange = 0x7FFFFFFF;
1571                                         // set timeout for blocking
1572   timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
1573                                         // shared or exclusive?
1574   shared = (o & LOCK_SH) ? 1 : 0;
1575                                         // do not block the unlock
1576   if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
1577     rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
1578     switch (rc) {
1579       case 0:
1580         errno = 0;
1581         return 0;
1582       case ERROR_INVALID_HANDLE:
1583         errno = EBADF;
1584         return -1;
1585       case ERROR_SHARING_BUFFER_EXCEEDED:
1586         errno = ENOLCK;
1587         return -1;
1588       case ERROR_LOCK_VIOLATION:
1589         break;                          // not an error
1590       case ERROR_INVALID_PARAMETER:
1591       case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1592       case ERROR_READ_LOCKS_NOT_SUPPORTED:
1593         errno = EINVAL;
1594         return -1;
1595       case ERROR_INTERRUPT:
1596         errno = EINTR;
1597         return -1;
1598       default:
1599         errno = EINVAL;
1600         return -1;
1601     }
1602   }
1603                                         // lock may block
1604   if (o & (LOCK_SH | LOCK_EX)) {
1605                                         // for blocking operations
1606     for (;;) {
1607       rc =
1608         DosSetFileLocks(
1609                 handle,
1610                 &rNull,
1611                 &rFull,
1612                 timeout,
1613                 shared
1614         );
1615       switch (rc) {
1616         case 0:
1617           errno = 0;
1618           return 0;
1619         case ERROR_INVALID_HANDLE:
1620           errno = EBADF;
1621           return -1;
1622         case ERROR_SHARING_BUFFER_EXCEEDED:
1623           errno = ENOLCK;
1624           return -1;
1625         case ERROR_LOCK_VIOLATION:
1626           if (!blocking) {
1627             errno = EWOULDBLOCK;
1628             return -1;
1629           }
1630           break;
1631         case ERROR_INVALID_PARAMETER:
1632         case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1633         case ERROR_READ_LOCKS_NOT_SUPPORTED:
1634           errno = EINVAL;
1635           return -1;
1636         case ERROR_INTERRUPT:
1637           errno = EINTR;
1638           return -1;
1639         default:
1640           errno = EINVAL;
1641           return -1;
1642       }
1643                                         // give away timeslice
1644       DosSleep(1);
1645     }
1646   }
1647
1648   errno = 0;
1649   return 0;
1650 }