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     if (tpath) {
1244         strcpy(tpath, p);
1245         tpath[len] = '/';
1246         strcpy(tpath + len + 1, TMPPATH1);
1247         tmppath = tpath;
1248     }
1249 }
1250
1251 #include "XSUB.h"
1252
1253 XS(XS_File__Copy_syscopy)
1254 {
1255     dXSARGS;
1256     if (items < 2 || items > 3)
1257         croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
1258     {
1259         STRLEN n_a;
1260         char *  src = (char *)SvPV(ST(0),n_a);
1261         char *  dst = (char *)SvPV(ST(1),n_a);
1262         U32     flag;
1263         int     RETVAL, rc;
1264
1265         if (items < 3)
1266             flag = 0;
1267         else {
1268             flag = (unsigned long)SvIV(ST(2));
1269         }
1270
1271         RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1272         ST(0) = sv_newmortal();
1273         sv_setiv(ST(0), (IV)RETVAL);
1274     }
1275     XSRETURN(1);
1276 }
1277
1278 #include "patchlevel.h"
1279
1280 char *
1281 mod2fname(sv)
1282      SV   *sv;
1283 {
1284     static char fname[9];
1285     int pos = 6, len, avlen;
1286     unsigned int sum = 0;
1287     AV  *av;
1288     SV  *svp;
1289     char *s;
1290     STRLEN n_a;
1291
1292     if (!SvROK(sv)) croak("Not a reference given to mod2fname");
1293     sv = SvRV(sv);
1294     if (SvTYPE(sv) != SVt_PVAV)
1295       croak("Not array reference given to mod2fname");
1296
1297     avlen = av_len((AV*)sv);
1298     if (avlen < 0)
1299       croak("Empty array reference given to mod2fname");
1300
1301     s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1302     strncpy(fname, s, 8);
1303     len = strlen(s);
1304     if (len < 6) pos = len;
1305     while (*s) {
1306         sum = 33 * sum + *(s++);        /* Checksumming first chars to
1307                                          * get the capitalization into c.s. */
1308     }
1309     avlen --;
1310     while (avlen >= 0) {
1311         s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1312         while (*s) {
1313             sum = 33 * sum + *(s++);    /* 7 is primitive mod 13. */
1314         }
1315         avlen --;
1316     }
1317 #ifdef USE_THREADS
1318     sum++;                              /* Avoid conflict of DLLs in memory. */
1319 #endif
1320     sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2;  /*  */
1321     fname[pos] = 'A' + (sum % 26);
1322     fname[pos + 1] = 'A' + (sum / 26 % 26);
1323     fname[pos + 2] = '\0';
1324     return (char *)fname;
1325 }
1326
1327 XS(XS_DynaLoader_mod2fname)
1328 {
1329     dXSARGS;
1330     if (items != 1)
1331         croak("Usage: DynaLoader::mod2fname(sv)");
1332     {
1333         SV *    sv = ST(0);
1334         char *  RETVAL;
1335
1336         RETVAL = mod2fname(sv);
1337         ST(0) = sv_newmortal();
1338         sv_setpv((SV*)ST(0), RETVAL);
1339     }
1340     XSRETURN(1);
1341 }
1342
1343 char *
1344 os2error(int rc)
1345 {
1346         static char buf[300];
1347         ULONG len;
1348
1349         if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1350         if (rc == 0)
1351                 return NULL;
1352         if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1353                 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1354         else
1355                 buf[len] = '\0';
1356         if (len > 0 && buf[len - 1] == '\n')
1357             buf[len - 1] = '\0';
1358         if (len > 1 && buf[len - 2] == '\r')
1359             buf[len - 2] = '\0';
1360         if (len > 2 && buf[len - 3] == '.')
1361             buf[len - 3] = '\0';
1362         return buf;
1363 }
1364
1365 char *
1366 perllib_mangle(char *s, unsigned int l)
1367 {
1368     static char *newp, *oldp;
1369     static int newl, oldl, notfound;
1370     static char ret[STATIC_FILE_LENGTH+1];
1371
1372     if (!newp && !notfound) {
1373         newp = getenv("PERLLIB_PREFIX");
1374         if (newp) {
1375             char *s;
1376
1377             oldp = newp;
1378             while (*newp && !isSPACE(*newp) && *newp != ';') {
1379                 newp++; oldl++;         /* Skip digits. */
1380             }
1381             while (*newp && (isSPACE(*newp) || *newp == ';')) {
1382                 newp++;                 /* Skip whitespace. */
1383             }
1384             newl = strlen(newp);
1385             if (newl == 0 || oldl == 0) {
1386                 croak("Malformed PERLLIB_PREFIX");
1387             }
1388             strcpy(ret, newp);
1389             s = ret;
1390             while (*s) {
1391                 if (*s == '\\') *s = '/';
1392                 s++;
1393             }
1394         } else {
1395             notfound = 1;
1396         }
1397     }
1398     if (!newp) {
1399         return s;
1400     }
1401     if (l == 0) {
1402         l = strlen(s);
1403     }
1404     if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1405         return s;
1406     }
1407     if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1408         croak("Malformed PERLLIB_PREFIX");
1409     }
1410     strcpy(ret + newl, s + oldl);
1411     return ret;
1412 }
1413
1414 unsigned long
1415 Perl_hab_GET()                  /* Needed if perl.h cannot be included */
1416 {
1417     return perl_hab_GET();
1418 }
1419
1420 HMQ
1421 Perl_Register_MQ(int serve)
1422 {
1423     PPIB pib;
1424     PTIB tib;
1425
1426     if (Perl_os2_initial_mode++)
1427         return Perl_hmq;
1428     DosGetInfoBlocks(&tib, &pib);
1429     Perl_os2_initial_mode = pib->pib_ultype;
1430     Perl_hmq_refcnt = 1;
1431     /* Try morphing into a PM application. */
1432     if (pib->pib_ultype != 3)           /* 2 is VIO */
1433         pib->pib_ultype = 3;            /* 3 is PM */
1434     init_PMWIN_entries();
1435     /* 64 messages if before OS/2 3.0, ignored otherwise */
1436     Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1437     if (!Perl_hmq) {
1438         static int cnt;
1439         if (cnt++)
1440             _exit(188);                 /* Panic can try to create a window. */
1441         croak("Cannot create a message queue, or morph to a PM application");
1442     }
1443     return Perl_hmq;
1444 }
1445
1446 int
1447 Perl_Serve_Messages(int force)
1448 {
1449     int cnt = 0;
1450     QMSG msg;
1451
1452     if (Perl_hmq_servers && !force)
1453         return 0;
1454     if (!Perl_hmq_refcnt)
1455         croak("No message queue");
1456     while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1457         cnt++;
1458         if (msg.msg == WM_QUIT)
1459             croak("QUITing...");
1460         (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1461     }
1462     return cnt;
1463 }
1464
1465 int
1466 Perl_Process_Messages(int force, I32 *cntp)
1467 {
1468     QMSG msg;
1469
1470     if (Perl_hmq_servers && !force)
1471         return 0;
1472     if (!Perl_hmq_refcnt)
1473         croak("No message queue");
1474     while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1475         if (cntp)
1476             (*cntp)++;
1477         (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1478         if (msg.msg == WM_DESTROY)
1479             return -1;
1480         if (msg.msg == WM_CREATE)
1481             return +1;
1482     }
1483     croak("QUITing...");
1484 }
1485
1486 void
1487 Perl_Deregister_MQ(int serve)
1488 {
1489     PPIB pib;
1490     PTIB tib;
1491
1492     if (--Perl_hmq_refcnt == 0) {
1493         (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1494         Perl_hmq = 0;
1495         /* Try morphing back from a PM application. */
1496         if (pib->pib_ultype == 3)               /* 3 is PM */
1497             pib->pib_ultype = Perl_os2_initial_mode;
1498         else
1499             warn("Unexpected program mode %d when morphing back from PM",
1500                  pib->pib_ultype);
1501     }
1502 }
1503
1504 extern void dlopen();
1505 void *fakedl = &dlopen;         /* Pull in dynaloading part. */
1506
1507 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1508                                 && ((path)[2] == '/' || (path)[2] == '\\'))
1509 #define sys_is_rooted _fnisabs
1510 #define sys_is_relative _fnisrel
1511 #define current_drive _getdrive
1512
1513 #undef chdir                            /* Was _chdir2. */
1514 #define sys_chdir(p) (chdir(p) == 0)
1515 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1516
1517 static int DOS_harderr_state = -1;
1518
1519 XS(XS_OS2_Error)
1520 {
1521     dXSARGS;
1522     if (items != 2)
1523         croak("Usage: OS2::Error(harderr, exception)");
1524     {
1525         int     arg1 = SvIV(ST(0));
1526         int     arg2 = SvIV(ST(1));
1527         int     a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1528                      | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1529         int     RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1530         unsigned long rc;
1531
1532         if (CheckOSError(DosError(a)))
1533             croak("DosError(%d) failed", a);
1534         ST(0) = sv_newmortal();
1535         if (DOS_harderr_state >= 0)
1536             sv_setiv(ST(0), DOS_harderr_state);
1537         DOS_harderr_state = RETVAL;
1538     }
1539     XSRETURN(1);
1540 }
1541
1542 static signed char DOS_suppression_state = -1;
1543
1544 XS(XS_OS2_Errors2Drive)
1545 {
1546     dXSARGS;
1547     if (items != 1)
1548         croak("Usage: OS2::Errors2Drive(drive)");
1549     {
1550         STRLEN n_a;
1551         SV  *sv = ST(0);
1552         int     suppress = SvOK(sv);
1553         char    *s = suppress ? SvPV(sv, n_a) : NULL;
1554         char    drive = (s ? *s : 0);
1555         unsigned long rc;
1556
1557         if (suppress && !isALPHA(drive))
1558             croak("Non-char argument '%c' to OS2::Errors2Drive()", drive);
1559         if (CheckOSError(DosSuppressPopUps((suppress
1560                                             ? SPU_ENABLESUPPRESSION
1561                                             : SPU_DISABLESUPPRESSION),
1562                                            drive)))
1563             croak("DosSuppressPopUps(%c) failed", drive);
1564         ST(0) = sv_newmortal();
1565         if (DOS_suppression_state > 0)
1566             sv_setpvn(ST(0), &DOS_suppression_state, 1);
1567         else if (DOS_suppression_state == 0)
1568             sv_setpvn(ST(0), "", 0);
1569         DOS_suppression_state = drive;
1570     }
1571     XSRETURN(1);
1572 }
1573
1574 static const char * const si_fields[QSV_MAX] = {
1575   "MAX_PATH_LENGTH",
1576   "MAX_TEXT_SESSIONS",
1577   "MAX_PM_SESSIONS",
1578   "MAX_VDM_SESSIONS",
1579   "BOOT_DRIVE",
1580   "DYN_PRI_VARIATION",
1581   "MAX_WAIT",
1582   "MIN_SLICE",
1583   "MAX_SLICE",
1584   "PAGE_SIZE",
1585   "VERSION_MAJOR",
1586   "VERSION_MINOR",
1587   "VERSION_REVISION",
1588   "MS_COUNT",
1589   "TIME_LOW",
1590   "TIME_HIGH",
1591   "TOTPHYSMEM",
1592   "TOTRESMEM",
1593   "TOTAVAILMEM",
1594   "MAXPRMEM",
1595   "MAXSHMEM",
1596   "TIMER_INTERVAL",
1597   "MAX_COMP_LENGTH",
1598   "FOREGROUND_FS_SESSION",
1599   "FOREGROUND_PROCESS"
1600 };
1601
1602 XS(XS_OS2_SysInfo)
1603 {
1604     dXSARGS;
1605     if (items != 0)
1606         croak("Usage: OS2::SysInfo()");
1607     {
1608         ULONG   si[QSV_MAX] = {0};      /* System Information Data Buffer */
1609         APIRET  rc      = NO_ERROR;     /* Return code            */
1610         int i = 0, j = 0;
1611
1612         if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
1613                                          QSV_MAX, /* information */
1614                                          (PVOID)si,
1615                                          sizeof(si))))
1616             croak("DosQuerySysInfo() failed");
1617         EXTEND(SP,2*QSV_MAX);
1618         while (i < QSV_MAX) {
1619             ST(j) = sv_newmortal();
1620             sv_setpv(ST(j++), si_fields[i]);
1621             ST(j) = sv_newmortal();
1622             sv_setiv(ST(j++), si[i]);
1623             i++;
1624         }
1625     }
1626     XSRETURN(2 * QSV_MAX);
1627 }
1628
1629 XS(XS_OS2_BootDrive)
1630 {
1631     dXSARGS;
1632     if (items != 0)
1633         croak("Usage: OS2::BootDrive()");
1634     {
1635         ULONG   si[1] = {0};    /* System Information Data Buffer */
1636         APIRET  rc    = NO_ERROR;       /* Return code            */
1637         char c;
1638
1639         if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
1640                                          (PVOID)si, sizeof(si))))
1641             croak("DosQuerySysInfo() failed");
1642         ST(0) = sv_newmortal();
1643         c = 'a' - 1 + si[0];
1644         sv_setpvn(ST(0), &c, 1);
1645     }
1646     XSRETURN(1);
1647 }
1648
1649 XS(XS_OS2_MorphPM)
1650 {
1651     dXSARGS;
1652     if (items != 1)
1653         croak("Usage: OS2::MorphPM(serve)");
1654     {
1655         bool  serve = SvOK(ST(0));
1656         unsigned long   pmq = perl_hmq_GET(serve);
1657
1658         ST(0) = sv_newmortal();
1659         sv_setiv(ST(0), pmq);
1660     }
1661     XSRETURN(1);
1662 }
1663
1664 XS(XS_OS2_UnMorphPM)
1665 {
1666     dXSARGS;
1667     if (items != 1)
1668         croak("Usage: OS2::UnMorphPM(serve)");
1669     {
1670         bool  serve = SvOK(ST(0));
1671
1672         perl_hmq_UNSET(serve);
1673     }
1674     XSRETURN(0);
1675 }
1676
1677 XS(XS_OS2_Serve_Messages)
1678 {
1679     dXSARGS;
1680     if (items != 1)
1681         croak("Usage: OS2::Serve_Messages(force)");
1682     {
1683         bool  force = SvOK(ST(0));
1684         unsigned long   cnt = Perl_Serve_Messages(force);
1685
1686         ST(0) = sv_newmortal();
1687         sv_setiv(ST(0), cnt);
1688     }
1689     XSRETURN(1);
1690 }
1691
1692 XS(XS_OS2_Process_Messages)
1693 {
1694     dXSARGS;
1695     if (items < 1 || items > 2)
1696         croak("Usage: OS2::Process_Messages(force [, cnt])");
1697     {
1698         bool  force = SvOK(ST(0));
1699         unsigned long   cnt;
1700         I32 *cntp = NULL;
1701
1702         if (items == 2) {
1703             SV *sv = ST(1);
1704             int fake = SvIV(sv);        /* Force SvIVX */
1705
1706             if (!SvIOK(sv))
1707                 croak("Can't upgrade count to IV");
1708             cntp = &SvIVX(sv);
1709         }
1710         cnt =  Perl_Process_Messages(force, cntp);
1711         ST(0) = sv_newmortal();
1712         sv_setiv(ST(0), cnt);
1713     }
1714     XSRETURN(1);
1715 }
1716
1717 XS(XS_Cwd_current_drive)
1718 {
1719     dXSARGS;
1720     if (items != 0)
1721         croak("Usage: Cwd::current_drive()");
1722     {
1723         char    RETVAL;
1724
1725         RETVAL = current_drive();
1726         ST(0) = sv_newmortal();
1727         sv_setpvn(ST(0), (char *)&RETVAL, 1);
1728     }
1729     XSRETURN(1);
1730 }
1731
1732 XS(XS_Cwd_sys_chdir)
1733 {
1734     dXSARGS;
1735     if (items != 1)
1736         croak("Usage: Cwd::sys_chdir(path)");
1737     {
1738         STRLEN n_a;
1739         char *  path = (char *)SvPV(ST(0),n_a);
1740         bool    RETVAL;
1741
1742         RETVAL = sys_chdir(path);
1743         ST(0) = boolSV(RETVAL);
1744         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1745     }
1746     XSRETURN(1);
1747 }
1748
1749 XS(XS_Cwd_change_drive)
1750 {
1751     dXSARGS;
1752     if (items != 1)
1753         croak("Usage: Cwd::change_drive(d)");
1754     {
1755         STRLEN n_a;
1756         char    d = (char)*SvPV(ST(0),n_a);
1757         bool    RETVAL;
1758
1759         RETVAL = change_drive(d);
1760         ST(0) = boolSV(RETVAL);
1761         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1762     }
1763     XSRETURN(1);
1764 }
1765
1766 XS(XS_Cwd_sys_is_absolute)
1767 {
1768     dXSARGS;
1769     if (items != 1)
1770         croak("Usage: Cwd::sys_is_absolute(path)");
1771     {
1772         STRLEN n_a;
1773         char *  path = (char *)SvPV(ST(0),n_a);
1774         bool    RETVAL;
1775
1776         RETVAL = sys_is_absolute(path);
1777         ST(0) = boolSV(RETVAL);
1778         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1779     }
1780     XSRETURN(1);
1781 }
1782
1783 XS(XS_Cwd_sys_is_rooted)
1784 {
1785     dXSARGS;
1786     if (items != 1)
1787         croak("Usage: Cwd::sys_is_rooted(path)");
1788     {
1789         STRLEN n_a;
1790         char *  path = (char *)SvPV(ST(0),n_a);
1791         bool    RETVAL;
1792
1793         RETVAL = sys_is_rooted(path);
1794         ST(0) = boolSV(RETVAL);
1795         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1796     }
1797     XSRETURN(1);
1798 }
1799
1800 XS(XS_Cwd_sys_is_relative)
1801 {
1802     dXSARGS;
1803     if (items != 1)
1804         croak("Usage: Cwd::sys_is_relative(path)");
1805     {
1806         STRLEN n_a;
1807         char *  path = (char *)SvPV(ST(0),n_a);
1808         bool    RETVAL;
1809
1810         RETVAL = sys_is_relative(path);
1811         ST(0) = boolSV(RETVAL);
1812         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1813     }
1814     XSRETURN(1);
1815 }
1816
1817 XS(XS_Cwd_sys_cwd)
1818 {
1819     dXSARGS;
1820     if (items != 0)
1821         croak("Usage: Cwd::sys_cwd()");
1822     {
1823         char p[MAXPATHLEN];
1824         char *  RETVAL;
1825         RETVAL = _getcwd2(p, MAXPATHLEN);
1826         ST(0) = sv_newmortal();
1827         sv_setpv((SV*)ST(0), RETVAL);
1828     }
1829     XSRETURN(1);
1830 }
1831
1832 XS(XS_Cwd_sys_abspath)
1833 {
1834     dXSARGS;
1835     if (items < 1 || items > 2)
1836         croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
1837     {
1838         STRLEN n_a;
1839         char *  path = (char *)SvPV(ST(0),n_a);
1840         char *  dir;
1841         char p[MAXPATHLEN];
1842         char *  RETVAL;
1843
1844         if (items < 2)
1845             dir = NULL;
1846         else {
1847             dir = (char *)SvPV(ST(1),n_a);
1848         }
1849         if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1850             path += 2;
1851         }
1852         if (dir == NULL) {
1853             if (_abspath(p, path, MAXPATHLEN) == 0) {
1854                 RETVAL = p;
1855             } else {
1856                 RETVAL = NULL;
1857             }
1858         } else {
1859             /* Absolute with drive: */
1860             if ( sys_is_absolute(path) ) {
1861                 if (_abspath(p, path, MAXPATHLEN) == 0) {
1862                     RETVAL = p;
1863                 } else {
1864                     RETVAL = NULL;
1865                 }
1866             } else if (path[0] == '/' || path[0] == '\\') {
1867                 /* Rooted, but maybe on different drive. */
1868                 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1869                     char p1[MAXPATHLEN];
1870
1871                     /* Need to prepend the drive. */
1872                     p1[0] = dir[0];
1873                     p1[1] = dir[1];
1874                     Copy(path, p1 + 2, strlen(path) + 1, char);
1875                     RETVAL = p;
1876                     if (_abspath(p, p1, MAXPATHLEN) == 0) {
1877                         RETVAL = p;
1878                     } else {
1879                         RETVAL = NULL;
1880                     }
1881                 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1882                     RETVAL = p;
1883                 } else {
1884                     RETVAL = NULL;
1885                 }
1886             } else {
1887                 /* Either path is relative, or starts with a drive letter. */
1888                 /* If the path starts with a drive letter, then dir is
1889                    relevant only if
1890                    a/b) it is absolute/x:relative on the same drive.
1891                    c)   path is on current drive, and dir is rooted
1892                    In all the cases it is safe to drop the drive part
1893                    of the path. */
1894                 if ( !sys_is_relative(path) ) {
1895                     int is_drived;
1896
1897                     if ( ( ( sys_is_absolute(dir)
1898                              || (isALPHA(dir[0]) && dir[1] == ':'
1899                                  && strnicmp(dir, path,1) == 0))
1900                            && strnicmp(dir, path,1) == 0)
1901                          || ( !(isALPHA(dir[0]) && dir[1] == ':')
1902                               && toupper(path[0]) == current_drive())) {
1903                         path += 2;
1904                     } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1905                         RETVAL = p; goto done;
1906                     } else {
1907                         RETVAL = NULL; goto done;
1908                     }
1909                 }
1910                 {
1911                     /* Need to prepend the absolute path of dir. */
1912                     char p1[MAXPATHLEN];
1913
1914                     if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1915                         int l = strlen(p1);
1916
1917                         if (p1[ l - 1 ] != '/') {
1918                             p1[ l ] = '/';
1919                             l++;
1920                         }
1921                         Copy(path, p1 + l, strlen(path) + 1, char);
1922                         if (_abspath(p, p1, MAXPATHLEN) == 0) {
1923                             RETVAL = p;
1924                         } else {
1925                             RETVAL = NULL;
1926                         }
1927                     } else {
1928                         RETVAL = NULL;
1929                     }
1930                 }
1931               done:
1932             }
1933         }
1934         ST(0) = sv_newmortal();
1935         sv_setpv((SV*)ST(0), RETVAL);
1936     }
1937     XSRETURN(1);
1938 }
1939 typedef APIRET (*PELP)(PSZ path, ULONG type);
1940
1941 APIRET
1942 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1943 {
1944     loadByOrd("doscalls",ord);          /* Guarantied to load or die! */
1945     return (*(PELP)ExtFCN[ord])(path, type);
1946 }
1947
1948 #define extLibpath(type)                                                \
1949     (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH   \
1950                                                  : BEGIN_LIBPATH)))     \
1951      ? NULL : to )
1952
1953 #define extLibpath_set(p,type)                                  \
1954     (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH   \
1955                                                  : BEGIN_LIBPATH))))
1956
1957 XS(XS_Cwd_extLibpath)
1958 {
1959     dXSARGS;
1960     if (items < 0 || items > 1)
1961         croak("Usage: Cwd::extLibpath(type = 0)");
1962     {
1963         bool    type;
1964         char    to[1024];
1965         U32     rc;
1966         char *  RETVAL;
1967
1968         if (items < 1)
1969             type = 0;
1970         else {
1971             type = (int)SvIV(ST(0));
1972         }
1973
1974         RETVAL = extLibpath(type);
1975         ST(0) = sv_newmortal();
1976         sv_setpv((SV*)ST(0), RETVAL);
1977     }
1978     XSRETURN(1);
1979 }
1980
1981 XS(XS_Cwd_extLibpath_set)
1982 {
1983     dXSARGS;
1984     if (items < 1 || items > 2)
1985         croak("Usage: Cwd::extLibpath_set(s, type = 0)");
1986     {
1987         STRLEN n_a;
1988         char *  s = (char *)SvPV(ST(0),n_a);
1989         bool    type;
1990         U32     rc;
1991         bool    RETVAL;
1992
1993         if (items < 2)
1994             type = 0;
1995         else {
1996             type = (int)SvIV(ST(1));
1997         }
1998
1999         RETVAL = extLibpath_set(s, type);
2000         ST(0) = boolSV(RETVAL);
2001         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2002     }
2003     XSRETURN(1);
2004 }
2005
2006 int
2007 Xs_OS2_init()
2008 {
2009     char *file = __FILE__;
2010     {
2011         GV *gv;
2012
2013         if (_emx_env & 0x200) { /* OS/2 */
2014             newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2015             newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2016             newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2017         }
2018         newXS("OS2::Error", XS_OS2_Error, file);
2019         newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2020         newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2021         newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2022         newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2023         newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2024         newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2025         newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
2026         newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2027         newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2028         newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2029         newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2030         newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2031         newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2032         newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2033         newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2034         newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
2035         gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2036         GvMULTI_on(gv);
2037 #ifdef PERL_IS_AOUT
2038         sv_setiv(GvSV(gv), 1);
2039 #endif
2040         gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2041         GvMULTI_on(gv);
2042         sv_setiv(GvSV(gv), _emx_rev);
2043         sv_setpv(GvSV(gv), _emx_vprt);
2044         SvIOK_on(GvSV(gv));
2045         gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2046         GvMULTI_on(gv);
2047         sv_setiv(GvSV(gv), _emx_env);
2048         gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2049         GvMULTI_on(gv);
2050         sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
2051     }
2052 }
2053
2054 OS2_Perl_data_t OS2_Perl_data;
2055
2056 void
2057 Perl_OS2_init(char **env)
2058 {
2059     char *shell;
2060
2061     MALLOC_INIT;
2062     settmppath();
2063     OS2_Perl_data.xs_init = &Xs_OS2_init;
2064     _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
2065     if (environ == NULL) {
2066         environ = env;
2067     }
2068     if ( (shell = getenv("PERL_SH_DRIVE")) ) {
2069         New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2070         strcpy(PL_sh_path, SH_PATH);
2071         PL_sh_path[0] = shell[0];
2072     } else if ( (shell = getenv("PERL_SH_DIR")) ) {
2073         int l = strlen(shell), i;
2074         if (shell[l-1] == '/' || shell[l-1] == '\\') {
2075             l--;
2076         }
2077         New(1304, PL_sh_path, l + 8, char);
2078         strncpy(PL_sh_path, shell, l);
2079         strcpy(PL_sh_path + l, "/sh.exe");
2080         for (i = 0; i < l; i++) {
2081             if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2082         }
2083     }
2084     MUTEX_INIT(&start_thread_mutex);
2085     os2_mytype = my_type();             /* Do it before morphing.  Needed? */
2086 }
2087
2088 #undef tmpnam
2089 #undef tmpfile
2090
2091 char *
2092 my_tmpnam (char *str)
2093 {
2094     char *p = getenv("TMP"), *tpath;
2095     int len;
2096
2097     if (!p) p = getenv("TEMP");
2098     tpath = tempnam(p, "pltmp");
2099     if (str && tpath) {
2100         strcpy(str, tpath);
2101         return str;
2102     }
2103     return tpath;
2104 }
2105
2106 FILE *
2107 my_tmpfile ()
2108 {
2109     struct stat s;
2110
2111     stat(".", &s);
2112     if (s.st_mode & S_IWOTH) {
2113         return tmpfile();
2114     }
2115     return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2116                                              grants TMP. */
2117 }
2118
2119 #undef flock
2120
2121 /* This code was contributed by Rocco Caputo. */
2122 int
2123 my_flock(int handle, int o)
2124 {
2125   FILELOCK      rNull, rFull;
2126   ULONG         timeout, handle_type, flag_word;
2127   APIRET        rc;
2128   int           blocking, shared;
2129   static int    use_my = -1;
2130
2131   if (use_my == -1) {
2132     char *s = getenv("USE_PERL_FLOCK");
2133     if (s)
2134         use_my = atoi(s);
2135     else
2136         use_my = 1;
2137   }
2138   if (!(_emx_env & 0x200) || !use_my)
2139     return flock(handle, o);    /* Delegate to EMX. */
2140
2141                                         // is this a file?
2142   if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2143       (handle_type & 0xFF))
2144   {
2145     errno = EBADF;
2146     return -1;
2147   }
2148                                         // set lock/unlock ranges
2149   rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2150   rFull.lRange = 0x7FFFFFFF;
2151                                         // set timeout for blocking
2152   timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2153                                         // shared or exclusive?
2154   shared = (o & LOCK_SH) ? 1 : 0;
2155                                         // do not block the unlock
2156   if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2157     rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2158     switch (rc) {
2159       case 0:
2160         errno = 0;
2161         return 0;
2162       case ERROR_INVALID_HANDLE:
2163         errno = EBADF;
2164         return -1;
2165       case ERROR_SHARING_BUFFER_EXCEEDED:
2166         errno = ENOLCK;
2167         return -1;
2168       case ERROR_LOCK_VIOLATION:
2169         break;                          // not an error
2170       case ERROR_INVALID_PARAMETER:
2171       case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2172       case ERROR_READ_LOCKS_NOT_SUPPORTED:
2173         errno = EINVAL;
2174         return -1;
2175       case ERROR_INTERRUPT:
2176         errno = EINTR;
2177         return -1;
2178       default:
2179         errno = EINVAL;
2180         return -1;
2181     }
2182   }
2183                                         // lock may block
2184   if (o & (LOCK_SH | LOCK_EX)) {
2185                                         // for blocking operations
2186     for (;;) {
2187       rc =
2188         DosSetFileLocks(
2189                 handle,
2190                 &rNull,
2191                 &rFull,
2192                 timeout,
2193                 shared
2194         );
2195       switch (rc) {
2196         case 0:
2197           errno = 0;
2198           return 0;
2199         case ERROR_INVALID_HANDLE:
2200           errno = EBADF;
2201           return -1;
2202         case ERROR_SHARING_BUFFER_EXCEEDED:
2203           errno = ENOLCK;
2204           return -1;
2205         case ERROR_LOCK_VIOLATION:
2206           if (!blocking) {
2207             errno = EWOULDBLOCK;
2208             return -1;
2209           }
2210           break;
2211         case ERROR_INVALID_PARAMETER:
2212         case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2213         case ERROR_READ_LOCKS_NOT_SUPPORTED:
2214           errno = EINVAL;
2215           return -1;
2216         case ERROR_INTERRUPT:
2217           errno = EINTR;
2218           return -1;
2219         default:
2220           errno = EINVAL;
2221           return -1;
2222       }
2223                                         // give away timeslice
2224       DosSleep(1);
2225     }
2226   }
2227
2228   errno = 0;
2229   return 0;
2230 }