pp_sys.c

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