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