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