pp_sys.c

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