os2/os2.c

   1 #define INCL_DOS
   2 #define INCL_NOPM
   3 #define INCL_DOSFILEMGR
   4 #define INCL_DOSMEMMGR
   5 #define INCL_DOSERRORS
   6 /* These 3 are needed for compile if os2.h includes os2tk.h, not os2emx.h */
   7 #define INCL_DOSPROCESS
   8 #define SPU_DISABLESUPPRESSION          0
   9 #define SPU_ENABLESUPPRESSION           1
  10 #include <os2.h>
  11 #include "dlfcn.h"
  12
  13 #include <sys/uflags.h>
  14
  15 /*
  16  * Various Unix compatibility functions for OS/2
  17  */
  18
  19 #include <stdio.h>
  20 #include <errno.h>
  21 #include <limits.h>
  22 #include <process.h>
  23 #include <fcntl.h>
  24 #include <pwd.h>
  25 #include <grp.h>
  26
  27 #define PERLIO_NOT_STDIO 0
  28
  29 #include "EXTERN.h"
  30 #include "perl.h"
  31
  32 static int exe_is_aout(void);
  33
  34 /*****************************************************************************/
  35 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
  36 #define C_ARR_LEN(sym)  (sizeof(sym)/sizeof(*sym))
  37
  38 struct dll_handle {
  39     const char *modname;
  40     HMODULE handle;
  41 };
  42 static struct dll_handle doscalls_handle = {"doscalls", 0};
  43 static struct dll_handle tcp_handle = {"tcp32dll", 0};
  44 static struct dll_handle pmwin_handle = {"pmwin", 0};
  45 static struct dll_handle rexx_handle = {"rexx", 0};
  46 static struct dll_handle rexxapi_handle = {"rexxapi", 0};
  47 static struct dll_handle sesmgr_handle = {"sesmgr", 0};
  48 static struct dll_handle pmshapi_handle = {"pmshapi", 0};
  49
  50 /* This should match enum entries_ordinals defined in os2ish.h. */
  51 static const struct {
  52     struct dll_handle *dll;
  53     const char *entryname;
  54     int entrypoint;
  55 } loadOrdinals[ORD_NENTRIES] = {
  56   {&doscalls_handle, NULL, 874},        /* DosQueryExtLibpath */
  57   {&doscalls_handle, NULL, 873},        /* DosSetExtLibpath */
  58   {&doscalls_handle, NULL, 460},        /* DosVerifyPidTid */
  59   {&tcp_handle, "SETHOSTENT", 0},
  60   {&tcp_handle, "SETNETENT" , 0},
  61   {&tcp_handle, "SETPROTOENT", 0},
  62   {&tcp_handle, "SETSERVENT", 0},
  63   {&tcp_handle, "GETHOSTENT", 0},
  64   {&tcp_handle, "GETNETENT" , 0},
  65   {&tcp_handle, "GETPROTOENT", 0},
  66   {&tcp_handle, "GETSERVENT", 0},
  67   {&tcp_handle, "ENDHOSTENT", 0},
  68   {&tcp_handle, "ENDNETENT", 0},
  69   {&tcp_handle, "ENDPROTOENT", 0},
  70   {&tcp_handle, "ENDSERVENT", 0},
  71   {&pmwin_handle, NULL, 763},           /* WinInitialize */
  72   {&pmwin_handle, NULL, 716},           /* WinCreateMsgQueue */
  73   {&pmwin_handle, NULL, 726},           /* WinDestroyMsgQueue */
  74   {&pmwin_handle, NULL, 918},           /* WinPeekMsg */
  75   {&pmwin_handle, NULL, 915},           /* WinGetMsg */
  76   {&pmwin_handle, NULL, 912},           /* WinDispatchMsg */
  77   {&pmwin_handle, NULL, 753},           /* WinGetLastError */
  78   {&pmwin_handle, NULL, 705},           /* WinCancelShutdown */
  79         /* These are needed in extensions.
  80            How to protect PMSHAPI: it comes through EMX functions? */
  81   {&rexx_handle,    "RexxStart", 0},
  82   {&rexx_handle,    "RexxVariablePool", 0},
  83   {&rexxapi_handle, "RexxRegisterFunctionExe", 0},
  84   {&rexxapi_handle, "RexxDeregisterFunction", 0},
  85   {&sesmgr_handle,  "DOSSMSETTITLE", 0}, /* Would not work runtime-loaded */
  86   {&pmshapi_handle, "PRF32QUERYPROFILESIZE", 0},
  87   {&pmshapi_handle, "PRF32OPENPROFILE", 0},
  88   {&pmshapi_handle, "PRF32CLOSEPROFILE", 0},
  89   {&pmshapi_handle, "PRF32QUERYPROFILE", 0},
  90   {&pmshapi_handle, "PRF32RESET", 0},
  91   {&pmshapi_handle, "PRF32QUERYPROFILEDATA", 0},
  92   {&pmshapi_handle, "PRF32WRITEPROFILEDATA", 0},
  93
  94   /* At least some of these do not work by name, since they need
  95         WIN32 instead of WIN... */
  96 #if 0
  97   These were generated with
  98     nm I:\emx\lib\os2.a  | fgrep -f API-list | grep = > API-list-entries
  99     perl -wnle "next unless /^0+\s+E\s+_(\w+)=(\w+).(\d+)/; print qq(    ORD_$1,)" API-list-entries > API-list-ORD_
 100     perl -wnle "next unless /^0+\s+E\s+_(\w+)=(\w+).(\d+)/; print qq(  {${2}_handle, NULL, $3},\t\t/* $1 */)" WinSwitch-API-list-entries  >API-list-entry
 101 #endif
 102   {&pmshapi_handle, NULL, 123},         /* WinChangeSwitchEntry */
 103   {&pmshapi_handle, NULL, 124},         /* WinQuerySwitchEntry */
 104   {&pmshapi_handle, NULL, 125},         /* WinQuerySwitchHandle */
 105   {&pmshapi_handle, NULL, 126},         /* WinQuerySwitchList */
 106   {&pmshapi_handle, NULL, 131},         /* WinSwitchToProgram */
 107   {&pmwin_handle, NULL, 702},           /* WinBeginEnumWindows */
 108   {&pmwin_handle, NULL, 737},           /* WinEndEnumWindows */
 109   {&pmwin_handle, NULL, 740},           /* WinEnumDlgItem */
 110   {&pmwin_handle, NULL, 756},           /* WinGetNextWindow */
 111   {&pmwin_handle, NULL, 768},           /* WinIsChild */
 112   {&pmwin_handle, NULL, 799},           /* WinQueryActiveWindow */
 113   {&pmwin_handle, NULL, 805},           /* WinQueryClassName */
 114   {&pmwin_handle, NULL, 817},           /* WinQueryFocus */
 115   {&pmwin_handle, NULL, 834},           /* WinQueryWindow */
 116   {&pmwin_handle, NULL, 837},           /* WinQueryWindowPos */
 117   {&pmwin_handle, NULL, 838},           /* WinQueryWindowProcess */
 118   {&pmwin_handle, NULL, 841},           /* WinQueryWindowText */
 119   {&pmwin_handle, NULL, 842},           /* WinQueryWindowTextLength */
 120   {&pmwin_handle, NULL, 860},           /* WinSetFocus */
 121   {&pmwin_handle, NULL, 875},           /* WinSetWindowPos */
 122   {&pmwin_handle, NULL, 877},           /* WinSetWindowText */
 123   {&pmwin_handle, NULL, 883},           /* WinShowWindow */
 124   {&pmwin_handle, NULL, 772},           /* WinIsWindow */
 125   {&pmwin_handle, NULL, 899},           /* WinWindowFromId */
 126   {&pmwin_handle, NULL, 900},           /* WinWindowFromPoint */
 127   {&pmwin_handle, NULL, 919},           /* WinPostMsg */
 128   {&pmwin_handle, NULL, 735},           /* WinEnableWindow */
 129   {&pmwin_handle, NULL, 736},           /* WinEnableWindowUpdate */
 130   {&pmwin_handle, NULL, 773},           /* WinIsWindowEnabled */
 131   {&pmwin_handle, NULL, 774},           /* WinIsWindowShowing */
 132   {&pmwin_handle, NULL, 775},           /* WinIsWindowVisible */
 133   {&pmwin_handle, NULL, 839},           /* WinQueryWindowPtr */
 134   {&pmwin_handle, NULL, 843},           /* WinQueryWindowULong */
 135   {&pmwin_handle, NULL, 844},           /* WinQueryWindowUShort */
 136   {&pmwin_handle, NULL, 874},           /* WinSetWindowBits */
 137   {&pmwin_handle, NULL, 876},           /* WinSetWindowPtr */
 138   {&pmwin_handle, NULL, 878},           /* WinSetWindowULong */
 139   {&pmwin_handle, NULL, 879},           /* WinSetWindowUShort */
 140   {&pmwin_handle, NULL, 813},           /* WinQueryDesktopWindow */
 141   {&pmwin_handle, NULL, 851},           /* WinSetActiveWindow */
 142   {&doscalls_handle, NULL, 360},        /* DosQueryModFromEIP */
 143 };
 144
 145 static PFN ExtFCN[C_ARR_LEN(loadOrdinals)];     /* Labeled by ord ORD_*. */
 146 const Perl_PFN * const pExtFCN = ExtFCN;
 147 struct PMWIN_entries_t PMWIN_entries;
 148
 149 HMODULE
 150 loadModule(const char *modname, int fail)
 151 {
 152     HMODULE h = (HMODULE)dlopen(modname, 0);
 153
 154     if (!h && fail)
 155         Perl_croak_nocontext("Error loading module '%s': %s",
 156                              modname, dlerror());
 157     return h;
 158 }
 159
 160 PFN
 161 loadByOrdinal(enum entries_ordinals ord, int fail)
 162 {
 163     if (ExtFCN[ord] == NULL) {
 164         PFN fcn = (PFN)-1;
 165         APIRET rc;
 166
 167         if (!loadOrdinals[ord].dll->handle)
 168             loadOrdinals[ord].dll->handle
 169                 = loadModule(loadOrdinals[ord].dll->modname, fail);
 170         if (!loadOrdinals[ord].dll->handle)
 171             return 0;                   /* Possible with FAIL==0 only */
 172         if (CheckOSError(DosQueryProcAddr(loadOrdinals[ord].dll->handle,
 173                                           loadOrdinals[ord].entrypoint,
 174                                           loadOrdinals[ord].entryname,&fcn))) {
 175             char buf[20], *s = (char*)loadOrdinals[ord].entryname;
 176
 177             if (!fail)
 178                 return 0;
 179             if (!s)
 180                 sprintf(s = buf, "%d", loadOrdinals[ord].entrypoint);
 181             Perl_croak_nocontext(
 182                  "This version of OS/2 does not support %s.%s",
 183                  loadOrdinals[ord].dll->modname, s);
 184         }
 185         ExtFCN[ord] = fcn;
 186     }
 187     if ((long)ExtFCN[ord] == -1)
 188         Perl_croak_nocontext("panic queryaddr");
 189     return ExtFCN[ord];
 190 }
 191
 192 void
 193 init_PMWIN_entries(void)
 194 {
 195     int i;
 196
 197     for (i = ORD_WinInitialize; i <= ORD_WinCancelShutdown; i++)
 198         ((PFN*)&PMWIN_entries)[i - ORD_WinInitialize] = loadByOrdinal(i, 1);
 199 }
 200
 201 /*****************************************************/
 202 /* socket forwarders without linking with tcpip DLLs */
 203
 204 DeclFuncByORD(struct hostent *,  gethostent,  ORD_GETHOSTENT,  (void), ())
 205 DeclFuncByORD(struct netent  *,  getnetent,   ORD_GETNETENT,   (void), ())
 206 DeclFuncByORD(struct protoent *, getprotoent, ORD_GETPROTOENT, (void), ())
 207 DeclFuncByORD(struct servent *,  getservent,  ORD_GETSERVENT,  (void), ())
 208
 209 DeclVoidFuncByORD(sethostent,  ORD_SETHOSTENT,  (int x), (x))
 210 DeclVoidFuncByORD(setnetent,   ORD_SETNETENT,   (int x), (x))
 211 DeclVoidFuncByORD(setprotoent, ORD_SETPROTOENT, (int x), (x))
 212 DeclVoidFuncByORD(setservent,  ORD_SETSERVENT,  (int x), (x))
 213
 214 DeclVoidFuncByORD(endhostent,  ORD_ENDHOSTENT,  (void), ())
 215 DeclVoidFuncByORD(endnetent,   ORD_ENDNETENT,   (void), ())
 216 DeclVoidFuncByORD(endprotoent, ORD_ENDPROTOENT, (void), ())
 217 DeclVoidFuncByORD(endservent,  ORD_ENDSERVENT,  (void), ())
 218
 219 /* priorities */
 220 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
 221                                                self inverse. */
 222 #define QSS_INI_BUFFER 1024
 223
 224 ULONG (*pDosVerifyPidTid) (PID pid, TID tid);
 225 static int pidtid_lookup;
 226
 227 PQTOPLEVEL
 228 get_sysinfo(ULONG pid, ULONG flags)
 229 {
 230     char *pbuffer;
 231     ULONG rc, buf_len = QSS_INI_BUFFER;
 232     PQTOPLEVEL psi;
 233
 234     if (!pidtid_lookup) {
 235         pidtid_lookup = 1;
 236         *(PFN*)&pDosVerifyPidTid = loadByOrdinal(ORD_DosVerifyPidTid, 0);
 237     }
 238     if (pDosVerifyPidTid) {     /* Warp3 or later */
 239         /* Up to some fixpak QuerySysState() kills the system if a non-existent
 240            pid is used. */
 241         if (CheckOSError(pDosVerifyPidTid(pid, 1)))
 242             return 0;
 243     }
 244     New(1322, pbuffer, buf_len, char);
 245     /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
 246     rc = QuerySysState(flags, pid, pbuffer, buf_len);
 247     while (rc == ERROR_BUFFER_OVERFLOW) {
 248         Renew(pbuffer, buf_len *= 2, char);
 249         rc = QuerySysState(flags, pid, pbuffer, buf_len);
 250     }
 251     if (rc) {
 252         FillOSError(rc);
 253         Safefree(pbuffer);
 254         return 0;
 255     }
 256     psi = (PQTOPLEVEL)pbuffer;
 257     if (psi && pid && pid != psi->procdata->pid) {
 258       Safefree(psi);
 259       Perl_croak_nocontext("panic: wrong pid in sysinfo");
 260     }
 261     return psi;
 262 }
 263
 264 #define PRIO_ERR 0x1111
 265
 266 static ULONG
 267 sys_prio(pid)
 268 {
 269   ULONG prio;
 270   PQTOPLEVEL psi;
 271
 272   if (!pid)
 273       return PRIO_ERR;
 274   psi = get_sysinfo(pid, QSS_PROCESS);
 275   if (!psi)
 276       return PRIO_ERR;
 277   prio = psi->procdata->threads->priority;
 278   Safefree(psi);
 279   return prio;
 280 }
 281
 282 int
 283 setpriority(int which, int pid, int val)
 284 {
 285   ULONG rc, prio = sys_prio(pid);
 286
 287   if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
 288   if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
 289       /* Do not change class. */
 290       return CheckOSError(DosSetPriority((pid < 0)
 291                                          ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
 292                                          0,
 293                                          (32 - val) % 32 - (prio & 0xFF),
 294                                          abs(pid)))
 295       ? -1 : 0;
 296   } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
 297       /* Documentation claims one can change both class and basevalue,
 298        * but I find it wrong. */
 299       /* Change class, but since delta == 0 denotes absolute 0, correct. */
 300       if (CheckOSError(DosSetPriority((pid < 0)
 301                                       ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
 302                                       priors[(32 - val) >> 5] + 1,
 303                                       0,
 304                                       abs(pid))))
 305           return -1;
 306       if ( ((32 - val) % 32) == 0 ) return 0;
 307       return CheckOSError(DosSetPriority((pid < 0)
 308                                          ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
 309                                          0,
 310                                          (32 - val) % 32,
 311                                          abs(pid)))
 312           ? -1 : 0;
 313   }
 314 }
 315
 316 int
 317 getpriority(int which /* ignored */, int pid)
 318 {
 319   ULONG ret;
 320
 321   if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
 322   ret = sys_prio(pid);
 323   if (ret == PRIO_ERR) {
 324       return -1;
 325   }
 326   return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
 327 }
 328
 329 /*****************************************************************************/
 330 /* spawn */
 331
 332 int emx_runtime_init;                   /* If 1, we need to manually init it */
 333 int emx_exception_init;                 /* If 1, we need to manually set it */
 334
 335 /* There is no big sense to make it thread-specific, since signals
 336    are delivered to thread 1 only.  XXXX Maybe make it into an array? */
 337 static int spawn_pid;
 338 static int spawn_killed;
 339
 340 static Signal_t
 341 spawn_sighandler(int sig)
 342 {
 343     /* Some programs do not arrange for the keyboard signals to be
 344        delivered to them.  We need to deliver the signal manually. */
 345     /* We may get a signal only if
 346        a) kid does not receive keyboard signal: deliver it;
 347        b) kid already died, and we get a signal.  We may only hope
 348           that the pid number was not reused.
 349      */
 350
 351     if (spawn_killed)
 352         sig = SIGKILL;                  /* Try harder. */
 353     kill(spawn_pid, sig);
 354     spawn_killed = 1;
 355 }
 356
 357 static int
 358 result(pTHX_ int flag, int pid)
 359 {
 360         int r, status;
 361         Signal_t (*ihand)();     /* place to save signal during system() */
 362         Signal_t (*qhand)();     /* place to save signal during system() */
 363 #ifndef __EMX__
 364         RESULTCODES res;
 365         int rpid;
 366 #endif
 367
 368         if (pid < 0 || flag != 0)
 369                 return pid;
 370
 371 #ifdef __EMX__
 372         spawn_pid = pid;
 373         spawn_killed = 0;
 374         ihand = rsignal(SIGINT, &spawn_sighandler);
 375         qhand = rsignal(SIGQUIT, &spawn_sighandler);
 376         do {
 377             r = wait4pid(pid, &status, 0);
 378         } while (r == -1 && errno == EINTR);
 379         rsignal(SIGINT, ihand);
 380         rsignal(SIGQUIT, qhand);
 381
 382         PL_statusvalue = (U16)status;
 383         if (r < 0)
 384                 return -1;
 385         return status & 0xFFFF;
 386 #else
 387         ihand = rsignal(SIGINT, SIG_IGN);
 388         r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
 389         rsignal(SIGINT, ihand);
 390         PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
 391         if (r)
 392                 return -1;
 393         return PL_statusvalue;
 394 #endif
 395 }
 396
 397 enum execf_t {
 398   EXECF_SPAWN,
 399   EXECF_EXEC,
 400   EXECF_TRUEEXEC,
 401   EXECF_SPAWN_NOWAIT,
 402   EXECF_SPAWN_BYFLAG,
 403   EXECF_SYNC
 404 };
 405
 406 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
 407
 408 static int
 409 my_type()
 410 {
 411     int rc;
 412     TIB *tib;
 413     PIB *pib;
 414
 415     if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
 416     if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
 417         return -1;
 418
 419     return (pib->pib_ultype);
 420 }
 421
 422 static ULONG
 423 file_type(char *path)
 424 {
 425     int rc;
 426     ULONG apptype;
 427
 428     if (!(_emx_env & 0x200))
 429         Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */
 430     if (CheckOSError(DosQueryAppType(path, &apptype))) {
 431         switch (rc) {
 432         case ERROR_FILE_NOT_FOUND:
 433         case ERROR_PATH_NOT_FOUND:
 434             return -1;
 435         case ERROR_ACCESS_DENIED:       /* Directory with this name found? */
 436             return -3;
 437         default:                        /* Found, but not an
 438                                            executable, or some other
 439                                            read error. */
 440             return -2;
 441         }
 442     }
 443     return apptype;
 444 }
 445
 446 static ULONG os2_mytype;
 447
 448 /* Spawn/exec a program, revert to shell if needed. */
 449 /* global PL_Argv[] contains arguments. */
 450
 451 extern ULONG _emx_exception (   EXCEPTIONREPORTRECORD *,
 452                                 EXCEPTIONREGISTRATIONRECORD *,
 453                                 CONTEXTRECORD *,
 454                                 void *);
 455
 456 int
 457 do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
 458 {
 459         int trueflag = flag;
 460         int rc, pass = 1;
 461         char *tmps;
 462         char *args[4];
 463         static char * fargs[4]
 464             = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
 465         char **argsp = fargs;
 466         int nargs = 4;
 467         int force_shell;
 468         int new_stderr = -1, nostderr = 0;
 469         int fl_stderr = 0;
 470         STRLEN n_a;
 471         char *buf;
 472         PerlIO *file;
 473
 474         if (flag == P_WAIT)
 475                 flag = P_NOWAIT;
 476
 477       retry:
 478         if (strEQ(PL_Argv[0],"/bin/sh"))
 479             PL_Argv[0] = PL_sh_path;
 480
 481         /* We should check PERL_SH* and PERLLIB_* as well? */
 482         if (!really || !*(tmps = SvPV(really, n_a)))
 483             tmps = PL_Argv[0];
 484         if (tmps[0] != '/' && tmps[0] != '\\'
 485             && !(tmps[0] && tmps[1] == ':'
 486                  && (tmps[2] == '/' || tmps[2] != '\\'))
 487             ) /* will spawnvp use PATH? */
 488             TAINT_ENV();        /* testing IFS here is overkill, probably */
 489
 490       reread:
 491         force_shell = 0;
 492         if (_emx_env & 0x200) { /* OS/2. */
 493             int type = file_type(tmps);
 494           type_again:
 495             if (type == -1) {           /* Not found */
 496                 errno = ENOENT;
 497                 rc = -1;
 498                 goto do_script;
 499             }
 500             else if (type == -2) {              /* Not an EXE */
 501                 errno = ENOEXEC;
 502                 rc = -1;
 503                 goto do_script;
 504             }
 505             else if (type == -3) {              /* Is a directory? */
 506                 /* Special-case this */
 507                 char tbuf[512];
 508                 int l = strlen(tmps);
 509
 510                 if (l + 5 <= sizeof tbuf) {
 511                     strcpy(tbuf, tmps);
 512                     strcpy(tbuf + l, ".exe");
 513                     type = file_type(tbuf);
 514                     if (type >= -3)
 515                         goto type_again;
 516                 }
 517
 518                 errno = ENOEXEC;
 519                 rc = -1;
 520                 goto do_script;
 521             }
 522             switch (type & 7) {
 523                 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
 524             case FAPPTYP_WINDOWAPI:
 525             {
 526                 if (os2_mytype != 3) {  /* not PM */
 527                     if (flag == P_NOWAIT)
 528                         flag = P_PM;
 529                     else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION)
 530                         Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting PM process with flag=%d, mytype=%d",
 531                              flag, os2_mytype);
 532                 }
 533             }
 534             break;
 535             case FAPPTYP_NOTWINDOWCOMPAT:
 536             {
 537                 if (os2_mytype != 0) {  /* not full screen */
 538                     if (flag == P_NOWAIT)
 539                         flag = P_SESSION;
 540                     else if ((flag & 7) != P_SESSION)
 541                         Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting Full Screen process with flag=%d, mytype=%d",
 542                              flag, os2_mytype);
 543                 }
 544             }
 545             break;
 546             case FAPPTYP_NOTSPEC:
 547                 /* Let the shell handle this... */
 548                 force_shell = 1;
 549                 buf = "";               /* Pacify a warning */
 550                 file = 0;               /* Pacify a warning */
 551                 goto doshell_args;
 552                 break;
 553             }
 554         }
 555
 556         if (addflag) {
 557             addflag = 0;
 558             new_stderr = dup(2);                /* Preserve stderr */
 559             if (new_stderr == -1) {
 560                 if (errno == EBADF)
 561                     nostderr = 1;
 562                 else {
 563                     rc = -1;
 564                     goto finish;
 565                 }
 566             } else
 567                 fl_stderr = fcntl(2, F_GETFD);
 568             rc = dup2(1,2);
 569             if (rc == -1)
 570                 goto finish;
 571             fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
 572         }
 573
 574 #if 0
 575         rc = result(aTHX_ trueflag, spawnvp(flag,tmps,PL_Argv));
 576 #else
 577         if (execf == EXECF_TRUEEXEC)
 578             rc = execvp(tmps,PL_Argv);
 579         else if (execf == EXECF_EXEC)
 580             rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
 581         else if (execf == EXECF_SPAWN_NOWAIT)
 582             rc = spawnvp(flag,tmps,PL_Argv);
 583         else if (execf == EXECF_SYNC)
 584             rc = spawnvp(trueflag,tmps,PL_Argv);
 585         else                            /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
 586             rc = result(aTHX_ trueflag,
 587                         spawnvp(flag,tmps,PL_Argv));
 588 #endif
 589         if (rc < 0 && pass == 1
 590             && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
 591               do_script:
 592             {
 593             int err = errno;
 594
 595             if (err == ENOENT || err == ENOEXEC) {
 596                 /* No such file, or is a script. */
 597                 /* Try adding script extensions to the file name, and
 598                    search on PATH. */
 599                 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
 600
 601                 if (scr) {
 602                     char *s = 0, *s1;
 603                     SV *scrsv = sv_2mortal(newSVpv(scr, 0));
 604                     SV *bufsv = sv_newmortal();
 605
 606                     Safefree(scr);
 607                     scr = SvPV(scrsv, n_a); /* free()ed later */
 608
 609                     file = PerlIO_open(scr, "r");
 610                     PL_Argv[0] = scr;
 611                     if (!file)
 612                         goto panic_file;
 613
 614                     buf = sv_gets(bufsv, file, 0 /* No append */);
 615                     if (!buf)
 616                         buf = "";       /* XXX Needed? */
 617                     if (!buf[0]) {      /* Empty... */
 618                         PerlIO_close(file);
 619                         /* Special case: maybe from -Zexe build, so
 620                            there is an executable around (contrary to
 621                            documentation, DosQueryAppType sometimes (?)
 622                            does not append ".exe", so we could have
 623                            reached this place). */
 624                         sv_catpv(scrsv, ".exe");
 625                         scr = SvPV(scrsv, n_a); /* Reload */
 626                         if (PerlLIO_stat(scr,&PL_statbuf) >= 0
 627                             && !S_ISDIR(PL_statbuf.st_mode)) {  /* Found */
 628                                 tmps = scr;
 629                                 pass++;
 630                                 goto reread;
 631                         } else {                /* Restore */
 632                                 SvCUR_set(scrsv, SvCUR(scrsv) - 4);
 633                                 *SvEND(scrsv) = 0;
 634                         }
 635                     }
 636                     if (PerlIO_close(file) != 0) { /* Failure */
 637                       panic_file:
 638                         Perl_warner(aTHX_ packWARN(WARN_EXEC), "Error reading \"%s\": %s",
 639                              scr, Strerror(errno));
 640                         buf = "";       /* Not #! */
 641                         goto doshell_args;
 642                     }
 643                     if (buf[0] == '#') {
 644                         if (buf[1] == '!')
 645                             s = buf + 2;
 646                     } else if (buf[0] == 'e') {
 647                         if (strnEQ(buf, "extproc", 7)
 648                             && isSPACE(buf[7]))
 649                             s = buf + 8;
 650                     } else if (buf[0] == 'E') {
 651                         if (strnEQ(buf, "EXTPROC", 7)
 652                             && isSPACE(buf[7]))
 653                             s = buf + 8;
 654                     }
 655                     if (!s) {
 656                         buf = "";       /* Not #! */
 657                         goto doshell_args;
 658                     }
 659
 660                     s1 = s;
 661                     nargs = 0;
 662                     argsp = args;
 663                     while (1) {
 664                         /* Do better than pdksh: allow a few args,
 665                            strip trailing whitespace.  */
 666                         while (isSPACE(*s))
 667                             s++;
 668                         if (*s == 0)
 669                             break;
 670                         if (nargs == 4) {
 671                             nargs = -1;
 672                             break;
 673                         }
 674                         args[nargs++] = s;
 675                         while (*s && !isSPACE(*s))
 676                             s++;
 677                         if (*s == 0)
 678                             break;
 679                         *s++ = 0;
 680                     }
 681                     if (nargs == -1) {
 682                         Perl_warner(aTHX_ packWARN(WARN_EXEC), "Too many args on %.*s line of \"%s\"",
 683                              s1 - buf, buf, scr);
 684                         nargs = 4;
 685                         argsp = fargs;
 686                     }
 687                     /* Can jump from far, buf/file invalid if force_shell: */
 688                   doshell_args:
 689                     {
 690                         char **a = PL_Argv;
 691                         char *exec_args[2];
 692
 693                         if (force_shell
 694                             || (!buf[0] && file)) { /* File without magic */
 695                             /* In fact we tried all what pdksh would
 696                                try.  There is no point in calling
 697                                pdksh, we may just emulate its logic. */
 698                             char *shell = getenv("EXECSHELL");
 699                             char *shell_opt = NULL;
 700
 701                             if (!shell) {
 702                                 char *s;
 703
 704                                 shell_opt = "/c";
 705                                 shell = getenv("OS2_SHELL");
 706                                 if (inicmd) { /* No spaces at start! */
 707                                     s = inicmd;
 708                                     while (*s && !isSPACE(*s)) {
 709                                         if (*s++ == '/') {
 710                                             inicmd = NULL; /* Cannot use */
 711                                             break;
 712                                         }
 713                                     }
 714                                 }
 715                                 if (!inicmd) {
 716                                     s = PL_Argv[0];
 717                                     while (*s) {
 718                                         /* Dosish shells will choke on slashes
 719                                            in paths, fortunately, this is
 720                                            important for zeroth arg only. */
 721                                         if (*s == '/')
 722                                             *s = '\\';
 723                                         s++;
 724                                     }
 725                                 }
 726                             }
 727                             /* If EXECSHELL is set, we do not set */
 728
 729                             if (!shell)
 730                                 shell = ((_emx_env & 0x200)
 731                                          ? "c:/os2/cmd.exe"
 732                                          : "c:/command.com");
 733                             nargs = shell_opt ? 2 : 1;  /* shell file args */
 734                             exec_args[0] = shell;
 735                             exec_args[1] = shell_opt;
 736                             argsp = exec_args;
 737                             if (nargs == 2 && inicmd) {
 738                                 /* Use the original cmd line */
 739                                 /* XXXX This is good only until we refuse
 740                                         quoted arguments... */
 741                                 PL_Argv[0] = inicmd;
 742                                 PL_Argv[1] = Nullch;
 743                             }
 744                         } else if (!buf[0] && inicmd) { /* No file */
 745                             /* Start with the original cmdline. */
 746                             /* XXXX This is good only until we refuse
 747                                     quoted arguments... */
 748
 749                             PL_Argv[0] = inicmd;
 750                             PL_Argv[1] = Nullch;
 751                             nargs = 2;  /* shell -c */
 752                         }
 753
 754                         while (a[1])            /* Get to the end */
 755                             a++;
 756                         a++;                    /* Copy finil NULL too */
 757                         while (a >= PL_Argv) {
 758                             *(a + nargs) = *a;  /* PL_Argv was preallocated to be
 759                                                    long enough. */
 760                             a--;
 761                         }
 762                         while (--nargs >= 0)
 763                             PL_Argv[nargs] = argsp[nargs];
 764                         /* Enable pathless exec if #! (as pdksh). */
 765                         pass = (buf[0] == '#' ? 2 : 3);
 766                         goto retry;
 767                     }
 768                 }
 769                 /* Not found: restore errno */
 770                 errno = err;
 771             }
 772           }
 773         } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
 774             char *no_dir = strrchr(PL_Argv[0], '/');
 775
 776             /* Do as pdksh port does: if not found with /, try without
 777                path. */
 778             if (no_dir) {
 779                 PL_Argv[0] = no_dir + 1;
 780                 pass++;
 781                 goto retry;
 782             }
 783         }
 784         if (rc < 0 && ckWARN(WARN_EXEC))
 785             Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s\n",
 786                  ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
 787                   ? "spawn" : "exec"),
 788                  PL_Argv[0], Strerror(errno));
 789         if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
 790             && ((trueflag & 0xFF) == P_WAIT))
 791             rc = -1;
 792
 793   finish:
 794     if (new_stderr != -1) {     /* How can we use error codes? */
 795         dup2(new_stderr, 2);
 796         close(new_stderr);
 797         fcntl(2, F_SETFD, fl_stderr);
 798     } else if (nostderr)
 799        close(2);
 800     return rc;
 801 }
 802
 803 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
 804 int
 805 do_spawn3(pTHX_ char *cmd, int execf, int flag)
 806 {
 807     register char **a;
 808     register char *s;
 809     char *shell, *copt, *news = NULL;
 810     int rc, seenspace = 0, mergestderr = 0;
 811
 812 #ifdef TRYSHELL
 813     if ((shell = getenv("EMXSHELL")) != NULL)
 814         copt = "-c";
 815     else if ((shell = getenv("SHELL")) != NULL)
 816         copt = "-c";
 817     else if ((shell = getenv("COMSPEC")) != NULL)
 818         copt = "/C";
 819     else
 820         shell = "cmd.exe";
 821 #else
 822     /* Consensus on perl5-porters is that it is _very_ important to
 823        have a shell which will not change between computers with the
 824        same architecture, to avoid "action on a distance".
 825        And to have simple build, this shell should be sh. */
 826     shell = PL_sh_path;
 827     copt = "-c";
 828 #endif
 829
 830     while (*cmd && isSPACE(*cmd))
 831         cmd++;
 832
 833     if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
 834         STRLEN l = strlen(PL_sh_path);
 835
 836         New(1302, news, strlen(cmd) - 7 + l + 1, char);
 837         strcpy(news, PL_sh_path);
 838         strcpy(news + l, cmd + 7);
 839         cmd = news;
 840     }
 841
 842     /* save an extra exec if possible */
 843     /* see if there are shell metacharacters in it */
 844
 845     if (*cmd == '.' && isSPACE(cmd[1]))
 846         goto doshell;
 847
 848     if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
 849         goto doshell;
 850
 851     for (s = cmd; *s && isALPHA(*s); s++) ;     /* catch VAR=val gizmo */
 852     if (*s == '=')
 853         goto doshell;
 854
 855     for (s = cmd; *s; s++) {
 856         if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
 857             if (*s == '\n' && s[1] == '\0') {
 858                 *s = '\0';
 859                 break;
 860             } else if (*s == '\\' && !seenspace) {
 861                 continue;               /* Allow backslashes in names */
 862             } else if (*s == '>' && s >= cmd + 3
 863                         && s[-1] == '2' && s[1] == '&' && s[2] == '1'
 864                         && isSPACE(s[-2]) ) {
 865                 char *t = s + 3;
 866
 867                 while (*t && isSPACE(*t))
 868                     t++;
 869                 if (!*t) {
 870                     s[-2] = '\0';
 871                     mergestderr = 1;
 872                     break;              /* Allow 2>&1 as the last thing */
 873                 }
 874             }
 875             /* We do not convert this to do_spawn_ve since shell
 876                should be smart enough to start itself gloriously. */
 877           doshell:
 878             if (execf == EXECF_TRUEEXEC)
 879                 rc = execl(shell,shell,copt,cmd,(char*)0);
 880             else if (execf == EXECF_EXEC)
 881                 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
 882             else if (execf == EXECF_SPAWN_NOWAIT)
 883                 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
 884             else if (execf == EXECF_SPAWN_BYFLAG)
 885                 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
 886             else {
 887                 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
 888                 if (execf == EXECF_SYNC)
 889                    rc = spawnl(P_WAIT,shell,shell,copt,cmd,(char*)0);
 890                 else
 891                    rc = result(aTHX_ P_WAIT,
 892                                spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
 893                 if (rc < 0 && ckWARN(WARN_EXEC))
 894                     Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
 895                          (execf == EXECF_SPAWN ? "spawn" : "exec"),
 896                          shell, Strerror(errno));
 897                 if (rc < 0)
 898                     rc = -1;
 899             }
 900             if (news)
 901                 Safefree(news);
 902             return rc;
 903         } else if (*s == ' ' || *s == '\t') {
 904             seenspace = 1;
 905         }
 906     }
 907
 908     /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
 909     New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
 910     PL_Cmd = savepvn(cmd, s-cmd);
 911     a = PL_Argv;
 912     for (s = PL_Cmd; *s;) {
 913         while (*s && isSPACE(*s)) s++;
 914         if (*s)
 915             *(a++) = s;
 916         while (*s && !isSPACE(*s)) s++;
 917         if (*s)
 918             *s++ = '\0';
 919     }
 920     *a = Nullch;
 921     if (PL_Argv[0])
 922         rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr);
 923     else
 924         rc = -1;
 925     if (news)
 926         Safefree(news);
 927     do_execfree();
 928     return rc;
 929 }
 930
 931 /* Array spawn.  */
 932 int
 933 os2_do_aspawn(pTHX_ SV *really, register void **vmark, register void **vsp)
 934 {
 935     register SV **mark = (SV **)vmark;
 936     register SV **sp = (SV **)vsp;
 937     register char **a;
 938     int rc;
 939     int flag = P_WAIT, flag_set = 0;
 940     STRLEN n_a;
 941
 942     if (sp > mark) {
 943         New(1301,PL_Argv, sp - mark + 3, char*);
 944         a = PL_Argv;
 945
 946         if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
 947                 ++mark;
 948                 flag = SvIVx(*mark);
 949                 flag_set = 1;
 950
 951         }
 952
 953         while (++mark <= sp) {
 954             if (*mark)
 955                 *a++ = SvPVx(*mark, n_a);
 956             else
 957                 *a++ = "";
 958         }
 959         *a = Nullch;
 960
 961         if (flag_set && (a == PL_Argv + 1)) { /* One arg? */
 962             rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
 963         } else
 964             rc = do_spawn_ve(aTHX_ really, flag, EXECF_SPAWN, NULL, 0);
 965     } else
 966         rc = -1;
 967     do_execfree();
 968     return rc;
 969 }
 970
 971 int
 972 os2_do_spawn(pTHX_ char *cmd)
 973 {
 974     return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
 975 }
 976
 977 int
 978 do_spawn_nowait(pTHX_ char *cmd)
 979 {
 980     return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
 981 }
 982
 983 bool
 984 Perl_do_exec(pTHX_ char *cmd)
 985 {
 986     do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
 987     return FALSE;
 988 }
 989
 990 bool
 991 os2exec(pTHX_ char *cmd)
 992 {
 993     return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
 994 }
 995
 996 PerlIO *
 997 my_syspopen(pTHX_ char *cmd, char *mode)
 998 {
 999 #ifndef USE_POPEN
1000     int p[2];
1001     register I32 this, that, newfd;
1002     register I32 pid;
1003     SV *sv;
1004     int fh_fl = 0;                      /* Pacify the warning */
1005
1006     /* `this' is what we use in the parent, `that' in the child. */
1007     this = (*mode == 'w');
1008     that = !this;
1009     if (PL_tainting) {
1010         taint_env();
1011         taint_proper("Insecure %s%s", "EXEC");
1012     }
1013     if (pipe(p) < 0)
1014         return Nullfp;
1015     /* Now we need to spawn the child. */
1016     if (p[this] == (*mode == 'r')) {    /* if fh 0/1 was initially closed. */
1017         int new = dup(p[this]);
1018
1019         if (new == -1)
1020             goto closepipes;
1021         close(p[this]);
1022         p[this] = new;
1023     }
1024     newfd = dup(*mode == 'r');          /* Preserve std* */
1025     if (newfd == -1) {
1026         /* This cannot happen due to fh being bad after pipe(), since
1027            pipe() should have created fh 0 and 1 even if they were
1028            initially closed.  But we closed p[this] before.  */
1029         if (errno != EBADF) {
1030           closepipes:
1031             close(p[0]);
1032             close(p[1]);
1033             return Nullfp;
1034         }
1035     } else
1036         fh_fl = fcntl(*mode == 'r', F_GETFD);
1037     if (p[that] != (*mode == 'r')) {    /* if fh 0/1 was initially closed. */
1038         dup2(p[that], *mode == 'r');
1039         close(p[that]);
1040     }
1041     /* Where is `this' and newfd now? */
1042     fcntl(p[this], F_SETFD, FD_CLOEXEC);
1043     if (newfd != -1)
1044         fcntl(newfd, F_SETFD, FD_CLOEXEC);
1045     pid = do_spawn_nowait(aTHX_ cmd);
1046     if (newfd == -1)
1047         close(*mode == 'r');            /* It was closed initially */
1048     else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
1049         dup2(newfd, *mode == 'r');      /* Return std* back. */
1050         close(newfd);
1051         fcntl(*mode == 'r', F_SETFD, fh_fl);
1052     } else
1053         fcntl(*mode == 'r', F_SETFD, fh_fl);
1054     if (p[that] == (*mode == 'r'))
1055         close(p[that]);
1056     if (pid == -1) {
1057         close(p[this]);
1058         return Nullfp;
1059     }
1060     if (p[that] < p[this]) {            /* Make fh as small as possible */
1061         dup2(p[this], p[that]);
1062         close(p[this]);
1063         p[this] = p[that];
1064     }
1065     sv = *av_fetch(PL_fdpid,p[this],TRUE);
1066     (void)SvUPGRADE(sv,SVt_IV);
1067     SvIVX(sv) = pid;
1068     PL_forkprocess = pid;
1069     return PerlIO_fdopen(p[this], mode);
1070
1071 #else  /* USE_POPEN */
1072
1073     PerlIO *res;
1074     SV *sv;
1075
1076 #  ifdef TRYSHELL
1077     res = popen(cmd, mode);
1078 #  else
1079     char *shell = getenv("EMXSHELL");
1080
1081     my_setenv("EMXSHELL", PL_sh_path);
1082     res = popen(cmd, mode);
1083     my_setenv("EMXSHELL", shell);
1084 #  endif
1085     sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1086     (void)SvUPGRADE(sv,SVt_IV);
1087     SvIVX(sv) = -1;                     /* A cooky. */
1088     return res;
1089
1090 #endif /* USE_POPEN */
1091
1092 }
1093
1094 /******************************************************************/
1095
1096 #ifndef HAS_FORK
1097 int
1098 fork(void)
1099 {
1100     Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
1101     errno = EINVAL;
1102     return -1;
1103 }
1104 #endif
1105
1106 /*******************************************************************/
1107 /* not implemented in EMX 0.9d */
1108
1109 char *  ctermid(char *s)        { return 0; }
1110
1111 #ifdef MYTTYNAME /* was not in emx0.9a */
1112 void *  ttyname(x)      { return 0; }
1113 #endif
1114
1115 /*****************************************************************************/
1116 /* not implemented in C Set++ */
1117
1118 #ifndef __EMX__
1119 int     setuid(x)       { errno = EINVAL; return -1; }
1120 int     setgid(x)       { errno = EINVAL; return -1; }
1121 #endif
1122
1123 /*****************************************************************************/
1124 /* stat() hack for char/block device */
1125
1126 #if OS2_STAT_HACK
1127
1128     /* First attempt used DosQueryFSAttach which crashed the system when
1129        used with 5.001. Now just look for /dev/. */
1130
1131 int
1132 os2_stat(const char *name, struct stat *st)
1133 {
1134     static int ino = SHRT_MAX;
1135
1136     if (stricmp(name, "/dev/con") != 0
1137      && stricmp(name, "/dev/tty") != 0)
1138         return stat(name, st);
1139
1140     memset(st, 0, sizeof *st);
1141     st->st_mode = S_IFCHR|0666;
1142     st->st_ino = (ino-- & 0x7FFF);
1143     st->st_nlink = 1;
1144     return 0;
1145 }
1146
1147 #endif
1148
1149 #ifdef USE_PERL_SBRK
1150
1151 /* SBRK() emulation, mostly moved to malloc.c. */
1152
1153 void *
1154 sys_alloc(int size) {
1155     void *got;
1156     APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1157
1158     if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1159         return (void *) -1;
1160     } else if ( rc )
1161         Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
1162     return got;
1163 }
1164
1165 #endif /* USE_PERL_SBRK */
1166
1167 /* tmp path */
1168
1169 char *tmppath = TMPPATH1;
1170
1171 void
1172 settmppath()
1173 {
1174     char *p = getenv("TMP"), *tpath;
1175     int len;
1176
1177     if (!p) p = getenv("TEMP");
1178     if (!p) return;
1179     len = strlen(p);
1180     tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1181     if (tpath) {
1182         strcpy(tpath, p);
1183         tpath[len] = '/';
1184         strcpy(tpath + len + 1, TMPPATH1);
1185         tmppath = tpath;
1186     }
1187 }
1188
1189 #include "XSUB.h"
1190
1191 XS(XS_File__Copy_syscopy)
1192 {
1193     dXSARGS;
1194     if (items < 2 || items > 3)
1195         Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
1196     {
1197         STRLEN n_a;
1198         char *  src = (char *)SvPV(ST(0),n_a);
1199         char *  dst = (char *)SvPV(ST(1),n_a);
1200         U32     flag;
1201         int     RETVAL, rc;
1202
1203         if (items < 3)
1204             flag = 0;
1205         else {
1206             flag = (unsigned long)SvIV(ST(2));
1207         }
1208
1209         RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1210         ST(0) = sv_newmortal();
1211         sv_setiv(ST(0), (IV)RETVAL);
1212     }
1213     XSRETURN(1);
1214 }
1215
1216 #define PERL_PATCHLEVEL_H_IMPLICIT      /* Do not init local_patches. */
1217 #include "patchlevel.h"
1218 #undef PERL_PATCHLEVEL_H_IMPLICIT
1219
1220 char *
1221 mod2fname(pTHX_ SV *sv)
1222 {
1223     static char fname[9];
1224     int pos = 6, len, avlen;
1225     unsigned int sum = 0;
1226     char *s;
1227     STRLEN n_a;
1228
1229     if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
1230     sv = SvRV(sv);
1231     if (SvTYPE(sv) != SVt_PVAV)
1232       Perl_croak_nocontext("Not array reference given to mod2fname");
1233
1234     avlen = av_len((AV*)sv);
1235     if (avlen < 0)
1236       Perl_croak_nocontext("Empty array reference given to mod2fname");
1237
1238     s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1239     strncpy(fname, s, 8);
1240     len = strlen(s);
1241     if (len < 6) pos = len;
1242     while (*s) {
1243         sum = 33 * sum + *(s++);        /* Checksumming first chars to
1244                                          * get the capitalization into c.s. */
1245     }
1246     avlen --;
1247     while (avlen >= 0) {
1248         s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1249         while (*s) {
1250             sum = 33 * sum + *(s++);    /* 7 is primitive mod 13. */
1251         }
1252         avlen --;
1253     }
1254    /* We always load modules as *specific* DLLs, and with the full name.
1255       When loading a specific DLL by its full name, one cannot get a
1256       different DLL, even if a DLL with the same basename is loaded already.
1257       Thus there is no need to include the version into the mangling scheme. */
1258 #if 0
1259     sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2;  /* Up to 5.6.1 */
1260 #else
1261 #  ifndef COMPATIBLE_VERSION_SUM  /* Binary compatibility with the 5.00553 binary */
1262 #    define COMPATIBLE_VERSION_SUM (5 * 200 + 53 * 2)
1263 #  endif
1264     sum += COMPATIBLE_VERSION_SUM;
1265 #endif
1266     fname[pos] = 'A' + (sum % 26);
1267     fname[pos + 1] = 'A' + (sum / 26 % 26);
1268     fname[pos + 2] = '\0';
1269     return (char *)fname;
1270 }
1271
1272 XS(XS_DynaLoader_mod2fname)
1273 {
1274     dXSARGS;
1275     if (items != 1)
1276         Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
1277     {
1278         SV *    sv = ST(0);
1279         char *  RETVAL;
1280
1281         RETVAL = mod2fname(aTHX_ sv);
1282         ST(0) = sv_newmortal();
1283         sv_setpv((SV*)ST(0), RETVAL);
1284     }
1285     XSRETURN(1);
1286 }
1287
1288 char *
1289 os2error(int rc)
1290 {
1291         static char buf[300];
1292         ULONG len;
1293         char *s;
1294         int number = SvTRUE(get_sv("OS2::nsyserror", TRUE));
1295
1296         if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1297         if (rc == 0)
1298                 return "";
1299         if (number) {
1300             sprintf(buf, "SYS%04d=%#x: ", rc, rc);
1301             s = buf + strlen(buf);
1302         } else
1303             s = buf;
1304         if (DosGetMessage(NULL, 0, s, sizeof(buf) - 1 - (s-buf),
1305                           rc, "OSO001.MSG", &len)) {
1306             if (!number) {
1307                 sprintf(buf, "SYS%04d=%#x: ", rc, rc);
1308                 s = buf + strlen(buf);
1309             }
1310             sprintf(s, "[No description found in OSO001.MSG]");
1311         } else {
1312                 s[len] = '\0';
1313                 if (len && s[len - 1] == '\n')
1314                         s[--len] = 0;
1315                 if (len && s[len - 1] == '\r')
1316                         s[--len] = 0;
1317                 if (len && s[len - 1] == '.')
1318                         s[--len] = 0;
1319                 if (len >= 10 && number && strnEQ(s, buf, 7)
1320                     && s[7] == ':' && s[8] == ' ')
1321                     /* Some messages start with SYSdddd:, some not */
1322                     Move(s + 9, s, (len -= 9) + 1, char);
1323         }
1324         return buf;
1325 }
1326
1327 void
1328 ResetWinError(void)
1329 {
1330   WinError_2_Perl_rc;
1331 }
1332
1333 void
1334 CroakWinError(int die, char *name)
1335 {
1336   FillWinError;
1337   if (die && Perl_rc)
1338     croak("%s: %s", (name ? name : "Win* API call"), os2error(Perl_rc));
1339 }
1340
1341 char *
1342 os2_execname(pTHX)
1343 {
1344   char buf[300], *p, *o = PL_origargv[0], ok = 1;
1345
1346   if (_execname(buf, sizeof buf) != 0)
1347         return o;
1348   p = buf;
1349   while (*p) {
1350     if (*p == '\\')
1351         *p = '/';
1352     if (*p == '/') {
1353         if (ok && *o != '/' && *o != '\\')
1354             ok = 0;
1355     } else if (ok && tolower(*o) != tolower(*p))
1356         ok = 0;
1357     p++;
1358     o++;
1359   }
1360   if (ok) { /* PL_origargv[0] matches the real name.  Use PL_origargv[0]: */
1361      strcpy(buf, PL_origargv[0]);       /* _execname() is always uppercased */
1362      p = buf;
1363      while (*p) {
1364        if (*p == '\\')
1365            *p = '/';
1366        p++;
1367      }
1368   }
1369   p = savepv(buf);
1370   SAVEFREEPV(p);
1371   return p;
1372 }
1373
1374 char *
1375 perllib_mangle(char *s, unsigned int l)
1376 {
1377     static char *newp, *oldp;
1378     static int newl, oldl, notfound;
1379     static char ret[STATIC_FILE_LENGTH+1];
1380
1381     if (!newp && !notfound) {
1382         newp = getenv("PERLLIB_PREFIX");
1383         if (newp) {
1384             char *s;
1385
1386             oldp = newp;
1387             while (*newp && !isSPACE(*newp) && *newp != ';') {
1388                 newp++; oldl++;         /* Skip digits. */
1389             }
1390             while (*newp && (isSPACE(*newp) || *newp == ';')) {
1391                 newp++;                 /* Skip whitespace. */
1392             }
1393             newl = strlen(newp);
1394             if (newl == 0 || oldl == 0) {
1395                 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1396             }
1397             strcpy(ret, newp);
1398             s = ret;
1399             while (*s) {
1400                 if (*s == '\\') *s = '/';
1401                 s++;
1402             }
1403         } else {
1404             notfound = 1;
1405         }
1406     }
1407     if (!newp) {
1408         return s;
1409     }
1410     if (l == 0) {
1411         l = strlen(s);
1412     }
1413     if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1414         return s;
1415     }
1416     if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1417         Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1418     }
1419     strcpy(ret + newl, s + oldl);
1420     return ret;
1421 }
1422
1423 unsigned long
1424 Perl_hab_GET()                  /* Needed if perl.h cannot be included */
1425 {
1426     return perl_hab_GET();
1427 }
1428
1429 HMQ
1430 Perl_Register_MQ(int serve)
1431 {
1432   if (Perl_hmq_refcnt <= 0) {
1433     PPIB pib;
1434     PTIB tib;
1435
1436     Perl_hmq_refcnt = 0;                /* Be extra safe */
1437     DosGetInfoBlocks(&tib, &pib);
1438     Perl_os2_initial_mode = pib->pib_ultype;
1439     /* Try morphing into a PM application. */
1440     if (pib->pib_ultype != 3)           /* 2 is VIO */
1441         pib->pib_ultype = 3;            /* 3 is PM */
1442     init_PMWIN_entries();
1443     /* 64 messages if before OS/2 3.0, ignored otherwise */
1444     Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1445     if (!Perl_hmq) {
1446         static int cnt;
1447
1448         SAVEINT(cnt);                   /* Allow catch()ing. */
1449         if (cnt++)
1450             _exit(188);                 /* Panic can try to create a window. */
1451         Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application");
1452     }
1453   }
1454     if (serve) {
1455         if ( Perl_hmq_servers <= 0      /* Safe to inform us on shutdown, */
1456              && Perl_hmq_refcnt > 0 )   /* this was switched off before... */
1457             (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0);
1458         Perl_hmq_servers++;
1459     } else if (!Perl_hmq_servers)       /* Do not inform us on shutdown */
1460         (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
1461     Perl_hmq_refcnt++;
1462     return Perl_hmq;
1463 }
1464
1465 int
1466 Perl_Serve_Messages(int force)
1467 {
1468     int cnt = 0;
1469     QMSG msg;
1470
1471     if (Perl_hmq_servers > 0 && !force)
1472         return 0;
1473     if (Perl_hmq_refcnt <= 0)
1474         Perl_croak_nocontext("No message queue");
1475     while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1476         cnt++;
1477         if (msg.msg == WM_QUIT)
1478             Perl_croak_nocontext("QUITing...");
1479         (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1480     }
1481     return cnt;
1482 }
1483
1484 int
1485 Perl_Process_Messages(int force, I32 *cntp)
1486 {
1487     QMSG msg;
1488
1489     if (Perl_hmq_servers > 0 && !force)
1490         return 0;
1491     if (Perl_hmq_refcnt <= 0)
1492         Perl_croak_nocontext("No message queue");
1493     while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1494         if (cntp)
1495             (*cntp)++;
1496         (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1497         if (msg.msg == WM_DESTROY)
1498             return -1;
1499         if (msg.msg == WM_CREATE)
1500             return +1;
1501     }
1502     Perl_croak_nocontext("QUITing...");
1503 }
1504
1505 void
1506 Perl_Deregister_MQ(int serve)
1507 {
1508     PPIB pib;
1509     PTIB tib;
1510
1511     if (serve)
1512         Perl_hmq_servers--;
1513     if (--Perl_hmq_refcnt <= 0) {
1514         init_PMWIN_entries();                   /* To be extra safe */
1515         (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1516         Perl_hmq = 0;
1517         /* Try morphing back from a PM application. */
1518         DosGetInfoBlocks(&tib, &pib);
1519         if (pib->pib_ultype == 3)               /* 3 is PM */
1520             pib->pib_ultype = Perl_os2_initial_mode;
1521         else
1522             Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
1523                  pib->pib_ultype);
1524     } else if (serve && Perl_hmq_servers <= 0)  /* Last server exited */
1525         (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
1526 }
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
1726             (void)SvIV(sv);             /* Force SvIVX */
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 #ifndef INCOMPLETE_TAINTS
1853         SvTAINTED_on(ST(0));
1854 #endif
1855     }
1856     XSRETURN(1);
1857 }
1858
1859 XS(XS_Cwd_sys_abspath)
1860 {
1861     dXSARGS;
1862     if (items < 1 || items > 2)
1863         Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
1864     {
1865         STRLEN n_a;
1866         char *  path = (char *)SvPV(ST(0),n_a);
1867         char *  dir, *s, *t, *e;
1868         char p[MAXPATHLEN];
1869         char *  RETVAL;
1870         int l;
1871         SV *sv;
1872
1873         if (items < 2)
1874             dir = NULL;
1875         else {
1876             dir = (char *)SvPV(ST(1),n_a);
1877         }
1878         if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1879             path += 2;
1880         }
1881         if (dir == NULL) {
1882             if (_abspath(p, path, MAXPATHLEN) == 0) {
1883                 RETVAL = p;
1884             } else {
1885                 RETVAL = NULL;
1886             }
1887         } else {
1888             /* Absolute with drive: */
1889             if ( sys_is_absolute(path) ) {
1890                 if (_abspath(p, path, MAXPATHLEN) == 0) {
1891                     RETVAL = p;
1892                 } else {
1893                     RETVAL = NULL;
1894                 }
1895             } else if (path[0] == '/' || path[0] == '\\') {
1896                 /* Rooted, but maybe on different drive. */
1897                 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1898                     char p1[MAXPATHLEN];
1899
1900                     /* Need to prepend the drive. */
1901                     p1[0] = dir[0];
1902                     p1[1] = dir[1];
1903                     Copy(path, p1 + 2, strlen(path) + 1, char);
1904                     RETVAL = p;
1905                     if (_abspath(p, p1, MAXPATHLEN) == 0) {
1906                         RETVAL = p;
1907                     } else {
1908                         RETVAL = NULL;
1909                     }
1910                 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1911                     RETVAL = p;
1912                 } else {
1913                     RETVAL = NULL;
1914                 }
1915             } else {
1916                 /* Either path is relative, or starts with a drive letter. */
1917                 /* If the path starts with a drive letter, then dir is
1918                    relevant only if
1919                    a/b) it is absolute/x:relative on the same drive.
1920                    c)   path is on current drive, and dir is rooted
1921                    In all the cases it is safe to drop the drive part
1922                    of the path. */
1923                 if ( !sys_is_relative(path) ) {
1924                     if ( ( ( sys_is_absolute(dir)
1925                              || (isALPHA(dir[0]) && dir[1] == ':'
1926                                  && strnicmp(dir, path,1) == 0))
1927                            && strnicmp(dir, path,1) == 0)
1928                          || ( !(isALPHA(dir[0]) && dir[1] == ':')
1929                               && toupper(path[0]) == current_drive())) {
1930                         path += 2;
1931                     } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1932                         RETVAL = p; goto done;
1933                     } else {
1934                         RETVAL = NULL; goto done;
1935                     }
1936                 }
1937                 {
1938                     /* Need to prepend the absolute path of dir. */
1939                     char p1[MAXPATHLEN];
1940
1941                     if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1942                         int l = strlen(p1);
1943
1944                         if (p1[ l - 1 ] != '/') {
1945                             p1[ l ] = '/';
1946                             l++;
1947                         }
1948                         Copy(path, p1 + l, strlen(path) + 1, char);
1949                         if (_abspath(p, p1, MAXPATHLEN) == 0) {
1950                             RETVAL = p;
1951                         } else {
1952                             RETVAL = NULL;
1953                         }
1954                     } else {
1955                         RETVAL = NULL;
1956                     }
1957                 }
1958               done:
1959             }
1960         }
1961         if (!RETVAL)
1962             XSRETURN_EMPTY;
1963         /* Backslashes are already converted to slashes. */
1964         /* Remove trailing slashes */
1965         l = strlen(RETVAL);
1966         while (l > 0 && RETVAL[l-1] == '/')
1967             l--;
1968         ST(0) = sv_newmortal();
1969         sv_setpvn( sv = (SV*)ST(0), RETVAL, l);
1970         /* Remove duplicate slashes, skipping the first three, which
1971            may be parts of a server-based path */
1972         s = t = 3 + SvPV_force(sv, n_a);
1973         e = SvEND(sv);
1974         /* Do not worry about multibyte chars here, this would contradict the
1975            eventual UTFization, and currently most other places break too... */
1976         while (s < e) {
1977             if (s[0] == t[-1] && s[0] == '/')
1978                 s++;                            /* Skip duplicate / */
1979             else
1980                 *t++ = *s++;
1981         }
1982         if (t < e) {
1983             *t = 0;
1984             SvCUR_set(sv, t - SvPVX(sv));
1985         }
1986     }
1987     XSRETURN(1);
1988 }
1989 typedef APIRET (*PELP)(PSZ path, ULONG type);
1990
1991 /* Kernels after 2000/09/15 understand this too: */
1992 #ifndef LIBPATHSTRICT
1993 #  define LIBPATHSTRICT 3
1994 #endif
1995
1996 APIRET
1997 ExtLIBPATH(ULONG ord, PSZ path, IV type)
1998 {
1999     ULONG what;
2000     PFN f = loadByOrdinal(ord, 1);      /* Guarantied to load or die! */
2001
2002     if (type > 0)
2003         what = END_LIBPATH;
2004     else if (type == 0)
2005         what = BEGIN_LIBPATH;
2006     else
2007         what = LIBPATHSTRICT;
2008     return (*(PELP)f)(path, what);
2009 }
2010
2011 #define extLibpath(to,type)                                             \
2012     (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type))) ? NULL : (to) )
2013
2014 #define extLibpath_set(p,type)                                  \
2015     (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type))))
2016
2017 XS(XS_Cwd_extLibpath)
2018 {
2019     dXSARGS;
2020     if (items < 0 || items > 1)
2021         Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
2022     {
2023         IV      type;
2024         char    to[1024];
2025         U32     rc;
2026         char *  RETVAL;
2027
2028         if (items < 1)
2029             type = 0;
2030         else {
2031             type = SvIV(ST(0));
2032         }
2033
2034         to[0] = 1; to[1] = 0;           /* Sometimes no error reported */
2035         RETVAL = extLibpath(to, type);
2036         if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
2037             Perl_croak_nocontext("panic Cwd::extLibpath parameter");
2038         ST(0) = sv_newmortal();
2039         sv_setpv((SV*)ST(0), RETVAL);
2040     }
2041     XSRETURN(1);
2042 }
2043
2044 XS(XS_Cwd_extLibpath_set)
2045 {
2046     dXSARGS;
2047     if (items < 1 || items > 2)
2048         Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
2049     {
2050         STRLEN n_a;
2051         char *  s = (char *)SvPV(ST(0),n_a);
2052         IV      type;
2053         U32     rc;
2054         bool    RETVAL;
2055
2056         if (items < 2)
2057             type = 0;
2058         else {
2059             type = SvIV(ST(1));
2060         }
2061
2062         RETVAL = extLibpath_set(s, type);
2063         ST(0) = boolSV(RETVAL);
2064         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2065     }
2066     XSRETURN(1);
2067 }
2068
2069 /* Input: Address, BufLen
2070 APIRET APIENTRY
2071 DosQueryModFromEIP (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
2072                     ULONG * Offset, ULONG Address);
2073 */
2074
2075 DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP,
2076                         (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
2077                         ULONG * Offset, ULONG Address),
2078                         (hmod, obj, BufLen, Buf, Offset, Address))
2079
2080 enum module_name_how { mod_name_handle, mod_name_shortname, mod_name_full};
2081
2082 static SV*
2083 module_name_at(void *pp, enum module_name_how how)
2084 {
2085     char buf[MAXPATHLEN];
2086     char *p = buf;
2087     HMODULE mod;
2088     ULONG obj, offset, rc;
2089
2090     if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, (ULONG)pp))
2091         return &PL_sv_undef;
2092     if (how == mod_name_handle)
2093         return newSVuv(mod);
2094     /* Full name... */
2095     if ( how == mod_name_full
2096          && CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) )
2097         return &PL_sv_undef;
2098     while (*p) {
2099         if (*p == '\\')
2100             *p = '/';
2101         p++;
2102     }
2103     return newSVpv(buf, 0);
2104 }
2105
2106 static SV*
2107 module_name_of_cv(SV *cv, enum module_name_how how)
2108 {
2109     if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv)))
2110         croak("Not an XSUB reference");
2111     return module_name_at(CvXSUB(SvRV(cv)), how);
2112 }
2113
2114 /* Find module name to which *this* subroutine is compiled */
2115 #define module_name(how)        module_name_at(&module_name_at, how)
2116
2117 XS(XS_OS2_DLLname)
2118 {
2119     dXSARGS;
2120     if (items > 2)
2121         Perl_croak(aTHX_ "Usage: OS2::DLLname( [ how, [\\&xsub] ] )");
2122     {
2123         SV *    RETVAL;
2124         int     how;
2125
2126         if (items < 1)
2127             how = mod_name_full;
2128         else {
2129             how = (int)SvIV(ST(0));
2130         }
2131         if (items < 2)
2132             RETVAL = module_name(how);
2133         else
2134             RETVAL = module_name_of_cv(ST(1), how);
2135         ST(0) = RETVAL;
2136         sv_2mortal(ST(0));
2137     }
2138     XSRETURN(1);
2139 }
2140
2141 #define get_control87()         _control87(0,0)
2142 #define set_control87           _control87
2143
2144 XS(XS_OS2__control87)
2145 {
2146     dXSARGS;
2147     if (items != 2)
2148         croak("Usage: OS2::_control87(new,mask)");
2149     {
2150         unsigned        new = (unsigned)SvIV(ST(0));
2151         unsigned        mask = (unsigned)SvIV(ST(1));
2152         unsigned        RETVAL;
2153
2154         RETVAL = _control87(new, mask);
2155         ST(0) = sv_newmortal();
2156         sv_setiv(ST(0), (IV)RETVAL);
2157     }
2158     XSRETURN(1);
2159 }
2160
2161 XS(XS_OS2_get_control87)
2162 {
2163     dXSARGS;
2164     if (items != 0)
2165         croak("Usage: OS2::get_control87()");
2166     {
2167         unsigned        RETVAL;
2168
2169         RETVAL = get_control87();
2170         ST(0) = sv_newmortal();
2171         sv_setiv(ST(0), (IV)RETVAL);
2172     }
2173     XSRETURN(1);
2174 }
2175
2176
2177 XS(XS_OS2_set_control87)
2178 {
2179     dXSARGS;
2180     if (items < 0 || items > 2)
2181         croak("Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
2182     {
2183         unsigned        new;
2184         unsigned        mask;
2185         unsigned        RETVAL;
2186
2187         if (items < 1)
2188             new = MCW_EM;
2189         else {
2190             new = (unsigned)SvIV(ST(0));
2191         }
2192
2193         if (items < 2)
2194             mask = MCW_EM;
2195         else {
2196             mask = (unsigned)SvIV(ST(1));
2197         }
2198
2199         RETVAL = set_control87(new, mask);
2200         ST(0) = sv_newmortal();
2201         sv_setiv(ST(0), (IV)RETVAL);
2202     }
2203     XSRETURN(1);
2204 }
2205
2206 int
2207 Xs_OS2_init(pTHX)
2208 {
2209     char *file = __FILE__;
2210     {
2211         GV *gv;
2212
2213         if (_emx_env & 0x200) { /* OS/2 */
2214             newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2215             newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2216             newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2217         }
2218         newXS("OS2::Error", XS_OS2_Error, file);
2219         newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2220         newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2221         newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2222         newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2223         newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2224         newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2225         newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
2226         newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2227         newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2228         newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2229         newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2230         newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2231         newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2232         newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2233         newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2234         newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
2235         newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
2236         newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
2237         newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
2238         newXSproto("OS2::DLLname", XS_OS2_DLLname, file, ";$$");
2239         gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2240         GvMULTI_on(gv);
2241 #ifdef PERL_IS_AOUT
2242         sv_setiv(GvSV(gv), 1);
2243 #endif
2244         gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV);
2245         GvMULTI_on(gv);
2246         sv_setiv(GvSV(gv), exe_is_aout());
2247         gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2248         GvMULTI_on(gv);
2249         sv_setiv(GvSV(gv), _emx_rev);
2250         sv_setpv(GvSV(gv), _emx_vprt);
2251         SvIOK_on(GvSV(gv));
2252         gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2253         GvMULTI_on(gv);
2254         sv_setiv(GvSV(gv), _emx_env);
2255         gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2256         GvMULTI_on(gv);
2257         sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
2258         gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV);
2259         GvMULTI_on(gv);
2260         sv_setiv(GvSV(gv), 1);          /* DEFAULT: Show number on syserror */
2261     }
2262     return 0;
2263 }
2264
2265 OS2_Perl_data_t OS2_Perl_data;
2266
2267 extern void _emx_init(void*);
2268
2269 static void jmp_out_of_atexit(void);
2270
2271 #define FORCE_EMX_INIT_CONTRACT_ARGV    1
2272 #define FORCE_EMX_INIT_INSTALL_ATEXIT   2
2273
2274 static void
2275 my_emx_init(void *layout) {
2276     static volatile void *p = 0;        /* Cannot be on stack! */
2277
2278     /* Can't just call emx_init(), since it moves the stack pointer */
2279     /* It also busts a lot of registers, so be extra careful */
2280     __asm__(    "pushf\n"
2281                 "pusha\n"
2282                 "movl %%esp, %1\n"
2283                 "push %0\n"
2284                 "call __emx_init\n"
2285                 "movl %1, %%esp\n"
2286                 "popa\n"
2287                 "popf\n" : : "r" (layout), "m" (p)      );
2288 }
2289
2290 struct layout_table_t {
2291     ULONG text_base;
2292     ULONG text_end;
2293     ULONG data_base;
2294     ULONG data_end;
2295     ULONG bss_base;
2296     ULONG bss_end;
2297     ULONG heap_base;
2298     ULONG heap_end;
2299     ULONG heap_brk;
2300     ULONG heap_off;
2301     ULONG os2_dll;
2302     ULONG stack_base;
2303     ULONG stack_end;
2304     ULONG flags;
2305     ULONG reserved[2];
2306     char options[64];
2307 };
2308
2309 static ULONG
2310 my_os_version() {
2311     static ULONG res;                   /* Cannot be on stack! */
2312
2313     /* Can't just call __os_version(), since it does not follow C
2314        calling convention: it busts a lot of registers, so be extra careful */
2315     __asm__(    "pushf\n"
2316                 "pusha\n"
2317                 "call ___os_version\n"
2318                 "movl %%eax, %0\n"
2319                 "popa\n"
2320                 "popf\n" : "=m" (res)   );
2321
2322     return res;
2323 }
2324
2325 static void
2326 force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags)
2327 {
2328     /* Calling emx_init() will bust the top of stack: it installs an
2329        exception handler and puts argv data there. */
2330     char *oldarg, *oldenv;
2331     void *oldstackend, *oldstack;
2332     PPIB pib;
2333     PTIB tib;
2334     static ULONG os2_dll;
2335     ULONG rc, error = 0, out;
2336     char buf[512];
2337     static struct layout_table_t layout_table;
2338     struct {
2339         char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */
2340         double alignment1;
2341         EXCEPTIONREGISTRATIONRECORD xreg;
2342     } *newstack;
2343     char *s;
2344
2345     layout_table.os2_dll = (ULONG)&os2_dll;
2346     layout_table.flags   = 0x02000002;  /* flags: application, OMF */
2347
2348     DosGetInfoBlocks(&tib, &pib);
2349     oldarg = pib->pib_pchcmd;
2350     oldenv = pib->pib_pchenv;
2351     oldstack = tib->tib_pstack;
2352     oldstackend = tib->tib_pstacklimit;
2353
2354     /* Minimize the damage to the stack via reducing the size of argv. */
2355     if (flags & FORCE_EMX_INIT_CONTRACT_ARGV) {
2356         pib->pib_pchcmd = "\0\0";       /* Need 3 concatenated strings */
2357         pib->pib_pchcmd = "\0";         /* Ended by an extra \0. */
2358     }
2359
2360     newstack = alloca(sizeof(*newstack));
2361     /* Emulate the stack probe */
2362     s = ((char*)newstack) + sizeof(*newstack);
2363     while (s > (char*)newstack) {
2364         s[-1] = 0;
2365         s -= 4096;
2366     }
2367
2368     /* Reassigning stack is documented to work */
2369     tib->tib_pstack = (void*)newstack;
2370     tib->tib_pstacklimit = (void*)((char*)newstack + sizeof(*newstack));
2371
2372     /* Can't just call emx_init(), since it moves the stack pointer */
2373     my_emx_init((void*)&layout_table);
2374
2375     /* Remove the exception handler, cannot use it - too low on the stack.
2376        Check whether it is inside the new stack.  */
2377     buf[0] = 0;
2378     if (tib->tib_pexchain >= tib->tib_pstacklimit
2379         || tib->tib_pexchain < tib->tib_pstack) {
2380         error = 1;
2381         sprintf(buf,
2382                 "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n",
2383                 (unsigned long)tib->tib_pstack,
2384                 (unsigned long)tib->tib_pexchain,
2385                 (unsigned long)tib->tib_pstacklimit);
2386         goto finish;
2387     }
2388     if (tib->tib_pexchain != &(newstack->xreg)) {
2389         sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n",
2390                 (unsigned long)tib->tib_pexchain,
2391                 (unsigned long)&(newstack->xreg));
2392     }
2393     rc = DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)tib->tib_pexchain);
2394     if (rc)
2395         sprintf(buf + strlen(buf),
2396                 "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc);
2397
2398     if (preg) {
2399         /* ExceptionRecords should be on stack, in a correct order.  Sigh... */
2400         preg->prev_structure = 0;
2401         preg->ExceptionHandler = _emx_exception;
2402         rc = DosSetExceptionHandler(preg);
2403         if (rc) {
2404             sprintf(buf + strlen(buf),
2405                     "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc);
2406             DosWrite(2, buf, strlen(buf), &out);
2407             emx_exception_init = 1;     /* Do it around spawn*() calls */
2408         }
2409     } else
2410         emx_exception_init = 1;         /* Do it around spawn*() calls */
2411
2412   finish:
2413     /* Restore the damage */
2414     pib->pib_pchcmd = oldarg;
2415     pib->pib_pchcmd = oldenv;
2416     tib->tib_pstacklimit = oldstackend;
2417     tib->tib_pstack = oldstack;
2418     emx_runtime_init = 1;
2419     if (buf[0])
2420         DosWrite(2, buf, strlen(buf), &out);
2421     if (error)
2422         exit(56);
2423 }
2424
2425 jmp_buf at_exit_buf;
2426 int longjmp_at_exit;
2427
2428 static void
2429 jmp_out_of_atexit(void)
2430 {
2431     if (longjmp_at_exit)
2432         longjmp(at_exit_buf, 1);
2433 }
2434
2435 extern void _CRT_term(void);
2436
2437 int emx_runtime_secondary;
2438
2439 void
2440 Perl_OS2_term(void **p, int exitstatus, int flags)
2441 {
2442     if (!emx_runtime_secondary)
2443         return;
2444
2445     /* The principal executable is not running the same CRTL, so there
2446        is nobody to shutdown *this* CRTL except us... */
2447     if (flags & FORCE_EMX_DEINIT_EXIT) {
2448         if (p && !emx_exception_init)
2449             DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
2450         /* Do not run the executable's CRTL's termination routines */
2451         exit(exitstatus);               /* Run at-exit, flush buffers, etc */
2452     }
2453     /* Run at-exit list, and jump out at the end */
2454     if ((flags & FORCE_EMX_DEINIT_RUN_ATEXIT) && !setjmp(at_exit_buf)) {
2455         longjmp_at_exit = 1;
2456         exit(exitstatus);               /* The first pass through "if" */
2457     }
2458
2459     /* Get here if we managed to jump out of exit(), or did not run atexit. */
2460     longjmp_at_exit = 0;                /* Maybe exit() is called again? */
2461 #if 0 /* _atexit_n is not exported */
2462     if (flags & FORCE_EMX_DEINIT_RUN_ATEXIT)
2463         _atexit_n = 0;                  /* Remove the atexit() handlers */
2464 #endif
2465     /* Will segfault on program termination if we leave this dangling... */
2466     if (p && !emx_exception_init)
2467         DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
2468     /* Typically there is no need to do this, done from _DLL_InitTerm() */
2469     if (flags & FORCE_EMX_DEINIT_CRT_TERM)
2470         _CRT_term();                    /* Flush buffers, etc. */
2471     /* Now it is a good time to call exit() in the caller's CRTL... */
2472 }
2473
2474 #include <emx/startup.h>
2475
2476 extern ULONG __os_version();            /* See system.doc */
2477
2478 static int emx_wasnt_initialized;
2479
2480 void
2481 check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
2482 {
2483     ULONG v_crt, v_emx;
2484
2485     /*  If _environ is not set, this code sits in a DLL which
2486         uses a CRT DLL which not compatible with the executable's
2487         CRT library.  Some parts of the DLL are not initialized.
2488      */
2489     if (_environ != NULL)
2490         return;                         /* Properly initialized */
2491
2492     /*  If the executable does not use EMX.DLL, EMX.DLL is not completely
2493         initialized either.  Uninitialized EMX.DLL returns 0 in the low
2494         nibble of __os_version().  */
2495     v_emx = my_os_version();
2496
2497     /*  _osmajor and _osminor are normally set in _DLL_InitTerm of CRT DLL
2498         (=>_CRT_init=>_entry2) via a call to __os_version(), then
2499         reset when the EXE initialization code calls _text=>_init=>_entry2.
2500         The first time they are wrongly set to 0; the second time the
2501         EXE initialization code had already called emx_init=>initialize1
2502         which correctly set version_major, version_minor used by
2503         __os_version().  */
2504     v_crt = (_osmajor | _osminor);
2505
2506     if ((_emx_env & 0x200) && !(v_emx & 0xFFFF)) {      /* OS/2, EMX uninit. */
2507         force_init_emx_runtime( preg,
2508                                 FORCE_EMX_INIT_CONTRACT_ARGV
2509                                 | FORCE_EMX_INIT_INSTALL_ATEXIT );
2510         emx_wasnt_initialized = 1;
2511         /* Update CRTL data basing on now-valid EMX runtime data */
2512         if (!v_crt) {           /* The only wrong data are the versions. */
2513             v_emx = my_os_version();                    /* *Now* it works */
2514             *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */
2515             *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF;
2516         }
2517     }
2518     emx_runtime_secondary = 1;
2519     /* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */
2520     atexit(jmp_out_of_atexit);          /* Allow run of atexit() w/o exit()  */
2521
2522     if (env == NULL) {                  /* Fetch from the process info block */
2523         int c = 0;
2524         PPIB pib;
2525         PTIB tib;
2526         char *e, **ep;
2527
2528         DosGetInfoBlocks(&tib, &pib);
2529         e = pib->pib_pchenv;
2530         while (*e) {                    /* Get count */
2531             c++;
2532             e = e + strlen(e) + 1;
2533         }
2534         New(1307, env, c + 1, char*);
2535         ep = env;
2536         e = pib->pib_pchenv;
2537         while (c--) {
2538             *ep++ = e;
2539             e = e + strlen(e) + 1;
2540         }
2541         *ep = NULL;
2542     }
2543     _environ = _org_environ = env;
2544 }
2545
2546 #define ENTRY_POINT 0x10000
2547
2548 static int
2549 exe_is_aout(void)
2550 {
2551     struct layout_table_t *layout;
2552     if (emx_wasnt_initialized)
2553         return 0;
2554     /* Now we know that the principal executable is an EMX application
2555        - unless somebody did already play with delayed initialization... */
2556     /* With EMX applications to determine whether it is AOUT one needs
2557        to examine the start of the executable to find "layout" */
2558     if ( *(unsigned char*)ENTRY_POINT != 0x68           /* PUSH n */
2559          || *(unsigned char*)(ENTRY_POINT+5) != 0xe8    /* CALL */
2560          || *(unsigned char*)(ENTRY_POINT+10) != 0xeb   /* JMP */
2561          || *(unsigned char*)(ENTRY_POINT+12) != 0xe8)  /* CALL */
2562         return 0;                                       /* ! EMX executable */
2563     /* Fix alignment */
2564     Copy((char*)(ENTRY_POINT+1), &layout, 1, struct layout_table_t*);
2565     return !(layout->flags & 2);
2566 }
2567
2568 void
2569 Perl_OS2_init(char **env)
2570 {
2571     Perl_OS2_init3(env, 0, 0);
2572 }
2573
2574 void
2575 Perl_OS2_init3(char **env, void **preg, int flags)
2576 {
2577     char *shell;
2578
2579     _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
2580     MALLOC_INIT;
2581
2582     check_emx_runtime(env, (EXCEPTIONREGISTRATIONRECORD *)preg);
2583
2584     settmppath();
2585     OS2_Perl_data.xs_init = &Xs_OS2_init;
2586     if ( (shell = getenv("PERL_SH_DRIVE")) ) {
2587         New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2588         strcpy(PL_sh_path, SH_PATH);
2589         PL_sh_path[0] = shell[0];
2590     } else if ( (shell = getenv("PERL_SH_DIR")) ) {
2591         int l = strlen(shell), i;
2592         if (shell[l-1] == '/' || shell[l-1] == '\\') {
2593             l--;
2594         }
2595         New(1304, PL_sh_path, l + 8, char);
2596         strncpy(PL_sh_path, shell, l);
2597         strcpy(PL_sh_path + l, "/sh.exe");
2598         for (i = 0; i < l; i++) {
2599             if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2600         }
2601     }
2602     MUTEX_INIT(&start_thread_mutex);
2603     os2_mytype = my_type();             /* Do it before morphing.  Needed? */
2604     /* Some DLLs reset FP flags on load.  We may have been linked with them */
2605     _control87(MCW_EM, MCW_EM);
2606 }
2607
2608 #undef tmpnam
2609 #undef tmpfile
2610
2611 char *
2612 my_tmpnam (char *str)
2613 {
2614     char *p = getenv("TMP"), *tpath;
2615
2616     if (!p) p = getenv("TEMP");
2617     tpath = tempnam(p, "pltmp");
2618     if (str && tpath) {
2619         strcpy(str, tpath);
2620         return str;
2621     }
2622     return tpath;
2623 }
2624
2625 FILE *
2626 my_tmpfile ()
2627 {
2628     struct stat s;
2629
2630     stat(".", &s);
2631     if (s.st_mode & S_IWOTH) {
2632         return tmpfile();
2633     }
2634     return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2635                                              grants TMP. */
2636 }
2637
2638 #undef rmdir
2639
2640 /* EMX flavors do not tolerate trailing slashes.  t/op/mkdir.t has many
2641    trailing slashes, so we need to support this as well. */
2642
2643 int
2644 my_rmdir (__const__ char *s)
2645 {
2646     char b[MAXPATHLEN];
2647     char *buf = b;
2648     STRLEN l = strlen(s);
2649     int rc;
2650
2651     if (s[l-1] == '/' || s[l-1] == '\\') {      /* EMX mkdir fails... */
2652         if (l >= sizeof b)
2653             New(1305, buf, l + 1, char);
2654         strcpy(buf,s);
2655         while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
2656             l--;
2657         buf[l] = 0;
2658         s = buf;
2659     }
2660     rc = rmdir(s);
2661     if (b != buf)
2662         Safefree(buf);
2663     return rc;
2664 }
2665
2666 #undef mkdir
2667
2668 int
2669 my_mkdir (__const__ char *s, long perm)
2670 {
2671     char b[MAXPATHLEN];
2672     char *buf = b;
2673     STRLEN l = strlen(s);
2674     int rc;
2675
2676     if (s[l-1] == '/' || s[l-1] == '\\') {      /* EMX mkdir fails... */
2677         if (l >= sizeof b)
2678             New(1305, buf, l + 1, char);
2679         strcpy(buf,s);
2680         while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
2681             l--;
2682         buf[l] = 0;
2683         s = buf;
2684     }
2685     rc = mkdir(s, perm);
2686     if (b != buf)
2687         Safefree(buf);
2688     return rc;
2689 }
2690
2691 #undef flock
2692
2693 /* This code was contributed by Rocco Caputo. */
2694 int
2695 my_flock(int handle, int o)
2696 {
2697   FILELOCK      rNull, rFull;
2698   ULONG         timeout, handle_type, flag_word;
2699   APIRET        rc;
2700   int           blocking, shared;
2701   static int    use_my = -1;
2702
2703   if (use_my == -1) {
2704     char *s = getenv("USE_PERL_FLOCK");
2705     if (s)
2706         use_my = atoi(s);
2707     else
2708         use_my = 1;
2709   }
2710   if (!(_emx_env & 0x200) || !use_my)
2711     return flock(handle, o);    /* Delegate to EMX. */
2712
2713                                         /* is this a file? */
2714   if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2715       (handle_type & 0xFF))
2716   {
2717     errno = EBADF;
2718     return -1;
2719   }
2720                                         /* set lock/unlock ranges */
2721   rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2722   rFull.lRange = 0x7FFFFFFF;
2723                                         /* set timeout for blocking */
2724   timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2725                                         /* shared or exclusive? */
2726   shared = (o & LOCK_SH) ? 1 : 0;
2727                                         /* do not block the unlock */
2728   if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2729     rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2730     switch (rc) {
2731       case 0:
2732         errno = 0;
2733         return 0;
2734       case ERROR_INVALID_HANDLE:
2735         errno = EBADF;
2736         return -1;
2737       case ERROR_SHARING_BUFFER_EXCEEDED:
2738         errno = ENOLCK;
2739         return -1;
2740       case ERROR_LOCK_VIOLATION:
2741         break;                          /* not an error */
2742       case ERROR_INVALID_PARAMETER:
2743       case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2744       case ERROR_READ_LOCKS_NOT_SUPPORTED:
2745         errno = EINVAL;
2746         return -1;
2747       case ERROR_INTERRUPT:
2748         errno = EINTR;
2749         return -1;
2750       default:
2751         errno = EINVAL;
2752         return -1;
2753     }
2754   }
2755                                         /* lock may block */
2756   if (o & (LOCK_SH | LOCK_EX)) {
2757                                         /* for blocking operations */
2758     for (;;) {
2759       rc =
2760         DosSetFileLocks(
2761                 handle,
2762                 &rNull,
2763                 &rFull,
2764                 timeout,
2765                 shared
2766         );
2767       switch (rc) {
2768         case 0:
2769           errno = 0;
2770           return 0;
2771         case ERROR_INVALID_HANDLE:
2772           errno = EBADF;
2773           return -1;
2774         case ERROR_SHARING_BUFFER_EXCEEDED:
2775           errno = ENOLCK;
2776           return -1;
2777         case ERROR_LOCK_VIOLATION:
2778           if (!blocking) {
2779             errno = EWOULDBLOCK;
2780             return -1;
2781           }
2782           break;
2783         case ERROR_INVALID_PARAMETER:
2784         case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2785         case ERROR_READ_LOCKS_NOT_SUPPORTED:
2786           errno = EINVAL;
2787           return -1;
2788         case ERROR_INTERRUPT:
2789           errno = EINTR;
2790           return -1;
2791         default:
2792           errno = EINVAL;
2793           return -1;
2794       }
2795                                         /* give away timeslice */
2796       DosSleep(1);
2797     }
2798   }
2799
2800   errno = 0;
2801   return 0;
2802 }
2803
2804 static int pwent_cnt;
2805 static int _my_pwent = -1;
2806
2807 static int
2808 use_my_pwent(void)
2809 {
2810   if (_my_pwent == -1) {
2811     char *s = getenv("USE_PERL_PWENT");
2812     if (s)
2813         _my_pwent = atoi(s);
2814     else
2815         _my_pwent = 1;
2816   }
2817   return _my_pwent;
2818 }
2819
2820 #undef setpwent
2821 #undef getpwent
2822 #undef endpwent
2823
2824 void
2825 my_setpwent(void)
2826 {
2827   if (!use_my_pwent()) {
2828     setpwent();                 /* Delegate to EMX. */
2829     return;
2830   }
2831   pwent_cnt = 0;
2832 }
2833
2834 void
2835 my_endpwent(void)
2836 {
2837   if (!use_my_pwent()) {
2838     endpwent();                 /* Delegate to EMX. */
2839     return;
2840   }
2841 }
2842
2843 struct passwd *
2844 my_getpwent (void)
2845 {
2846   if (!use_my_pwent())
2847     return getpwent();                  /* Delegate to EMX. */
2848   if (pwent_cnt++)
2849     return 0;                           /* Return one entry only */
2850   return getpwuid(0);
2851 }
2852
2853 static int grent_cnt;
2854
2855 void
2856 setgrent(void)
2857 {
2858   grent_cnt = 0;
2859 }
2860
2861 void
2862 endgrent(void)
2863 {
2864 }
2865
2866 struct group *
2867 getgrent (void)
2868 {
2869   if (grent_cnt++)
2870     return 0;                           /* Return one entry only */
2871   return getgrgid(0);
2872 }
2873
2874 #undef getpwuid
2875 #undef getpwnam
2876
2877 /* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */
2878 static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
2879
2880 static struct passwd *
2881 passw_wrap(struct passwd *p)
2882 {
2883     static struct passwd pw;
2884     char *s;
2885
2886     if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
2887         return p;
2888     pw = *p;
2889     s = getenv("PW_PASSWD");
2890     if (!s)
2891         s = (char*)pw_p;                /* Make match impossible */
2892
2893     pw.pw_passwd = s;
2894     return &pw;
2895 }
2896
2897 struct passwd *
2898 my_getpwuid (uid_t id)
2899 {
2900     return passw_wrap(getpwuid(id));
2901 }
2902
2903 struct passwd *
2904 my_getpwnam (__const__ char *n)
2905 {
2906     return passw_wrap(getpwnam(n));
2907 }
2908
2909 char *
2910 gcvt_os2 (double value, int digits, char *buffer)
2911 {
2912   return gcvt (value, digits, buffer);
2913 }