pp_sys.c

   1 /*    pp_sys.c
   2  *
   3  *    Copyright (c) 1991-1999, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * But only a short way ahead its floor and the walls on either side were
  12  * cloven by a great fissure, out of which the red glare came, now leaping
  13  * up, now dying down into darkness; and all the while far below there was
  14  * a rumour and a trouble as of great engines throbbing and labouring.
  15  */
  16
  17 #include "EXTERN.h"
  18 #define PERL_IN_PP_SYS_C
  19 #include "perl.h"
  20
  21 #ifdef I_SHADOW
  22 /* Shadow password support for solaris - pdo@cs.umd.edu
  23  * Not just Solaris: at least HP-UX, IRIX, Linux.
  24  * the API is from SysV. --jhi */
  25 #ifdef __hpux__
  26 /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
  27  * and another MAXINT from "perl.h" <- <sys/param.h>. */
  28 #undef MAXINT
  29 #endif
  30 #include <shadow.h>
  31 #endif
  32
  33 /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
  34 #ifdef I_UNISTD
  35 # include <unistd.h>
  36 #endif
  37
  38 #ifdef HAS_SYSCALL
  39 #ifdef __cplusplus
  40 extern "C" int syscall(unsigned long,...);
  41 #endif
  42 #endif
  43
  44 #ifdef I_SYS_WAIT
  45 # include <sys/wait.h>
  46 #endif
  47
  48 #ifdef I_SYS_RESOURCE
  49 # include <sys/resource.h>
  50 #endif
  51
  52 #if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
  53 # include <sys/socket.h>
  54 # if defined(USE_SOCKS) && defined(I_SOCKS)
  55 #   include <socks.h>
  56 # endif
  57 # ifdef I_NETDB
  58 #  include <netdb.h>
  59 # endif
  60 # ifndef ENOTSOCK
  61 #  ifdef I_NET_ERRNO
  62 #   include <net/errno.h>
  63 #  endif
  64 # endif
  65 #endif
  66
  67 #ifdef HAS_SELECT
  68 #ifdef I_SYS_SELECT
  69 #include <sys/select.h>
  70 #endif
  71 #endif
  72
  73 /* XXX Configure test needed.
  74    h_errno might not be a simple 'int', especially for multi-threaded
  75    applications, see "extern int errno in perl.h".  Creating such
  76    a test requires taking into account the differences between
  77    compiling multithreaded and singlethreaded ($ccflags et al).
  78    HOST_NOT_FOUND is typically defined in <netdb.h>.
  79 */
  80 #if defined(HOST_NOT_FOUND) && !defined(h_errno)
  81 extern int h_errno;
  82 #endif
  83
  84 #ifdef HAS_PASSWD
  85 # ifdef I_PWD
  86 #  include <pwd.h>
  87 # else
  88     struct passwd *getpwnam (char *);
  89     struct passwd *getpwuid (Uid_t);
  90 # endif
  91 # ifdef HAS_GETPWENT
  92   struct passwd *getpwent (void);
  93 # endif
  94 #endif
  95
  96 #ifdef HAS_GROUP
  97 # ifdef I_GRP
  98 #  include <grp.h>
  99 # else
 100     struct group *getgrnam (char *);
 101     struct group *getgrgid (Gid_t);
 102 # endif
 103 # ifdef HAS_GETGRENT
 104     struct group *getgrent (void);
 105 # endif
 106 #endif
 107
 108 #ifdef I_UTIME
 109 #  if defined(_MSC_VER) || defined(__MINGW32__)
 110 #    include <sys/utime.h>
 111 #  else
 112 #    include <utime.h>
 113 #  endif
 114 #endif
 115 #ifdef I_FCNTL
 116 #include <fcntl.h>
 117 #endif
 118 #ifdef I_SYS_FILE
 119 #include <sys/file.h>
 120 #endif
 121
 122 /* Put this after #includes because fork and vfork prototypes may conflict. */
 123 #ifndef HAS_VFORK
 124 #   define vfork fork
 125 #endif
 126
 127 /* Put this after #includes because <unistd.h> defines _XOPEN_*. */
 128 #ifndef Sock_size_t
 129 #  if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__)
 130 #    define Sock_size_t Size_t
 131 #  else
 132 #    define Sock_size_t int
 133 #  endif
 134 #endif
 135
 136 #ifdef HAS_CHSIZE
 137 # ifdef my_chsize  /* Probably #defined to Perl_my_chsize in embed.h */
 138 #   undef my_chsize
 139 # endif
 140 # define my_chsize PerlLIO_chsize
 141 #endif
 142
 143 #ifdef HAS_FLOCK
 144 #  define FLOCK flock
 145 #else /* no flock() */
 146
 147    /* fcntl.h might not have been included, even if it exists, because
 148       the current Configure only sets I_FCNTL if it's needed to pick up
 149       the *_OK constants.  Make sure it has been included before testing
 150       the fcntl() locking constants. */
 151 #  if defined(HAS_FCNTL) && !defined(I_FCNTL)
 152 #    include <fcntl.h>
 153 #  endif
 154
 155 #  if defined(HAS_FCNTL) && defined(F_SETLK) && defined (F_SETLKW)
 156 #    define FLOCK fcntl_emulate_flock
 157 #    define FCNTL_EMULATE_FLOCK
 158 #  else /* no flock() or fcntl(F_SETLK,...) */
 159 #    ifdef HAS_LOCKF
 160 #      define FLOCK lockf_emulate_flock
 161 #      define LOCKF_EMULATE_FLOCK
 162 #    endif /* lockf */
 163 #  endif /* no flock() or fcntl(F_SETLK,...) */
 164
 165 #  ifdef FLOCK
 166      static int FLOCK (int, int);
 167
 168     /*
 169      * These are the flock() constants.  Since this sytems doesn't have
 170      * flock(), the values of the constants are probably not available.
 171      */
 172 #    ifndef LOCK_SH
 173 #      define LOCK_SH 1
 174 #    endif
 175 #    ifndef LOCK_EX
 176 #      define LOCK_EX 2
 177 #    endif
 178 #    ifndef LOCK_NB
 179 #      define LOCK_NB 4
 180 #    endif
 181 #    ifndef LOCK_UN
 182 #      define LOCK_UN 8
 183 #    endif
 184 #  endif /* emulating flock() */
 185
 186 #endif /* no flock() */
 187
 188 #define ZBTLEN 10
 189 static char zero_but_true[ZBTLEN + 1] = "0 but true";
 190
 191 #if defined(I_SYS_ACCESS) && !defined(R_OK)
 192 #  include <sys/access.h>
 193 #endif
 194
 195 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
 196 #  define FD_CLOEXEC 1          /* NeXT needs this */
 197 #endif
 198
 199 #undef PERL_EFF_ACCESS_R_OK     /* EFFective uid/gid ACCESS R_OK */
 200 #undef PERL_EFF_ACCESS_W_OK
 201 #undef PERL_EFF_ACCESS_X_OK
 202
 203 /* F_OK unused: if stat() cannot find it... */
 204
 205 #if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
 206     /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
 207 #   define PERL_EFF_ACCESS_R_OK(p) (access((p), R_OK | EFF_ONLY_OK))
 208 #   define PERL_EFF_ACCESS_W_OK(p) (access((p), W_OK | EFF_ONLY_OK))
 209 #   define PERL_EFF_ACCESS_X_OK(p) (access((p), X_OK | EFF_ONLY_OK))
 210 #endif
 211
 212 #if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_EACCESS)
 213 #   if defined(I_SYS_SECURITY)
 214 #       include <sys/security.h>
 215 #   endif
 216     /* XXX Configure test needed for eaccess */
 217 #   ifdef ACC_SELF
 218         /* HP SecureWare */
 219 #       define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK, ACC_SELF))
 220 #       define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK, ACC_SELF))
 221 #       define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK, ACC_SELF))
 222 #   else
 223         /* SCO */
 224 #       define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK))
 225 #       define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK))
 226 #       define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK))
 227 #   endif
 228 #endif
 229
 230 #if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESSX) && defined(ACC_SELF)
 231     /* AIX */
 232 #   define PERL_EFF_ACCESS_R_OK(p) (accessx((p), R_OK, ACC_SELF))
 233 #   define PERL_EFF_ACCESS_W_OK(p) (accessx((p), W_OK, ACC_SELF))
 234 #   define PERL_EFF_ACCESS_X_OK(p) (accessx((p), X_OK, ACC_SELF))
 235 #endif
 236
 237 #if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS)       \
 238     && (defined(HAS_SETREUID) || defined(HAS_SETRESUID)         \
 239         || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
 240 /* The Hard Way. */
 241 STATIC int
 242 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
 243 {
 244     Uid_t ruid = getuid();
 245     Uid_t euid = geteuid();
 246     Gid_t rgid = getgid();
 247     Gid_t egid = getegid();
 248     int res;
 249
 250     MUTEX_LOCK(&PL_cred_mutex);
 251 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
 252     Perl_croak(aTHX_ "switching effective uid is not implemented");
 253 #else
 254 #ifdef HAS_SETREUID
 255     if (setreuid(euid, ruid))
 256 #else
 257 #ifdef HAS_SETRESUID
 258     if (setresuid(euid, ruid, (Uid_t)-1))
 259 #endif
 260 #endif
 261         Perl_croak(aTHX_ "entering effective uid failed");
 262 #endif
 263
 264 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
 265     Perl_croak(aTHX_ "switching effective gid is not implemented");
 266 #else
 267 #ifdef HAS_SETREGID
 268     if (setregid(egid, rgid))
 269 #else
 270 #ifdef HAS_SETRESGID
 271     if (setresgid(egid, rgid, (Gid_t)-1))
 272 #endif
 273 #endif
 274         Perl_croak(aTHX_ "entering effective gid failed");
 275 #endif
 276
 277     res = access(path, mode);
 278
 279 #ifdef HAS_SETREUID
 280     if (setreuid(ruid, euid))
 281 #else
 282 #ifdef HAS_SETRESUID
 283     if (setresuid(ruid, euid, (Uid_t)-1))
 284 #endif
 285 #endif
 286         Perl_croak(aTHX_ "leaving effective uid failed");
 287
 288 #ifdef HAS_SETREGID
 289     if (setregid(rgid, egid))
 290 #else
 291 #ifdef HAS_SETRESGID
 292     if (setresgid(rgid, egid, (Gid_t)-1))
 293 #endif
 294 #endif
 295         Perl_croak(aTHX_ "leaving effective gid failed");
 296     MUTEX_UNLOCK(&PL_cred_mutex);
 297
 298     return res;
 299 }
 300 #   define PERL_EFF_ACCESS_R_OK(p) (emulate_eaccess((p), R_OK))
 301 #   define PERL_EFF_ACCESS_W_OK(p) (emulate_eaccess((p), W_OK))
 302 #   define PERL_EFF_ACCESS_X_OK(p) (emulate_eaccess((p), X_OK))
 303 #endif
 304
 305 #if !defined(PERL_EFF_ACCESS_R_OK)
 306 STATIC int
 307 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
 308 {
 309     Perl_croak(aTHX_ "switching effective uid is not implemented");
 310     /*NOTREACHED*/
 311     return -1;
 312 }
 313 #endif
 314
 315 PP(pp_backtick)
 316 {
 317     djSP; dTARGET;
 318     PerlIO *fp;
 319     STRLEN n_a;
 320     char *tmps = POPpx;
 321     I32 gimme = GIMME_V;
 322
 323     TAINT_PROPER("``");
 324     fp = PerlProc_popen(tmps, "r");
 325     if (fp) {
 326         if (gimme == G_VOID) {
 327             char tmpbuf[256];
 328             while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
 329                 /*SUPPRESS 530*/
 330                 ;
 331         }
 332         else if (gimme == G_SCALAR) {
 333             sv_setpv(TARG, ""); /* note that this preserves previous buffer */
 334             while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
 335                 /*SUPPRESS 530*/
 336                 ;
 337             XPUSHs(TARG);
 338             SvTAINTED_on(TARG);
 339         }
 340         else {
 341             SV *sv;
 342
 343             for (;;) {
 344                 sv = NEWSV(56, 79);
 345                 if (sv_gets(sv, fp, 0) == Nullch) {
 346                     SvREFCNT_dec(sv);
 347                     break;
 348                 }
 349                 XPUSHs(sv_2mortal(sv));
 350                 if (SvLEN(sv) - SvCUR(sv) > 20) {
 351                     SvLEN_set(sv, SvCUR(sv)+1);
 352                     Renew(SvPVX(sv), SvLEN(sv), char);
 353                 }
 354                 SvTAINTED_on(sv);
 355             }
 356         }
 357         STATUS_NATIVE_SET(PerlProc_pclose(fp));
 358         TAINT;          /* "I believe that this is not gratuitous!" */
 359     }
 360     else {
 361         STATUS_NATIVE_SET(-1);
 362         if (gimme == G_SCALAR)
 363             RETPUSHUNDEF;
 364     }
 365
 366     RETURN;
 367 }
 368
 369 PP(pp_glob)
 370 {
 371     OP *result;
 372     tryAMAGICunTARGET(iter, -1);
 373
 374     ENTER;
 375
 376 #ifndef VMS
 377     if (PL_tainting) {
 378         /*
 379          * The external globbing program may use things we can't control,
 380          * so for security reasons we must assume the worst.
 381          */
 382         TAINT;
 383         taint_proper(PL_no_security, "glob");
 384     }
 385 #endif /* !VMS */
 386
 387     SAVESPTR(PL_last_in_gv);    /* We don't want this to be permanent. */
 388     PL_last_in_gv = (GV*)*PL_stack_sp--;
 389
 390     SAVESPTR(PL_rs);            /* This is not permanent, either. */
 391     PL_rs = sv_2mortal(newSVpvn("\000", 1));
 392 #ifndef DOSISH
 393 #ifndef CSH
 394     *SvPVX(PL_rs) = '\n';
 395 #endif  /* !CSH */
 396 #endif  /* !DOSISH */
 397
 398     result = do_readline();
 399     LEAVE;
 400     return result;
 401 }
 402
 403 #if 0           /* XXX never used! */
 404 PP(pp_indread)
 405 {
 406     STRLEN n_a;
 407     PL_last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*PL_stack_sp--)), n_a), TRUE,SVt_PVIO);
 408     return do_readline();
 409 }
 410 #endif
 411
 412 PP(pp_rcatline)
 413 {
 414     PL_last_in_gv = cGVOP->op_gv;
 415     return do_readline();
 416 }
 417
 418 PP(pp_warn)
 419 {
 420     djSP; dMARK;
 421     SV *tmpsv;
 422     char *tmps;
 423     STRLEN len;
 424     if (SP - MARK != 1) {
 425         dTARGET;
 426         do_join(TARG, &PL_sv_no, MARK, SP);
 427         tmpsv = TARG;
 428         SP = MARK + 1;
 429     }
 430     else {
 431         tmpsv = TOPs;
 432     }
 433     tmps = SvPV(tmpsv, len);
 434     if (!tmps || !len) {
 435         SV *error = ERRSV;
 436         (void)SvUPGRADE(error, SVt_PV);
 437         if (SvPOK(error) && SvCUR(error))
 438             sv_catpv(error, "\t...caught");
 439         tmpsv = error;
 440         tmps = SvPV(tmpsv, len);
 441     }
 442     if (!tmps || !len)
 443         tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26));
 444
 445     Perl_warn(aTHX_ "%_", tmpsv);
 446     RETSETYES;
 447 }
 448
 449 PP(pp_die)
 450 {
 451     djSP; dMARK;
 452     char *tmps;
 453     SV *tmpsv;
 454     STRLEN len;
 455     bool multiarg = 0;
 456     if (SP - MARK != 1) {
 457         dTARGET;
 458         do_join(TARG, &PL_sv_no, MARK, SP);
 459         tmpsv = TARG;
 460         tmps = SvPV(tmpsv, len);
 461         multiarg = 1;
 462         SP = MARK + 1;
 463     }
 464     else {
 465         tmpsv = TOPs;
 466         tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len);
 467     }
 468     if (!tmps || !len) {
 469         SV *error = ERRSV;
 470         (void)SvUPGRADE(error, SVt_PV);
 471         if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
 472             if (!multiarg)
 473                 SvSetSV(error,tmpsv);
 474             else if (sv_isobject(error)) {
 475                 HV *stash = SvSTASH(SvRV(error));
 476                 GV *gv = gv_fetchmethod(stash, "PROPAGATE");
 477                 if (gv) {
 478                     SV *file = sv_2mortal(newSVsv(GvSV(PL_curcop->cop_filegv)));
 479                     SV *line = sv_2mortal(newSViv(PL_curcop->cop_line));
 480                     EXTEND(SP, 3);
 481                     PUSHMARK(SP);
 482                     PUSHs(error);
 483                     PUSHs(file);
 484                     PUSHs(line);
 485                     PUTBACK;
 486                     call_sv((SV*)GvCV(gv),
 487                             G_SCALAR|G_EVAL|G_KEEPERR);
 488                     sv_setsv(error,*PL_stack_sp--);
 489                 }
 490             }
 491             DIE(aTHX_ Nullch);
 492         }
 493         else {
 494             if (SvPOK(error) && SvCUR(error))
 495                 sv_catpv(error, "\t...propagated");
 496             tmpsv = error;
 497             tmps = SvPV(tmpsv, len);
 498         }
 499     }
 500     if (!tmps || !len)
 501         tmpsv = sv_2mortal(newSVpvn("Died", 4));
 502
 503     DIE(aTHX_ "%_", tmpsv);
 504 }
 505
 506 /* I/O. */
 507
 508 PP(pp_open)
 509 {
 510     djSP; dTARGET;
 511     GV *gv;
 512     SV *sv;
 513     SV *name;
 514     I32 have_name = 0;
 515     char *tmps;
 516     STRLEN len;
 517     MAGIC *mg;
 518
 519     if (MAXARG > 2) {
 520         name = POPs;
 521         have_name = 1;
 522     }
 523     if (MAXARG > 1)
 524         sv = POPs;
 525     if (!isGV(TOPs))
 526         DIE(aTHX_ PL_no_usym, "filehandle");
 527     if (MAXARG <= 1)
 528         sv = GvSV(TOPs);
 529     gv = (GV*)POPs;
 530     if (!isGV(gv))
 531         DIE(aTHX_ PL_no_usym, "filehandle");
 532     if (GvIOp(gv))
 533         IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
 534
 535 #if 0 /* no undef means tmpfile() yet */
 536     if (sv == &PL_sv_undef) {
 537 #ifdef PerlIO
 538         PerlIO *fp = PerlIO_tmpfile();
 539 #else
 540         PerlIO *fp = tmpfile();
 541 #endif
 542         if (fp != Nullfp && do_open(gv, "+>&", 3, FALSE, 0, 0, fp))
 543             PUSHi( (I32)PL_forkprocess );
 544         else
 545             RETPUSHUNDEF;
 546         RETURN;
 547     }
 548 #endif /* no undef means tmpfile() yet */
 549
 550
 551     if (mg = SvTIED_mg((SV*)gv, 'q')) {
 552         PUSHMARK(SP);
 553         XPUSHs(SvTIED_obj((SV*)gv, mg));
 554         XPUSHs(sv);
 555         if (have_name)
 556             XPUSHs(name);
 557         PUTBACK;
 558         ENTER;
 559         call_method("OPEN", G_SCALAR);
 560         LEAVE;
 561         SPAGAIN;
 562         RETURN;
 563     }
 564
 565     tmps = SvPV(sv, len);
 566     if (do_open9(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp, name, have_name))
 567         PUSHi( (I32)PL_forkprocess );
 568     else if (PL_forkprocess == 0)               /* we are a new child */
 569         PUSHi(0);
 570     else
 571         RETPUSHUNDEF;
 572     RETURN;
 573 }
 574
 575 PP(pp_close)
 576 {
 577     djSP;
 578     GV *gv;
 579     MAGIC *mg;
 580
 581     if (MAXARG == 0)
 582         gv = PL_defoutgv;
 583     else
 584         gv = (GV*)POPs;
 585
 586     if (mg = SvTIED_mg((SV*)gv, 'q')) {
 587         PUSHMARK(SP);
 588         XPUSHs(SvTIED_obj((SV*)gv, mg));
 589         PUTBACK;
 590         ENTER;
 591         call_method("CLOSE", G_SCALAR);
 592         LEAVE;
 593         SPAGAIN;
 594         RETURN;
 595     }
 596     EXTEND(SP, 1);
 597     PUSHs(boolSV(do_close(gv, TRUE)));
 598     RETURN;
 599 }
 600
 601 PP(pp_pipe_op)
 602 {
 603     djSP;
 604 #ifdef HAS_PIPE
 605     GV *rgv;
 606     GV *wgv;
 607     register IO *rstio;
 608     register IO *wstio;
 609     int fd[2];
 610
 611     wgv = (GV*)POPs;
 612     rgv = (GV*)POPs;
 613
 614     if (!rgv || !wgv)
 615         goto badexit;
 616
 617     if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
 618         DIE(aTHX_ PL_no_usym, "filehandle");
 619     rstio = GvIOn(rgv);
 620     wstio = GvIOn(wgv);
 621
 622     if (IoIFP(rstio))
 623         do_close(rgv, FALSE);
 624     if (IoIFP(wstio))
 625         do_close(wgv, FALSE);
 626
 627     if (PerlProc_pipe(fd) < 0)
 628         goto badexit;
 629
 630     IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
 631     IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
 632     IoIFP(wstio) = IoOFP(wstio);
 633     IoTYPE(rstio) = '<';
 634     IoTYPE(wstio) = '>';
 635
 636     if (!IoIFP(rstio) || !IoOFP(wstio)) {
 637         if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
 638         else PerlLIO_close(fd[0]);
 639         if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
 640         else PerlLIO_close(fd[1]);
 641         goto badexit;
 642     }
 643 #if defined(HAS_FCNTL) && defined(F_SETFD)
 644     fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);   /* ensure close-on-exec */
 645     fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);   /* ensure close-on-exec */
 646 #endif
 647     RETPUSHYES;
 648
 649 badexit:
 650     RETPUSHUNDEF;
 651 #else
 652     DIE(aTHX_ PL_no_func, "pipe");
 653 #endif
 654 }
 655
 656 PP(pp_fileno)
 657 {
 658     djSP; dTARGET;
 659     GV *gv;
 660     IO *io;
 661     PerlIO *fp;
 662     MAGIC  *mg;
 663
 664     if (MAXARG < 1)
 665         RETPUSHUNDEF;
 666     gv = (GV*)POPs;
 667
 668     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
 669         PUSHMARK(SP);
 670         XPUSHs(SvTIED_obj((SV*)gv, mg));
 671         PUTBACK;
 672         ENTER;
 673         call_method("FILENO", G_SCALAR);
 674         LEAVE;
 675         SPAGAIN;
 676         RETURN;
 677     }
 678
 679     if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
 680         RETPUSHUNDEF;
 681     PUSHi(PerlIO_fileno(fp));
 682     RETURN;
 683 }
 684
 685 PP(pp_umask)
 686 {
 687     djSP; dTARGET;
 688     Mode_t anum;
 689
 690 #ifdef HAS_UMASK
 691     if (MAXARG < 1) {
 692         anum = PerlLIO_umask(0);
 693         (void)PerlLIO_umask(anum);
 694     }
 695     else
 696         anum = PerlLIO_umask(POPi);
 697     TAINT_PROPER("umask");
 698     XPUSHi(anum);
 699 #else
 700     /* Only DIE if trying to restrict permissions on `user' (self).
 701      * Otherwise it's harmless and more useful to just return undef
 702      * since 'group' and 'other' concepts probably don't exist here. */
 703     if (MAXARG >= 1 && (POPi & 0700))
 704         DIE(aTHX_ "umask not implemented");
 705     XPUSHs(&PL_sv_undef);
 706 #endif
 707     RETURN;
 708 }
 709
 710 PP(pp_binmode)
 711 {
 712     djSP;
 713     GV *gv;
 714     IO *io;
 715     PerlIO *fp;
 716     MAGIC *mg;
 717
 718     if (MAXARG < 1)
 719         RETPUSHUNDEF;
 720
 721     gv = (GV*)POPs;
 722
 723     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
 724         PUSHMARK(SP);
 725         XPUSHs(SvTIED_obj((SV*)gv, mg));
 726         PUTBACK;
 727         ENTER;
 728         call_method("BINMODE", G_SCALAR);
 729         LEAVE;
 730         SPAGAIN;
 731         RETURN;
 732     }
 733
 734     EXTEND(SP, 1);
 735     if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
 736         RETPUSHUNDEF;
 737
 738     if (do_binmode(fp,IoTYPE(io),TRUE))
 739         RETPUSHYES;
 740     else
 741         RETPUSHUNDEF;
 742 }
 743
 744
 745 PP(pp_tie)
 746 {
 747     djSP;
 748     dMARK;
 749     SV *varsv;
 750     HV* stash;
 751     GV *gv;
 752     SV *sv;
 753     I32 markoff = MARK - PL_stack_base;
 754     char *methname;
 755     int how = 'P';
 756     U32 items;
 757     STRLEN n_a;
 758
 759     varsv = *++MARK;
 760     switch(SvTYPE(varsv)) {
 761         case SVt_PVHV:
 762             methname = "TIEHASH";
 763             break;
 764         case SVt_PVAV:
 765             methname = "TIEARRAY";
 766             break;
 767         case SVt_PVGV:
 768             methname = "TIEHANDLE";
 769             how = 'q';
 770             break;
 771         default:
 772             methname = "TIESCALAR";
 773             how = 'q';
 774             break;
 775     }
 776     items = SP - MARK++;
 777     if (sv_isobject(*MARK)) {
 778         ENTER;
 779         PUSHSTACKi(PERLSI_MAGIC);
 780         PUSHMARK(SP);
 781         EXTEND(SP,items);
 782         while (items--)
 783             PUSHs(*MARK++);
 784         PUTBACK;
 785         call_method(methname, G_SCALAR);
 786     }
 787     else {
 788         /* Not clear why we don't call call_method here too.
 789          * perhaps to get different error message ?
 790          */
 791         stash = gv_stashsv(*MARK, FALSE);
 792         if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
 793             DIE(aTHX_ "Can't locate object method \"%s\" via package \"%s\"",
 794                  methname, SvPV(*MARK,n_a));
 795         }
 796         ENTER;
 797         PUSHSTACKi(PERLSI_MAGIC);
 798         PUSHMARK(SP);
 799         EXTEND(SP,items);
 800         while (items--)
 801             PUSHs(*MARK++);
 802         PUTBACK;
 803         call_sv((SV*)GvCV(gv), G_SCALAR);
 804     }
 805     SPAGAIN;
 806
 807     sv = TOPs;
 808     POPSTACK;
 809     if (sv_isobject(sv)) {
 810         sv_unmagic(varsv, how);
 811         sv_magic(varsv, (SvRV(sv) == varsv ? Nullsv : sv), how, Nullch, 0);
 812     }
 813     LEAVE;
 814     SP = PL_stack_base + markoff;
 815     PUSHs(sv);
 816     RETURN;
 817 }
 818
 819 PP(pp_untie)
 820 {
 821     djSP;
 822     SV *sv = POPs;
 823     char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
 824
 825     if (ckWARN(WARN_UNTIE)) {
 826         MAGIC * mg ;
 827         if (mg = SvTIED_mg(sv, how)) {
 828             if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
 829                 Perl_warner(aTHX_ WARN_UNTIE,
 830                     "untie attempted while %"UVuf" inner references still exist",
 831                     (UV)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
 832         }
 833     }
 834
 835     sv_unmagic(sv, how);
 836     RETPUSHYES;
 837 }
 838
 839 PP(pp_tied)
 840 {
 841     djSP;
 842     SV *sv = POPs;
 843     char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
 844     MAGIC *mg;
 845
 846     if (mg = SvTIED_mg(sv, how)) {
 847         SV *osv = SvTIED_obj(sv, mg);
 848         if (osv == mg->mg_obj)
 849             osv = sv_mortalcopy(osv);
 850         PUSHs(osv);
 851         RETURN;
 852     }
 853     RETPUSHUNDEF;
 854 }
 855
 856 PP(pp_dbmopen)
 857 {
 858     djSP;
 859     HV *hv;
 860     dPOPPOPssrl;
 861     HV* stash;
 862     GV *gv;
 863     SV *sv;
 864
 865     hv = (HV*)POPs;
 866
 867     sv = sv_mortalcopy(&PL_sv_no);
 868     sv_setpv(sv, "AnyDBM_File");
 869     stash = gv_stashsv(sv, FALSE);
 870     if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
 871         PUTBACK;
 872         require_pv("AnyDBM_File.pm");
 873         SPAGAIN;
 874         if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
 875             DIE(aTHX_ "No dbm on this machine");
 876     }
 877
 878     ENTER;
 879     PUSHMARK(SP);
 880
 881     EXTEND(SP, 5);
 882     PUSHs(sv);
 883     PUSHs(left);
 884     if (SvIV(right))
 885         PUSHs(sv_2mortal(newSViv(O_RDWR|O_CREAT)));
 886     else
 887         PUSHs(sv_2mortal(newSViv(O_RDWR)));
 888     PUSHs(right);
 889     PUTBACK;
 890     call_sv((SV*)GvCV(gv), G_SCALAR);
 891     SPAGAIN;
 892
 893     if (!sv_isobject(TOPs)) {
 894         SP--;
 895         PUSHMARK(SP);
 896         PUSHs(sv);
 897         PUSHs(left);
 898         PUSHs(sv_2mortal(newSViv(O_RDONLY)));
 899         PUSHs(right);
 900         PUTBACK;
 901         call_sv((SV*)GvCV(gv), G_SCALAR);
 902         SPAGAIN;
 903     }
 904
 905     if (sv_isobject(TOPs)) {
 906         sv_unmagic((SV *) hv, 'P');
 907         sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
 908     }
 909     LEAVE;
 910     RETURN;
 911 }
 912
 913 PP(pp_dbmclose)
 914 {
 915     return pp_untie();
 916 }
 917
 918 PP(pp_sselect)
 919 {
 920     djSP; dTARGET;
 921 #ifdef HAS_SELECT
 922     register I32 i;
 923     register I32 j;
 924     register char *s;
 925     register SV *sv;
 926     NV value;
 927     I32 maxlen = 0;
 928     I32 nfound;
 929     struct timeval timebuf;
 930     struct timeval *tbuf = &timebuf;
 931     I32 growsize;
 932     char *fd_sets[4];
 933     STRLEN n_a;
 934 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
 935         I32 masksize;
 936         I32 offset;
 937         I32 k;
 938
 939 #   if BYTEORDER & 0xf0000
 940 #       define ORDERBYTE (0x88888888 - BYTEORDER)
 941 #   else
 942 #       define ORDERBYTE (0x4444 - BYTEORDER)
 943 #   endif
 944
 945 #endif
 946
 947     SP -= 4;
 948     for (i = 1; i <= 3; i++) {
 949         if (!SvPOK(SP[i]))
 950             continue;
 951         j = SvCUR(SP[i]);
 952         if (maxlen < j)
 953             maxlen = j;
 954     }
 955
 956 /* little endians can use vecs directly */
 957 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
 958 #  if SELECT_MIN_BITS > 1
 959     /* If SELECT_MIN_BITS is greater than one we most probably will want
 960      * to align the sizes with SELECT_MIN_BITS/8 because for example
 961      * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
 962      * UNIX, Solaris, NeXT, Rhapsody) the smallest quantum select() operates
 963      * on (sets/tests/clears bits) is 32 bits.  */
 964     growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
 965 #  else
 966     growsize = sizeof(fd_set);
 967 #  endif
 968 # else
 969 #  ifdef NFDBITS
 970
 971 #    ifndef NBBY
 972 #     define NBBY 8
 973 #    endif
 974
 975     masksize = NFDBITS / NBBY;
 976 #  else
 977     masksize = sizeof(long);    /* documented int, everyone seems to use long */
 978 #  endif
 979     growsize = maxlen + (masksize - (maxlen % masksize));
 980     Zero(&fd_sets[0], 4, char*);
 981 #endif
 982
 983     sv = SP[4];
 984     if (SvOK(sv)) {
 985         value = SvNV(sv);
 986         if (value < 0.0)
 987             value = 0.0;
 988         timebuf.tv_sec = (long)value;
 989         value -= (NV)timebuf.tv_sec;
 990         timebuf.tv_usec = (long)(value * 1000000.0);
 991     }
 992     else
 993         tbuf = Null(struct timeval*);
 994
 995     for (i = 1; i <= 3; i++) {
 996         sv = SP[i];
 997         if (!SvOK(sv)) {
 998             fd_sets[i] = 0;
 999             continue;
1000         }
1001         else if (!SvPOK(sv))
1002             SvPV_force(sv,n_a); /* force string conversion */
1003         j = SvLEN(sv);
1004         if (j < growsize) {
1005             Sv_Grow(sv, growsize);
1006         }
1007         j = SvCUR(sv);
1008         s = SvPVX(sv) + j;
1009         while (++j <= growsize) {
1010             *s++ = '\0';
1011         }
1012
1013 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1014         s = SvPVX(sv);
1015         New(403, fd_sets[i], growsize, char);
1016         for (offset = 0; offset < growsize; offset += masksize) {
1017             for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1018                 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1019         }
1020 #else
1021         fd_sets[i] = SvPVX(sv);
1022 #endif
1023     }
1024
1025     nfound = PerlSock_select(
1026         maxlen * 8,
1027         (Select_fd_set_t) fd_sets[1],
1028         (Select_fd_set_t) fd_sets[2],
1029         (Select_fd_set_t) fd_sets[3],
1030         tbuf);
1031     for (i = 1; i <= 3; i++) {
1032         if (fd_sets[i]) {
1033             sv = SP[i];
1034 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1035             s = SvPVX(sv);
1036             for (offset = 0; offset < growsize; offset += masksize) {
1037                 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1038                     s[(k % masksize) + offset] = fd_sets[i][j+offset];
1039             }
1040             Safefree(fd_sets[i]);
1041 #endif
1042             SvSETMAGIC(sv);
1043         }
1044     }
1045
1046     PUSHi(nfound);
1047     if (GIMME == G_ARRAY && tbuf) {
1048         value = (NV)(timebuf.tv_sec) +
1049                 (NV)(timebuf.tv_usec) / 1000000.0;
1050         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1051         sv_setnv(sv, value);
1052     }
1053     RETURN;
1054 #else
1055     DIE(aTHX_ "select not implemented");
1056 #endif
1057 }
1058
1059 void
1060 Perl_setdefout(pTHX_ GV *gv)
1061 {
1062     dTHR;
1063     if (gv)
1064         (void)SvREFCNT_inc(gv);
1065     if (PL_defoutgv)
1066         SvREFCNT_dec(PL_defoutgv);
1067     PL_defoutgv = gv;
1068 }
1069
1070 PP(pp_select)
1071 {
1072     djSP; dTARGET;
1073     GV *newdefout, *egv;
1074     HV *hv;
1075
1076     newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
1077
1078     egv = GvEGV(PL_defoutgv);
1079     if (!egv)
1080         egv = PL_defoutgv;
1081     hv = GvSTASH(egv);
1082     if (! hv)
1083         XPUSHs(&PL_sv_undef);
1084     else {
1085         GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1086         if (gvp && *gvp == egv) {
1087             gv_efullname3(TARG, PL_defoutgv, Nullch);
1088             XPUSHTARG;
1089         }
1090         else {
1091             XPUSHs(sv_2mortal(newRV((SV*)egv)));
1092         }
1093     }
1094
1095     if (newdefout) {
1096         if (!GvIO(newdefout))
1097             gv_IOadd(newdefout);
1098         setdefout(newdefout);
1099     }
1100
1101     RETURN;
1102 }
1103
1104 PP(pp_getc)
1105 {
1106     djSP; dTARGET;
1107     GV *gv;
1108     MAGIC *mg;
1109
1110     if (MAXARG <= 0)
1111         gv = PL_stdingv;
1112     else
1113         gv = (GV*)POPs;
1114     if (!gv)
1115         gv = PL_argvgv;
1116
1117     if (mg = SvTIED_mg((SV*)gv, 'q')) {
1118         I32 gimme = GIMME_V;
1119         PUSHMARK(SP);
1120         XPUSHs(SvTIED_obj((SV*)gv, mg));
1121         PUTBACK;
1122         ENTER;
1123         call_method("GETC", gimme);
1124         LEAVE;
1125         SPAGAIN;
1126         if (gimme == G_SCALAR)
1127             SvSetMagicSV_nosteal(TARG, TOPs);
1128         RETURN;
1129     }
1130     if (!gv || do_eof(gv)) /* make sure we have fp with something */
1131         RETPUSHUNDEF;
1132     TAINT;
1133     sv_setpv(TARG, " ");
1134     *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1135     PUSHTARG;
1136     RETURN;
1137 }
1138
1139 PP(pp_read)
1140 {
1141     return pp_sysread();
1142 }
1143
1144 STATIC OP *
1145 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1146 {
1147     dTHR;
1148     register PERL_CONTEXT *cx;
1149     I32 gimme = GIMME_V;
1150     AV* padlist = CvPADLIST(cv);
1151     SV** svp = AvARRAY(padlist);
1152
1153     ENTER;
1154     SAVETMPS;
1155
1156     push_return(retop);
1157     PUSHBLOCK(cx, CXt_SUB, PL_stack_sp);
1158     PUSHFORMAT(cx);
1159     SAVESPTR(PL_curpad);
1160     PL_curpad = AvARRAY((AV*)svp[1]);
1161
1162     setdefout(gv);          /* locally select filehandle so $% et al work */
1163     return CvSTART(cv);
1164 }
1165
1166 PP(pp_enterwrite)
1167 {
1168     djSP;
1169     register GV *gv;
1170     register IO *io;
1171     GV *fgv;
1172     CV *cv;
1173
1174     if (MAXARG == 0)
1175         gv = PL_defoutgv;
1176     else {
1177         gv = (GV*)POPs;
1178         if (!gv)
1179             gv = PL_defoutgv;
1180     }
1181     EXTEND(SP, 1);
1182     io = GvIO(gv);
1183     if (!io) {
1184         RETPUSHNO;
1185     }
1186     if (IoFMT_GV(io))
1187         fgv = IoFMT_GV(io);
1188     else
1189         fgv = gv;
1190
1191     cv = GvFORM(fgv);
1192     if (!cv) {
1193         if (fgv) {
1194             SV *tmpsv = sv_newmortal();
1195             gv_efullname3(tmpsv, fgv, Nullch);
1196             DIE(aTHX_ "Undefined format \"%s\" called",SvPVX(tmpsv));
1197         }
1198         DIE(aTHX_ "Not a format reference");
1199     }
1200     if (CvCLONE(cv))
1201         cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1202
1203     IoFLAGS(io) &= ~IOf_DIDTOP;
1204     return doform(cv,gv,PL_op->op_next);
1205 }
1206
1207 PP(pp_leavewrite)
1208 {
1209     djSP;
1210     GV *gv = cxstack[cxstack_ix].blk_sub.gv;
1211     register IO *io = GvIOp(gv);
1212     PerlIO *ofp = IoOFP(io);
1213     PerlIO *fp;
1214     SV **newsp;
1215     I32 gimme;
1216     register PERL_CONTEXT *cx;
1217
1218     DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1219           (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1220     if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1221         PL_formtarget != PL_toptarget)
1222     {
1223         GV *fgv;
1224         CV *cv;
1225         if (!IoTOP_GV(io)) {
1226             GV *topgv;
1227             SV *topname;
1228
1229             if (!IoTOP_NAME(io)) {
1230                 if (!IoFMT_NAME(io))
1231                     IoFMT_NAME(io) = savepv(GvNAME(gv));
1232                 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", IoFMT_NAME(io)));
1233                 topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
1234                 if ((topgv && GvFORM(topgv)) ||
1235                   !gv_fetchpv("top",FALSE,SVt_PVFM))
1236                     IoTOP_NAME(io) = savepv(SvPVX(topname));
1237                 else
1238                     IoTOP_NAME(io) = savepv("top");
1239             }
1240             topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
1241             if (!topgv || !GvFORM(topgv)) {
1242                 IoLINES_LEFT(io) = 100000000;
1243                 goto forget_top;
1244             }
1245             IoTOP_GV(io) = topgv;
1246         }
1247         if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear.  It still doesn't fit. */
1248             I32 lines = IoLINES_LEFT(io);
1249             char *s = SvPVX(PL_formtarget);
1250             if (lines <= 0)             /* Yow, header didn't even fit!!! */
1251                 goto forget_top;
1252             while (lines-- > 0) {
1253                 s = strchr(s, '\n');
1254                 if (!s)
1255                     break;
1256                 s++;
1257             }
1258             if (s) {
1259                 PerlIO_write(ofp, SvPVX(PL_formtarget), s - SvPVX(PL_formtarget));
1260                 sv_chop(PL_formtarget, s);
1261                 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1262             }
1263         }
1264         if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1265             PerlIO_write(ofp, SvPVX(PL_formfeed), SvCUR(PL_formfeed));
1266         IoLINES_LEFT(io) = IoPAGE_LEN(io);
1267         IoPAGE(io)++;
1268         PL_formtarget = PL_toptarget;
1269         IoFLAGS(io) |= IOf_DIDTOP;
1270         fgv = IoTOP_GV(io);
1271         if (!fgv)
1272             DIE(aTHX_ "bad top format reference");
1273         cv = GvFORM(fgv);
1274         if (!cv) {
1275             SV *tmpsv = sv_newmortal();
1276             gv_efullname3(tmpsv, fgv, Nullch);
1277             DIE(aTHX_ "Undefined top format \"%s\" called",SvPVX(tmpsv));
1278         }
1279         if (CvCLONE(cv))
1280             cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1281         return doform(cv,gv,PL_op);
1282     }
1283
1284   forget_top:
1285     POPBLOCK(cx,PL_curpm);
1286     POPFORMAT(cx);
1287     LEAVE;
1288
1289     fp = IoOFP(io);
1290     if (!fp) {
1291         if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1292             SV* sv = sv_newmortal();
1293             gv_efullname3(sv, gv, Nullch);
1294             if (IoIFP(io))
1295                 Perl_warner(aTHX_ WARN_IO,
1296                             "Filehandle %s opened only for input",
1297                             SvPV_nolen(sv));
1298             else if (ckWARN(WARN_CLOSED))
1299                 Perl_warner(aTHX_ WARN_CLOSED,
1300                             "Write on closed filehandle %s", SvPV_nolen(sv));
1301         }
1302         PUSHs(&PL_sv_no);
1303     }
1304     else {
1305         if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1306             if (ckWARN(WARN_IO))
1307                 Perl_warner(aTHX_ WARN_IO, "page overflow");
1308         }
1309         if (!PerlIO_write(ofp, SvPVX(PL_formtarget), SvCUR(PL_formtarget)) ||
1310                 PerlIO_error(fp))
1311             PUSHs(&PL_sv_no);
1312         else {
1313             FmLINES(PL_formtarget) = 0;
1314             SvCUR_set(PL_formtarget, 0);
1315             *SvEND(PL_formtarget) = '\0';
1316             if (IoFLAGS(io) & IOf_FLUSH)
1317                 (void)PerlIO_flush(fp);
1318             PUSHs(&PL_sv_yes);
1319         }
1320     }
1321     PL_formtarget = PL_bodytarget;
1322     PUTBACK;
1323     return pop_return();
1324 }
1325
1326 PP(pp_prtf)
1327 {
1328     djSP; dMARK; dORIGMARK;
1329     GV *gv;
1330     IO *io;
1331     PerlIO *fp;
1332     SV *sv;
1333     MAGIC *mg;
1334     STRLEN n_a;
1335
1336     if (PL_op->op_flags & OPf_STACKED)
1337         gv = (GV*)*++MARK;
1338     else
1339         gv = PL_defoutgv;
1340
1341     if (mg = SvTIED_mg((SV*)gv, 'q')) {
1342         if (MARK == ORIGMARK) {
1343             MEXTEND(SP, 1);
1344             ++MARK;
1345             Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1346             ++SP;
1347         }
1348         PUSHMARK(MARK - 1);
1349         *MARK = SvTIED_obj((SV*)gv, mg);
1350         PUTBACK;
1351         ENTER;
1352         call_method("PRINTF", G_SCALAR);
1353         LEAVE;
1354         SPAGAIN;
1355         MARK = ORIGMARK + 1;
1356         *MARK = *SP;
1357         SP = MARK;
1358         RETURN;
1359     }
1360
1361     sv = NEWSV(0,0);
1362     if (!(io = GvIO(gv))) {
1363         if (ckWARN(WARN_UNOPENED)) {
1364             gv_efullname3(sv, gv, Nullch);
1365             Perl_warner(aTHX_ WARN_UNOPENED,
1366                         "Filehandle %s never opened", SvPV(sv,n_a));
1367         }
1368         SETERRNO(EBADF,RMS$_IFI);
1369         goto just_say_no;
1370     }
1371     else if (!(fp = IoOFP(io))) {
1372         if (ckWARN2(WARN_CLOSED,WARN_IO))  {
1373             gv_efullname3(sv, gv, Nullch);
1374             if (IoIFP(io))
1375                 Perl_warner(aTHX_ WARN_IO,
1376                             "Filehandle %s opened only for input",
1377                             SvPV(sv,n_a));
1378             else if (ckWARN(WARN_CLOSED))
1379                 Perl_warner(aTHX_ WARN_CLOSED,
1380                             "printf on closed filehandle %s", SvPV(sv,n_a));
1381         }
1382         SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
1383         goto just_say_no;
1384     }
1385     else {
1386         do_sprintf(sv, SP - MARK, MARK + 1);
1387         if (!do_print(sv, fp))
1388             goto just_say_no;
1389
1390         if (IoFLAGS(io) & IOf_FLUSH)
1391             if (PerlIO_flush(fp) == EOF)
1392                 goto just_say_no;
1393     }
1394     SvREFCNT_dec(sv);
1395     SP = ORIGMARK;
1396     PUSHs(&PL_sv_yes);
1397     RETURN;
1398
1399   just_say_no:
1400     SvREFCNT_dec(sv);
1401     SP = ORIGMARK;
1402     PUSHs(&PL_sv_undef);
1403     RETURN;
1404 }
1405
1406 PP(pp_sysopen)
1407 {
1408     djSP;
1409     GV *gv;
1410     SV *sv;
1411     char *tmps;
1412     STRLEN len;
1413     int mode, perm;
1414
1415     if (MAXARG > 3)
1416         perm = POPi;
1417     else
1418         perm = 0666;
1419     mode = POPi;
1420     sv = POPs;
1421     gv = (GV *)POPs;
1422
1423     /* Need TIEHANDLE method ? */
1424
1425     tmps = SvPV(sv, len);
1426     if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
1427         IoLINES(GvIOp(gv)) = 0;
1428         PUSHs(&PL_sv_yes);
1429     }
1430     else {
1431         PUSHs(&PL_sv_undef);
1432     }
1433     RETURN;
1434 }
1435
1436 PP(pp_sysread)
1437 {
1438     djSP; dMARK; dORIGMARK; dTARGET;
1439     int offset;
1440     GV *gv;
1441     IO *io;
1442     char *buffer;
1443     SSize_t length;
1444     Sock_size_t bufsize;
1445     SV *bufsv;
1446     STRLEN blen;
1447     MAGIC *mg;
1448
1449     gv = (GV*)*++MARK;
1450     if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) &&
1451         (mg = SvTIED_mg((SV*)gv, 'q')))
1452     {
1453         SV *sv;
1454
1455         PUSHMARK(MARK-1);
1456         *MARK = SvTIED_obj((SV*)gv, mg);
1457         ENTER;
1458         call_method("READ", G_SCALAR);
1459         LEAVE;
1460         SPAGAIN;
1461         sv = POPs;
1462         SP = ORIGMARK;
1463         PUSHs(sv);
1464         RETURN;
1465     }
1466
1467     if (!gv)
1468         goto say_undef;
1469     bufsv = *++MARK;
1470     if (! SvOK(bufsv))
1471         sv_setpvn(bufsv, "", 0);
1472     buffer = SvPV_force(bufsv, blen);
1473     length = SvIVx(*++MARK);
1474     if (length < 0)
1475         DIE(aTHX_ "Negative length");
1476     SETERRNO(0,0);
1477     if (MARK < SP)
1478         offset = SvIVx(*++MARK);
1479     else
1480         offset = 0;
1481     io = GvIO(gv);
1482     if (!io || !IoIFP(io))
1483         goto say_undef;
1484 #ifdef HAS_SOCKET
1485     if (PL_op->op_type == OP_RECV) {
1486         char namebuf[MAXPATHLEN];
1487 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE)
1488         bufsize = sizeof (struct sockaddr_in);
1489 #else
1490         bufsize = sizeof namebuf;
1491 #endif
1492 #ifdef OS2      /* At least Warp3+IAK: only the first byte of bufsize set */
1493         if (bufsize >= 256)
1494             bufsize = 255;
1495 #endif
1496 #ifdef OS2      /* At least Warp3+IAK: only the first byte of bufsize set */
1497         if (bufsize >= 256)
1498             bufsize = 255;
1499 #endif
1500         buffer = SvGROW(bufsv, length+1);
1501         /* 'offset' means 'flags' here */
1502         length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1503                           (struct sockaddr *)namebuf, &bufsize);
1504         if (length < 0)
1505             RETPUSHUNDEF;
1506         SvCUR_set(bufsv, length);
1507         *SvEND(bufsv) = '\0';
1508         (void)SvPOK_only(bufsv);
1509         SvSETMAGIC(bufsv);
1510         /* This should not be marked tainted if the fp is marked clean */
1511         if (!(IoFLAGS(io) & IOf_UNTAINT))
1512             SvTAINTED_on(bufsv);
1513         SP = ORIGMARK;
1514         sv_setpvn(TARG, namebuf, bufsize);
1515         PUSHs(TARG);
1516         RETURN;
1517     }
1518 #else
1519     if (PL_op->op_type == OP_RECV)
1520         DIE(aTHX_ PL_no_sock_func, "recv");
1521 #endif
1522     if (offset < 0) {
1523         if (-offset > blen)
1524             DIE(aTHX_ "Offset outside string");
1525         offset += blen;
1526     }
1527     bufsize = SvCUR(bufsv);
1528     buffer = SvGROW(bufsv, length+offset+1);
1529     if (offset > bufsize) { /* Zero any newly allocated space */
1530         Zero(buffer+bufsize, offset-bufsize, char);
1531     }
1532     if (PL_op->op_type == OP_SYSREAD) {
1533 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1534         if (IoTYPE(io) == 's') {
1535             length = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1536                                    buffer+offset, length, 0);
1537         }
1538         else
1539 #endif
1540         {
1541             length = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1542                                   buffer+offset, length);
1543         }
1544     }
1545     else
1546 #ifdef HAS_SOCKET__bad_code_maybe
1547     if (IoTYPE(io) == 's') {
1548         char namebuf[MAXPATHLEN];
1549 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1550         bufsize = sizeof (struct sockaddr_in);
1551 #else
1552         bufsize = sizeof namebuf;
1553 #endif
1554         length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
1555                           (struct sockaddr *)namebuf, &bufsize);
1556     }
1557     else
1558 #endif
1559     {
1560         length = PerlIO_read(IoIFP(io), buffer+offset, length);
1561         /* fread() returns 0 on both error and EOF */
1562         if (length == 0 && PerlIO_error(IoIFP(io)))
1563             length = -1;
1564     }
1565     if (length < 0) {
1566         if ((IoTYPE(io) == '>' || IoIFP(io) == PerlIO_stdout()
1567             || IoIFP(io) == PerlIO_stderr()) && ckWARN(WARN_IO))
1568         {
1569             SV* sv = sv_newmortal();
1570             gv_efullname3(sv, gv, Nullch);
1571             Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output",
1572                         SvPV_nolen(sv));
1573         }
1574         goto say_undef;
1575     }
1576     SvCUR_set(bufsv, length+offset);
1577     *SvEND(bufsv) = '\0';
1578     (void)SvPOK_only(bufsv);
1579     SvSETMAGIC(bufsv);
1580     /* This should not be marked tainted if the fp is marked clean */
1581     if (!(IoFLAGS(io) & IOf_UNTAINT))
1582         SvTAINTED_on(bufsv);
1583     SP = ORIGMARK;
1584     PUSHi(length);
1585     RETURN;
1586
1587   say_undef:
1588     SP = ORIGMARK;
1589     RETPUSHUNDEF;
1590 }
1591
1592 PP(pp_syswrite)
1593 {
1594     djSP;
1595     int items = (SP - PL_stack_base) - TOPMARK;
1596     if (items == 2) {
1597         SV *sv;
1598         EXTEND(SP, 1);
1599         sv = sv_2mortal(newSViv(sv_len(*SP)));
1600         PUSHs(sv);
1601         PUTBACK;
1602     }
1603     return pp_send();
1604 }
1605
1606 PP(pp_send)
1607 {
1608     djSP; dMARK; dORIGMARK; dTARGET;
1609     GV *gv;
1610     IO *io;
1611     int offset;
1612     SV *bufsv;
1613     char *buffer;
1614     int length;
1615     STRLEN blen;
1616     MAGIC *mg;
1617
1618     gv = (GV*)*++MARK;
1619     if (PL_op->op_type == OP_SYSWRITE && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1620         SV *sv;
1621
1622         PUSHMARK(MARK-1);
1623         *MARK = SvTIED_obj((SV*)gv, mg);
1624         ENTER;
1625         call_method("WRITE", G_SCALAR);
1626         LEAVE;
1627         SPAGAIN;
1628         sv = POPs;
1629         SP = ORIGMARK;
1630         PUSHs(sv);
1631         RETURN;
1632     }
1633     if (!gv)
1634         goto say_undef;
1635     bufsv = *++MARK;
1636     buffer = SvPV(bufsv, blen);
1637     length = SvIVx(*++MARK);
1638     if (length < 0)
1639         DIE(aTHX_ "Negative length");
1640     SETERRNO(0,0);
1641     io = GvIO(gv);
1642     if (!io || !IoIFP(io)) {
1643         length = -1;
1644         if (ckWARN(WARN_CLOSED)) {
1645             if (PL_op->op_type == OP_SYSWRITE)
1646                 Perl_warner(aTHX_ WARN_CLOSED, "Syswrite on closed filehandle");
1647             else
1648                 Perl_warner(aTHX_ WARN_CLOSED, "Send on closed socket");
1649         }
1650     }
1651     else if (PL_op->op_type == OP_SYSWRITE) {
1652         if (MARK < SP) {
1653             offset = SvIVx(*++MARK);
1654             if (offset < 0) {
1655                 if (-offset > blen)
1656                     DIE(aTHX_ "Offset outside string");
1657                 offset += blen;
1658             } else if (offset >= blen && blen > 0)
1659                 DIE(aTHX_ "Offset outside string");
1660         } else
1661             offset = 0;
1662         if (length > blen - offset)
1663             length = blen - offset;
1664 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1665         if (IoTYPE(io) == 's') {
1666             length = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1667                                    buffer+offset, length, 0);
1668         }
1669         else
1670 #endif
1671         {
1672             /* See the note at doio.c:do_print about filesize limits. --jhi */
1673             length = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1674                                    buffer+offset, length);
1675         }
1676     }
1677 #ifdef HAS_SOCKET
1678     else if (SP > MARK) {
1679         char *sockbuf;
1680         STRLEN mlen;
1681         sockbuf = SvPVx(*++MARK, mlen);
1682         length = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
1683                                 (struct sockaddr *)sockbuf, mlen);
1684     }
1685     else
1686         length = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
1687
1688 #else
1689     else
1690         DIE(aTHX_ PL_no_sock_func, "send");
1691 #endif
1692     if (length < 0)
1693         goto say_undef;
1694     SP = ORIGMARK;
1695     PUSHi(length);
1696     RETURN;
1697
1698   say_undef:
1699     SP = ORIGMARK;
1700     RETPUSHUNDEF;
1701 }
1702
1703 PP(pp_recv)
1704 {
1705     return pp_sysread();
1706 }
1707
1708 PP(pp_eof)
1709 {
1710     djSP;
1711     GV *gv;
1712     MAGIC *mg;
1713
1714     if (MAXARG <= 0)
1715         gv = PL_last_in_gv;
1716     else
1717         gv = PL_last_in_gv = (GV*)POPs;
1718
1719     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1720         PUSHMARK(SP);
1721         XPUSHs(SvTIED_obj((SV*)gv, mg));
1722         PUTBACK;
1723         ENTER;
1724         call_method("EOF", G_SCALAR);
1725         LEAVE;
1726         SPAGAIN;
1727         RETURN;
1728     }
1729
1730     PUSHs(boolSV(!gv || do_eof(gv)));
1731     RETURN;
1732 }
1733
1734 PP(pp_tell)
1735 {
1736     djSP; dTARGET;
1737     GV *gv;
1738     MAGIC *mg;
1739
1740     if (MAXARG <= 0)
1741         gv = PL_last_in_gv;
1742     else
1743         gv = PL_last_in_gv = (GV*)POPs;
1744
1745     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1746         PUSHMARK(SP);
1747         XPUSHs(SvTIED_obj((SV*)gv, mg));
1748         PUTBACK;
1749         ENTER;
1750         call_method("TELL", G_SCALAR);
1751         LEAVE;
1752         SPAGAIN;
1753         RETURN;
1754     }
1755
1756     PUSHi( do_tell(gv) );
1757     RETURN;
1758 }
1759
1760 PP(pp_seek)
1761 {
1762     return pp_sysseek();
1763 }
1764
1765 PP(pp_sysseek)
1766 {
1767     djSP;
1768     GV *gv;
1769     int whence = POPi;
1770     Off_t offset = (Off_t)SvIVx(POPs);
1771     MAGIC *mg;
1772
1773     gv = PL_last_in_gv = (GV*)POPs;
1774
1775     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1776         PUSHMARK(SP);
1777         XPUSHs(SvTIED_obj((SV*)gv, mg));
1778         XPUSHs(sv_2mortal(newSViv((IV) offset)));
1779         XPUSHs(sv_2mortal(newSViv((IV) whence)));
1780         PUTBACK;
1781         ENTER;
1782         call_method("SEEK", G_SCALAR);
1783         LEAVE;
1784         SPAGAIN;
1785         RETURN;
1786     }
1787
1788     if (PL_op->op_type == OP_SEEK)
1789         PUSHs(boolSV(do_seek(gv, offset, whence)));
1790     else {
1791         Off_t n = do_sysseek(gv, offset, whence);
1792         PUSHs((n < 0) ? &PL_sv_undef
1793               : sv_2mortal(n ? newSViv((IV)n)
1794                            : newSVpvn(zero_but_true, ZBTLEN)));
1795     }
1796     RETURN;
1797 }
1798
1799 PP(pp_truncate)
1800 {
1801     djSP;
1802     Off_t len = (Off_t)POPn;
1803     int result = 1;
1804     GV *tmpgv;
1805     STRLEN n_a;
1806
1807     SETERRNO(0,0);
1808 #if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
1809     if (PL_op->op_flags & OPf_SPECIAL) {
1810         tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
1811     do_ftruncate:
1812         TAINT_PROPER("truncate");
1813         if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
1814 #ifdef HAS_TRUNCATE
1815           ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
1816 #else
1817           my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
1818 #endif
1819             result = 0;
1820     }
1821     else {
1822         SV *sv = POPs;
1823         char *name;
1824         STRLEN n_a;
1825
1826         if (SvTYPE(sv) == SVt_PVGV) {
1827             tmpgv = (GV*)sv;            /* *main::FRED for example */
1828             goto do_ftruncate;
1829         }
1830         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1831             tmpgv = (GV*) SvRV(sv);     /* \*main::FRED for example */
1832             goto do_ftruncate;
1833         }
1834
1835         name = SvPV(sv, n_a);
1836         TAINT_PROPER("truncate");
1837 #ifdef HAS_TRUNCATE
1838         if (truncate(name, len) < 0)
1839             result = 0;
1840 #else
1841         {
1842             int tmpfd;
1843             if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
1844                 result = 0;
1845             else {
1846                 if (my_chsize(tmpfd, len) < 0)
1847                     result = 0;
1848                 PerlLIO_close(tmpfd);
1849             }
1850         }
1851 #endif
1852     }
1853
1854     if (result)
1855         RETPUSHYES;
1856     if (!errno)
1857         SETERRNO(EBADF,RMS$_IFI);
1858     RETPUSHUNDEF;
1859 #else
1860     DIE(aTHX_ "truncate not implemented");
1861 #endif
1862 }
1863
1864 PP(pp_fcntl)
1865 {
1866     return pp_ioctl();
1867 }
1868
1869 PP(pp_ioctl)
1870 {
1871     djSP; dTARGET;
1872     SV *argsv = POPs;
1873     unsigned int func = U_I(POPn);
1874     int optype = PL_op->op_type;
1875     char *s;
1876     IV retval;
1877     GV *gv = (GV*)POPs;
1878     IO *io = GvIOn(gv);
1879
1880     if (!io || !argsv || !IoIFP(io)) {
1881         SETERRNO(EBADF,RMS$_IFI);       /* well, sort of... */
1882         RETPUSHUNDEF;
1883     }
1884
1885     if (SvPOK(argsv) || !SvNIOK(argsv)) {
1886         STRLEN len;
1887         STRLEN need;
1888         s = SvPV_force(argsv, len);
1889         need = IOCPARM_LEN(func);
1890         if (len < need) {
1891             s = Sv_Grow(argsv, need + 1);
1892             SvCUR_set(argsv, need);
1893         }
1894
1895         s[SvCUR(argsv)] = 17;   /* a little sanity check here */
1896     }
1897     else {
1898         retval = SvIV(argsv);
1899         s = INT2PTR(char*,retval);              /* ouch */
1900     }
1901
1902     TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
1903
1904     if (optype == OP_IOCTL)
1905 #ifdef HAS_IOCTL
1906         retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
1907 #else
1908         DIE(aTHX_ "ioctl is not implemented");
1909 #endif
1910     else
1911 #ifdef HAS_FCNTL
1912 #if defined(OS2) && defined(__EMX__)
1913         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
1914 #else
1915         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
1916 #endif
1917 #else
1918         DIE(aTHX_ "fcntl is not implemented");
1919 #endif
1920
1921     if (SvPOK(argsv)) {
1922         if (s[SvCUR(argsv)] != 17)
1923             DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
1924                 PL_op_name[optype]);
1925         s[SvCUR(argsv)] = 0;            /* put our null back */
1926         SvSETMAGIC(argsv);              /* Assume it has changed */
1927     }
1928
1929     if (retval == -1)
1930         RETPUSHUNDEF;
1931     if (retval != 0) {
1932         PUSHi(retval);
1933     }
1934     else {
1935         PUSHp(zero_but_true, ZBTLEN);
1936     }
1937     RETURN;
1938 }
1939
1940 PP(pp_flock)
1941 {
1942     djSP; dTARGET;
1943     I32 value;
1944     int argtype;
1945     GV *gv;
1946     PerlIO *fp;
1947
1948 #ifdef FLOCK
1949     argtype = POPi;
1950     if (MAXARG <= 0)
1951         gv = PL_last_in_gv;
1952     else
1953         gv = (GV*)POPs;
1954     if (gv && GvIO(gv))
1955         fp = IoIFP(GvIOp(gv));
1956     else
1957         fp = Nullfp;
1958     if (fp) {
1959         (void)PerlIO_flush(fp);
1960         value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
1961     }
1962     else
1963         value = 0;
1964     PUSHi(value);
1965     RETURN;
1966 #else
1967     DIE(aTHX_ PL_no_func, "flock()");
1968 #endif
1969 }
1970
1971 /* Sockets. */
1972
1973 PP(pp_socket)
1974 {
1975     djSP;
1976 #ifdef HAS_SOCKET
1977     GV *gv;
1978     register IO *io;
1979     int protocol = POPi;
1980     int type = POPi;
1981     int domain = POPi;
1982     int fd;
1983
1984     gv = (GV*)POPs;
1985
1986     if (!gv) {
1987         SETERRNO(EBADF,LIB$_INVARG);
1988         RETPUSHUNDEF;
1989     }
1990
1991     io = GvIOn(gv);
1992     if (IoIFP(io))
1993         do_close(gv, FALSE);
1994
1995     TAINT_PROPER("socket");
1996     fd = PerlSock_socket(domain, type, protocol);
1997     if (fd < 0)
1998         RETPUSHUNDEF;
1999     IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
2000     IoOFP(io) = PerlIO_fdopen(fd, "w");
2001     IoTYPE(io) = 's';
2002     if (!IoIFP(io) || !IoOFP(io)) {
2003         if (IoIFP(io)) PerlIO_close(IoIFP(io));
2004         if (IoOFP(io)) PerlIO_close(IoOFP(io));
2005         if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2006         RETPUSHUNDEF;
2007     }
2008
2009     RETPUSHYES;
2010 #else
2011     DIE(aTHX_ PL_no_sock_func, "socket");
2012 #endif
2013 }
2014
2015 PP(pp_sockpair)
2016 {
2017     djSP;
2018 #ifdef HAS_SOCKETPAIR
2019     GV *gv1;
2020     GV *gv2;
2021     register IO *io1;
2022     register IO *io2;
2023     int protocol = POPi;
2024     int type = POPi;
2025     int domain = POPi;
2026     int fd[2];
2027
2028     gv2 = (GV*)POPs;
2029     gv1 = (GV*)POPs;
2030     if (!gv1 || !gv2)
2031         RETPUSHUNDEF;
2032
2033     io1 = GvIOn(gv1);
2034     io2 = GvIOn(gv2);
2035     if (IoIFP(io1))
2036         do_close(gv1, FALSE);
2037     if (IoIFP(io2))
2038         do_close(gv2, FALSE);
2039
2040     TAINT_PROPER("socketpair");
2041     if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2042         RETPUSHUNDEF;
2043     IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
2044     IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
2045     IoTYPE(io1) = 's';
2046     IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
2047     IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
2048     IoTYPE(io2) = 's';
2049     if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2050         if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2051         if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2052         if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2053         if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2054         if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2055         if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2056         RETPUSHUNDEF;
2057     }
2058
2059     RETPUSHYES;
2060 #else
2061     DIE(aTHX_ PL_no_sock_func, "socketpair");
2062 #endif
2063 }
2064
2065 PP(pp_bind)
2066 {
2067     djSP;
2068 #ifdef HAS_SOCKET
2069 #ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
2070     extern GETPRIVMODE();
2071     extern GETUSERMODE();
2072 #endif
2073     SV *addrsv = POPs;
2074     char *addr;
2075     GV *gv = (GV*)POPs;
2076     register IO *io = GvIOn(gv);
2077     STRLEN len;
2078     int bind_ok = 0;
2079 #ifdef MPE
2080     int mpeprivmode = 0;
2081 #endif
2082
2083     if (!io || !IoIFP(io))
2084         goto nuts;
2085
2086     addr = SvPV(addrsv, len);
2087     TAINT_PROPER("bind");
2088 #ifdef MPE /* Deal with MPE bind() peculiarities */
2089     if (((struct sockaddr *)addr)->sa_family == AF_INET) {
2090         /* The address *MUST* stupidly be zero. */
2091         ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
2092         /* PRIV mode is required to bind() to ports < 1024. */
2093         if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
2094             ((struct sockaddr_in *)addr)->sin_port > 0) {
2095             GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
2096             mpeprivmode = 1;
2097         }
2098     }
2099 #endif /* MPE */
2100     if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
2101                       (struct sockaddr *)addr, len) >= 0)
2102         bind_ok = 1;
2103
2104 #ifdef MPE /* Switch back to USER mode */
2105     if (mpeprivmode)
2106         GETUSERMODE();
2107 #endif /* MPE */
2108
2109     if (bind_ok)
2110         RETPUSHYES;
2111     else
2112         RETPUSHUNDEF;
2113
2114 nuts:
2115     if (ckWARN(WARN_CLOSED))
2116         Perl_warner(aTHX_ WARN_CLOSED, "bind() on closed fd");
2117     SETERRNO(EBADF,SS$_IVCHAN);
2118     RETPUSHUNDEF;
2119 #else
2120     DIE(aTHX_ PL_no_sock_func, "bind");
2121 #endif
2122 }
2123
2124 PP(pp_connect)
2125 {
2126     djSP;
2127 #ifdef HAS_SOCKET
2128     SV *addrsv = POPs;
2129     char *addr;
2130     GV *gv = (GV*)POPs;
2131     register IO *io = GvIOn(gv);
2132     STRLEN len;
2133
2134     if (!io || !IoIFP(io))
2135         goto nuts;
2136
2137     addr = SvPV(addrsv, len);
2138     TAINT_PROPER("connect");
2139     if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2140         RETPUSHYES;
2141     else
2142         RETPUSHUNDEF;
2143
2144 nuts:
2145     if (ckWARN(WARN_CLOSED))
2146         Perl_warner(aTHX_ WARN_CLOSED, "connect() on closed fd");
2147     SETERRNO(EBADF,SS$_IVCHAN);
2148     RETPUSHUNDEF;
2149 #else
2150     DIE(aTHX_ PL_no_sock_func, "connect");
2151 #endif
2152 }
2153
2154 PP(pp_listen)
2155 {
2156     djSP;
2157 #ifdef HAS_SOCKET
2158     int backlog = POPi;
2159     GV *gv = (GV*)POPs;
2160     register IO *io = GvIOn(gv);
2161
2162     if (!io || !IoIFP(io))
2163         goto nuts;
2164
2165     if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2166         RETPUSHYES;
2167     else
2168         RETPUSHUNDEF;
2169
2170 nuts:
2171     if (ckWARN(WARN_CLOSED))
2172         Perl_warner(aTHX_ WARN_CLOSED, "listen() on closed fd");
2173     SETERRNO(EBADF,SS$_IVCHAN);
2174     RETPUSHUNDEF;
2175 #else
2176     DIE(aTHX_ PL_no_sock_func, "listen");
2177 #endif
2178 }
2179
2180 PP(pp_accept)
2181 {
2182     djSP; dTARGET;
2183 #ifdef HAS_SOCKET
2184     GV *ngv;
2185     GV *ggv;
2186     register IO *nstio;
2187     register IO *gstio;
2188     struct sockaddr saddr;      /* use a struct to avoid alignment problems */
2189     Sock_size_t len = sizeof saddr;
2190     int fd;
2191
2192     ggv = (GV*)POPs;
2193     ngv = (GV*)POPs;
2194
2195     if (!ngv)
2196         goto badexit;
2197     if (!ggv)
2198         goto nuts;
2199
2200     gstio = GvIO(ggv);
2201     if (!gstio || !IoIFP(gstio))
2202         goto nuts;
2203
2204     nstio = GvIOn(ngv);
2205     if (IoIFP(nstio))
2206         do_close(ngv, FALSE);
2207
2208     fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
2209     if (fd < 0)
2210         goto badexit;
2211     IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2212     IoOFP(nstio) = PerlIO_fdopen(fd, "w");
2213     IoTYPE(nstio) = 's';
2214     if (!IoIFP(nstio) || !IoOFP(nstio)) {
2215         if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2216         if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2217         if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2218         goto badexit;
2219     }
2220
2221     PUSHp((char *)&saddr, len);
2222     RETURN;
2223
2224 nuts:
2225     if (ckWARN(WARN_CLOSED))
2226         Perl_warner(aTHX_ WARN_CLOSED, "accept() on closed fd");
2227     SETERRNO(EBADF,SS$_IVCHAN);
2228
2229 badexit:
2230     RETPUSHUNDEF;
2231
2232 #else
2233     DIE(aTHX_ PL_no_sock_func, "accept");
2234 #endif
2235 }
2236
2237 PP(pp_shutdown)
2238 {
2239     djSP; dTARGET;
2240 #ifdef HAS_SOCKET
2241     int how = POPi;
2242     GV *gv = (GV*)POPs;
2243     register IO *io = GvIOn(gv);
2244
2245     if (!io || !IoIFP(io))
2246         goto nuts;
2247
2248     PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2249     RETURN;
2250
2251 nuts:
2252     if (ckWARN(WARN_CLOSED))
2253         Perl_warner(aTHX_ WARN_CLOSED, "shutdown() on closed fd");
2254     SETERRNO(EBADF,SS$_IVCHAN);
2255     RETPUSHUNDEF;
2256 #else
2257     DIE(aTHX_ PL_no_sock_func, "shutdown");
2258 #endif
2259 }
2260
2261 PP(pp_gsockopt)
2262 {
2263 #ifdef HAS_SOCKET
2264     return pp_ssockopt();
2265 #else
2266     DIE(aTHX_ PL_no_sock_func, "getsockopt");
2267 #endif
2268 }
2269
2270 PP(pp_ssockopt)
2271 {
2272     djSP;
2273 #ifdef HAS_SOCKET
2274     int optype = PL_op->op_type;
2275     SV *sv;
2276     int fd;
2277     unsigned int optname;
2278     unsigned int lvl;
2279     GV *gv;
2280     register IO *io;
2281     Sock_size_t len;
2282
2283     if (optype == OP_GSOCKOPT)
2284         sv = sv_2mortal(NEWSV(22, 257));
2285     else
2286         sv = POPs;
2287     optname = (unsigned int) POPi;
2288     lvl = (unsigned int) POPi;
2289
2290     gv = (GV*)POPs;
2291     io = GvIOn(gv);
2292     if (!io || !IoIFP(io))
2293         goto nuts;
2294
2295     fd = PerlIO_fileno(IoIFP(io));
2296     switch (optype) {
2297     case OP_GSOCKOPT:
2298         SvGROW(sv, 257);
2299         (void)SvPOK_only(sv);
2300         SvCUR_set(sv,256);
2301         *SvEND(sv) ='\0';
2302         len = SvCUR(sv);
2303         if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2304             goto nuts2;
2305         SvCUR_set(sv, len);
2306         *SvEND(sv) ='\0';
2307         PUSHs(sv);
2308         break;
2309     case OP_SSOCKOPT: {
2310             char *buf;
2311             int aint;
2312             if (SvPOKp(sv)) {
2313                 STRLEN l;
2314                 buf = SvPV(sv, l);
2315                 len = l;
2316             }
2317             else {
2318                 aint = (int)SvIV(sv);
2319                 buf = (char*)&aint;
2320                 len = sizeof(int);
2321             }
2322             if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2323                 goto nuts2;
2324             PUSHs(&PL_sv_yes);
2325         }
2326         break;
2327     }
2328     RETURN;
2329
2330 nuts:
2331     if (ckWARN(WARN_CLOSED))
2332         Perl_warner(aTHX_ WARN_CLOSED, "[gs]etsockopt() on closed fd");
2333     SETERRNO(EBADF,SS$_IVCHAN);
2334 nuts2:
2335     RETPUSHUNDEF;
2336
2337 #else
2338     DIE(aTHX_ PL_no_sock_func, "setsockopt");
2339 #endif
2340 }
2341
2342 PP(pp_getsockname)
2343 {
2344 #ifdef HAS_SOCKET
2345     return pp_getpeername();
2346 #else
2347     DIE(aTHX_ PL_no_sock_func, "getsockname");
2348 #endif
2349 }
2350
2351 PP(pp_getpeername)
2352 {
2353     djSP;
2354 #ifdef HAS_SOCKET
2355     int optype = PL_op->op_type;
2356     SV *sv;
2357     int fd;
2358     GV *gv = (GV*)POPs;
2359     register IO *io = GvIOn(gv);
2360     Sock_size_t len;
2361
2362     if (!io || !IoIFP(io))
2363         goto nuts;
2364
2365     sv = sv_2mortal(NEWSV(22, 257));
2366     (void)SvPOK_only(sv);
2367     len = 256;
2368     SvCUR_set(sv, len);
2369     *SvEND(sv) ='\0';
2370     fd = PerlIO_fileno(IoIFP(io));
2371     switch (optype) {
2372     case OP_GETSOCKNAME:
2373         if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2374             goto nuts2;
2375         break;
2376     case OP_GETPEERNAME:
2377         if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2378             goto nuts2;
2379 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2380         {
2381             static const char nowhere[] = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
2382             /* If the call succeeded, make sure we don't have a zeroed port/addr */
2383             if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2384                 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2385                         sizeof(u_short) + sizeof(struct in_addr))) {
2386                 goto nuts2;
2387             }
2388         }
2389 #endif
2390         break;
2391     }
2392 #ifdef BOGUS_GETNAME_RETURN
2393     /* Interactive Unix, getpeername() and getsockname()
2394       does not return valid namelen */
2395     if (len == BOGUS_GETNAME_RETURN)
2396         len = sizeof(struct sockaddr);
2397 #endif
2398     SvCUR_set(sv, len);
2399     *SvEND(sv) ='\0';
2400     PUSHs(sv);
2401     RETURN;
2402
2403 nuts:
2404     if (ckWARN(WARN_CLOSED))
2405         Perl_warner(aTHX_ WARN_CLOSED, "get{sock, peer}name() on closed fd");
2406     SETERRNO(EBADF,SS$_IVCHAN);
2407 nuts2:
2408     RETPUSHUNDEF;
2409
2410 #else
2411     DIE(aTHX_ PL_no_sock_func, "getpeername");
2412 #endif
2413 }
2414
2415 /* Stat calls. */
2416
2417 PP(pp_lstat)
2418 {
2419     return pp_stat();
2420 }
2421
2422 PP(pp_stat)
2423 {
2424     djSP;
2425     GV *tmpgv;
2426     I32 gimme;
2427     I32 max = 13;
2428     STRLEN n_a;
2429
2430     if (PL_op->op_flags & OPf_REF) {
2431         tmpgv = cGVOP->op_gv;
2432       do_fstat:
2433         if (tmpgv != PL_defgv) {
2434             PL_laststype = OP_STAT;
2435             PL_statgv = tmpgv;
2436             sv_setpv(PL_statname, "");
2437             PL_laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
2438                 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &PL_statcache) : -1);
2439         }
2440         if (PL_laststatval < 0)
2441             max = 0;
2442     }
2443     else {
2444         SV* sv = POPs;
2445         if (SvTYPE(sv) == SVt_PVGV) {
2446             tmpgv = (GV*)sv;
2447             goto do_fstat;
2448         }
2449         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2450             tmpgv = (GV*)SvRV(sv);
2451             goto do_fstat;
2452         }
2453         sv_setpv(PL_statname, SvPV(sv,n_a));
2454         PL_statgv = Nullgv;
2455 #ifdef HAS_LSTAT
2456         PL_laststype = PL_op->op_type;
2457         if (PL_op->op_type == OP_LSTAT)
2458             PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
2459         else
2460 #endif
2461             PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
2462         if (PL_laststatval < 0) {
2463             if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
2464                 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
2465             max = 0;
2466         }
2467     }
2468
2469     gimme = GIMME_V;
2470     if (gimme != G_ARRAY) {
2471         if (gimme != G_VOID)
2472             XPUSHs(boolSV(max));
2473         RETURN;
2474     }
2475     if (max) {
2476         EXTEND(SP, max);
2477         EXTEND_MORTAL(max);
2478         PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2479         PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2480         PUSHs(sv_2mortal(newSViv(PL_statcache.st_mode)));
2481         PUSHs(sv_2mortal(newSViv(PL_statcache.st_nlink)));
2482         PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2483         PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2484 #ifdef USE_STAT_RDEV
2485         PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2486 #else
2487         PUSHs(sv_2mortal(newSVpvn("", 0)));
2488 #endif
2489         PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2490 #ifdef BIG_TIME
2491         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2492         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2493         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2494 #else
2495         PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2496         PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2497         PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
2498 #endif
2499 #ifdef USE_STAT_BLOCKS
2500         PUSHs(sv_2mortal(newSViv(PL_statcache.st_blksize)));
2501         PUSHs(sv_2mortal(newSViv(PL_statcache.st_blocks)));
2502 #else
2503         PUSHs(sv_2mortal(newSVpvn("", 0)));
2504         PUSHs(sv_2mortal(newSVpvn("", 0)));
2505 #endif
2506     }
2507     RETURN;
2508 }
2509
2510 PP(pp_ftrread)
2511 {
2512     I32 result;
2513     djSP;
2514 #if defined(HAS_ACCESS) && defined(R_OK)
2515     STRLEN n_a;
2516     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2517         result = access(TOPpx, R_OK);
2518         if (result == 0)
2519             RETPUSHYES;
2520         if (result < 0)
2521             RETPUSHUNDEF;
2522         RETPUSHNO;
2523     }
2524     else
2525         result = my_stat();
2526 #else
2527     result = my_stat();
2528 #endif
2529     SPAGAIN;
2530     if (result < 0)
2531         RETPUSHUNDEF;
2532     if (cando(S_IRUSR, 0, &PL_statcache))
2533         RETPUSHYES;
2534     RETPUSHNO;
2535 }
2536
2537 PP(pp_ftrwrite)
2538 {
2539     I32 result;
2540     djSP;
2541 #if defined(HAS_ACCESS) && defined(W_OK)
2542     STRLEN n_a;
2543     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2544         result = access(TOPpx, W_OK);
2545         if (result == 0)
2546             RETPUSHYES;
2547         if (result < 0)
2548             RETPUSHUNDEF;
2549         RETPUSHNO;
2550     }
2551     else
2552         result = my_stat();
2553 #else
2554     result = my_stat();
2555 #endif
2556     SPAGAIN;
2557     if (result < 0)
2558         RETPUSHUNDEF;
2559     if (cando(S_IWUSR, 0, &PL_statcache))
2560         RETPUSHYES;
2561     RETPUSHNO;
2562 }
2563
2564 PP(pp_ftrexec)
2565 {
2566     I32 result;
2567     djSP;
2568 #if defined(HAS_ACCESS) && defined(X_OK)
2569     STRLEN n_a;
2570     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2571         result = access(TOPpx, X_OK);
2572         if (result == 0)
2573             RETPUSHYES;
2574         if (result < 0)
2575             RETPUSHUNDEF;
2576         RETPUSHNO;
2577     }
2578     else
2579         result = my_stat();
2580 #else
2581     result = my_stat();
2582 #endif
2583     SPAGAIN;
2584     if (result < 0)
2585         RETPUSHUNDEF;
2586     if (cando(S_IXUSR, 0, &PL_statcache))
2587         RETPUSHYES;
2588     RETPUSHNO;
2589 }
2590
2591 PP(pp_fteread)
2592 {
2593     I32 result;
2594     djSP;
2595 #ifdef PERL_EFF_ACCESS_R_OK
2596     STRLEN n_a;
2597     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2598         result = PERL_EFF_ACCESS_R_OK(TOPpx);
2599         if (result == 0)
2600             RETPUSHYES;
2601         if (result < 0)
2602             RETPUSHUNDEF;
2603         RETPUSHNO;
2604     }
2605     else
2606         result = my_stat();
2607 #else
2608     result = my_stat();
2609 #endif
2610     SPAGAIN;
2611     if (result < 0)
2612         RETPUSHUNDEF;
2613     if (cando(S_IRUSR, 1, &PL_statcache))
2614         RETPUSHYES;
2615     RETPUSHNO;
2616 }
2617
2618 PP(pp_ftewrite)
2619 {
2620     I32 result;
2621     djSP;
2622 #ifdef PERL_EFF_ACCESS_W_OK
2623     STRLEN n_a;
2624     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2625         result = PERL_EFF_ACCESS_W_OK(TOPpx);
2626         if (result == 0)
2627             RETPUSHYES;
2628         if (result < 0)
2629             RETPUSHUNDEF;
2630         RETPUSHNO;
2631     }
2632     else
2633         result = my_stat();
2634 #else
2635     result = my_stat();
2636 #endif
2637     SPAGAIN;
2638     if (result < 0)
2639         RETPUSHUNDEF;
2640     if (cando(S_IWUSR, 1, &PL_statcache))
2641         RETPUSHYES;
2642     RETPUSHNO;
2643 }
2644
2645 PP(pp_fteexec)
2646 {
2647     I32 result;
2648     djSP;
2649 #ifdef PERL_EFF_ACCESS_X_OK
2650     STRLEN n_a;
2651     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2652         result = PERL_EFF_ACCESS_X_OK(TOPpx);
2653         if (result == 0)
2654             RETPUSHYES;
2655         if (result < 0)
2656             RETPUSHUNDEF;
2657         RETPUSHNO;
2658     }
2659     else
2660         result = my_stat();
2661 #else
2662     result = my_stat();
2663 #endif
2664     SPAGAIN;
2665     if (result < 0)
2666         RETPUSHUNDEF;
2667     if (cando(S_IXUSR, 1, &PL_statcache))
2668         RETPUSHYES;
2669     RETPUSHNO;
2670 }
2671
2672 PP(pp_ftis)
2673 {
2674     I32 result = my_stat();
2675     djSP;
2676     if (result < 0)
2677         RETPUSHUNDEF;
2678     RETPUSHYES;
2679 }
2680
2681 PP(pp_fteowned)
2682 {
2683     return pp_ftrowned();
2684 }
2685
2686 PP(pp_ftrowned)
2687 {
2688     I32 result = my_stat();
2689     djSP;
2690     if (result < 0)
2691         RETPUSHUNDEF;
2692     if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ? PL_euid : PL_uid) )
2693         RETPUSHYES;
2694     RETPUSHNO;
2695 }
2696
2697 PP(pp_ftzero)
2698 {
2699     I32 result = my_stat();
2700     djSP;
2701     if (result < 0)
2702         RETPUSHUNDEF;
2703     if (!PL_statcache.st_size)
2704         RETPUSHYES;
2705     RETPUSHNO;
2706 }
2707
2708 PP(pp_ftsize)
2709 {
2710     I32 result = my_stat();
2711     djSP; dTARGET;
2712     if (result < 0)
2713         RETPUSHUNDEF;
2714     PUSHi(PL_statcache.st_size);
2715     RETURN;
2716 }
2717
2718 PP(pp_ftmtime)
2719 {
2720     I32 result = my_stat();
2721     djSP; dTARGET;
2722     if (result < 0)
2723         RETPUSHUNDEF;
2724     PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
2725     RETURN;
2726 }
2727
2728 PP(pp_ftatime)
2729 {
2730     I32 result = my_stat();
2731     djSP; dTARGET;
2732     if (result < 0)
2733         RETPUSHUNDEF;
2734     PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
2735     RETURN;
2736 }
2737
2738 PP(pp_ftctime)
2739 {
2740     I32 result = my_stat();
2741     djSP; dTARGET;
2742     if (result < 0)
2743         RETPUSHUNDEF;
2744     PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
2745     RETURN;
2746 }
2747
2748 PP(pp_ftsock)
2749 {
2750     I32 result = my_stat();
2751     djSP;
2752     if (result < 0)
2753         RETPUSHUNDEF;
2754     if (S_ISSOCK(PL_statcache.st_mode))
2755         RETPUSHYES;
2756     RETPUSHNO;
2757 }
2758
2759 PP(pp_ftchr)
2760 {
2761     I32 result = my_stat();
2762     djSP;
2763     if (result < 0)
2764         RETPUSHUNDEF;
2765     if (S_ISCHR(PL_statcache.st_mode))
2766         RETPUSHYES;
2767     RETPUSHNO;
2768 }
2769
2770 PP(pp_ftblk)
2771 {
2772     I32 result = my_stat();
2773     djSP;
2774     if (result < 0)
2775         RETPUSHUNDEF;
2776     if (S_ISBLK(PL_statcache.st_mode))
2777         RETPUSHYES;
2778     RETPUSHNO;
2779 }
2780
2781 PP(pp_ftfile)
2782 {
2783     I32 result = my_stat();
2784     djSP;
2785     if (result < 0)
2786         RETPUSHUNDEF;
2787     if (S_ISREG(PL_statcache.st_mode))
2788         RETPUSHYES;
2789     RETPUSHNO;
2790 }
2791
2792 PP(pp_ftdir)
2793 {
2794     I32 result = my_stat();
2795     djSP;
2796     if (result < 0)
2797         RETPUSHUNDEF;
2798     if (S_ISDIR(PL_statcache.st_mode))
2799         RETPUSHYES;
2800     RETPUSHNO;
2801 }
2802
2803 PP(pp_ftpipe)
2804 {
2805     I32 result = my_stat();
2806     djSP;
2807     if (result < 0)
2808         RETPUSHUNDEF;
2809     if (S_ISFIFO(PL_statcache.st_mode))
2810         RETPUSHYES;
2811     RETPUSHNO;
2812 }
2813
2814 PP(pp_ftlink)
2815 {
2816     I32 result = my_lstat();
2817     djSP;
2818     if (result < 0)
2819         RETPUSHUNDEF;
2820     if (S_ISLNK(PL_statcache.st_mode))
2821         RETPUSHYES;
2822     RETPUSHNO;
2823 }
2824
2825 PP(pp_ftsuid)
2826 {
2827     djSP;
2828 #ifdef S_ISUID
2829     I32 result = my_stat();
2830     SPAGAIN;
2831     if (result < 0)
2832         RETPUSHUNDEF;
2833     if (PL_statcache.st_mode & S_ISUID)
2834         RETPUSHYES;
2835 #endif
2836     RETPUSHNO;
2837 }
2838
2839 PP(pp_ftsgid)
2840 {
2841     djSP;
2842 #ifdef S_ISGID
2843     I32 result = my_stat();
2844     SPAGAIN;
2845     if (result < 0)
2846         RETPUSHUNDEF;
2847     if (PL_statcache.st_mode & S_ISGID)
2848         RETPUSHYES;
2849 #endif
2850     RETPUSHNO;
2851 }
2852
2853 PP(pp_ftsvtx)
2854 {
2855     djSP;
2856 #ifdef S_ISVTX
2857     I32 result = my_stat();
2858     SPAGAIN;
2859     if (result < 0)
2860         RETPUSHUNDEF;
2861     if (PL_statcache.st_mode & S_ISVTX)
2862         RETPUSHYES;
2863 #endif
2864     RETPUSHNO;
2865 }
2866
2867 PP(pp_fttty)
2868 {
2869     djSP;
2870     int fd;
2871     GV *gv;
2872     char *tmps = Nullch;
2873     STRLEN n_a;
2874
2875     if (PL_op->op_flags & OPf_REF)
2876         gv = cGVOP->op_gv;
2877     else if (isGV(TOPs))
2878         gv = (GV*)POPs;
2879     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2880         gv = (GV*)SvRV(POPs);
2881     else
2882         gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
2883
2884     if (GvIO(gv) && IoIFP(GvIOp(gv)))
2885         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
2886     else if (tmps && isDIGIT(*tmps))
2887         fd = atoi(tmps);
2888     else
2889         RETPUSHUNDEF;
2890     if (PerlLIO_isatty(fd))
2891         RETPUSHYES;
2892     RETPUSHNO;
2893 }
2894
2895 #if defined(atarist) /* this will work with atariST. Configure will
2896                         make guesses for other systems. */
2897 # define FILE_base(f) ((f)->_base)
2898 # define FILE_ptr(f) ((f)->_ptr)
2899 # define FILE_cnt(f) ((f)->_cnt)
2900 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
2901 #endif
2902
2903 PP(pp_fttext)
2904 {
2905     djSP;
2906     I32 i;
2907     I32 len;
2908     I32 odd = 0;
2909     STDCHAR tbuf[512];
2910     register STDCHAR *s;
2911     register IO *io;
2912     register SV *sv;
2913     GV *gv;
2914     STRLEN n_a;
2915
2916     if (PL_op->op_flags & OPf_REF)
2917         gv = cGVOP->op_gv;
2918     else if (isGV(TOPs))
2919         gv = (GV*)POPs;
2920     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2921         gv = (GV*)SvRV(POPs);
2922     else
2923         gv = Nullgv;
2924
2925     if (gv) {
2926         EXTEND(SP, 1);
2927         if (gv == PL_defgv) {
2928             if (PL_statgv)
2929                 io = GvIO(PL_statgv);
2930             else {
2931                 sv = PL_statname;
2932                 goto really_filename;
2933             }
2934         }
2935         else {
2936             PL_statgv = gv;
2937             PL_laststatval = -1;
2938             sv_setpv(PL_statname, "");
2939             io = GvIO(PL_statgv);
2940         }
2941         if (io && IoIFP(io)) {
2942             if (! PerlIO_has_base(IoIFP(io)))
2943                 DIE(aTHX_ "-T and -B not implemented on filehandles");
2944             PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2945             if (PL_laststatval < 0)
2946                 RETPUSHUNDEF;
2947             if (S_ISDIR(PL_statcache.st_mode))  /* handle NFS glitch */
2948                 if (PL_op->op_type == OP_FTTEXT)
2949                     RETPUSHNO;
2950                 else
2951                     RETPUSHYES;
2952             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
2953                 i = PerlIO_getc(IoIFP(io));
2954                 if (i != EOF)
2955                     (void)PerlIO_ungetc(IoIFP(io),i);
2956             }
2957             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
2958                 RETPUSHYES;
2959             len = PerlIO_get_bufsiz(IoIFP(io));
2960             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
2961             /* sfio can have large buffers - limit to 512 */
2962             if (len > 512)
2963                 len = 512;
2964         }
2965         else {
2966             if (ckWARN(WARN_UNOPENED))
2967                 Perl_warner(aTHX_ WARN_UNOPENED, "Test on unopened file <%s>",
2968                   GvENAME(cGVOP->op_gv));
2969             SETERRNO(EBADF,RMS$_IFI);
2970             RETPUSHUNDEF;
2971         }
2972     }
2973     else {
2974         sv = POPs;
2975       really_filename:
2976         PL_statgv = Nullgv;
2977         PL_laststatval = -1;
2978         sv_setpv(PL_statname, SvPV(sv, n_a));
2979 #ifdef HAS_OPEN3
2980         i = PerlLIO_open3(SvPV(sv, n_a), O_RDONLY, 0);
2981 #else
2982         i = PerlLIO_open(SvPV(sv, n_a), 0);
2983 #endif
2984         if (i < 0) {
2985             if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
2986                 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
2987             RETPUSHUNDEF;
2988         }
2989         PL_laststatval = PerlLIO_fstat(i, &PL_statcache);
2990         if (PL_laststatval < 0)
2991             RETPUSHUNDEF;
2992         len = PerlLIO_read(i, tbuf, 512);
2993         (void)PerlLIO_close(i);
2994         if (len <= 0) {
2995             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
2996                 RETPUSHNO;              /* special case NFS directories */
2997             RETPUSHYES;         /* null file is anything */
2998         }
2999         s = tbuf;
3000     }
3001
3002     /* now scan s to look for textiness */
3003     /*   XXX ASCII dependent code */
3004
3005     for (i = 0; i < len; i++, s++) {
3006         if (!*s) {                      /* null never allowed in text */
3007             odd += len;
3008             break;
3009         }
3010 #ifdef EBCDIC
3011         else if (!(isPRINT(*s) || isSPACE(*s)))
3012             odd++;
3013 #else
3014         else if (*s & 128)
3015             odd++;
3016         else if (*s < 32 &&
3017           *s != '\n' && *s != '\r' && *s != '\b' &&
3018           *s != '\t' && *s != '\f' && *s != 27)
3019             odd++;
3020 #endif
3021     }
3022
3023     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3024         RETPUSHNO;
3025     else
3026         RETPUSHYES;
3027 }
3028
3029 PP(pp_ftbinary)
3030 {
3031     return pp_fttext();
3032 }
3033
3034 /* File calls. */
3035
3036 PP(pp_chdir)
3037 {
3038     djSP; dTARGET;
3039     char *tmps;
3040     SV **svp;
3041     STRLEN n_a;
3042
3043     if (MAXARG < 1)
3044         tmps = Nullch;
3045     else
3046         tmps = POPpx;
3047     if (!tmps || !*tmps) {
3048         svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
3049         if (svp)
3050             tmps = SvPV(*svp, n_a);
3051     }
3052     if (!tmps || !*tmps) {
3053         svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
3054         if (svp)
3055             tmps = SvPV(*svp, n_a);
3056     }
3057 #ifdef VMS
3058     if (!tmps || !*tmps) {
3059        svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
3060        if (svp)
3061            tmps = SvPV(*svp, n_a);
3062     }
3063 #endif
3064     TAINT_PROPER("chdir");
3065     PUSHi( PerlDir_chdir(tmps) >= 0 );
3066 #ifdef VMS
3067     /* Clear the DEFAULT element of ENV so we'll get the new value
3068      * in the future. */
3069     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3070 #endif
3071     RETURN;
3072 }
3073
3074 PP(pp_chown)
3075 {
3076     djSP; dMARK; dTARGET;
3077     I32 value;
3078 #ifdef HAS_CHOWN
3079     value = (I32)apply(PL_op->op_type, MARK, SP);
3080     SP = MARK;
3081     PUSHi(value);
3082     RETURN;
3083 #else
3084     DIE(aTHX_ PL_no_func, "Unsupported function chown");
3085 #endif
3086 }
3087
3088 PP(pp_chroot)
3089 {
3090     djSP; dTARGET;
3091     char *tmps;
3092 #ifdef HAS_CHROOT
3093     STRLEN n_a;
3094     tmps = POPpx;
3095     TAINT_PROPER("chroot");
3096     PUSHi( chroot(tmps) >= 0 );
3097     RETURN;
3098 #else
3099     DIE(aTHX_ PL_no_func, "chroot");
3100 #endif
3101 }
3102
3103 PP(pp_unlink)
3104 {
3105     djSP; dMARK; dTARGET;
3106     I32 value;
3107     value = (I32)apply(PL_op->op_type, MARK, SP);
3108     SP = MARK;
3109     PUSHi(value);
3110     RETURN;
3111 }
3112
3113 PP(pp_chmod)
3114 {
3115     djSP; dMARK; dTARGET;
3116     I32 value;
3117     value = (I32)apply(PL_op->op_type, MARK, SP);
3118     SP = MARK;
3119     PUSHi(value);
3120     RETURN;
3121 }
3122
3123 PP(pp_utime)
3124 {
3125     djSP; dMARK; dTARGET;
3126     I32 value;
3127     value = (I32)apply(PL_op->op_type, MARK, SP);
3128     SP = MARK;
3129     PUSHi(value);
3130     RETURN;
3131 }
3132
3133 PP(pp_rename)
3134 {
3135     djSP; dTARGET;
3136     int anum;
3137     STRLEN n_a;
3138
3139     char *tmps2 = POPpx;
3140     char *tmps = SvPV(TOPs, n_a);
3141     TAINT_PROPER("rename");
3142 #ifdef HAS_RENAME
3143     anum = PerlLIO_rename(tmps, tmps2);
3144 #else
3145     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3146         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3147             anum = 1;
3148         else {
3149             if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3150                 (void)UNLINK(tmps2);
3151             if (!(anum = link(tmps, tmps2)))
3152                 anum = UNLINK(tmps);
3153         }
3154     }
3155 #endif
3156     SETi( anum >= 0 );
3157     RETURN;
3158 }
3159
3160 PP(pp_link)
3161 {
3162     djSP; dTARGET;
3163 #ifdef HAS_LINK
3164     STRLEN n_a;
3165     char *tmps2 = POPpx;
3166     char *tmps = SvPV(TOPs, n_a);
3167     TAINT_PROPER("link");
3168     SETi( link(tmps, tmps2) >= 0 );
3169 #else
3170     DIE(aTHX_ PL_no_func, "Unsupported function link");
3171 #endif
3172     RETURN;
3173 }
3174
3175 PP(pp_symlink)
3176 {
3177     djSP; dTARGET;
3178 #ifdef HAS_SYMLINK
3179     STRLEN n_a;
3180     char *tmps2 = POPpx;
3181     char *tmps = SvPV(TOPs, n_a);
3182     TAINT_PROPER("symlink");
3183     SETi( symlink(tmps, tmps2) >= 0 );
3184     RETURN;
3185 #else
3186     DIE(aTHX_ PL_no_func, "symlink");
3187 #endif
3188 }
3189
3190 PP(pp_readlink)
3191 {
3192     djSP; dTARGET;
3193 #ifdef HAS_SYMLINK
3194     char *tmps;
3195     char buf[MAXPATHLEN];
3196     int len;
3197     STRLEN n_a;
3198
3199 #ifndef INCOMPLETE_TAINTS
3200     TAINT;
3201 #endif
3202     tmps = POPpx;
3203     len = readlink(tmps, buf, sizeof buf);
3204     EXTEND(SP, 1);
3205     if (len < 0)
3206         RETPUSHUNDEF;
3207     PUSHp(buf, len);
3208     RETURN;
3209 #else
3210     EXTEND(SP, 1);
3211     RETSETUNDEF;                /* just pretend it's a normal file */
3212 #endif
3213 }
3214
3215 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3216 STATIC int
3217 S_dooneliner(pTHX_ char *cmd, char *filename)
3218 {
3219     char *save_filename = filename;
3220     char *cmdline;
3221     char *s;
3222     PerlIO *myfp;
3223     int anum = 1;
3224
3225     New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3226     strcpy(cmdline, cmd);
3227     strcat(cmdline, " ");
3228     for (s = cmdline + strlen(cmdline); *filename; ) {
3229         *s++ = '\\';
3230         *s++ = *filename++;
3231     }
3232     strcpy(s, " 2>&1");
3233     myfp = PerlProc_popen(cmdline, "r");
3234     Safefree(cmdline);
3235
3236     if (myfp) {
3237         SV *tmpsv = sv_newmortal();
3238         /* Need to save/restore 'PL_rs' ?? */
3239         s = sv_gets(tmpsv, myfp, 0);
3240         (void)PerlProc_pclose(myfp);
3241         if (s != Nullch) {
3242             int e;
3243             for (e = 1;
3244 #ifdef HAS_SYS_ERRLIST
3245                  e <= sys_nerr
3246 #endif
3247                  ; e++)
3248             {
3249                 /* you don't see this */
3250                 char *errmsg =
3251 #ifdef HAS_SYS_ERRLIST
3252                     sys_errlist[e]
3253 #else
3254                     strerror(e)
3255 #endif
3256                     ;
3257                 if (!errmsg)
3258                     break;
3259                 if (instr(s, errmsg)) {
3260                     SETERRNO(e,0);
3261                     return 0;
3262                 }
3263             }
3264             SETERRNO(0,0);
3265 #ifndef EACCES
3266 #define EACCES EPERM
3267 #endif
3268             if (instr(s, "cannot make"))
3269                 SETERRNO(EEXIST,RMS$_FEX);
3270             else if (instr(s, "existing file"))
3271                 SETERRNO(EEXIST,RMS$_FEX);
3272             else if (instr(s, "ile exists"))
3273                 SETERRNO(EEXIST,RMS$_FEX);
3274             else if (instr(s, "non-exist"))
3275                 SETERRNO(ENOENT,RMS$_FNF);
3276             else if (instr(s, "does not exist"))
3277                 SETERRNO(ENOENT,RMS$_FNF);
3278             else if (instr(s, "not empty"))
3279                 SETERRNO(EBUSY,SS$_DEVOFFLINE);
3280             else if (instr(s, "cannot access"))
3281                 SETERRNO(EACCES,RMS$_PRV);
3282             else
3283                 SETERRNO(EPERM,RMS$_PRV);
3284             return 0;
3285         }
3286         else {  /* some mkdirs return no failure indication */
3287             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3288             if (PL_op->op_type == OP_RMDIR)
3289                 anum = !anum;
3290             if (anum)
3291                 SETERRNO(0,0);
3292             else
3293                 SETERRNO(EACCES,RMS$_PRV);      /* a guess */
3294         }
3295         return anum;
3296     }
3297     else
3298         return 0;
3299 }
3300 #endif
3301
3302 PP(pp_mkdir)
3303 {
3304     djSP; dTARGET;
3305     int mode = POPi;
3306 #ifndef HAS_MKDIR
3307     int oldumask;
3308 #endif
3309     STRLEN n_a;
3310     char *tmps = SvPV(TOPs, n_a);
3311
3312     TAINT_PROPER("mkdir");
3313 #ifdef HAS_MKDIR
3314     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3315 #else
3316     SETi( dooneliner("mkdir", tmps) );
3317     oldumask = PerlLIO_umask(0);
3318     PerlLIO_umask(oldumask);
3319     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3320 #endif
3321     RETURN;
3322 }
3323
3324 PP(pp_rmdir)
3325 {
3326     djSP; dTARGET;
3327     char *tmps;
3328     STRLEN n_a;
3329
3330     tmps = POPpx;
3331     TAINT_PROPER("rmdir");
3332 #ifdef HAS_RMDIR
3333     XPUSHi( PerlDir_rmdir(tmps) >= 0 );
3334 #else
3335     XPUSHi( dooneliner("rmdir", tmps) );
3336 #endif
3337     RETURN;
3338 }
3339
3340 /* Directory calls. */
3341
3342 PP(pp_open_dir)
3343 {
3344     djSP;
3345 #if defined(Direntry_t) && defined(HAS_READDIR)
3346     STRLEN n_a;
3347     char *dirname = POPpx;
3348     GV *gv = (GV*)POPs;
3349     register IO *io = GvIOn(gv);
3350
3351     if (!io)
3352         goto nope;
3353
3354     if (IoDIRP(io))
3355         PerlDir_close(IoDIRP(io));
3356     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3357         goto nope;
3358
3359     RETPUSHYES;
3360 nope:
3361     if (!errno)
3362         SETERRNO(EBADF,RMS$_DIR);
3363     RETPUSHUNDEF;
3364 #else
3365     DIE(aTHX_ PL_no_dir_func, "opendir");
3366 #endif
3367 }
3368
3369 PP(pp_readdir)
3370 {
3371     djSP;
3372 #if defined(Direntry_t) && defined(HAS_READDIR)
3373 #ifndef I_DIRENT
3374     Direntry_t *readdir (DIR *);
3375 #endif
3376     register Direntry_t *dp;
3377     GV *gv = (GV*)POPs;
3378     register IO *io = GvIOn(gv);
3379     SV *sv;
3380
3381     if (!io || !IoDIRP(io))
3382         goto nope;
3383
3384     if (GIMME == G_ARRAY) {
3385         /*SUPPRESS 560*/
3386         while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
3387 #ifdef DIRNAMLEN
3388             sv = newSVpvn(dp->d_name, dp->d_namlen);
3389 #else
3390             sv = newSVpv(dp->d_name, 0);
3391 #endif
3392 #ifndef INCOMPLETE_TAINTS
3393             SvTAINTED_on(sv);
3394 #endif
3395             XPUSHs(sv_2mortal(sv));
3396         }
3397     }
3398     else {
3399         if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
3400             goto nope;
3401 #ifdef DIRNAMLEN
3402         sv = newSVpvn(dp->d_name, dp->d_namlen);
3403 #else
3404         sv = newSVpv(dp->d_name, 0);
3405 #endif
3406 #ifndef INCOMPLETE_TAINTS
3407         SvTAINTED_on(sv);
3408 #endif
3409         XPUSHs(sv_2mortal(sv));
3410     }
3411     RETURN;
3412
3413 nope:
3414     if (!errno)
3415         SETERRNO(EBADF,RMS$_ISI);
3416     if (GIMME == G_ARRAY)
3417         RETURN;
3418     else
3419         RETPUSHUNDEF;
3420 #else
3421     DIE(aTHX_ PL_no_dir_func, "readdir");
3422 #endif
3423 }
3424
3425 PP(pp_telldir)
3426 {
3427     djSP; dTARGET;
3428 #if defined(HAS_TELLDIR) || defined(telldir)
3429  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3430  /* XXX netbsd still seemed to.
3431     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3432     --JHI 1999-Feb-02 */
3433 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3434     long telldir (DIR *);
3435 # endif
3436     GV *gv = (GV*)POPs;
3437     register IO *io = GvIOn(gv);
3438
3439     if (!io || !IoDIRP(io))
3440         goto nope;
3441
3442     PUSHi( PerlDir_tell(IoDIRP(io)) );
3443     RETURN;
3444 nope:
3445     if (!errno)
3446         SETERRNO(EBADF,RMS$_ISI);
3447     RETPUSHUNDEF;
3448 #else
3449     DIE(aTHX_ PL_no_dir_func, "telldir");
3450 #endif
3451 }
3452
3453 PP(pp_seekdir)
3454 {
3455     djSP;
3456 #if defined(HAS_SEEKDIR) || defined(seekdir)
3457     long along = POPl;
3458     GV *gv = (GV*)POPs;
3459     register IO *io = GvIOn(gv);
3460
3461     if (!io || !IoDIRP(io))
3462         goto nope;
3463
3464     (void)PerlDir_seek(IoDIRP(io), along);
3465
3466     RETPUSHYES;
3467 nope:
3468     if (!errno)
3469         SETERRNO(EBADF,RMS$_ISI);
3470     RETPUSHUNDEF;
3471 #else
3472     DIE(aTHX_ PL_no_dir_func, "seekdir");
3473 #endif
3474 }
3475
3476 PP(pp_rewinddir)
3477 {
3478     djSP;
3479 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3480     GV *gv = (GV*)POPs;
3481     register IO *io = GvIOn(gv);
3482
3483     if (!io || !IoDIRP(io))
3484         goto nope;
3485
3486     (void)PerlDir_rewind(IoDIRP(io));
3487     RETPUSHYES;
3488 nope:
3489     if (!errno)
3490         SETERRNO(EBADF,RMS$_ISI);
3491     RETPUSHUNDEF;
3492 #else
3493     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3494 #endif
3495 }
3496
3497 PP(pp_closedir)
3498 {
3499     djSP;
3500 #if defined(Direntry_t) && defined(HAS_READDIR)
3501     GV *gv = (GV*)POPs;
3502     register IO *io = GvIOn(gv);
3503
3504     if (!io || !IoDIRP(io))
3505         goto nope;
3506
3507 #ifdef VOID_CLOSEDIR
3508     PerlDir_close(IoDIRP(io));
3509 #else
3510     if (PerlDir_close(IoDIRP(io)) < 0) {
3511         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3512         goto nope;
3513     }
3514 #endif
3515     IoDIRP(io) = 0;
3516
3517     RETPUSHYES;
3518 nope:
3519     if (!errno)
3520         SETERRNO(EBADF,RMS$_IFI);
3521     RETPUSHUNDEF;
3522 #else
3523     DIE(aTHX_ PL_no_dir_func, "closedir");
3524 #endif
3525 }
3526
3527 /* Process control. */
3528
3529 PP(pp_fork)
3530 {
3531 #ifdef HAS_FORK
3532     djSP; dTARGET;
3533     Pid_t childpid;
3534     GV *tmpgv;
3535
3536     EXTEND(SP, 1);
3537     PERL_FLUSHALL_FOR_CHILD;
3538     childpid = fork();
3539     if (childpid < 0)
3540         RETSETUNDEF;
3541     if (!childpid) {
3542         /*SUPPRESS 560*/
3543         if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
3544             sv_setiv(GvSV(tmpgv), (IV)getpid());
3545         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3546     }
3547     PUSHi(childpid);
3548     RETURN;
3549 #else
3550     DIE(aTHX_ PL_no_func, "Unsupported function fork");
3551 #endif
3552 }
3553
3554 PP(pp_wait)
3555 {
3556 #if !defined(DOSISH) || defined(OS2) || defined(WIN32)
3557     djSP; dTARGET;
3558     Pid_t childpid;
3559     int argflags;
3560
3561     childpid = wait4pid(-1, &argflags, 0);
3562     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3563     XPUSHi(childpid);
3564     RETURN;
3565 #else
3566     DIE(aTHX_ PL_no_func, "Unsupported function wait");
3567 #endif
3568 }
3569
3570 PP(pp_waitpid)
3571 {
3572 #if !defined(DOSISH) || defined(OS2) || defined(WIN32)
3573     djSP; dTARGET;
3574     Pid_t childpid;
3575     int optype;
3576     int argflags;
3577
3578     optype = POPi;
3579     childpid = TOPi;
3580     childpid = wait4pid(childpid, &argflags, optype);
3581     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3582     SETi(childpid);
3583     RETURN;
3584 #else
3585     DIE(aTHX_ PL_no_func, "Unsupported function waitpid");
3586 #endif
3587 }
3588
3589 PP(pp_system)
3590 {
3591     djSP; dMARK; dORIGMARK; dTARGET;
3592     I32 value;
3593     Pid_t childpid;
3594     int result;
3595     int status;
3596     Sigsave_t ihand,qhand;     /* place to save signals during system() */
3597     STRLEN n_a;
3598     I32 did_pipes = 0;
3599     int pp[2];
3600
3601     if (SP - MARK == 1) {
3602         if (PL_tainting) {
3603             char *junk = SvPV(TOPs, n_a);
3604             TAINT_ENV();
3605             TAINT_PROPER("system");
3606         }
3607     }
3608     PERL_FLUSHALL_FOR_CHILD;
3609 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
3610     if (PerlProc_pipe(pp) >= 0)
3611         did_pipes = 1;
3612     while ((childpid = vfork()) == -1) {
3613         if (errno != EAGAIN) {
3614             value = -1;
3615             SP = ORIGMARK;
3616             PUSHi(value);
3617             if (did_pipes) {
3618                 PerlLIO_close(pp[0]);
3619                 PerlLIO_close(pp[1]);
3620             }
3621             RETURN;
3622         }
3623         sleep(5);
3624     }
3625     if (childpid > 0) {
3626         if (did_pipes)
3627             PerlLIO_close(pp[1]);
3628         rsignal_save(SIGINT, SIG_IGN, &ihand);
3629         rsignal_save(SIGQUIT, SIG_IGN, &qhand);
3630         do {
3631             result = wait4pid(childpid, &status, 0);
3632         } while (result == -1 && errno == EINTR);
3633         (void)rsignal_restore(SIGINT, &ihand);
3634         (void)rsignal_restore(SIGQUIT, &qhand);
3635         STATUS_NATIVE_SET(result == -1 ? -1 : status);
3636         do_execfree();  /* free any memory child malloced on vfork */
3637         SP = ORIGMARK;
3638         if (did_pipes) {
3639             int errkid;
3640             int n = 0, n1;
3641
3642             while (n < sizeof(int)) {
3643                 n1 = PerlLIO_read(pp[0],
3644                                   (void*)(((char*)&errkid)+n),
3645                                   (sizeof(int)) - n);
3646                 if (n1 <= 0)
3647                     break;
3648                 n += n1;
3649             }
3650             PerlLIO_close(pp[0]);
3651             if (n) {                    /* Error */
3652                 if (n != sizeof(int))
3653                     DIE(aTHX_ "panic: kid popen errno read");
3654                 errno = errkid;         /* Propagate errno from kid */
3655                 STATUS_CURRENT = -1;
3656             }
3657         }
3658         PUSHi(STATUS_CURRENT);
3659         RETURN;
3660     }
3661     if (did_pipes) {
3662         PerlLIO_close(pp[0]);
3663 #if defined(HAS_FCNTL) && defined(F_SETFD)
3664         fcntl(pp[1], F_SETFD, FD_CLOEXEC);
3665 #endif
3666     }
3667     if (PL_op->op_flags & OPf_STACKED) {
3668         SV *really = *++MARK;
3669         value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
3670     }
3671     else if (SP - MARK != 1)
3672         value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
3673     else {
3674         value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
3675     }
3676     PerlProc__exit(-1);
3677 #else /* ! FORK or VMS or OS/2 */
3678     if (PL_op->op_flags & OPf_STACKED) {
3679         SV *really = *++MARK;
3680         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
3681     }
3682     else if (SP - MARK != 1)
3683         value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
3684     else {
3685         value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
3686     }
3687     STATUS_NATIVE_SET(value);
3688     do_execfree();
3689     SP = ORIGMARK;
3690     PUSHi(STATUS_CURRENT);
3691 #endif /* !FORK or VMS */
3692     RETURN;
3693 }
3694
3695 PP(pp_exec)
3696 {
3697     djSP; dMARK; dORIGMARK; dTARGET;
3698     I32 value;
3699     STRLEN n_a;
3700
3701     PERL_FLUSHALL_FOR_CHILD;
3702     if (PL_op->op_flags & OPf_STACKED) {
3703         SV *really = *++MARK;
3704         value = (I32)do_aexec(really, MARK, SP);
3705     }
3706     else if (SP - MARK != 1)
3707 #ifdef VMS
3708         value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3709 #else
3710 #  ifdef __OPEN_VM
3711         {
3712            (void ) do_aspawn(Nullsv, MARK, SP);
3713            value = 0;
3714         }
3715 #  else
3716         value = (I32)do_aexec(Nullsv, MARK, SP);
3717 #  endif
3718 #endif
3719     else {
3720         if (PL_tainting) {
3721             char *junk = SvPV(*SP, n_a);
3722             TAINT_ENV();
3723             TAINT_PROPER("exec");
3724         }
3725 #ifdef VMS
3726         value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
3727 #else
3728 #  ifdef __OPEN_VM
3729         (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
3730         value = 0;
3731 #  else
3732         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
3733 #  endif
3734 #endif
3735     }
3736     SP = ORIGMARK;
3737     PUSHi(value);
3738     RETURN;
3739 }
3740
3741 PP(pp_kill)
3742 {
3743     djSP; dMARK; dTARGET;
3744     I32 value;
3745 #ifdef HAS_KILL
3746     value = (I32)apply(PL_op->op_type, MARK, SP);
3747     SP = MARK;
3748     PUSHi(value);
3749     RETURN;
3750 #else
3751     DIE(aTHX_ PL_no_func, "Unsupported function kill");
3752 #endif
3753 }
3754
3755 PP(pp_getppid)
3756 {
3757 #ifdef HAS_GETPPID
3758     djSP; dTARGET;
3759     XPUSHi( getppid() );
3760     RETURN;
3761 #else
3762     DIE(aTHX_ PL_no_func, "getppid");
3763 #endif
3764 }
3765
3766 PP(pp_getpgrp)
3767 {
3768 #ifdef HAS_GETPGRP
3769     djSP; dTARGET;
3770     Pid_t pid;
3771     Pid_t pgrp;
3772
3773     if (MAXARG < 1)
3774         pid = 0;
3775     else
3776         pid = SvIVx(POPs);
3777 #ifdef BSD_GETPGRP
3778     pgrp = (I32)BSD_GETPGRP(pid);
3779 #else
3780     if (pid != 0 && pid != getpid())
3781         DIE(aTHX_ "POSIX getpgrp can't take an argument");
3782     pgrp = getpgrp();
3783 #endif
3784     XPUSHi(pgrp);
3785     RETURN;
3786 #else
3787     DIE(aTHX_ PL_no_func, "getpgrp()");
3788 #endif
3789 }
3790
3791 PP(pp_setpgrp)
3792 {
3793 #ifdef HAS_SETPGRP
3794     djSP; dTARGET;
3795     Pid_t pgrp;
3796     Pid_t pid;
3797     if (MAXARG < 2) {
3798         pgrp = 0;
3799         pid = 0;
3800     }
3801     else {
3802         pgrp = POPi;
3803         pid = TOPi;
3804     }
3805
3806     TAINT_PROPER("setpgrp");
3807 #ifdef BSD_SETPGRP
3808     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
3809 #else
3810     if ((pgrp != 0 && pgrp != getpid()) || (pid != 0 && pid != getpid()))
3811         DIE(aTHX_ "POSIX setpgrp can't take an argument");
3812     SETi( setpgrp() >= 0 );
3813 #endif /* USE_BSDPGRP */
3814     RETURN;
3815 #else
3816     DIE(aTHX_ PL_no_func, "setpgrp()");
3817 #endif
3818 }
3819
3820 PP(pp_getpriority)
3821 {
3822     djSP; dTARGET;
3823     int which;
3824     int who;
3825 #ifdef HAS_GETPRIORITY
3826     who = POPi;
3827     which = TOPi;
3828     SETi( getpriority(which, who) );
3829     RETURN;
3830 #else
3831     DIE(aTHX_ PL_no_func, "getpriority()");
3832 #endif
3833 }
3834
3835 PP(pp_setpriority)
3836 {
3837     djSP; dTARGET;
3838     int which;
3839     int who;
3840     int niceval;
3841 #ifdef HAS_SETPRIORITY
3842     niceval = POPi;
3843     who = POPi;
3844     which = TOPi;
3845     TAINT_PROPER("setpriority");
3846     SETi( setpriority(which, who, niceval) >= 0 );
3847     RETURN;
3848 #else
3849     DIE(aTHX_ PL_no_func, "setpriority()");
3850 #endif
3851 }
3852
3853 /* Time calls. */
3854
3855 PP(pp_time)
3856 {
3857     djSP; dTARGET;
3858 #ifdef BIG_TIME
3859     XPUSHn( time(Null(Time_t*)) );
3860 #else
3861     XPUSHi( time(Null(Time_t*)) );
3862 #endif
3863     RETURN;
3864 }
3865
3866 /* XXX The POSIX name is CLK_TCK; it is to be preferred
3867    to HZ.  Probably.  For now, assume that if the system
3868    defines HZ, it does so correctly.  (Will this break
3869    on VMS?)
3870    Probably we ought to use _sysconf(_SC_CLK_TCK), if
3871    it's supported.    --AD  9/96.
3872 */
3873
3874 #ifndef HZ
3875 #  ifdef CLK_TCK
3876 #    define HZ CLK_TCK
3877 #  else
3878 #    define HZ 60
3879 #  endif
3880 #endif
3881
3882 PP(pp_tms)
3883 {
3884     djSP;
3885
3886 #ifndef HAS_TIMES
3887     DIE(aTHX_ "times not implemented");
3888 #else
3889     EXTEND(SP, 4);
3890
3891 #ifndef VMS
3892     (void)PerlProc_times(&PL_timesbuf);
3893 #else
3894     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
3895                                                    /* struct tms, though same data   */
3896                                                    /* is returned.                   */
3897 #endif
3898
3899     PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
3900     if (GIMME == G_ARRAY) {
3901         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
3902         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
3903         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
3904     }
3905     RETURN;
3906 #endif /* HAS_TIMES */
3907 }
3908
3909 PP(pp_localtime)
3910 {
3911     return pp_gmtime();
3912 }
3913
3914 PP(pp_gmtime)
3915 {
3916     djSP;
3917     Time_t when;
3918     struct tm *tmbuf;
3919     static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
3920     static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
3921                               "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
3922
3923     if (MAXARG < 1)
3924         (void)time(&when);
3925     else
3926 #ifdef BIG_TIME
3927         when = (Time_t)SvNVx(POPs);
3928 #else
3929         when = (Time_t)SvIVx(POPs);
3930 #endif
3931
3932     if (PL_op->op_type == OP_LOCALTIME)
3933         tmbuf = localtime(&when);
3934     else
3935         tmbuf = gmtime(&when);
3936
3937     EXTEND(SP, 9);
3938     EXTEND_MORTAL(9);
3939     if (GIMME != G_ARRAY) {
3940         dTARGET;
3941         SV *tsv;
3942         if (!tmbuf)
3943             RETPUSHUNDEF;
3944         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
3945                             dayname[tmbuf->tm_wday],
3946                             monname[tmbuf->tm_mon],
3947                             tmbuf->tm_mday,
3948                             tmbuf->tm_hour,
3949                             tmbuf->tm_min,
3950                             tmbuf->tm_sec,
3951                             tmbuf->tm_year + 1900);
3952         PUSHs(sv_2mortal(tsv));
3953     }
3954     else if (tmbuf) {
3955         PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
3956         PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
3957         PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
3958         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
3959         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
3960         PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
3961         PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
3962         PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
3963         PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
3964     }
3965     RETURN;
3966 }
3967
3968 PP(pp_alarm)
3969 {
3970     djSP; dTARGET;
3971     int anum;
3972 #ifdef HAS_ALARM
3973     anum = POPi;
3974     anum = alarm((unsigned int)anum);
3975     EXTEND(SP, 1);
3976     if (anum < 0)
3977         RETPUSHUNDEF;
3978     PUSHi(anum);
3979     RETURN;
3980 #else
3981     DIE(aTHX_ PL_no_func, "Unsupported function alarm");
3982 #endif
3983 }
3984
3985 PP(pp_sleep)
3986 {
3987     djSP; dTARGET;
3988     I32 duration;
3989     Time_t lasttime;
3990     Time_t when;
3991
3992     (void)time(&lasttime);
3993     if (MAXARG < 1)
3994         PerlProc_pause();
3995     else {
3996         duration = POPi;
3997         PerlProc_sleep((unsigned int)duration);
3998     }
3999     (void)time(&when);
4000     XPUSHi(when - lasttime);
4001     RETURN;
4002 }
4003
4004 /* Shared memory. */
4005
4006 PP(pp_shmget)
4007 {
4008     return pp_semget();
4009 }
4010
4011 PP(pp_shmctl)
4012 {
4013     return pp_semctl();
4014 }
4015
4016 PP(pp_shmread)
4017 {
4018     return pp_shmwrite();
4019 }
4020
4021 PP(pp_shmwrite)
4022 {
4023 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4024     djSP; dMARK; dTARGET;
4025     I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
4026     SP = MARK;
4027     PUSHi(value);
4028     RETURN;
4029 #else
4030     return pp_semget();
4031 #endif
4032 }
4033
4034 /* Message passing. */
4035
4036 PP(pp_msgget)
4037 {
4038     return pp_semget();
4039 }
4040
4041 PP(pp_msgctl)
4042 {
4043     return pp_semctl();
4044 }
4045
4046 PP(pp_msgsnd)
4047 {
4048 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4049     djSP; dMARK; dTARGET;
4050     I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4051     SP = MARK;
4052     PUSHi(value);
4053     RETURN;
4054 #else
4055     return pp_semget();
4056 #endif
4057 }
4058
4059 PP(pp_msgrcv)
4060 {
4061 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4062     djSP; dMARK; dTARGET;
4063     I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4064     SP = MARK;
4065     PUSHi(value);
4066     RETURN;
4067 #else
4068     return pp_semget();
4069 #endif
4070 }
4071
4072 /* Semaphores. */
4073
4074 PP(pp_semget)
4075 {
4076 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4077     djSP; dMARK; dTARGET;
4078     int anum = do_ipcget(PL_op->op_type, MARK, SP);
4079     SP = MARK;
4080     if (anum == -1)
4081         RETPUSHUNDEF;
4082     PUSHi(anum);
4083     RETURN;
4084 #else
4085     DIE(aTHX_ "System V IPC is not implemented on this machine");
4086 #endif
4087 }
4088
4089 PP(pp_semctl)
4090 {
4091 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4092     djSP; dMARK; dTARGET;
4093     int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4094     SP = MARK;
4095     if (anum == -1)
4096         RETSETUNDEF;
4097     if (anum != 0) {
4098         PUSHi(anum);
4099     }
4100     else {
4101         PUSHp(zero_but_true, ZBTLEN);
4102     }
4103     RETURN;
4104 #else
4105     return pp_semget();
4106 #endif
4107 }
4108
4109 PP(pp_semop)
4110 {
4111 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4112     djSP; dMARK; dTARGET;
4113     I32 value = (I32)(do_semop(MARK, SP) >= 0);
4114     SP = MARK;
4115     PUSHi(value);
4116     RETURN;
4117 #else
4118     return pp_semget();
4119 #endif
4120 }
4121
4122 /* Get system info. */
4123
4124 PP(pp_ghbyname)
4125 {
4126 #ifdef HAS_GETHOSTBYNAME
4127     return pp_ghostent();
4128 #else
4129     DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4130 #endif
4131 }
4132
4133 PP(pp_ghbyaddr)
4134 {
4135 #ifdef HAS_GETHOSTBYADDR
4136     return pp_ghostent();
4137 #else
4138     DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4139 #endif
4140 }
4141
4142 PP(pp_ghostent)
4143 {
4144     djSP;
4145 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4146     I32 which = PL_op->op_type;
4147     register char **elem;
4148     register SV *sv;
4149 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4150     struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4151     struct hostent *PerlSock_gethostbyname(Netdb_name_t);
4152     struct hostent *PerlSock_gethostent(void);
4153 #endif
4154     struct hostent *hent;
4155     unsigned long len;
4156     STRLEN n_a;
4157
4158     EXTEND(SP, 10);
4159     if (which == OP_GHBYNAME)
4160 #ifdef HAS_GETHOSTBYNAME
4161         hent = PerlSock_gethostbyname(POPpx);
4162 #else
4163         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4164 #endif
4165     else if (which == OP_GHBYADDR) {
4166 #ifdef HAS_GETHOSTBYADDR
4167         int addrtype = POPi;
4168         SV *addrsv = POPs;
4169         STRLEN addrlen;
4170         Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen);
4171
4172         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4173 #else
4174         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4175 #endif
4176     }
4177     else
4178 #ifdef HAS_GETHOSTENT
4179         hent = PerlSock_gethostent();
4180 #else
4181         DIE(aTHX_ PL_no_sock_func, "gethostent");
4182 #endif
4183
4184 #ifdef HOST_NOT_FOUND
4185     if (!hent)
4186         STATUS_NATIVE_SET(h_errno);
4187 #endif
4188
4189     if (GIMME != G_ARRAY) {
4190         PUSHs(sv = sv_newmortal());
4191         if (hent) {
4192             if (which == OP_GHBYNAME) {
4193                 if (hent->h_addr)
4194                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4195             }
4196             else
4197                 sv_setpv(sv, (char*)hent->h_name);
4198         }
4199         RETURN;
4200     }
4201
4202     if (hent) {
4203         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4204         sv_setpv(sv, (char*)hent->h_name);
4205         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4206         for (elem = hent->h_aliases; elem && *elem; elem++) {
4207             sv_catpv(sv, *elem);
4208             if (elem[1])
4209                 sv_catpvn(sv, " ", 1);
4210         }
4211         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4212         sv_setiv(sv, (IV)hent->h_addrtype);
4213         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4214         len = hent->h_length;
4215         sv_setiv(sv, (IV)len);
4216 #ifdef h_addr
4217         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4218             XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
4219             sv_setpvn(sv, *elem, len);
4220         }
4221 #else
4222         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4223         if (hent->h_addr)
4224             sv_setpvn(sv, hent->h_addr, len);
4225 #endif /* h_addr */
4226     }
4227     RETURN;
4228 #else
4229     DIE(aTHX_ PL_no_sock_func, "gethostent");
4230 #endif
4231 }
4232
4233 PP(pp_gnbyname)
4234 {
4235 #ifdef HAS_GETNETBYNAME
4236     return pp_gnetent();
4237 #else
4238     DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4239 #endif
4240 }
4241
4242 PP(pp_gnbyaddr)
4243 {
4244 #ifdef HAS_GETNETBYADDR
4245     return pp_gnetent();
4246 #else
4247     DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4248 #endif
4249 }
4250
4251 PP(pp_gnetent)
4252 {
4253     djSP;
4254 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4255     I32 which = PL_op->op_type;
4256     register char **elem;
4257     register SV *sv;
4258 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4259     struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4260     struct netent *PerlSock_getnetbyname(Netdb_name_t);
4261     struct netent *PerlSock_getnetent(void);
4262 #endif
4263     struct netent *nent;
4264     STRLEN n_a;
4265
4266     if (which == OP_GNBYNAME)
4267 #ifdef HAS_GETNETBYNAME
4268         nent = PerlSock_getnetbyname(POPpx);
4269 #else
4270         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4271 #endif
4272     else if (which == OP_GNBYADDR) {
4273 #ifdef HAS_GETNETBYADDR
4274         int addrtype = POPi;
4275         Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
4276         nent = PerlSock_getnetbyaddr(addr, addrtype);
4277 #else
4278         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4279 #endif
4280     }
4281     else
4282 #ifdef HAS_GETNETENT
4283         nent = PerlSock_getnetent();
4284 #else
4285         DIE(aTHX_ PL_no_sock_func, "getnetent");
4286 #endif
4287
4288     EXTEND(SP, 4);
4289     if (GIMME != G_ARRAY) {
4290         PUSHs(sv = sv_newmortal());
4291         if (nent) {
4292             if (which == OP_GNBYNAME)
4293                 sv_setiv(sv, (IV)nent->n_net);
4294             else
4295                 sv_setpv(sv, nent->n_name);
4296         }
4297         RETURN;
4298     }
4299
4300     if (nent) {
4301         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4302         sv_setpv(sv, nent->n_name);
4303         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4304         for (elem = nent->n_aliases; elem && *elem; elem++) {
4305             sv_catpv(sv, *elem);
4306             if (elem[1])
4307                 sv_catpvn(sv, " ", 1);
4308         }
4309         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4310         sv_setiv(sv, (IV)nent->n_addrtype);
4311         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4312         sv_setiv(sv, (IV)nent->n_net);
4313     }
4314
4315     RETURN;
4316 #else
4317     DIE(aTHX_ PL_no_sock_func, "getnetent");
4318 #endif
4319 }
4320
4321 PP(pp_gpbyname)
4322 {
4323 #ifdef HAS_GETPROTOBYNAME
4324     return pp_gprotoent();
4325 #else
4326     DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4327 #endif
4328 }
4329
4330 PP(pp_gpbynumber)
4331 {
4332 #ifdef HAS_GETPROTOBYNUMBER
4333     return pp_gprotoent();
4334 #else
4335     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4336 #endif
4337 }
4338
4339 PP(pp_gprotoent)
4340 {
4341     djSP;
4342 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4343     I32 which = PL_op->op_type;
4344     register char **elem;
4345     register SV *sv;
4346 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4347     struct protoent *PerlSock_getprotobyname(Netdb_name_t);
4348     struct protoent *PerlSock_getprotobynumber(int);
4349     struct protoent *PerlSock_getprotoent(void);
4350 #endif
4351     struct protoent *pent;
4352     STRLEN n_a;
4353
4354     if (which == OP_GPBYNAME)
4355 #ifdef HAS_GETPROTOBYNAME
4356         pent = PerlSock_getprotobyname(POPpx);
4357 #else
4358         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4359 #endif
4360     else if (which == OP_GPBYNUMBER)
4361 #ifdef HAS_GETPROTOBYNUMBER
4362         pent = PerlSock_getprotobynumber(POPi);
4363 #else
4364     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4365 #endif
4366     else
4367 #ifdef HAS_GETPROTOENT
4368         pent = PerlSock_getprotoent();
4369 #else
4370         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4371 #endif
4372
4373     EXTEND(SP, 3);
4374     if (GIMME != G_ARRAY) {
4375         PUSHs(sv = sv_newmortal());
4376         if (pent) {
4377             if (which == OP_GPBYNAME)
4378                 sv_setiv(sv, (IV)pent->p_proto);
4379             else
4380                 sv_setpv(sv, pent->p_name);
4381         }
4382         RETURN;
4383     }
4384
4385     if (pent) {
4386         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4387         sv_setpv(sv, pent->p_name);
4388         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4389         for (elem = pent->p_aliases; elem && *elem; elem++) {
4390             sv_catpv(sv, *elem);
4391             if (elem[1])
4392                 sv_catpvn(sv, " ", 1);
4393         }
4394         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4395         sv_setiv(sv, (IV)pent->p_proto);
4396     }
4397
4398     RETURN;
4399 #else
4400     DIE(aTHX_ PL_no_sock_func, "getprotoent");
4401 #endif
4402 }
4403
4404 PP(pp_gsbyname)
4405 {
4406 #ifdef HAS_GETSERVBYNAME
4407     return pp_gservent();
4408 #else
4409     DIE(aTHX_ PL_no_sock_func, "getservbyname");
4410 #endif
4411 }
4412
4413 PP(pp_gsbyport)
4414 {
4415 #ifdef HAS_GETSERVBYPORT
4416     return pp_gservent();
4417 #else
4418     DIE(aTHX_ PL_no_sock_func, "getservbyport");
4419 #endif
4420 }
4421
4422 PP(pp_gservent)
4423 {
4424     djSP;
4425 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4426     I32 which = PL_op->op_type;
4427     register char **elem;
4428     register SV *sv;
4429 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4430     struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4431     struct servent *PerlSock_getservbyport(int, Netdb_name_t);
4432     struct servent *PerlSock_getservent(void);
4433 #endif
4434     struct servent *sent;
4435     STRLEN n_a;
4436
4437     if (which == OP_GSBYNAME) {
4438 #ifdef HAS_GETSERVBYNAME
4439         char *proto = POPpx;
4440         char *name = POPpx;
4441
4442         if (proto && !*proto)
4443             proto = Nullch;
4444
4445         sent = PerlSock_getservbyname(name, proto);
4446 #else
4447         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4448 #endif
4449     }
4450     else if (which == OP_GSBYPORT) {
4451 #ifdef HAS_GETSERVBYPORT
4452         char *proto = POPpx;
4453         unsigned short port = POPu;
4454
4455 #ifdef HAS_HTONS
4456         port = PerlSock_htons(port);
4457 #endif
4458         sent = PerlSock_getservbyport(port, proto);
4459 #else
4460         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4461 #endif
4462     }
4463     else
4464 #ifdef HAS_GETSERVENT
4465         sent = PerlSock_getservent();
4466 #else
4467         DIE(aTHX_ PL_no_sock_func, "getservent");
4468 #endif
4469
4470     EXTEND(SP, 4);
4471     if (GIMME != G_ARRAY) {
4472         PUSHs(sv = sv_newmortal());
4473         if (sent) {
4474             if (which == OP_GSBYNAME) {
4475 #ifdef HAS_NTOHS
4476                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4477 #else
4478                 sv_setiv(sv, (IV)(sent->s_port));
4479 #endif
4480             }
4481             else
4482                 sv_setpv(sv, sent->s_name);
4483         }
4484         RETURN;
4485     }
4486
4487     if (sent) {
4488         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4489         sv_setpv(sv, sent->s_name);
4490         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4491         for (elem = sent->s_aliases; elem && *elem; elem++) {
4492             sv_catpv(sv, *elem);
4493             if (elem[1])
4494                 sv_catpvn(sv, " ", 1);
4495         }
4496         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4497 #ifdef HAS_NTOHS
4498         sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4499 #else
4500         sv_setiv(sv, (IV)(sent->s_port));
4501 #endif
4502         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4503         sv_setpv(sv, sent->s_proto);
4504     }
4505
4506     RETURN;
4507 #else
4508     DIE(aTHX_ PL_no_sock_func, "getservent");
4509 #endif
4510 }
4511
4512 PP(pp_shostent)
4513 {
4514     djSP;
4515 #ifdef HAS_SETHOSTENT
4516     PerlSock_sethostent(TOPi);
4517     RETSETYES;
4518 #else
4519     DIE(aTHX_ PL_no_sock_func, "sethostent");
4520 #endif
4521 }
4522
4523 PP(pp_snetent)
4524 {
4525     djSP;
4526 #ifdef HAS_SETNETENT
4527     PerlSock_setnetent(TOPi);
4528     RETSETYES;
4529 #else
4530     DIE(aTHX_ PL_no_sock_func, "setnetent");
4531 #endif
4532 }
4533
4534 PP(pp_sprotoent)
4535 {
4536     djSP;
4537 #ifdef HAS_SETPROTOENT
4538     PerlSock_setprotoent(TOPi);
4539     RETSETYES;
4540 #else
4541     DIE(aTHX_ PL_no_sock_func, "setprotoent");
4542 #endif
4543 }
4544
4545 PP(pp_sservent)
4546 {
4547     djSP;
4548 #ifdef HAS_SETSERVENT
4549     PerlSock_setservent(TOPi);
4550     RETSETYES;
4551 #else
4552     DIE(aTHX_ PL_no_sock_func, "setservent");
4553 #endif
4554 }
4555
4556 PP(pp_ehostent)
4557 {
4558     djSP;
4559 #ifdef HAS_ENDHOSTENT
4560     PerlSock_endhostent();
4561     EXTEND(SP,1);
4562     RETPUSHYES;
4563 #else
4564     DIE(aTHX_ PL_no_sock_func, "endhostent");
4565 #endif
4566 }
4567
4568 PP(pp_enetent)
4569 {
4570     djSP;
4571 #ifdef HAS_ENDNETENT
4572     PerlSock_endnetent();
4573     EXTEND(SP,1);
4574     RETPUSHYES;
4575 #else
4576     DIE(aTHX_ PL_no_sock_func, "endnetent");
4577 #endif
4578 }
4579
4580 PP(pp_eprotoent)
4581 {
4582     djSP;
4583 #ifdef HAS_ENDPROTOENT
4584     PerlSock_endprotoent();
4585     EXTEND(SP,1);
4586     RETPUSHYES;
4587 #else
4588     DIE(aTHX_ PL_no_sock_func, "endprotoent");
4589 #endif
4590 }
4591
4592 PP(pp_eservent)
4593 {
4594     djSP;
4595 #ifdef HAS_ENDSERVENT
4596     PerlSock_endservent();
4597     EXTEND(SP,1);
4598     RETPUSHYES;
4599 #else
4600     DIE(aTHX_ PL_no_sock_func, "endservent");
4601 #endif
4602 }
4603
4604 PP(pp_gpwnam)
4605 {
4606 #ifdef HAS_PASSWD
4607     return pp_gpwent();
4608 #else
4609     DIE(aTHX_ PL_no_func, "getpwnam");
4610 #endif
4611 }
4612
4613 PP(pp_gpwuid)
4614 {
4615 #ifdef HAS_PASSWD
4616     return pp_gpwent();
4617 #else
4618     DIE(aTHX_ PL_no_func, "getpwuid");
4619 #endif
4620 }
4621
4622 PP(pp_gpwent)
4623 {
4624     djSP;
4625 #if defined(HAS_PASSWD) && defined(HAS_GETPWENT)
4626     I32 which = PL_op->op_type;
4627     register SV *sv;
4628     struct passwd *pwent;
4629     STRLEN n_a;
4630 #if defined(HAS_GETSPENT) || defined(HAS_GETSPNAM)
4631     struct spwd *spwent = NULL;
4632 #endif
4633
4634     if (which == OP_GPWNAM)
4635         pwent = getpwnam(POPpx);
4636     else if (which == OP_GPWUID)
4637         pwent = getpwuid(POPi);
4638     else
4639         pwent = (struct passwd *)getpwent();
4640
4641 #ifdef HAS_GETSPNAM
4642     if (which == OP_GPWNAM) {
4643         if (pwent)
4644             spwent = getspnam(pwent->pw_name);
4645     }
4646 #  ifdef HAS_GETSPUID /* AFAIK there isn't any anywhere. --jhi */
4647     else if (which == OP_GPWUID) {
4648         if (pwent)
4649             spwent = getspnam(pwent->pw_name);
4650     }
4651 #  endif
4652 #  ifdef HAS_GETSPENT
4653     else
4654         spwent = (struct spwd *)getspent();
4655 #  endif
4656 #endif
4657
4658     EXTEND(SP, 10);
4659     if (GIMME != G_ARRAY) {
4660         PUSHs(sv = sv_newmortal());
4661         if (pwent) {
4662             if (which == OP_GPWNAM)
4663                 sv_setiv(sv, (IV)pwent->pw_uid);
4664             else
4665                 sv_setpv(sv, pwent->pw_name);
4666         }
4667         RETURN;
4668     }
4669
4670     if (pwent) {
4671         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4672         sv_setpv(sv, pwent->pw_name);
4673
4674         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4675 #ifdef PWPASSWD
4676 #   if defined(HAS_GETSPENT) || defined(HAS_GETSPNAM)
4677       if (spwent)
4678               sv_setpv(sv, spwent->sp_pwdp);
4679       else
4680               sv_setpv(sv, pwent->pw_passwd);
4681 #   else
4682         sv_setpv(sv, pwent->pw_passwd);
4683 #   endif
4684 #endif
4685
4686         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4687         sv_setiv(sv, (IV)pwent->pw_uid);
4688
4689         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4690         sv_setiv(sv, (IV)pwent->pw_gid);
4691
4692         /* pw_change, pw_quota, and pw_age are mutually exclusive. */
4693         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4694 #ifdef PWCHANGE
4695         sv_setiv(sv, (IV)pwent->pw_change);
4696 #else
4697 #   ifdef PWQUOTA
4698         sv_setiv(sv, (IV)pwent->pw_quota);
4699 #   else
4700 #       ifdef PWAGE
4701         sv_setpv(sv, pwent->pw_age);
4702 #       endif
4703 #   endif
4704 #endif
4705
4706         /* pw_class and pw_comment are mutually exclusive. */
4707         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4708 #ifdef PWCLASS
4709         sv_setpv(sv, pwent->pw_class);
4710 #else
4711 #   ifdef PWCOMMENT
4712         sv_setpv(sv, pwent->pw_comment);
4713 #   endif
4714 #endif
4715
4716         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4717 #ifdef PWGECOS
4718         sv_setpv(sv, pwent->pw_gecos);
4719 #endif
4720 #ifndef INCOMPLETE_TAINTS
4721         /* pw_gecos is tainted because user himself can diddle with it. */
4722         SvTAINTED_on(sv);
4723 #endif
4724
4725         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4726         sv_setpv(sv, pwent->pw_dir);
4727
4728         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4729         sv_setpv(sv, pwent->pw_shell);
4730
4731 #ifdef PWEXPIRE
4732         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4733         sv_setiv(sv, (IV)pwent->pw_expire);
4734 #endif
4735     }
4736     RETURN;
4737 #else
4738     DIE(aTHX_ PL_no_func, "getpwent");
4739 #endif
4740 }
4741
4742 PP(pp_spwent)
4743 {
4744     djSP;
4745 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
4746     setpwent();
4747 #   ifdef HAS_SETSPENT
4748     setspent();
4749 #   endif
4750     RETPUSHYES;
4751 #else
4752     DIE(aTHX_ PL_no_func, "setpwent");
4753 #endif
4754 }
4755
4756 PP(pp_epwent)
4757 {
4758     djSP;
4759 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
4760     endpwent();
4761 #   ifdef HAS_ENDSPENT
4762     endspent();
4763 #   endif
4764     RETPUSHYES;
4765 #else
4766     DIE(aTHX_ PL_no_func, "endpwent");
4767 #endif
4768 }
4769
4770 PP(pp_ggrnam)
4771 {
4772 #ifdef HAS_GROUP
4773     return pp_ggrent();
4774 #else
4775     DIE(aTHX_ PL_no_func, "getgrnam");
4776 #endif
4777 }
4778
4779 PP(pp_ggrgid)
4780 {
4781 #ifdef HAS_GROUP
4782     return pp_ggrent();
4783 #else
4784     DIE(aTHX_ PL_no_func, "getgrgid");
4785 #endif
4786 }
4787
4788 PP(pp_ggrent)
4789 {
4790     djSP;
4791 #if defined(HAS_GROUP) && defined(HAS_GETGRENT)
4792     I32 which = PL_op->op_type;
4793     register char **elem;
4794     register SV *sv;
4795     struct group *grent;
4796     STRLEN n_a;
4797
4798     if (which == OP_GGRNAM)
4799         grent = (struct group *)getgrnam(POPpx);
4800     else if (which == OP_GGRGID)
4801         grent = (struct group *)getgrgid(POPi);
4802     else
4803         grent = (struct group *)getgrent();
4804
4805     EXTEND(SP, 4);
4806     if (GIMME != G_ARRAY) {
4807         PUSHs(sv = sv_newmortal());
4808         if (grent) {
4809             if (which == OP_GGRNAM)
4810                 sv_setiv(sv, (IV)grent->gr_gid);
4811             else
4812                 sv_setpv(sv, grent->gr_name);
4813         }
4814         RETURN;
4815     }
4816
4817     if (grent) {
4818         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4819         sv_setpv(sv, grent->gr_name);
4820
4821         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4822 #ifdef GRPASSWD
4823         sv_setpv(sv, grent->gr_passwd);
4824 #endif
4825
4826         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4827         sv_setiv(sv, (IV)grent->gr_gid);
4828
4829         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4830         for (elem = grent->gr_mem; elem && *elem; elem++) {
4831             sv_catpv(sv, *elem);
4832             if (elem[1])
4833                 sv_catpvn(sv, " ", 1);
4834         }
4835     }
4836
4837     RETURN;
4838 #else
4839     DIE(aTHX_ PL_no_func, "getgrent");
4840 #endif
4841 }
4842
4843 PP(pp_sgrent)
4844 {
4845     djSP;
4846 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
4847     setgrent();
4848     RETPUSHYES;
4849 #else
4850     DIE(aTHX_ PL_no_func, "setgrent");
4851 #endif
4852 }
4853
4854 PP(pp_egrent)
4855 {
4856     djSP;
4857 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
4858     endgrent();
4859     RETPUSHYES;
4860 #else
4861     DIE(aTHX_ PL_no_func, "endgrent");
4862 #endif
4863 }
4864
4865 PP(pp_getlogin)
4866 {
4867     djSP; dTARGET;
4868 #ifdef HAS_GETLOGIN
4869     char *tmps;
4870     EXTEND(SP, 1);
4871     if (!(tmps = PerlProc_getlogin()))
4872         RETPUSHUNDEF;
4873     PUSHp(tmps, strlen(tmps));
4874     RETURN;
4875 #else
4876     DIE(aTHX_ PL_no_func, "getlogin");
4877 #endif
4878 }
4879
4880 /* Miscellaneous. */
4881
4882 PP(pp_syscall)
4883 {
4884 #ifdef HAS_SYSCALL
4885     djSP; dMARK; dORIGMARK; dTARGET;
4886     register I32 items = SP - MARK;
4887     unsigned long a[20];
4888     register I32 i = 0;
4889     I32 retval = -1;
4890     MAGIC *mg;
4891     STRLEN n_a;
4892
4893     if (PL_tainting) {
4894         while (++MARK <= SP) {
4895             if (SvTAINTED(*MARK)) {
4896                 TAINT;
4897                 break;
4898             }
4899         }
4900         MARK = ORIGMARK;
4901         TAINT_PROPER("syscall");
4902     }
4903
4904     /* This probably won't work on machines where sizeof(long) != sizeof(int)
4905      * or where sizeof(long) != sizeof(char*).  But such machines will
4906      * not likely have syscall implemented either, so who cares?
4907      */
4908     while (++MARK <= SP) {
4909         if (SvNIOK(*MARK) || !i)
4910             a[i++] = SvIV(*MARK);
4911         else if (*MARK == &PL_sv_undef)
4912             a[i++] = 0;
4913         else
4914             a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
4915         if (i > 15)
4916             break;
4917     }
4918     switch (items) {
4919     default:
4920         DIE(aTHX_ "Too many args to syscall");
4921     case 0:
4922         DIE(aTHX_ "Too few args to syscall");
4923     case 1:
4924         retval = syscall(a[0]);
4925         break;
4926     case 2:
4927         retval = syscall(a[0],a[1]);
4928         break;
4929     case 3:
4930         retval = syscall(a[0],a[1],a[2]);
4931         break;
4932     case 4:
4933         retval = syscall(a[0],a[1],a[2],a[3]);
4934         break;
4935     case 5:
4936         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
4937         break;
4938     case 6:
4939         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
4940         break;
4941     case 7:
4942         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
4943         break;
4944     case 8:
4945         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
4946         break;
4947 #ifdef atarist
4948     case 9:
4949         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
4950         break;
4951     case 10:
4952         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
4953         break;
4954     case 11:
4955         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4956           a[10]);
4957         break;
4958     case 12:
4959         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4960           a[10],a[11]);
4961         break;
4962     case 13:
4963         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4964           a[10],a[11],a[12]);
4965         break;
4966     case 14:
4967         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4968           a[10],a[11],a[12],a[13]);
4969         break;
4970 #endif /* atarist */
4971     }
4972     SP = ORIGMARK;
4973     PUSHi(retval);
4974     RETURN;
4975 #else
4976     DIE(aTHX_ PL_no_func, "syscall");
4977 #endif
4978 }
4979
4980 #ifdef FCNTL_EMULATE_FLOCK
4981
4982 /*  XXX Emulate flock() with fcntl().
4983     What's really needed is a good file locking module.
4984 */
4985
4986 static int
4987 fcntl_emulate_flock(int fd, int operation)
4988 {
4989     struct flock flock;
4990
4991     switch (operation & ~LOCK_NB) {
4992     case LOCK_SH:
4993         flock.l_type = F_RDLCK;
4994         break;
4995     case LOCK_EX:
4996         flock.l_type = F_WRLCK;
4997         break;
4998     case LOCK_UN:
4999         flock.l_type = F_UNLCK;
5000         break;
5001     default:
5002         errno = EINVAL;
5003         return -1;
5004     }
5005     flock.l_whence = SEEK_SET;
5006     flock.l_start = flock.l_len = (Off_t)0;
5007
5008     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5009 }
5010
5011 #endif /* FCNTL_EMULATE_FLOCK */
5012
5013 #ifdef LOCKF_EMULATE_FLOCK
5014
5015 /*  XXX Emulate flock() with lockf().  This is just to increase
5016     portability of scripts.  The calls are not completely
5017     interchangeable.  What's really needed is a good file
5018     locking module.
5019 */
5020
5021 /*  The lockf() constants might have been defined in <unistd.h>.
5022     Unfortunately, <unistd.h> causes troubles on some mixed
5023     (BSD/POSIX) systems, such as SunOS 4.1.3.
5024
5025    Further, the lockf() constants aren't POSIX, so they might not be
5026    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5027    just stick in the SVID values and be done with it.  Sigh.
5028 */
5029
5030 # ifndef F_ULOCK
5031 #  define F_ULOCK       0       /* Unlock a previously locked region */
5032 # endif
5033 # ifndef F_LOCK
5034 #  define F_LOCK        1       /* Lock a region for exclusive use */
5035 # endif
5036 # ifndef F_TLOCK
5037 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5038 # endif
5039 # ifndef F_TEST
5040 #  define F_TEST        3       /* Test a region for other processes locks */
5041 # endif
5042
5043 static int
5044 lockf_emulate_flock(int fd, int operation)
5045 {
5046     int i;
5047     int save_errno;
5048     Off_t pos;
5049
5050     /* flock locks entire file so for lockf we need to do the same      */
5051     save_errno = errno;
5052     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5053     if (pos > 0)        /* is seekable and needs to be repositioned     */
5054         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5055             pos = -1;   /* seek failed, so don't seek back afterwards   */
5056     errno = save_errno;
5057
5058     switch (operation) {
5059
5060         /* LOCK_SH - get a shared lock */
5061         case LOCK_SH:
5062         /* LOCK_EX - get an exclusive lock */
5063         case LOCK_EX:
5064             i = lockf (fd, F_LOCK, 0);
5065             break;
5066
5067         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5068         case LOCK_SH|LOCK_NB:
5069         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5070         case LOCK_EX|LOCK_NB:
5071             i = lockf (fd, F_TLOCK, 0);
5072             if (i == -1)
5073                 if ((errno == EAGAIN) || (errno == EACCES))
5074                     errno = EWOULDBLOCK;
5075             break;
5076
5077         /* LOCK_UN - unlock (non-blocking is a no-op) */
5078         case LOCK_UN:
5079         case LOCK_UN|LOCK_NB:
5080             i = lockf (fd, F_ULOCK, 0);
5081             break;
5082
5083         /* Default - can't decipher operation */
5084         default:
5085             i = -1;
5086             errno = EINVAL;
5087             break;
5088     }
5089
5090     if (pos > 0)      /* need to restore position of the handle */
5091         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5092
5093     return (i);
5094 }
5095
5096 #endif /* LOCKF_EMULATE_FLOCK */