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