pp_sys.c

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