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         I32 *cntp = NULL;
1722
1723         if (items == 2) {
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             cntp = &SvIVX(sv);
1730         }
1731         cnt =  Perl_Process_Messages(force, cntp);
1732         ST(0) = sv_newmortal();
1733         sv_setiv(ST(0), cnt);
1734     }
1735     XSRETURN(1);
1736 }
1737
1738 XS(XS_Cwd_current_drive)
1739 {
1740     dXSARGS;
1741     if (items != 0)
1742         Perl_croak_nocontext("Usage: Cwd::current_drive()");
1743     {
1744         char    RETVAL;
1745
1746         RETVAL = current_drive();
1747         ST(0) = sv_newmortal();
1748         sv_setpvn(ST(0), (char *)&RETVAL, 1);
1749     }
1750     XSRETURN(1);
1751 }
1752
1753 XS(XS_Cwd_sys_chdir)
1754 {
1755     dXSARGS;
1756     if (items != 1)
1757         Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
1758     {
1759         STRLEN n_a;
1760         char *  path = (char *)SvPV(ST(0),n_a);
1761         bool    RETVAL;
1762
1763         RETVAL = sys_chdir(path);
1764         ST(0) = boolSV(RETVAL);
1765         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1766     }
1767     XSRETURN(1);
1768 }
1769
1770 XS(XS_Cwd_change_drive)
1771 {
1772     dXSARGS;
1773     if (items != 1)
1774         Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
1775     {
1776         STRLEN n_a;
1777         char    d = (char)*SvPV(ST(0),n_a);
1778         bool    RETVAL;
1779
1780         RETVAL = change_drive(d);
1781         ST(0) = boolSV(RETVAL);
1782         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1783     }
1784     XSRETURN(1);
1785 }
1786
1787 XS(XS_Cwd_sys_is_absolute)
1788 {
1789     dXSARGS;
1790     if (items != 1)
1791         Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
1792     {
1793         STRLEN n_a;
1794         char *  path = (char *)SvPV(ST(0),n_a);
1795         bool    RETVAL;
1796
1797         RETVAL = sys_is_absolute(path);
1798         ST(0) = boolSV(RETVAL);
1799         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1800     }
1801     XSRETURN(1);
1802 }
1803
1804 XS(XS_Cwd_sys_is_rooted)
1805 {
1806     dXSARGS;
1807     if (items != 1)
1808         Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
1809     {
1810         STRLEN n_a;
1811         char *  path = (char *)SvPV(ST(0),n_a);
1812         bool    RETVAL;
1813
1814         RETVAL = sys_is_rooted(path);
1815         ST(0) = boolSV(RETVAL);
1816         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1817     }
1818     XSRETURN(1);
1819 }
1820
1821 XS(XS_Cwd_sys_is_relative)
1822 {
1823     dXSARGS;
1824     if (items != 1)
1825         Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
1826     {
1827         STRLEN n_a;
1828         char *  path = (char *)SvPV(ST(0),n_a);
1829         bool    RETVAL;
1830
1831         RETVAL = sys_is_relative(path);
1832         ST(0) = boolSV(RETVAL);
1833         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1834     }
1835     XSRETURN(1);
1836 }
1837
1838 XS(XS_Cwd_sys_cwd)
1839 {
1840     dXSARGS;
1841     if (items != 0)
1842         Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
1843     {
1844         char p[MAXPATHLEN];
1845         char *  RETVAL;
1846         RETVAL = _getcwd2(p, MAXPATHLEN);
1847         ST(0) = sv_newmortal();
1848         sv_setpv((SV*)ST(0), RETVAL);
1849     }
1850     XSRETURN(1);
1851 }
1852
1853 XS(XS_Cwd_sys_abspath)
1854 {
1855     dXSARGS;
1856     if (items < 1 || items > 2)
1857         Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
1858     {
1859         STRLEN n_a;
1860         char *  path = (char *)SvPV(ST(0),n_a);
1861         char *  dir;
1862         char p[MAXPATHLEN];
1863         char *  RETVAL;
1864
1865         if (items < 2)
1866             dir = NULL;
1867         else {
1868             dir = (char *)SvPV(ST(1),n_a);
1869         }
1870         if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1871             path += 2;
1872         }
1873         if (dir == NULL) {
1874             if (_abspath(p, path, MAXPATHLEN) == 0) {
1875                 RETVAL = p;
1876             } else {
1877                 RETVAL = NULL;
1878             }
1879         } else {
1880             /* Absolute with drive: */
1881             if ( sys_is_absolute(path) ) {
1882                 if (_abspath(p, path, MAXPATHLEN) == 0) {
1883                     RETVAL = p;
1884                 } else {
1885                     RETVAL = NULL;
1886                 }
1887             } else if (path[0] == '/' || path[0] == '\\') {
1888                 /* Rooted, but maybe on different drive. */
1889                 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1890                     char p1[MAXPATHLEN];
1891
1892                     /* Need to prepend the drive. */
1893                     p1[0] = dir[0];
1894                     p1[1] = dir[1];
1895                     Copy(path, p1 + 2, strlen(path) + 1, char);
1896                     RETVAL = p;
1897                     if (_abspath(p, p1, MAXPATHLEN) == 0) {
1898                         RETVAL = p;
1899                     } else {
1900                         RETVAL = NULL;
1901                     }
1902                 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1903                     RETVAL = p;
1904                 } else {
1905                     RETVAL = NULL;
1906                 }
1907             } else {
1908                 /* Either path is relative, or starts with a drive letter. */
1909                 /* If the path starts with a drive letter, then dir is
1910                    relevant only if
1911                    a/b) it is absolute/x:relative on the same drive.
1912                    c)   path is on current drive, and dir is rooted
1913                    In all the cases it is safe to drop the drive part
1914                    of the path. */
1915                 if ( !sys_is_relative(path) ) {
1916                     int is_drived;
1917
1918                     if ( ( ( sys_is_absolute(dir)
1919                              || (isALPHA(dir[0]) && dir[1] == ':'
1920                                  && strnicmp(dir, path,1) == 0))
1921                            && strnicmp(dir, path,1) == 0)
1922                          || ( !(isALPHA(dir[0]) && dir[1] == ':')
1923                               && toupper(path[0]) == current_drive())) {
1924                         path += 2;
1925                     } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1926                         RETVAL = p; goto done;
1927                     } else {
1928                         RETVAL = NULL; goto done;
1929                     }
1930                 }
1931                 {
1932                     /* Need to prepend the absolute path of dir. */
1933                     char p1[MAXPATHLEN];
1934
1935                     if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1936                         int l = strlen(p1);
1937
1938                         if (p1[ l - 1 ] != '/') {
1939                             p1[ l ] = '/';
1940                             l++;
1941                         }
1942                         Copy(path, p1 + l, strlen(path) + 1, char);
1943                         if (_abspath(p, p1, MAXPATHLEN) == 0) {
1944                             RETVAL = p;
1945                         } else {
1946                             RETVAL = NULL;
1947                         }
1948                     } else {
1949                         RETVAL = NULL;
1950                     }
1951                 }
1952               done:
1953             }
1954         }
1955         ST(0) = sv_newmortal();
1956         sv_setpv((SV*)ST(0), RETVAL);
1957     }
1958     XSRETURN(1);
1959 }
1960 typedef APIRET (*PELP)(PSZ path, ULONG type);
1961
1962 APIRET
1963 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1964 {
1965     loadByOrd("doscalls",ord);          /* Guarantied to load or die! */
1966     return (*(PELP)ExtFCN[ord])(path, type);
1967 }
1968
1969 #define extLibpath(type)                                                \
1970     (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH   \
1971                                                  : BEGIN_LIBPATH)))     \
1972      ? NULL : to )
1973
1974 #define extLibpath_set(p,type)                                  \
1975     (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH   \
1976                                                  : BEGIN_LIBPATH))))
1977
1978 XS(XS_Cwd_extLibpath)
1979 {
1980     dXSARGS;
1981     if (items < 0 || items > 1)
1982         Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
1983     {
1984         bool    type;
1985         char    to[1024];
1986         U32     rc;
1987         char *  RETVAL;
1988
1989         if (items < 1)
1990             type = 0;
1991         else {
1992             type = (int)SvIV(ST(0));
1993         }
1994
1995         RETVAL = extLibpath(type);
1996         ST(0) = sv_newmortal();
1997         sv_setpv((SV*)ST(0), RETVAL);
1998     }
1999     XSRETURN(1);
2000 }
2001
2002 XS(XS_Cwd_extLibpath_set)
2003 {
2004     dXSARGS;
2005     if (items < 1 || items > 2)
2006         Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
2007     {
2008         STRLEN n_a;
2009         char *  s = (char *)SvPV(ST(0),n_a);
2010         bool    type;
2011         U32     rc;
2012         bool    RETVAL;
2013
2014         if (items < 2)
2015             type = 0;
2016         else {
2017             type = (int)SvIV(ST(1));
2018         }
2019
2020         RETVAL = extLibpath_set(s, type);
2021         ST(0) = boolSV(RETVAL);
2022         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2023     }
2024     XSRETURN(1);
2025 }
2026
2027 int
2028 Xs_OS2_init(pTHX)
2029 {
2030     char *file = __FILE__;
2031     {
2032         GV *gv;
2033
2034         if (_emx_env & 0x200) { /* OS/2 */
2035             newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2036             newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2037             newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2038         }
2039         newXS("OS2::Error", XS_OS2_Error, file);
2040         newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2041         newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2042         newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2043         newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2044         newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2045         newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2046         newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
2047         newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2048         newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2049         newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2050         newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2051         newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2052         newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2053         newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2054         newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2055         newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
2056         gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2057         GvMULTI_on(gv);
2058 #ifdef PERL_IS_AOUT
2059         sv_setiv(GvSV(gv), 1);
2060 #endif
2061         gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2062         GvMULTI_on(gv);
2063         sv_setiv(GvSV(gv), _emx_rev);
2064         sv_setpv(GvSV(gv), _emx_vprt);
2065         SvIOK_on(GvSV(gv));
2066         gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2067         GvMULTI_on(gv);
2068         sv_setiv(GvSV(gv), _emx_env);
2069         gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2070         GvMULTI_on(gv);
2071         sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
2072     }
2073 }
2074
2075 OS2_Perl_data_t OS2_Perl_data;
2076
2077 void
2078 Perl_OS2_init(char **env)
2079 {
2080     char *shell;
2081
2082     MALLOC_INIT;
2083     settmppath();
2084     OS2_Perl_data.xs_init = &Xs_OS2_init;
2085     _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
2086     if (environ == NULL && env) {
2087         environ = env;
2088     }
2089     if ( (shell = getenv("PERL_SH_DRIVE")) ) {
2090         New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2091         strcpy(PL_sh_path, SH_PATH);
2092         PL_sh_path[0] = shell[0];
2093     } else if ( (shell = getenv("PERL_SH_DIR")) ) {
2094         int l = strlen(shell), i;
2095         if (shell[l-1] == '/' || shell[l-1] == '\\') {
2096             l--;
2097         }
2098         New(1304, PL_sh_path, l + 8, char);
2099         strncpy(PL_sh_path, shell, l);
2100         strcpy(PL_sh_path + l, "/sh.exe");
2101         for (i = 0; i < l; i++) {
2102             if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2103         }
2104     }
2105     MUTEX_INIT(&start_thread_mutex);
2106     os2_mytype = my_type();             /* Do it before morphing.  Needed? */
2107 }
2108
2109 #undef tmpnam
2110 #undef tmpfile
2111
2112 char *
2113 my_tmpnam (char *str)
2114 {
2115     char *p = getenv("TMP"), *tpath;
2116     int len;
2117
2118     if (!p) p = getenv("TEMP");
2119     tpath = tempnam(p, "pltmp");
2120     if (str && tpath) {
2121         strcpy(str, tpath);
2122         return str;
2123     }
2124     return tpath;
2125 }
2126
2127 FILE *
2128 my_tmpfile ()
2129 {
2130     struct stat s;
2131
2132     stat(".", &s);
2133     if (s.st_mode & S_IWOTH) {
2134         return tmpfile();
2135     }
2136     return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2137                                              grants TMP. */
2138 }
2139
2140 #undef flock
2141
2142 /* This code was contributed by Rocco Caputo. */
2143 int
2144 my_flock(int handle, int o)
2145 {
2146   FILELOCK      rNull, rFull;
2147   ULONG         timeout, handle_type, flag_word;
2148   APIRET        rc;
2149   int           blocking, shared;
2150   static int    use_my = -1;
2151
2152   if (use_my == -1) {
2153     char *s = getenv("USE_PERL_FLOCK");
2154     if (s)
2155         use_my = atoi(s);
2156     else
2157         use_my = 1;
2158   }
2159   if (!(_emx_env & 0x200) || !use_my)
2160     return flock(handle, o);    /* Delegate to EMX. */
2161
2162                                         // is this a file?
2163   if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2164       (handle_type & 0xFF))
2165   {
2166     errno = EBADF;
2167     return -1;
2168   }
2169                                         // set lock/unlock ranges
2170   rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2171   rFull.lRange = 0x7FFFFFFF;
2172                                         // set timeout for blocking
2173   timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2174                                         // shared or exclusive?
2175   shared = (o & LOCK_SH) ? 1 : 0;
2176                                         // do not block the unlock
2177   if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2178     rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2179     switch (rc) {
2180       case 0:
2181         errno = 0;
2182         return 0;
2183       case ERROR_INVALID_HANDLE:
2184         errno = EBADF;
2185         return -1;
2186       case ERROR_SHARING_BUFFER_EXCEEDED:
2187         errno = ENOLCK;
2188         return -1;
2189       case ERROR_LOCK_VIOLATION:
2190         break;                          // not an error
2191       case ERROR_INVALID_PARAMETER:
2192       case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2193       case ERROR_READ_LOCKS_NOT_SUPPORTED:
2194         errno = EINVAL;
2195         return -1;
2196       case ERROR_INTERRUPT:
2197         errno = EINTR;
2198         return -1;
2199       default:
2200         errno = EINVAL;
2201         return -1;
2202     }
2203   }
2204                                         // lock may block
2205   if (o & (LOCK_SH | LOCK_EX)) {
2206                                         // for blocking operations
2207     for (;;) {
2208       rc =
2209         DosSetFileLocks(
2210                 handle,
2211                 &rNull,
2212                 &rFull,
2213                 timeout,
2214                 shared
2215         );
2216       switch (rc) {
2217         case 0:
2218           errno = 0;
2219           return 0;
2220         case ERROR_INVALID_HANDLE:
2221           errno = EBADF;
2222           return -1;
2223         case ERROR_SHARING_BUFFER_EXCEEDED:
2224           errno = ENOLCK;
2225           return -1;
2226         case ERROR_LOCK_VIOLATION:
2227           if (!blocking) {
2228             errno = EWOULDBLOCK;
2229             return -1;
2230           }
2231           break;
2232         case ERROR_INVALID_PARAMETER:
2233         case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2234         case ERROR_READ_LOCKS_NOT_SUPPORTED:
2235           errno = EINVAL;
2236           return -1;
2237         case ERROR_INTERRUPT:
2238           errno = EINTR;
2239           return -1;
2240         default:
2241           errno = EINVAL;
2242           return -1;
2243       }
2244                                         // give away timeslice
2245       DosSleep(1);
2246     }
2247   }
2248
2249   errno = 0;
2250   return 0;
2251 }