os2/os2.c

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