pp_sys.c

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