os2/os2.c

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