os2/os2.c

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