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