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