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