pp_sys.c

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