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