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;
1975         char p[MAXPATHLEN];
1976         char *  RETVAL;
1977
1978         if (items < 2)
1979             dir = NULL;
1980         else {
1981             dir = (char *)SvPV(ST(1),n_a);
1982         }
1983         if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1984             path += 2;
1985         }
1986         if (dir == NULL) {
1987             if (_abspath(p, path, MAXPATHLEN) == 0) {
1988                 RETVAL = p;
1989             } else {
1990                 RETVAL = NULL;
1991             }
1992         } else {
1993             /* Absolute with drive: */
1994             if ( sys_is_absolute(path) ) {
1995                 if (_abspath(p, path, MAXPATHLEN) == 0) {
1996                     RETVAL = p;
1997                 } else {
1998                     RETVAL = NULL;
1999                 }
2000             } else if (path[0] == '/' || path[0] == '\\') {
2001                 /* Rooted, but maybe on different drive. */
2002                 if (isALPHA(dir[0]) && dir[1] == ':' ) {
2003                     char p1[MAXPATHLEN];
2004
2005                     /* Need to prepend the drive. */
2006                     p1[0] = dir[0];
2007                     p1[1] = dir[1];
2008                     Copy(path, p1 + 2, strlen(path) + 1, char);
2009                     RETVAL = p;
2010                     if (_abspath(p, p1, MAXPATHLEN) == 0) {
2011                         RETVAL = p;
2012                     } else {
2013                         RETVAL = NULL;
2014                     }
2015                 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
2016                     RETVAL = p;
2017                 } else {
2018                     RETVAL = NULL;
2019                 }
2020             } else {
2021                 /* Either path is relative, or starts with a drive letter. */
2022                 /* If the path starts with a drive letter, then dir is
2023                    relevant only if
2024                    a/b) it is absolute/x:relative on the same drive.
2025                    c)   path is on current drive, and dir is rooted
2026                    In all the cases it is safe to drop the drive part
2027                    of the path. */
2028                 if ( !sys_is_relative(path) ) {
2029                     if ( ( ( sys_is_absolute(dir)
2030                              || (isALPHA(dir[0]) && dir[1] == ':'
2031                                  && strnicmp(dir, path,1) == 0))
2032                            && strnicmp(dir, path,1) == 0)
2033                          || ( !(isALPHA(dir[0]) && dir[1] == ':')
2034                               && toupper(path[0]) == current_drive())) {
2035                         path += 2;
2036                     } else if (_abspath(p, path, MAXPATHLEN) == 0) {
2037                         RETVAL = p; goto done;
2038                     } else {
2039                         RETVAL = NULL; goto done;
2040                     }
2041                 }
2042                 {
2043                     /* Need to prepend the absolute path of dir. */
2044                     char p1[MAXPATHLEN];
2045
2046                     if (_abspath(p1, dir, MAXPATHLEN) == 0) {
2047                         int l = strlen(p1);
2048
2049                         if (p1[ l - 1 ] != '/') {
2050                             p1[ l ] = '/';
2051                             l++;
2052                         }
2053                         Copy(path, p1 + l, strlen(path) + 1, char);
2054                         if (_abspath(p, p1, MAXPATHLEN) == 0) {
2055                             RETVAL = p;
2056                         } else {
2057                             RETVAL = NULL;
2058                         }
2059                     } else {
2060                         RETVAL = NULL;
2061                     }
2062                 }
2063               done:
2064             }
2065         }
2066         ST(0) = sv_newmortal();
2067         sv_setpv((SV*)ST(0), RETVAL);
2068     }
2069     XSRETURN(1);
2070 }
2071 typedef APIRET (*PELP)(PSZ path, ULONG type);
2072
2073 /* Kernels after 2000/09/15 understand this too: */
2074 #ifndef LIBPATHSTRICT
2075 #  define LIBPATHSTRICT 3
2076 #endif
2077
2078 APIRET
2079 ExtLIBPATH(ULONG ord, PSZ path, IV type)
2080 {
2081     ULONG what;
2082     PFN f = loadByOrdinal(ord, 1);      /* Guarantied to load or die! */
2083
2084     if (type > 0)
2085         what = END_LIBPATH;
2086     else if (type == 0)
2087         what = BEGIN_LIBPATH;
2088     else
2089         what = LIBPATHSTRICT;
2090     return (*(PELP)f)(path, what);
2091 }
2092
2093 #define extLibpath(to,type)                                             \
2094     (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type))) ? NULL : (to) )
2095
2096 #define extLibpath_set(p,type)                                  \
2097     (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type))))
2098
2099 XS(XS_Cwd_extLibpath)
2100 {
2101     dXSARGS;
2102     if (items < 0 || items > 1)
2103         Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
2104     {
2105         IV      type;
2106         char    to[1024];
2107         U32     rc;
2108         char *  RETVAL;
2109
2110         if (items < 1)
2111             type = 0;
2112         else {
2113             type = SvIV(ST(0));
2114         }
2115
2116         to[0] = 1; to[1] = 0;           /* Sometimes no error reported */
2117         RETVAL = extLibpath(to, type);
2118         if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
2119             Perl_croak_nocontext("panic Cwd::extLibpath parameter");
2120         ST(0) = sv_newmortal();
2121         sv_setpv((SV*)ST(0), RETVAL);
2122     }
2123     XSRETURN(1);
2124 }
2125
2126 XS(XS_Cwd_extLibpath_set)
2127 {
2128     dXSARGS;
2129     if (items < 1 || items > 2)
2130         Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
2131     {
2132         STRLEN n_a;
2133         char *  s = (char *)SvPV(ST(0),n_a);
2134         IV      type;
2135         U32     rc;
2136         bool    RETVAL;
2137
2138         if (items < 2)
2139             type = 0;
2140         else {
2141             type = SvIV(ST(1));
2142         }
2143
2144         RETVAL = extLibpath_set(s, type);
2145         ST(0) = boolSV(RETVAL);
2146         if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2147     }
2148     XSRETURN(1);
2149 }
2150
2151 #define get_control87()         _control87(0,0)
2152 #define set_control87           _control87
2153
2154 XS(XS_OS2__control87)
2155 {
2156     dXSARGS;
2157     if (items != 2)
2158         croak("Usage: OS2::_control87(new,mask)");
2159     {
2160         unsigned        new = (unsigned)SvIV(ST(0));
2161         unsigned        mask = (unsigned)SvIV(ST(1));
2162         unsigned        RETVAL;
2163
2164         RETVAL = _control87(new, mask);
2165         ST(0) = sv_newmortal();
2166         sv_setiv(ST(0), (IV)RETVAL);
2167     }
2168     XSRETURN(1);
2169 }
2170
2171 XS(XS_OS2_get_control87)
2172 {
2173     dXSARGS;
2174     if (items != 0)
2175         croak("Usage: OS2::get_control87()");
2176     {
2177         unsigned        RETVAL;
2178
2179         RETVAL = get_control87();
2180         ST(0) = sv_newmortal();
2181         sv_setiv(ST(0), (IV)RETVAL);
2182     }
2183     XSRETURN(1);
2184 }
2185
2186
2187 XS(XS_OS2_set_control87)
2188 {
2189     dXSARGS;
2190     if (items < 0 || items > 2)
2191         croak("Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
2192     {
2193         unsigned        new;
2194         unsigned        mask;
2195         unsigned        RETVAL;
2196
2197         if (items < 1)
2198             new = MCW_EM;
2199         else {
2200             new = (unsigned)SvIV(ST(0));
2201         }
2202
2203         if (items < 2)
2204             mask = MCW_EM;
2205         else {
2206             mask = (unsigned)SvIV(ST(1));
2207         }
2208
2209         RETVAL = set_control87(new, mask);
2210         ST(0) = sv_newmortal();
2211         sv_setiv(ST(0), (IV)RETVAL);
2212     }
2213     XSRETURN(1);
2214 }
2215
2216 int
2217 Xs_OS2_init(pTHX)
2218 {
2219     char *file = __FILE__;
2220     {
2221         GV *gv;
2222
2223         if (_emx_env & 0x200) { /* OS/2 */
2224             newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2225             newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2226             newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2227         }
2228         newXS("OS2::Error", XS_OS2_Error, file);
2229         newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2230         newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2231         newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2232         newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2233         newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2234         newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2235         newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
2236         newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2237         newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2238         newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2239         newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2240         newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2241         newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2242         newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2243         newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2244         newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
2245         newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
2246         newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
2247         newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
2248         gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2249         GvMULTI_on(gv);
2250 #ifdef PERL_IS_AOUT
2251         sv_setiv(GvSV(gv), 1);
2252 #endif
2253         gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2254         GvMULTI_on(gv);
2255         sv_setiv(GvSV(gv), _emx_rev);
2256         sv_setpv(GvSV(gv), _emx_vprt);
2257         SvIOK_on(GvSV(gv));
2258         gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2259         GvMULTI_on(gv);
2260         sv_setiv(GvSV(gv), _emx_env);
2261         gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2262         GvMULTI_on(gv);
2263         sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
2264         gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV);
2265         GvMULTI_on(gv);
2266         sv_setiv(GvSV(gv), 1);          /* DEFAULT: Show number on syserror */
2267     }
2268     return 0;
2269 }
2270
2271 OS2_Perl_data_t OS2_Perl_data;
2272
2273 void
2274 Perl_OS2_init(char **env)
2275 {
2276     char *shell;
2277
2278     MALLOC_INIT;
2279     settmppath();
2280     OS2_Perl_data.xs_init = &Xs_OS2_init;
2281     _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
2282     if (environ == NULL && env) {
2283         environ = env;
2284     }
2285     if ( (shell = getenv("PERL_SH_DRIVE")) ) {
2286         New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2287         strcpy(PL_sh_path, SH_PATH);
2288         PL_sh_path[0] = shell[0];
2289     } else if ( (shell = getenv("PERL_SH_DIR")) ) {
2290         int l = strlen(shell), i;
2291         if (shell[l-1] == '/' || shell[l-1] == '\\') {
2292             l--;
2293         }
2294         New(1304, PL_sh_path, l + 8, char);
2295         strncpy(PL_sh_path, shell, l);
2296         strcpy(PL_sh_path + l, "/sh.exe");
2297         for (i = 0; i < l; i++) {
2298             if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2299         }
2300     }
2301     MUTEX_INIT(&start_thread_mutex);
2302     os2_mytype = my_type();             /* Do it before morphing.  Needed? */
2303     /* Some DLLs reset FP flags on load.  We may have been linked with them */
2304     _control87(MCW_EM, MCW_EM);
2305 }
2306
2307 #undef tmpnam
2308 #undef tmpfile
2309
2310 char *
2311 my_tmpnam (char *str)
2312 {
2313     char *p = getenv("TMP"), *tpath;
2314
2315     if (!p) p = getenv("TEMP");
2316     tpath = tempnam(p, "pltmp");
2317     if (str && tpath) {
2318         strcpy(str, tpath);
2319         return str;
2320     }
2321     return tpath;
2322 }
2323
2324 FILE *
2325 my_tmpfile ()
2326 {
2327     struct stat s;
2328
2329     stat(".", &s);
2330     if (s.st_mode & S_IWOTH) {
2331         return tmpfile();
2332     }
2333     return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2334                                              grants TMP. */
2335 }
2336
2337 #undef rmdir
2338
2339 int
2340 my_rmdir (__const__ char *s)
2341 {
2342     char buf[MAXPATHLEN];
2343     STRLEN l = strlen(s);
2344
2345     if (s[l-1] == '/' || s[l-1] == '\\') {      /* EMX rmdir fails... */
2346         strcpy(buf,s);
2347         buf[l - 1] = 0;
2348         s = buf;
2349     }
2350     return rmdir(s);
2351 }
2352
2353 #undef mkdir
2354
2355 int
2356 my_mkdir (__const__ char *s, long perm)
2357 {
2358     char buf[MAXPATHLEN];
2359     STRLEN l = strlen(s);
2360
2361     if (s[l-1] == '/' || s[l-1] == '\\') {      /* EMX mkdir fails... */
2362         strcpy(buf,s);
2363         buf[l - 1] = 0;
2364         s = buf;
2365     }
2366     return mkdir(s, perm);
2367 }
2368
2369 #undef flock
2370
2371 /* This code was contributed by Rocco Caputo. */
2372 int
2373 my_flock(int handle, int o)
2374 {
2375   FILELOCK      rNull, rFull;
2376   ULONG         timeout, handle_type, flag_word;
2377   APIRET        rc;
2378   int           blocking, shared;
2379   static int    use_my = -1;
2380
2381   if (use_my == -1) {
2382     char *s = getenv("USE_PERL_FLOCK");
2383     if (s)
2384         use_my = atoi(s);
2385     else
2386         use_my = 1;
2387   }
2388   if (!(_emx_env & 0x200) || !use_my)
2389     return flock(handle, o);    /* Delegate to EMX. */
2390
2391                                         // is this a file?
2392   if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2393       (handle_type & 0xFF))
2394   {
2395     errno = EBADF;
2396     return -1;
2397   }
2398                                         // set lock/unlock ranges
2399   rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2400   rFull.lRange = 0x7FFFFFFF;
2401                                         // set timeout for blocking
2402   timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2403                                         // shared or exclusive?
2404   shared = (o & LOCK_SH) ? 1 : 0;
2405                                         // do not block the unlock
2406   if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2407     rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2408     switch (rc) {
2409       case 0:
2410         errno = 0;
2411         return 0;
2412       case ERROR_INVALID_HANDLE:
2413         errno = EBADF;
2414         return -1;
2415       case ERROR_SHARING_BUFFER_EXCEEDED:
2416         errno = ENOLCK;
2417         return -1;
2418       case ERROR_LOCK_VIOLATION:
2419         break;                          // not an error
2420       case ERROR_INVALID_PARAMETER:
2421       case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2422       case ERROR_READ_LOCKS_NOT_SUPPORTED:
2423         errno = EINVAL;
2424         return -1;
2425       case ERROR_INTERRUPT:
2426         errno = EINTR;
2427         return -1;
2428       default:
2429         errno = EINVAL;
2430         return -1;
2431     }
2432   }
2433                                         // lock may block
2434   if (o & (LOCK_SH | LOCK_EX)) {
2435                                         // for blocking operations
2436     for (;;) {
2437       rc =
2438         DosSetFileLocks(
2439                 handle,
2440                 &rNull,
2441                 &rFull,
2442                 timeout,
2443                 shared
2444         );
2445       switch (rc) {
2446         case 0:
2447           errno = 0;
2448           return 0;
2449         case ERROR_INVALID_HANDLE:
2450           errno = EBADF;
2451           return -1;
2452         case ERROR_SHARING_BUFFER_EXCEEDED:
2453           errno = ENOLCK;
2454           return -1;
2455         case ERROR_LOCK_VIOLATION:
2456           if (!blocking) {
2457             errno = EWOULDBLOCK;
2458             return -1;
2459           }
2460           break;
2461         case ERROR_INVALID_PARAMETER:
2462         case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2463         case ERROR_READ_LOCKS_NOT_SUPPORTED:
2464           errno = EINVAL;
2465           return -1;
2466         case ERROR_INTERRUPT:
2467           errno = EINTR;
2468           return -1;
2469         default:
2470           errno = EINVAL;
2471           return -1;
2472       }
2473                                         // give away timeslice
2474       DosSleep(1);
2475     }
2476   }
2477
2478   errno = 0;
2479   return 0;
2480 }
2481
2482 static int pwent_cnt;
2483 static int _my_pwent = -1;
2484
2485 static int
2486 use_my_pwent(void)
2487 {
2488   if (_my_pwent == -1) {
2489     char *s = getenv("USE_PERL_PWENT");
2490     if (s)
2491         _my_pwent = atoi(s);
2492     else
2493         _my_pwent = 1;
2494   }
2495   return _my_pwent;
2496 }
2497
2498 #undef setpwent
2499 #undef getpwent
2500 #undef endpwent
2501
2502 void
2503 my_setpwent(void)
2504 {
2505   if (!use_my_pwent()) {
2506     setpwent();                 /* Delegate to EMX. */
2507     return;
2508   }
2509   pwent_cnt = 0;
2510 }
2511
2512 void
2513 my_endpwent(void)
2514 {
2515   if (!use_my_pwent()) {
2516     endpwent();                 /* Delegate to EMX. */
2517     return;
2518   }
2519 }
2520
2521 struct passwd *
2522 my_getpwent (void)
2523 {
2524   if (!use_my_pwent())
2525     return getpwent();                  /* Delegate to EMX. */
2526   if (pwent_cnt++)
2527     return 0;                           // Return one entry only
2528   return getpwuid(0);
2529 }
2530
2531 static int grent_cnt;
2532
2533 void
2534 setgrent(void)
2535 {
2536   grent_cnt = 0;
2537 }
2538
2539 void
2540 endgrent(void)
2541 {
2542 }
2543
2544 struct group *
2545 getgrent (void)
2546 {
2547   if (grent_cnt++)
2548     return 0;                           // Return one entry only
2549   return getgrgid(0);
2550 }
2551
2552 #undef getpwuid
2553 #undef getpwnam
2554
2555 /* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */
2556 static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
2557
2558 static struct passwd *
2559 passw_wrap(struct passwd *p)
2560 {
2561     static struct passwd pw;
2562     char *s;
2563
2564     if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
2565         return p;
2566     pw = *p;
2567     s = getenv("PW_PASSWD");
2568     if (!s)
2569         s = (char*)pw_p;                /* Make match impossible */
2570
2571     pw.pw_passwd = s;
2572     return &pw;
2573 }
2574
2575 struct passwd *
2576 my_getpwuid (uid_t id)
2577 {
2578     return passw_wrap(getpwuid(id));
2579 }
2580
2581 struct passwd *
2582 my_getpwnam (__const__ char *n)
2583 {
2584     return passw_wrap(getpwnam(n));
2585 }