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     STRLEN n_a;
 166     if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET))
 167         croak("panic: COND_WAIT-reset: rc=%i", rc);
 168     if (m) MUTEX_UNLOCK(m);
 169     if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
 170         && (rc != ERROR_INTERRUPT))
 171         croak("panic: COND_WAIT: rc=%i", rc);
 172     if (rc == ERROR_INTERRUPT)
 173         errno = EINTR;
 174     if (m) MUTEX_LOCK(m);
 175 }
 176 #endif
 177
 178 /*****************************************************************************/
 179 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
 180 static PFN ExtFCN[2];                   /* Labeled by ord below. */
 181 static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
 182 #define ORD_QUERY_ELP   0
 183 #define ORD_SET_ELP     1
 184 struct PMWIN_entries_t PMWIN_entries;
 185
 186 APIRET
 187 loadByOrd(char *modname, ULONG ord)
 188 {
 189     if (ExtFCN[ord] == NULL) {
 190         static HMODULE hdosc = 0;
 191         BYTE buf[20];
 192         PFN fcn;
 193         APIRET rc;
 194
 195         if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf,
 196                                                   modname, &hdosc)))
 197             || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
 198             croak("This version of OS/2 does not support %s.%i",
 199                   modname, loadOrd[ord]);
 200         ExtFCN[ord] = fcn;
 201     }
 202     if ((long)ExtFCN[ord] == -1)
 203         croak("panic queryaddr");
 204 }
 205
 206 void
 207 init_PMWIN_entries(void)
 208 {
 209     static HMODULE hpmwin = 0;
 210     static const int ords[] = {
 211         763,                            /* Initialize */
 212         716,                            /* CreateMsgQueue */
 213         726,                            /* DestroyMsgQueue */
 214         918,                            /* PeekMsg */
 215         915,                            /* GetMsg */
 216         912,                            /* DispatchMsg */
 217     };
 218     BYTE buf[20];
 219     int i = 0;
 220     unsigned long rc;
 221
 222     if (hpmwin)
 223         return;
 224
 225     if (CheckOSError(DosLoadModule(buf, sizeof buf, "pmwin", &hpmwin)))
 226         croak("This version of OS/2 does not support pmwin: error in %s", buf);
 227     while (i <= 5) {
 228         if (CheckOSError(DosQueryProcAddr(hpmwin, ords[i], NULL,
 229                                           ((PFN*)&PMWIN_entries)+i)))
 230             croak("This version of OS/2 does not support pmwin.%d", ords[i]);
 231         i++;
 232     }
 233 }
 234
 235
 236 /* priorities */
 237 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
 238                                                self inverse. */
 239 #define QSS_INI_BUFFER 1024
 240
 241 PQTOPLEVEL
 242 get_sysinfo(ULONG pid, ULONG flags)
 243 {
 244     char *pbuffer;
 245     ULONG rc, buf_len = QSS_INI_BUFFER;
 246
 247     New(1322, pbuffer, buf_len, char);
 248     /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
 249     rc = QuerySysState(flags, pid, pbuffer, buf_len);
 250     while (rc == ERROR_BUFFER_OVERFLOW) {
 251         Renew(pbuffer, buf_len *= 2, char);
 252         rc = QuerySysState(flags, pid, pbuffer, buf_len);
 253     }
 254     if (rc) {
 255         FillOSError(rc);
 256         Safefree(pbuffer);
 257         return 0;
 258     }
 259     return (PQTOPLEVEL)pbuffer;
 260 }
 261
 262 #define PRIO_ERR 0x1111
 263
 264 static ULONG
 265 sys_prio(pid)
 266 {
 267   ULONG prio;
 268   PQTOPLEVEL psi;
 269
 270   psi = get_sysinfo(pid, QSS_PROCESS);
 271   if (!psi) {
 272       return PRIO_ERR;
 273   }
 274   if (pid != psi->procdata->pid) {
 275       Safefree(psi);
 276       croak("panic: wrong pid in sysinfo");
 277   }
 278   prio = psi->procdata->threads->priority;
 279   Safefree(psi);
 280   return prio;
 281 }
 282
 283 int
 284 setpriority(int which, int pid, int val)
 285 {
 286   ULONG rc, prio;
 287   PQTOPLEVEL psi;
 288
 289   prio = sys_prio(pid);
 290
 291   if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
 292   if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
 293       /* Do not change class. */
 294       return CheckOSError(DosSetPriority((pid < 0)
 295                                          ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
 296                                          0,
 297                                          (32 - val) % 32 - (prio & 0xFF),
 298                                          abs(pid)))
 299       ? -1 : 0;
 300   } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
 301       /* Documentation claims one can change both class and basevalue,
 302        * but I find it wrong. */
 303       /* Change class, but since delta == 0 denotes absolute 0, correct. */
 304       if (CheckOSError(DosSetPriority((pid < 0)
 305                                       ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
 306                                       priors[(32 - val) >> 5] + 1,
 307                                       0,
 308                                       abs(pid))))
 309           return -1;
 310       if ( ((32 - val) % 32) == 0 ) return 0;
 311       return CheckOSError(DosSetPriority((pid < 0)
 312                                          ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
 313                                          0,
 314                                          (32 - val) % 32,
 315                                          abs(pid)))
 316           ? -1 : 0;
 317   }
 318 /*   else return CheckOSError(DosSetPriority((pid < 0)  */
 319 /*                                        ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
 320 /*                                        priors[(32 - val) >> 5] + 1,  */
 321 /*                                        (32 - val) % 32 - (prio & 0xFF),  */
 322 /*                                        abs(pid))) */
 323 /*       ? -1 : 0; */
 324 }
 325
 326 int
 327 getpriority(int which /* ignored */, int pid)
 328 {
 329   TIB *tib;
 330   PIB *pib;
 331   ULONG rc, ret;
 332
 333   if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
 334   /* DosGetInfoBlocks has old priority! */
 335 /*   if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
 336 /*   if (pid != pib->pib_ulpid) { */
 337   ret = sys_prio(pid);
 338   if (ret == PRIO_ERR) {
 339       return -1;
 340   }
 341 /*   } else */
 342 /*       ret = tib->tib_ptib2->tib2_ulpri; */
 343   return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
 344 }
 345
 346 /*****************************************************************************/
 347 /* spawn */
 348
 349 /* There is no big sense to make it thread-specific, since signals
 350    are delivered to thread 1 only.  XXXX Maybe make it into an array? */
 351 static int spawn_pid;
 352 static int spawn_killed;
 353
 354 static Signal_t
 355 spawn_sighandler(int sig)
 356 {
 357     /* Some programs do not arrange for the keyboard signals to be
 358        delivered to them.  We need to deliver the signal manually. */
 359     /* We may get a signal only if
 360        a) kid does not receive keyboard signal: deliver it;
 361        b) kid already died, and we get a signal.  We may only hope
 362           that the pid number was not reused.
 363      */
 364
 365     if (spawn_killed)
 366         sig = SIGKILL;                  /* Try harder. */
 367     kill(spawn_pid, sig);
 368     spawn_killed = 1;
 369 }
 370
 371 static int
 372 result(int flag, int pid)
 373 {
 374         int r, status;
 375         Signal_t (*ihand)();     /* place to save signal during system() */
 376         Signal_t (*qhand)();     /* place to save signal during system() */
 377 #ifndef __EMX__
 378         RESULTCODES res;
 379         int rpid;
 380 #endif
 381
 382         if (pid < 0 || flag != 0)
 383                 return pid;
 384
 385 #ifdef __EMX__
 386         spawn_pid = pid;
 387         spawn_killed = 0;
 388         ihand = rsignal(SIGINT, &spawn_sighandler);
 389         qhand = rsignal(SIGQUIT, &spawn_sighandler);
 390         do {
 391             r = wait4pid(pid, &status, 0);
 392         } while (r == -1 && errno == EINTR);
 393         rsignal(SIGINT, ihand);
 394         rsignal(SIGQUIT, qhand);
 395
 396         PL_statusvalue = (U16)status;
 397         if (r < 0)
 398                 return -1;
 399         return status & 0xFFFF;
 400 #else
 401         ihand = rsignal(SIGINT, SIG_IGN);
 402         r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
 403         rsignal(SIGINT, ihand);
 404         PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
 405         if (r)
 406                 return -1;
 407         return PL_statusvalue;
 408 #endif
 409 }
 410
 411 #define EXECF_SPAWN 0
 412 #define EXECF_EXEC 1
 413 #define EXECF_TRUEEXEC 2
 414 #define EXECF_SPAWN_NOWAIT 3
 415
 416 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
 417
 418 static int
 419 my_type()
 420 {
 421     int rc;
 422     TIB *tib;
 423     PIB *pib;
 424
 425     if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
 426     if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
 427         return -1;
 428
 429     return (pib->pib_ultype);
 430 }
 431
 432 static ULONG
 433 file_type(char *path)
 434 {
 435     int rc;
 436     ULONG apptype;
 437
 438     if (!(_emx_env & 0x200))
 439         croak("file_type not implemented on DOS"); /* not OS/2. */
 440     if (CheckOSError(DosQueryAppType(path, &apptype))) {
 441         switch (rc) {
 442         case ERROR_FILE_NOT_FOUND:
 443         case ERROR_PATH_NOT_FOUND:
 444             return -1;
 445         case ERROR_ACCESS_DENIED:       /* Directory with this name found? */
 446             return -3;
 447         default:                        /* Found, but not an
 448                                            executable, or some other
 449                                            read error. */
 450             return -2;
 451         }
 452     }
 453     return apptype;
 454 }
 455
 456 static ULONG os2_mytype;
 457
 458 /* Spawn/exec a program, revert to shell if needed. */
 459 /* global PL_Argv[] contains arguments. */
 460
 461 int
 462 do_spawn_ve(really, flag, execf, inicmd, addflag)
 463 SV *really;
 464 U32 flag;
 465 U32 execf;
 466 char *inicmd;
 467 U32 addflag;
 468 {
 469     dTHR;
 470         int trueflag = flag;
 471         int rc, pass = 1;
 472         char *tmps;
 473         char buf[256], *s = 0, scrbuf[280];
 474         char *args[4];
 475         static char * fargs[4]
 476             = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
 477         char **argsp = fargs;
 478         char nargs = 4;
 479         int force_shell;
 480         int new_stderr = -1, nostderr = 0, fl_stderr;
 481         STRLEN n_a;
 482
 483         if (flag == P_WAIT)
 484                 flag = P_NOWAIT;
 485
 486       retry:
 487         if (strEQ(PL_Argv[0],"/bin/sh"))
 488             PL_Argv[0] = PL_sh_path;
 489
 490         if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\'
 491             && !(PL_Argv[0][0] && PL_Argv[0][1] == ':'
 492                  && (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\'))
 493             ) /* will spawnvp use PATH? */
 494             TAINT_ENV();        /* testing IFS here is overkill, probably */
 495         /* We should check PERL_SH* and PERLLIB_* as well? */
 496         if (!really || !*(tmps = SvPV(really, n_a)))
 497             tmps = PL_Argv[0];
 498
 499       reread:
 500         force_shell = 0;
 501         if (_emx_env & 0x200) { /* OS/2. */
 502             int type = file_type(tmps);
 503           type_again:
 504             if (type == -1) {           /* Not found */
 505                 errno = ENOENT;
 506                 rc = -1;
 507                 goto do_script;
 508             }
 509             else if (type == -2) {              /* Not an EXE */
 510                 errno = ENOEXEC;
 511                 rc = -1;
 512                 goto do_script;
 513             }
 514             else if (type == -3) {              /* Is a directory? */
 515                 /* Special-case this */
 516                 char tbuf[512];
 517                 int l = strlen(tmps);
 518
 519                 if (l + 5 <= sizeof tbuf) {
 520                     strcpy(tbuf, tmps);
 521                     strcpy(tbuf + l, ".exe");
 522                     type = file_type(tbuf);
 523                     if (type >= -3)
 524                         goto type_again;
 525                 }
 526
 527                 errno = ENOEXEC;
 528                 rc = -1;
 529                 goto do_script;
 530             }
 531             switch (type & 7) {
 532                 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
 533             case FAPPTYP_WINDOWAPI:
 534             {
 535                 if (os2_mytype != 3) {  /* not PM */
 536                     if (flag == P_NOWAIT)
 537                         flag = P_PM;
 538                     else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION)
 539                         warn("Starting PM process with flag=%d, mytype=%d",
 540                              flag, os2_mytype);
 541                 }
 542             }
 543             break;
 544             case FAPPTYP_NOTWINDOWCOMPAT:
 545             {
 546                 if (os2_mytype != 0) {  /* not full screen */
 547                     if (flag == P_NOWAIT)
 548                         flag = P_SESSION;
 549                     else if ((flag & 7) != P_SESSION)
 550                         warn("Starting Full Screen process with flag=%d, mytype=%d",
 551                              flag, os2_mytype);
 552                 }
 553             }
 554             break;
 555             case FAPPTYP_NOTSPEC:
 556                 /* Let the shell handle this... */
 557                 force_shell = 1;
 558                 goto doshell_args;
 559                 break;
 560             }
 561         }
 562
 563         if (addflag) {
 564             addflag = 0;
 565             new_stderr = dup(2);                /* Preserve stderr */
 566             if (new_stderr == -1) {
 567                 if (errno == EBADF)
 568                     nostderr = 1;
 569                 else {
 570                     rc = -1;
 571                     goto finish;
 572                 }
 573             } else
 574                 fl_stderr = fcntl(2, F_GETFD);
 575             rc = dup2(1,2);
 576             if (rc == -1)
 577                 goto finish;
 578             fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
 579         }
 580
 581 #if 0
 582         rc = result(trueflag, spawnvp(flag,tmps,PL_Argv));
 583 #else
 584         if (execf == EXECF_TRUEEXEC)
 585             rc = execvp(tmps,PL_Argv);
 586         else if (execf == EXECF_EXEC)
 587             rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
 588         else if (execf == EXECF_SPAWN_NOWAIT)
 589             rc = spawnvp(flag,tmps,PL_Argv);
 590         else                            /* EXECF_SPAWN */
 591             rc = result(trueflag,
 592                         spawnvp(flag,tmps,PL_Argv));
 593 #endif
 594         if (rc < 0 && pass == 1
 595             && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
 596               do_script:
 597             {
 598             int err = errno;
 599
 600             if (err == ENOENT || err == ENOEXEC) {
 601                 /* No such file, or is a script. */
 602                 /* Try adding script extensions to the file name, and
 603                    search on PATH. */
 604                 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
 605
 606                 if (scr) {
 607                     FILE *file;
 608                     char *s = 0, *s1;
 609                     int l;
 610
 611                     l = strlen(scr);
 612
 613                     if (l >= sizeof scrbuf) {
 614                        Safefree(scr);
 615                      longbuf:
 616                        warn("Size of scriptname too big: %d", l);
 617                        rc = -1;
 618                        goto finish;
 619                     }
 620                     strcpy(scrbuf, scr);
 621                     Safefree(scr);
 622                     scr = scrbuf;
 623
 624                     file = fopen(scr, "r");
 625                     PL_Argv[0] = scr;
 626                     if (!file)
 627                         goto panic_file;
 628                     if (!fgets(buf, sizeof buf, file)) { /* Empty... */
 629
 630                         buf[0] = 0;
 631                         fclose(file);
 632                         /* Special case: maybe from -Zexe build, so
 633                            there is an executable around (contrary to
 634                            documentation, DosQueryAppType sometimes (?)
 635                            does not append ".exe", so we could have
 636                            reached this place). */
 637                         if (l + 5 < sizeof scrbuf) {
 638                             strcpy(scrbuf + l, ".exe");
 639                             if (PerlLIO_stat(scrbuf,&PL_statbuf) >= 0
 640                                 && !S_ISDIR(PL_statbuf.st_mode)) {
 641                                 /* Found */
 642                                 tmps = scr;
 643                                 pass++;
 644                                 goto reread;
 645                             } else
 646                                 scrbuf[l] = 0;
 647                         } else
 648                             goto longbuf;
 649                     }
 650                     if (fclose(file) != 0) { /* Failure */
 651                       panic_file:
 652                         warn("Error reading \"%s\": %s",
 653                              scr, Strerror(errno));
 654                         buf[0] = 0;     /* Not #! */
 655                         goto doshell_args;
 656                     }
 657                     if (buf[0] == '#') {
 658                         if (buf[1] == '!')
 659                             s = buf + 2;
 660                     } else if (buf[0] == 'e') {
 661                         if (strnEQ(buf, "extproc", 7)
 662                             && isSPACE(buf[7]))
 663                             s = buf + 8;
 664                     } else if (buf[0] == 'E') {
 665                         if (strnEQ(buf, "EXTPROC", 7)
 666                             && isSPACE(buf[7]))
 667                             s = buf + 8;
 668                     }
 669                     if (!s) {
 670                         buf[0] = 0;     /* Not #! */
 671                         goto doshell_args;
 672                     }
 673
 674                     s1 = s;
 675                     nargs = 0;
 676                     argsp = args;
 677                     while (1) {
 678                         /* Do better than pdksh: allow a few args,
 679                            strip trailing whitespace.  */
 680                         while (isSPACE(*s))
 681                             s++;
 682                         if (*s == 0)
 683                             break;
 684                         if (nargs == 4) {
 685                             nargs = -1;
 686                             break;
 687                         }
 688                         args[nargs++] = s;
 689                         while (*s && !isSPACE(*s))
 690                             s++;
 691                         if (*s == 0)
 692                             break;
 693                         *s++ = 0;
 694                     }
 695                     if (nargs == -1) {
 696                         warn("Too many args on %.*s line of \"%s\"",
 697                              s1 - buf, buf, scr);
 698                         nargs = 4;
 699                         argsp = fargs;
 700                     }
 701                   doshell_args:
 702                     {
 703                         char **a = PL_Argv;
 704                         char *exec_args[2];
 705
 706                         if (force_shell
 707                             || (!buf[0] && file)) { /* File without magic */
 708                             /* In fact we tried all what pdksh would
 709                                try.  There is no point in calling
 710                                pdksh, we may just emulate its logic. */
 711                             char *shell = getenv("EXECSHELL");
 712                             char *shell_opt = NULL;
 713
 714                             if (!shell) {
 715                                 char *s;
 716
 717                                 shell_opt = "/c";
 718                                 shell = getenv("OS2_SHELL");
 719                                 if (inicmd) { /* No spaces at start! */
 720                                     s = inicmd;
 721                                     while (*s && !isSPACE(*s)) {
 722                                         if (*s++ = '/') {
 723                                             inicmd = NULL; /* Cannot use */
 724                                             break;
 725                                         }
 726                                     }
 727                                 }
 728                                 if (!inicmd) {
 729                                     s = PL_Argv[0];
 730                                     while (*s) {
 731                                         /* Dosish shells will choke on slashes
 732                                            in paths, fortunately, this is
 733                                            important for zeroth arg only. */
 734                                         if (*s == '/')
 735                                             *s = '\\';
 736                                         s++;
 737                                     }
 738                                 }
 739                             }
 740                             /* If EXECSHELL is set, we do not set */
 741
 742                             if (!shell)
 743                                 shell = ((_emx_env & 0x200)
 744                                          ? "c:/os2/cmd.exe"
 745                                          : "c:/command.com");
 746                             nargs = shell_opt ? 2 : 1;  /* shell file args */
 747                             exec_args[0] = shell;
 748                             exec_args[1] = shell_opt;
 749                             argsp = exec_args;
 750                             if (nargs == 2 && inicmd) {
 751                                 /* Use the original cmd line */
 752                                 /* XXXX This is good only until we refuse
 753                                         quoted arguments... */
 754                                 PL_Argv[0] = inicmd;
 755                                 PL_Argv[1] = Nullch;
 756                             }
 757                         } else if (!buf[0] && inicmd) { /* No file */
 758                             /* Start with the original cmdline. */
 759                             /* XXXX This is good only until we refuse
 760                                     quoted arguments... */
 761
 762                             PL_Argv[0] = inicmd;
 763                             PL_Argv[1] = Nullch;
 764                             nargs = 2;  /* shell -c */
 765                         }
 766
 767                         while (a[1])            /* Get to the end */
 768                             a++;
 769                         a++;                    /* Copy finil NULL too */
 770                         while (a >= PL_Argv) {
 771                             *(a + nargs) = *a;  /* PL_Argv was preallocated to be
 772                                                    long enough. */
 773                             a--;
 774                         }
 775                         while (nargs-- >= 0)
 776                             PL_Argv[nargs] = argsp[nargs];
 777                         /* Enable pathless exec if #! (as pdksh). */
 778                         pass = (buf[0] == '#' ? 2 : 3);
 779                         goto retry;
 780                     }
 781                 }
 782                 /* Not found: restore errno */
 783                 errno = err;
 784             }
 785           }
 786         } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
 787             char *no_dir = strrchr(PL_Argv[0], '/');
 788
 789             /* Do as pdksh port does: if not found with /, try without
 790                path. */
 791             if (no_dir) {
 792                 PL_Argv[0] = no_dir + 1;
 793                 pass++;
 794                 goto retry;
 795             }
 796         }
 797         if (rc < 0 && PL_dowarn)
 798             warn("Can't %s \"%s\": %s\n",
 799                  ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
 800                   ? "spawn" : "exec"),
 801                  PL_Argv[0], Strerror(errno));
 802         if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
 803             && ((trueflag & 0xFF) == P_WAIT))
 804             rc = 255 << 8; /* Emulate the fork(). */
 805
 806   finish:
 807     if (new_stderr != -1) {     /* How can we use error codes? */
 808         dup2(new_stderr, 2);
 809         close(new_stderr);
 810         fcntl(2, F_SETFD, fl_stderr);
 811     } else if (nostderr)
 812        close(2);
 813     return rc;
 814 }
 815
 816 /* Array spawn.  */
 817 int
 818 do_aspawn(really,mark,sp)
 819 SV *really;
 820 register SV **mark;
 821 register SV **sp;
 822 {
 823     dTHR;
 824     register char **a;
 825     char *tmps = NULL;
 826     int rc;
 827     int flag = P_WAIT, trueflag, err, secondtry = 0;
 828     STRLEN n_a;
 829
 830     if (sp > mark) {
 831         New(1301,PL_Argv, sp - mark + 3, char*);
 832         a = PL_Argv;
 833
 834         if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
 835                 ++mark;
 836                 flag = SvIVx(*mark);
 837         }
 838
 839         while (++mark <= sp) {
 840             if (*mark)
 841                 *a++ = SvPVx(*mark, n_a);
 842             else
 843                 *a++ = "";
 844         }
 845         *a = Nullch;
 846
 847         rc = do_spawn_ve(really, flag, EXECF_SPAWN, NULL, 0);
 848     } else
 849         rc = -1;
 850     do_execfree();
 851     return rc;
 852 }
 853
 854 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
 855 int
 856 do_spawn2(cmd, execf)
 857 char *cmd;
 858 int execf;
 859 {
 860     register char **a;
 861     register char *s;
 862     char flags[10];
 863     char *shell, *copt, *news = NULL;
 864     int rc, err, seenspace = 0, mergestderr = 0;
 865     char fullcmd[MAXNAMLEN + 1];
 866
 867 #ifdef TRYSHELL
 868     if ((shell = getenv("EMXSHELL")) != NULL)
 869         copt = "-c";
 870     else if ((shell = getenv("SHELL")) != NULL)
 871         copt = "-c";
 872     else if ((shell = getenv("COMSPEC")) != NULL)
 873         copt = "/C";
 874     else
 875         shell = "cmd.exe";
 876 #else
 877     /* Consensus on perl5-porters is that it is _very_ important to
 878        have a shell which will not change between computers with the
 879        same architecture, to avoid "action on a distance".
 880        And to have simple build, this shell should be sh. */
 881     shell = PL_sh_path;
 882     copt = "-c";
 883 #endif
 884
 885     while (*cmd && isSPACE(*cmd))
 886         cmd++;
 887
 888     if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
 889         STRLEN l = strlen(PL_sh_path);
 890
 891         New(1302, news, strlen(cmd) - 7 + l + 1, char);
 892         strcpy(news, PL_sh_path);
 893         strcpy(news + l, cmd + 7);
 894         cmd = news;
 895     }
 896
 897     /* save an extra exec if possible */
 898     /* see if there are shell metacharacters in it */
 899
 900     if (*cmd == '.' && isSPACE(cmd[1]))
 901         goto doshell;
 902
 903     if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
 904         goto doshell;
 905
 906     for (s = cmd; *s && isALPHA(*s); s++) ;     /* catch VAR=val gizmo */
 907     if (*s == '=')
 908         goto doshell;
 909
 910     for (s = cmd; *s; s++) {
 911         if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
 912             if (*s == '\n' && s[1] == '\0') {
 913                 *s = '\0';
 914                 break;
 915             } else if (*s == '\\' && !seenspace) {
 916                 continue;               /* Allow backslashes in names */
 917             } else if (*s == '>' && s >= cmd + 3
 918                         && s[-1] == '2' && s[1] == '&' && s[2] == '1'
 919                         && isSPACE(s[-2]) ) {
 920                 char *t = s + 3;
 921
 922                 while (*t && isSPACE(*t))
 923                     t++;
 924                 if (!*t) {
 925                     s[-2] = '\0';
 926                     mergestderr = 1;
 927                     break;              /* Allow 2>&1 as the last thing */
 928                 }
 929             }
 930             /* We do not convert this to do_spawn_ve since shell
 931                should be smart enough to start itself gloriously. */
 932           doshell:
 933             if (execf == EXECF_TRUEEXEC)
 934                 rc = execl(shell,shell,copt,cmd,(char*)0);
 935             else if (execf == EXECF_EXEC)
 936                 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
 937             else if (execf == EXECF_SPAWN_NOWAIT)
 938                 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
 939             else {
 940                 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
 941                 rc = result(P_WAIT,
 942                             spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
 943                 if (rc < 0 && PL_dowarn)
 944                     warn("Can't %s \"%s\": %s",
 945                          (execf == EXECF_SPAWN ? "spawn" : "exec"),
 946                          shell, Strerror(errno));
 947                 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
 948             }
 949             if (news)
 950                 Safefree(news);
 951             return rc;
 952         } else if (*s == ' ' || *s == '\t') {
 953             seenspace = 1;
 954         }
 955     }
 956
 957     /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
 958     New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
 959     PL_Cmd = savepvn(cmd, s-cmd);
 960     a = PL_Argv;
 961     for (s = PL_Cmd; *s;) {
 962         while (*s && isSPACE(*s)) s++;
 963         if (*s)
 964             *(a++) = s;
 965         while (*s && !isSPACE(*s)) s++;
 966         if (*s)
 967             *s++ = '\0';
 968     }
 969     *a = Nullch;
 970     if (PL_Argv[0])
 971         rc = do_spawn_ve(NULL, 0, execf, cmd, mergestderr);
 972     else
 973         rc = -1;
 974     if (news)
 975         Safefree(news);
 976     do_execfree();
 977     return rc;
 978 }
 979
 980 int
 981 do_spawn(cmd)
 982 char *cmd;
 983 {
 984     return do_spawn2(cmd, EXECF_SPAWN);
 985 }
 986
 987 int
 988 do_spawn_nowait(cmd)
 989 char *cmd;
 990 {
 991     return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
 992 }
 993
 994 bool
 995 do_exec(cmd)
 996 char *cmd;
 997 {
 998     do_spawn2(cmd, EXECF_EXEC);
 999     return FALSE;
1000 }
1001
1002 bool
1003 os2exec(cmd)
1004 char *cmd;
1005 {
1006     return do_spawn2(cmd, EXECF_TRUEEXEC);
1007 }
1008
1009 PerlIO *
1010 my_syspopen(cmd,mode)
1011 char    *cmd;
1012 char    *mode;
1013 {
1014 #ifndef USE_POPEN
1015
1016     int p[2];
1017     register I32 this, that, newfd;
1018     register I32 pid, rc;
1019     PerlIO *res;
1020     SV *sv;
1021     int fh_fl;
1022
1023     /* `this' is what we use in the parent, `that' in the child. */
1024     this = (*mode == 'w');
1025     that = !this;
1026     if (PL_tainting) {
1027         taint_env();
1028         taint_proper("Insecure %s%s", "EXEC");
1029     }
1030     if (pipe(p) < 0)
1031         return Nullfp;
1032     /* Now we need to spawn the child. */
1033     if (p[this] == (*mode == 'r')) {    /* if fh 0/1 was initially closed. */
1034         int new = dup(p[this]);
1035
1036         if (new == -1)
1037             goto closepipes;
1038         close(p[this]);
1039         p[this] = new;
1040     }
1041     newfd = dup(*mode == 'r');          /* Preserve std* */
1042     if (newfd == -1) {
1043         /* This cannot happen due to fh being bad after pipe(), since
1044            pipe() should have created fh 0 and 1 even if they were
1045            initially closed.  But we closed p[this] before.  */
1046         if (errno != EBADF) {
1047           closepipes:
1048             close(p[0]);
1049             close(p[1]);
1050             return Nullfp;
1051         }
1052     } else
1053         fh_fl = fcntl(*mode == 'r', F_GETFD);
1054     if (p[that] != (*mode == 'r')) {    /* if fh 0/1 was initially closed. */
1055         dup2(p[that], *mode == 'r');
1056         close(p[that]);
1057     }
1058     /* Where is `this' and newfd now? */
1059     fcntl(p[this], F_SETFD, FD_CLOEXEC);
1060     if (newfd != -1)
1061         fcntl(newfd, F_SETFD, FD_CLOEXEC);
1062     pid = do_spawn_nowait(cmd);
1063     if (newfd == -1)
1064         close(*mode == 'r');            /* It was closed initially */
1065     else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
1066         dup2(newfd, *mode == 'r');      /* Return std* back. */
1067         close(newfd);
1068         fcntl(*mode == 'r', F_SETFD, fh_fl);
1069     } else
1070         fcntl(*mode == 'r', F_SETFD, fh_fl);
1071     if (p[that] == (*mode == 'r'))
1072         close(p[that]);
1073     if (pid == -1) {
1074         close(p[this]);
1075         return Nullfp;
1076     }
1077     if (p[that] < p[this]) {            /* Make fh as small as possible */
1078         dup2(p[this], p[that]);
1079         close(p[this]);
1080         p[this] = p[that];
1081     }
1082     sv = *av_fetch(PL_fdpid,p[this],TRUE);
1083     (void)SvUPGRADE(sv,SVt_IV);
1084     SvIVX(sv) = pid;
1085     PL_forkprocess = pid;
1086     return PerlIO_fdopen(p[this], mode);
1087
1088 #else  /* USE_POPEN */
1089
1090     PerlIO *res;
1091     SV *sv;
1092
1093 #  ifdef TRYSHELL
1094     res = popen(cmd, mode);
1095 #  else
1096     char *shell = getenv("EMXSHELL");
1097
1098     my_setenv("EMXSHELL", PL_sh_path);
1099     res = popen(cmd, mode);
1100     my_setenv("EMXSHELL", shell);
1101 #  endif
1102     sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1103     (void)SvUPGRADE(sv,SVt_IV);
1104     SvIVX(sv) = -1;                     /* A cooky. */
1105     return res;
1106
1107 #endif /* USE_POPEN */
1108
1109 }
1110
1111 /******************************************************************/
1112
1113 #ifndef HAS_FORK
1114 int
1115 fork(void)
1116 {
1117     croak(PL_no_func, "Unsupported function fork");
1118     errno = EINVAL;
1119     return -1;
1120 }
1121 #endif
1122
1123 /*******************************************************************/
1124 /* not implemented in EMX 0.9a */
1125
1126 void *  ctermid(x)      { return 0; }
1127
1128 #ifdef MYTTYNAME /* was not in emx0.9a */
1129 void *  ttyname(x)      { return 0; }
1130 #endif
1131
1132 /******************************************************************/
1133 /* my socket forwarders - EMX lib only provides static forwarders */
1134
1135 static HMODULE htcp = 0;
1136
1137 static void *
1138 tcp0(char *name)
1139 {
1140     static BYTE buf[20];
1141     PFN fcn;
1142
1143     if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
1144     if (!htcp)
1145         DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1146     if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1147         return (void *) ((void * (*)(void)) fcn) ();
1148     return 0;
1149 }
1150
1151 static void
1152 tcp1(char *name, int arg)
1153 {
1154     static BYTE buf[20];
1155     PFN fcn;
1156
1157     if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
1158     if (!htcp)
1159         DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1160     if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1161         ((void (*)(int)) fcn) (arg);
1162 }
1163
1164 void *  gethostent()    { return tcp0("GETHOSTENT");  }
1165 void *  getnetent()     { return tcp0("GETNETENT");   }
1166 void *  getprotoent()   { return tcp0("GETPROTOENT"); }
1167 void *  getservent()    { return tcp0("GETSERVENT");  }
1168 void    sethostent(x)   { tcp1("SETHOSTENT",  x); }
1169 void    setnetent(x)    { tcp1("SETNETENT",   x); }
1170 void    setprotoent(x)  { tcp1("SETPROTOENT", x); }
1171 void    setservent(x)   { tcp1("SETSERVENT",  x); }
1172 void    endhostent()    { tcp0("ENDHOSTENT");  }
1173 void    endnetent()     { tcp0("ENDNETENT");   }
1174 void    endprotoent()   { tcp0("ENDPROTOENT"); }
1175 void    endservent()    { tcp0("ENDSERVENT");  }
1176
1177 /*****************************************************************************/
1178 /* not implemented in C Set++ */
1179
1180 #ifndef __EMX__
1181 int     setuid(x)       { errno = EINVAL; return -1; }
1182 int     setgid(x)       { errno = EINVAL; return -1; }
1183 #endif
1184
1185 /*****************************************************************************/
1186 /* stat() hack for char/block device */
1187
1188 #if OS2_STAT_HACK
1189
1190     /* First attempt used DosQueryFSAttach which crashed the system when
1191        used with 5.001. Now just look for /dev/. */
1192
1193 int
1194 os2_stat(char *name, struct stat *st)
1195 {
1196     static int ino = SHRT_MAX;
1197
1198     if (stricmp(name, "/dev/con") != 0
1199      && stricmp(name, "/dev/tty") != 0)
1200         return stat(name, st);
1201
1202     memset(st, 0, sizeof *st);
1203     st->st_mode = S_IFCHR|0666;
1204     st->st_ino = (ino-- & 0x7FFF);
1205     st->st_nlink = 1;
1206     return 0;
1207 }
1208
1209 #endif
1210
1211 #ifdef USE_PERL_SBRK
1212
1213 /* SBRK() emulation, mostly moved to malloc.c. */
1214
1215 void *
1216 sys_alloc(int size) {
1217     void *got;
1218     APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1219
1220     if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1221         return (void *) -1;
1222     } else if ( rc )
1223         croak("Got an error from DosAllocMem: %li", (long)rc);
1224     return got;
1225 }
1226
1227 #endif /* USE_PERL_SBRK */
1228
1229 /* tmp path */
1230
1231 char *tmppath = TMPPATH1;
1232
1233 void
1234 settmppath()
1235 {
1236     char *p = getenv("TMP"), *tpath;
1237     int len;
1238
1239     if (!p) p = getenv("TEMP");
1240     if (!p) return;
1241     len = strlen(p);
1242     tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1243     strcpy(tpath, p);
1244     tpath[len] = '/';
1245     strcpy(tpath + len + 1, TMPPATH1);
1246     tmppath = tpath;
1247 }
1248
1249 #include "XSUB.h"
1250
1251 XS(XS_File__Copy_syscopy)
1252 {
1253     dXSARGS;
1254     if (items < 2 || items > 3)
1255         croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
1256     {
1257         STRLEN n_a;
1258         char *  src = (char *)SvPV(ST(0),n_a);
1259         char *  dst = (char *)SvPV(ST(1),n_a);
1260         U32     flag;
1261         int     RETVAL, rc;
1262
1263         if (items < 3)
1264             flag = 0;
1265         else {
1266             flag = (unsigned long)SvIV(ST(2));
1267         }
1268
1269         RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1270         ST(0) = sv_newmortal();
1271         sv_setiv(ST(0), (IV)RETVAL);
1272     }
1273     XSRETURN(1);
1274 }
1275
1276 #include "patchlevel.h"
1277
1278 char *
1279 mod2fname(sv)
1280      SV   *sv;
1281 {
1282     static char fname[9];
1283     int pos = 6, len, avlen;
1284     unsigned int sum = 0;
1285     AV  *av;
1286     SV  *svp;
1287     char *s;
1288     STRLEN n_a;
1289
1290     if (!SvROK(sv)) croak("Not a reference given to mod2fname");
1291     sv = SvRV(sv);
1292     if (SvTYPE(sv) != SVt_PVAV)
1293       croak("Not array reference given to mod2fname");
1294
1295     avlen = av_len((AV*)sv);
1296     if (avlen < 0)
1297       croak("Empty array reference given to mod2fname");
1298
1299     s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1300     strncpy(fname, s, 8);
1301     len = strlen(s);
1302     if (len < 6) pos = len;
1303     while (*s) {
1304         sum = 33 * sum + *(s++);        /* Checksumming first chars to
1305                                          * get the capitalization into c.s. */
1306     }
1307     avlen --;
1308     while (avlen >= 0) {
1309         s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1310         while (*s) {
1311             sum = 33 * sum + *(s++);    /* 7 is primitive mod 13. */
1312         }
1313         avlen --;
1314     }
1315 #ifdef USE_THREADS
1316     sum++;                              /* Avoid conflict of DLLs in memory. */
1317 #endif
1318     sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2;  /*  */
1319     fname[pos] = 'A' + (sum % 26);
1320     fname[pos + 1] = 'A' + (sum / 26 % 26);
1321     fname[pos + 2] = '\0';
1322     return (char *)fname;
1323 }
1324
1325 XS(XS_DynaLoader_mod2fname)
1326 {
1327     dXSARGS;
1328     if (items != 1)
1329         croak("Usage: DynaLoader::mod2fname(sv)");
1330     {
1331         SV *    sv = ST(0);
1332         char *  RETVAL;
1333
1334         RETVAL = mod2fname(sv);
1335         ST(0) = sv_newmortal();
1336         sv_setpv((SV*)ST(0), RETVAL);
1337     }
1338     XSRETURN(1);
1339 }
1340
1341 char *
1342 os2error(int rc)
1343 {
1344         static char buf[300];
1345         ULONG len;
1346
1347         if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1348         if (rc == 0)
1349                 return NULL;
1350         if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1351                 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1352         else
1353                 buf[len] = '\0';
1354         if (len > 0 && buf[len - 1] == '\n')
1355             buf[len - 1] = '\0';
1356         if (len > 1 && buf[len - 2] == '\r')
1357             buf[len - 2] = '\0';
1358         if (len > 2 && buf[len - 3] == '.')
1359             buf[len - 3] = '\0';
1360         return buf;
1361 }
1362
1363 char *
1364 perllib_mangle(char *s, unsigned int l)
1365 {
1366     static char *newp, *oldp;
1367     static int newl, oldl, notfound;
1368     static char ret[STATIC_FILE_LENGTH+1];
1369
1370     if (!newp && !notfound) {
1371         newp = getenv("PERLLIB_PREFIX");
1372         if (newp) {
1373             char *s;
1374
1375             oldp = newp;
1376             while (*newp && !isSPACE(*newp) && *newp != ';') {
1377                 newp++; oldl++;         /* Skip digits. */
1378             }
1379             while (*newp && (isSPACE(*newp) || *newp == ';')) {
1380                 newp++;                 /* Skip whitespace. */
1381             }
1382             newl = strlen(newp);
1383             if (newl == 0 || oldl == 0) {
1384                 croak("Malformed PERLLIB_PREFIX");
1385             }
1386             strcpy(ret, newp);
1387             s = ret;
1388             while (*s) {
1389                 if (*s == '\\') *s = '/';
1390                 s++;
1391             }
1392         } else {
1393             notfound = 1;
1394         }
1395     }
1396     if (!newp) {
1397         return s;
1398     }
1399     if (l == 0) {
1400         l = strlen(s);
1401     }
1402     if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1403         return s;
1404     }
1405     if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1406         croak("Malformed PERLLIB_PREFIX");
1407     }
1408     strcpy(ret + newl, s + oldl);
1409     return ret;
1410 }
1411
1412 unsigned long
1413 Perl_hab_GET()                  /* Needed if perl.h cannot be included */
1414 {
1415     return perl_hab_GET();
1416 }
1417
1418 HMQ
1419 Perl_Register_MQ(int serve)
1420 {
1421     PPIB pib;
1422     PTIB tib;
1423
1424     if (Perl_os2_initial_mode++)
1425         return Perl_hmq;
1426     DosGetInfoBlocks(&tib, &pib);
1427     Perl_os2_initial_mode = pib->pib_ultype;
1428     Perl_hmq_refcnt = 1;
1429     /* Try morphing into a PM application. */
1430     if (pib->pib_ultype != 3)           /* 2 is VIO */
1431         pib->pib_ultype = 3;            /* 3 is PM */
1432     init_PMWIN_entries();
1433     /* 64 messages if before OS/2 3.0, ignored otherwise */
1434     Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1435     if (!Perl_hmq) {
1436         static int cnt;
1437         if (cnt++)
1438             _exit(188);                 /* Panic can try to create a window. */
1439         croak("Cannot create a message queue, or morph to a PM application");
1440     }
1441     return Perl_hmq;
1442 }
1443
1444 int
1445 Perl_Serve_Messages(int force)
1446 {
1447     int cnt = 0;
1448     QMSG msg;
1449
1450     if (Perl_hmq_servers && !force)
1451         return 0;
1452     if (!Perl_hmq_refcnt)
1453         croak("No message queue");
1454     while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1455         cnt++;
1456         if (msg.msg == WM_QUIT)
1457             croak("QUITing...");
1458         (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1459     }
1460     return cnt;
1461 }
1462
1463 int
1464 Perl_Process_Messages(int force, I32 *cntp)
1465 {
1466     QMSG msg;
1467
1468     if (Perl_hmq_servers && !force)
1469         return 0;
1470     if (!Perl_hmq_refcnt)
1471         croak("No message queue");
1472     while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1473         if (cntp)
1474             (*cntp)++;
1475         (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1476         if (msg.msg == WM_DESTROY)
1477             return -1;
1478         if (msg.msg == WM_CREATE)
1479             return +1;
1480     }
1481     croak("QUITing...");
1482 }
1483
1484 void
1485 Perl_Deregister_MQ(int serve)
1486 {
1487     PPIB pib;
1488     PTIB tib;
1489
1490     if (--Perl_hmq_refcnt == 0) {
1491         (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1492         Perl_hmq = 0;
1493         /* Try morphing back from a PM application. */
1494         if (pib->pib_ultype == 3)               /* 3 is PM */
1495             pib->pib_ultype = Perl_os2_initial_mode;
1496         else
1497             warn("Unexpected program mode %d when morphing back from PM",
1498                  pib->pib_ultype);
1499     }
1500 }
1501
1502 extern void dlopen();
1503 void *fakedl = &dlopen;         /* Pull in dynaloading part. */
1504
1505 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1506                                 && ((path)[2] == '/' || (path)[2] == '\\'))
1507 #define sys_is_rooted _fnisabs
1508 #define sys_is_relative _fnisrel
1509 #define current_drive _getdrive
1510
1511 #undef chdir                            /* Was _chdir2. */
1512 #define sys_chdir(p) (chdir(p) == 0)
1513 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1514
1515 static int DOS_harderr_state = -1;
1516
1517 XS(XS_OS2_Error)
1518 {
1519     dXSARGS;
1520     if (items != 2)
1521         croak("Usage: OS2::Error(harderr, exception)");
1522     {
1523         int     arg1 = SvIV(ST(0));
1524         int     arg2 = SvIV(ST(1));
1525         int     a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1526                      | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1527         int     RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1528         unsigned long rc;
1529
1530         if (CheckOSError(DosError(a)))
1531             croak("DosError(%d) failed", a);
1532         ST(0) = sv_newmortal();
1533         if (DOS_harderr_state >= 0)
1534             sv_setiv(ST(0), DOS_harderr_state);
1535         DOS_harderr_state = RETVAL;
1536     }
1537     XSRETURN(1);
1538 }
1539
1540 static signed char DOS_suppression_state = -1;
1541
1542 XS(XS_OS2_Errors2Drive)
1543 {
1544     dXSARGS;
1545     if (items != 1)
1546         croak("Usage: OS2::Errors2Drive(drive)");
1547     {
1548         STRLEN n_a;
1549         SV  *sv = ST(0);
1550         int     suppress = SvOK(sv);
1551         char    *s = suppress ? SvPV(sv, n_a) : NULL;
1552         char    drive = (s ? *s : 0);
1553         unsigned long rc;
1554
1555         if (suppress && !isALPHA(drive))
1556             croak("Non-char argument '%c' to OS2::Errors2Drive()", drive);
1557         if (CheckOSError(DosSuppressPopUps((suppress
1558                                             ? SPU_ENABLESUPPRESSION
1559                                             : SPU_DISABLESUPPRESSION),
1560                                            drive)))
1561             croak("DosSuppressPopUps(%c) failed", drive);
1562         ST(0) = sv_newmortal();
1563         if (DOS_suppression_state > 0)
1564             sv_setpvn(ST(0), &DOS_suppression_state, 1);
1565         else if (DOS_suppression_state == 0)
1566             sv_setpvn(ST(0), "", 0);
1567         DOS_suppression_state = drive;
1568     }
1569     XSRETURN(1);
1570 }
1571
1572 static const char * const si_fields[QSV_MAX] = {
1573   "MAX_PATH_LENGTH",
1574   "MAX_TEXT_SESSIONS",
1575   "MAX_PM_SESSIONS",
1576   "MAX_VDM_SESSIONS",
1577   "BOOT_DRIVE",
1578   "DYN_PRI_VARIATION",
1579   "MAX_WAIT",
1580   "MIN_SLICE",
1581   "MAX_SLICE",
1582   "PAGE_SIZE",
1583   "VERSION_MAJOR",
1584   "VERSION_MINOR",
1585   "VERSION_REVISION",
1586   "MS_COUNT",
1587   "TIME_LOW",
1588   "TIME_HIGH",
1589   "TOTPHYSMEM",
1590   "TOTRESMEM",
1591   "TOTAVAILMEM",
1592   "MAXPRMEM",
1593   "MAXSHMEM",
1594   "TIMER_INTERVAL",
1595   "MAX_COMP_LENGTH",
1596   "FOREGROUND_FS_SESSION",
1597   "FOREGROUND_PROCESS"
1598 };
1599
1600 XS(XS_OS2_SysInfo)
1601 {
1602     dXSARGS;
1603     if (items != 0)
1604         croak("Usage: OS2::SysInfo()");
1605     {
1606         ULONG   si[QSV_MAX] = {0};      /* System Information Data Buffer */
1607         APIRET  rc      = NO_ERROR;     /* Return code            */
1608         int i = 0, j = 0;
1609
1610         if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
1611                                          QSV_MAX, /* information */
1612                                          (PVOID)si,
1613                                          sizeof(si))))
1614             croak("DosQuerySysInfo() failed");
1615         EXTEND(SP,2*QSV_MAX);
1616         while (i < QSV_MAX) {
1617             ST(j) = sv_newmortal();
1618             sv_setpv(ST(j++), si_fields[i]);
1619             ST(j) = sv_newmortal();
1620             sv_setiv(ST(j++), si[i]);
1621             i++;
1622         }
1623     }
1624     XSRETURN(2 * QSV_MAX);
1625 }
1626
1627 XS(XS_OS2_BootDrive)
1628 {
1629     dXSARGS;
1630     if (items != 0)
1631         croak("Usage: OS2::BootDrive()");
1632     {
1633         ULONG   si[1] = {0};    /* System Information Data Buffer */
1634         APIRET  rc    = NO_ERROR;       /* Return code            */
1635         char c;
1636
1637         if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
1638                                          (PVOID)si, sizeof(si))))
1639             croak("DosQuerySysInfo() failed");
1640         ST(0) = sv_newmortal();
1641         c = 'a' - 1 + si[0];
1642         sv_setpvn(ST(0), &c, 1);
1643     }
1644     XSRETURN(1);
1645 }
1646
1647 XS(XS_OS2_MorphPM)
1648 {
1649     dXSARGS;
1650     if (items != 1)
1651         croak("Usage: OS2::MorphPM(serve)");
1652     {
1653         bool  serve = SvOK(ST(0));
1654         unsigned long   pmq = perl_hmq_GET(serve);
1655
1656         ST(0) = sv_newmortal();
1657         sv_setiv(ST(0), pmq);
1658     }
1659     XSRETURN(1);
1660 }
1661
1662 XS(XS_OS2_UnMorphPM)
1663 {
1664     dXSARGS;
1665     if (items != 1)
1666         croak("Usage: OS2::UnMorphPM(serve)");
1667     {
1668         bool  serve = SvOK(ST(0));
1669
1670         perl_hmq_UNSET(serve);
1671     }
1672     XSRETURN(0);
1673 }
1674
1675 XS(XS_OS2_Serve_Messages)
1676 {
1677     dXSARGS;
1678     if (items != 1)
1679         croak("Usage: OS2::Serve_Messages(force)");
1680     {
1681         bool  force = SvOK(ST(0));
1682         unsigned long   cnt = Perl_Serve_Messages(force);
1683
1684         ST(0) = sv_newmortal();
1685         sv_setiv(ST(0), cnt);
1686     }
1687     XSRETURN(1);
1688 }
1689
1690 XS(XS_OS2_Process_Messages)
1691 {
1692     dXSARGS;
1693     if (items < 1 || items > 2)
1694         croak("Usage: OS2::Process_Messages(force [, cnt])");
1695     {
1696         bool  force = SvOK(ST(0));
1697         unsigned long   cnt;
1698         I32 *cntp = NULL;
1699
1700         if (items == 2) {
1701             SV *sv = ST(1);
1702             int fake = SvIV(sv);        /* Force SvIVX */
1703
1704             if (!SvIOK(sv))
1705                 croak("Can't upgrade count to IV");
1706             cntp = &SvIVX(sv);
1707         }
1708         cnt =  Perl_Process_Messages(force, cntp);
1709         ST(0) = sv_newmortal();
1710         sv_setiv(ST(0), cnt);
1711     }
1712     XSRETURN(1);
1713 }
1714
1715 XS(XS_Cwd_current_drive)
1716 {
1717     dXSARGS;
1718     if (items != 0)
1719         croak("Usage: Cwd::current_drive()");
1720     {
1721         char    RETVAL;
1722
1723         RETVAL = current_drive();
1724         ST(0) = sv_newmortal();
1725         sv_setpvn(ST(0), (char *)&RETVAL, 1);
1726     }
1727     XSRETURN(1);
1728 }
1729
1730 XS(XS_Cwd_sys_chdir)
1731 {
1732     dXSARGS;
1733     if (items != 1)
1734         croak("Usage: Cwd::sys_chdir(path)");
1735     {
1736         STRLEN n_a;
1737         char *  path = (char *)SvPV(ST(0),n_a);
1738         bool    RETVAL;
1739
1740         RETVAL = sys_chdir(path);
1741         ST(0) = boolSV(RETVAL);
1742         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1743     }
1744     XSRETURN(1);
1745 }
1746
1747 XS(XS_Cwd_change_drive)
1748 {
1749     dXSARGS;
1750     if (items != 1)
1751         croak("Usage: Cwd::change_drive(d)");
1752     {
1753         STRLEN n_a;
1754         char    d = (char)*SvPV(ST(0),n_a);
1755         bool    RETVAL;
1756
1757         RETVAL = change_drive(d);
1758         ST(0) = boolSV(RETVAL);
1759         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1760     }
1761     XSRETURN(1);
1762 }
1763
1764 XS(XS_Cwd_sys_is_absolute)
1765 {
1766     dXSARGS;
1767     if (items != 1)
1768         croak("Usage: Cwd::sys_is_absolute(path)");
1769     {
1770         STRLEN n_a;
1771         char *  path = (char *)SvPV(ST(0),n_a);
1772         bool    RETVAL;
1773
1774         RETVAL = sys_is_absolute(path);
1775         ST(0) = boolSV(RETVAL);
1776         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1777     }
1778     XSRETURN(1);
1779 }
1780
1781 XS(XS_Cwd_sys_is_rooted)
1782 {
1783     dXSARGS;
1784     if (items != 1)
1785         croak("Usage: Cwd::sys_is_rooted(path)");
1786     {
1787         STRLEN n_a;
1788         char *  path = (char *)SvPV(ST(0),n_a);
1789         bool    RETVAL;
1790
1791         RETVAL = sys_is_rooted(path);
1792         ST(0) = boolSV(RETVAL);
1793         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1794     }
1795     XSRETURN(1);
1796 }
1797
1798 XS(XS_Cwd_sys_is_relative)
1799 {
1800     dXSARGS;
1801     if (items != 1)
1802         croak("Usage: Cwd::sys_is_relative(path)");
1803     {
1804         STRLEN n_a;
1805         char *  path = (char *)SvPV(ST(0),n_a);
1806         bool    RETVAL;
1807
1808         RETVAL = sys_is_relative(path);
1809         ST(0) = boolSV(RETVAL);
1810         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1811     }
1812     XSRETURN(1);
1813 }
1814
1815 XS(XS_Cwd_sys_cwd)
1816 {
1817     dXSARGS;
1818     if (items != 0)
1819         croak("Usage: Cwd::sys_cwd()");
1820     {
1821         char p[MAXPATHLEN];
1822         char *  RETVAL;
1823         RETVAL = _getcwd2(p, MAXPATHLEN);
1824         ST(0) = sv_newmortal();
1825         sv_setpv((SV*)ST(0), RETVAL);
1826     }
1827     XSRETURN(1);
1828 }
1829
1830 XS(XS_Cwd_sys_abspath)
1831 {
1832     dXSARGS;
1833     if (items < 1 || items > 2)
1834         croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
1835     {
1836         STRLEN n_a;
1837         char *  path = (char *)SvPV(ST(0),n_a);
1838         char *  dir;
1839         char p[MAXPATHLEN];
1840         char *  RETVAL;
1841
1842         if (items < 2)
1843             dir = NULL;
1844         else {
1845             dir = (char *)SvPV(ST(1),n_a);
1846         }
1847         if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1848             path += 2;
1849         }
1850         if (dir == NULL) {
1851             if (_abspath(p, path, MAXPATHLEN) == 0) {
1852                 RETVAL = p;
1853             } else {
1854                 RETVAL = NULL;
1855             }
1856         } else {
1857             /* Absolute with drive: */
1858             if ( sys_is_absolute(path) ) {
1859                 if (_abspath(p, path, MAXPATHLEN) == 0) {
1860                     RETVAL = p;
1861                 } else {
1862                     RETVAL = NULL;
1863                 }
1864             } else if (path[0] == '/' || path[0] == '\\') {
1865                 /* Rooted, but maybe on different drive. */
1866                 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1867                     char p1[MAXPATHLEN];
1868
1869                     /* Need to prepend the drive. */
1870                     p1[0] = dir[0];
1871                     p1[1] = dir[1];
1872                     Copy(path, p1 + 2, strlen(path) + 1, char);
1873                     RETVAL = p;
1874                     if (_abspath(p, p1, MAXPATHLEN) == 0) {
1875                         RETVAL = p;
1876                     } else {
1877                         RETVAL = NULL;
1878                     }
1879                 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1880                     RETVAL = p;
1881                 } else {
1882                     RETVAL = NULL;
1883                 }
1884             } else {
1885                 /* Either path is relative, or starts with a drive letter. */
1886                 /* If the path starts with a drive letter, then dir is
1887                    relevant only if
1888                    a/b) it is absolute/x:relative on the same drive.
1889                    c)   path is on current drive, and dir is rooted
1890                    In all the cases it is safe to drop the drive part
1891                    of the path. */
1892                 if ( !sys_is_relative(path) ) {
1893                     int is_drived;
1894
1895                     if ( ( ( sys_is_absolute(dir)
1896                              || (isALPHA(dir[0]) && dir[1] == ':'
1897                                  && strnicmp(dir, path,1) == 0))
1898                            && strnicmp(dir, path,1) == 0)
1899                          || ( !(isALPHA(dir[0]) && dir[1] == ':')
1900                               && toupper(path[0]) == current_drive())) {
1901                         path += 2;
1902                     } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1903                         RETVAL = p; goto done;
1904                     } else {
1905                         RETVAL = NULL; goto done;
1906                     }
1907                 }
1908                 {
1909                     /* Need to prepend the absolute path of dir. */
1910                     char p1[MAXPATHLEN];
1911
1912                     if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1913                         int l = strlen(p1);
1914
1915                         if (p1[ l - 1 ] != '/') {
1916                             p1[ l ] = '/';
1917                             l++;
1918                         }
1919                         Copy(path, p1 + l, strlen(path) + 1, char);
1920                         if (_abspath(p, p1, MAXPATHLEN) == 0) {
1921                             RETVAL = p;
1922                         } else {
1923                             RETVAL = NULL;
1924                         }
1925                     } else {
1926                         RETVAL = NULL;
1927                     }
1928                 }
1929               done:
1930             }
1931         }
1932         ST(0) = sv_newmortal();
1933         sv_setpv((SV*)ST(0), RETVAL);
1934     }
1935     XSRETURN(1);
1936 }
1937 typedef APIRET (*PELP)(PSZ path, ULONG type);
1938
1939 APIRET
1940 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1941 {
1942     loadByOrd("doscalls",ord);          /* Guarantied to load or die! */
1943     return (*(PELP)ExtFCN[ord])(path, type);
1944 }
1945
1946 #define extLibpath(type)                                                \
1947     (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH   \
1948                                                  : BEGIN_LIBPATH)))     \
1949      ? NULL : to )
1950
1951 #define extLibpath_set(p,type)                                  \
1952     (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH   \
1953                                                  : BEGIN_LIBPATH))))
1954
1955 XS(XS_Cwd_extLibpath)
1956 {
1957     dXSARGS;
1958     if (items < 0 || items > 1)
1959         croak("Usage: Cwd::extLibpath(type = 0)");
1960     {
1961         bool    type;
1962         char    to[1024];
1963         U32     rc;
1964         char *  RETVAL;
1965
1966         if (items < 1)
1967             type = 0;
1968         else {
1969             type = (int)SvIV(ST(0));
1970         }
1971
1972         RETVAL = extLibpath(type);
1973         ST(0) = sv_newmortal();
1974         sv_setpv((SV*)ST(0), RETVAL);
1975     }
1976     XSRETURN(1);
1977 }
1978
1979 XS(XS_Cwd_extLibpath_set)
1980 {
1981     dXSARGS;
1982     if (items < 1 || items > 2)
1983         croak("Usage: Cwd::extLibpath_set(s, type = 0)");
1984     {
1985         STRLEN n_a;
1986         char *  s = (char *)SvPV(ST(0),n_a);
1987         bool    type;
1988         U32     rc;
1989         bool    RETVAL;
1990
1991         if (items < 2)
1992             type = 0;
1993         else {
1994             type = (int)SvIV(ST(1));
1995         }
1996
1997         RETVAL = extLibpath_set(s, type);
1998         ST(0) = boolSV(RETVAL);
1999         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2000     }
2001     XSRETURN(1);
2002 }
2003
2004 int
2005 Xs_OS2_init()
2006 {
2007     char *file = __FILE__;
2008     {
2009         GV *gv;
2010
2011         if (_emx_env & 0x200) { /* OS/2 */
2012             newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2013             newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2014             newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2015         }
2016         newXS("OS2::Error", XS_OS2_Error, file);
2017         newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2018         newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2019         newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2020         newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2021         newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2022         newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2023         newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
2024         newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2025         newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2026         newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2027         newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2028         newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2029         newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2030         newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2031         newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2032         newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
2033         gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2034         GvMULTI_on(gv);
2035 #ifdef PERL_IS_AOUT
2036         sv_setiv(GvSV(gv), 1);
2037 #endif
2038         gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2039         GvMULTI_on(gv);
2040         sv_setiv(GvSV(gv), _emx_rev);
2041         sv_setpv(GvSV(gv), _emx_vprt);
2042         SvIOK_on(GvSV(gv));
2043         gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2044         GvMULTI_on(gv);
2045         sv_setiv(GvSV(gv), _emx_env);
2046         gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2047         GvMULTI_on(gv);
2048         sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
2049     }
2050 }
2051
2052 OS2_Perl_data_t OS2_Perl_data;
2053
2054 void
2055 Perl_OS2_init(char **env)
2056 {
2057     char *shell;
2058
2059     MALLOC_INIT;
2060     settmppath();
2061     OS2_Perl_data.xs_init = &Xs_OS2_init;
2062     _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
2063     if (environ == NULL) {
2064         environ = env;
2065     }
2066     if ( (shell = getenv("PERL_SH_DRIVE")) ) {
2067         New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2068         strcpy(PL_sh_path, SH_PATH);
2069         PL_sh_path[0] = shell[0];
2070     } else if ( (shell = getenv("PERL_SH_DIR")) ) {
2071         int l = strlen(shell), i;
2072         if (shell[l-1] == '/' || shell[l-1] == '\\') {
2073             l--;
2074         }
2075         New(1304, PL_sh_path, l + 8, char);
2076         strncpy(PL_sh_path, shell, l);
2077         strcpy(PL_sh_path + l, "/sh.exe");
2078         for (i = 0; i < l; i++) {
2079             if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2080         }
2081     }
2082     MUTEX_INIT(&start_thread_mutex);
2083     os2_mytype = my_type();             /* Do it before morphing.  Needed? */
2084 }
2085
2086 #undef tmpnam
2087 #undef tmpfile
2088
2089 char *
2090 my_tmpnam (char *str)
2091 {
2092     char *p = getenv("TMP"), *tpath;
2093     int len;
2094
2095     if (!p) p = getenv("TEMP");
2096     tpath = tempnam(p, "pltmp");
2097     if (str && tpath) {
2098         strcpy(str, tpath);
2099         return str;
2100     }
2101     return tpath;
2102 }
2103
2104 FILE *
2105 my_tmpfile ()
2106 {
2107     struct stat s;
2108
2109     stat(".", &s);
2110     if (s.st_mode & S_IWOTH) {
2111         return tmpfile();
2112     }
2113     return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2114                                              grants TMP. */
2115 }
2116
2117 #undef flock
2118
2119 /* This code was contributed by Rocco Caputo. */
2120 int
2121 my_flock(int handle, int o)
2122 {
2123   FILELOCK      rNull, rFull;
2124   ULONG         timeout, handle_type, flag_word;
2125   APIRET        rc;
2126   int           blocking, shared;
2127   static int    use_my = -1;
2128
2129   if (use_my == -1) {
2130     char *s = getenv("USE_PERL_FLOCK");
2131     if (s)
2132         use_my = atoi(s);
2133     else
2134         use_my = 1;
2135   }
2136   if (!(_emx_env & 0x200) || !use_my)
2137     return flock(handle, o);    /* Delegate to EMX. */
2138
2139                                         // is this a file?
2140   if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2141       (handle_type & 0xFF))
2142   {
2143     errno = EBADF;
2144     return -1;
2145   }
2146                                         // set lock/unlock ranges
2147   rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2148   rFull.lRange = 0x7FFFFFFF;
2149                                         // set timeout for blocking
2150   timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2151                                         // shared or exclusive?
2152   shared = (o & LOCK_SH) ? 1 : 0;
2153                                         // do not block the unlock
2154   if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2155     rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2156     switch (rc) {
2157       case 0:
2158         errno = 0;
2159         return 0;
2160       case ERROR_INVALID_HANDLE:
2161         errno = EBADF;
2162         return -1;
2163       case ERROR_SHARING_BUFFER_EXCEEDED:
2164         errno = ENOLCK;
2165         return -1;
2166       case ERROR_LOCK_VIOLATION:
2167         break;                          // not an error
2168       case ERROR_INVALID_PARAMETER:
2169       case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2170       case ERROR_READ_LOCKS_NOT_SUPPORTED:
2171         errno = EINVAL;
2172         return -1;
2173       case ERROR_INTERRUPT:
2174         errno = EINTR;
2175         return -1;
2176       default:
2177         errno = EINVAL;
2178         return -1;
2179     }
2180   }
2181                                         // lock may block
2182   if (o & (LOCK_SH | LOCK_EX)) {
2183                                         // for blocking operations
2184     for (;;) {
2185       rc =
2186         DosSetFileLocks(
2187                 handle,
2188                 &rNull,
2189                 &rFull,
2190                 timeout,
2191                 shared
2192         );
2193       switch (rc) {
2194         case 0:
2195           errno = 0;
2196           return 0;
2197         case ERROR_INVALID_HANDLE:
2198           errno = EBADF;
2199           return -1;
2200         case ERROR_SHARING_BUFFER_EXCEEDED:
2201           errno = ENOLCK;
2202           return -1;
2203         case ERROR_LOCK_VIOLATION:
2204           if (!blocking) {
2205             errno = EWOULDBLOCK;
2206             return -1;
2207           }
2208           break;
2209         case ERROR_INVALID_PARAMETER:
2210         case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2211         case ERROR_READ_LOCKS_NOT_SUPPORTED:
2212           errno = EINVAL;
2213           return -1;
2214         case ERROR_INTERRUPT:
2215           errno = EINTR;
2216           return -1;
2217         default:
2218           errno = EINVAL;
2219           return -1;
2220       }
2221                                         // give away timeslice
2222       DosSleep(1);
2223     }
2224   }
2225
2226   errno = 0;
2227   return 0;
2228 }