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