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