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 Size_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 #ifdef HAS_FCNTL
2182 #if defined(OS2) && defined(__EMX__)
2183         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2184 #else
2185         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2186 #endif
2187
2188     if (SvPOK(argsv)) {
2189         if (s[SvCUR(argsv)] != 17)
2190             DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2191                 OP_NAME(PL_op));
2192         s[SvCUR(argsv)] = 0;            /* put our null back */
2193         SvSETMAGIC(argsv);              /* Assume it has changed */
2194     }
2195
2196     if (retval == -1)
2197         RETPUSHUNDEF;
2198     if (retval != 0) {
2199         PUSHi(retval);
2200     }
2201     else {
2202         PUSHp(zero_but_true, ZBTLEN);
2203     }
2204     RETURN;
2205
2206 #else
2207     DIE(aTHX_ "fcntl is not implemented");
2208 #endif
2209 }
2210
2211 PP(pp_flock)
2212 {
2213 #ifdef FLOCK
2214     dSP; dTARGET;
2215     I32 value;
2216     int argtype;
2217     GV *gv;
2218     IO *io = NULL;
2219     PerlIO *fp;
2220
2221     argtype = POPi;
2222     if (MAXARG == 0)
2223         gv = PL_last_in_gv;
2224     else
2225         gv = (GV*)POPs;
2226     if (gv && (io = GvIO(gv)))
2227         fp = IoIFP(io);
2228     else {
2229         fp = Nullfp;
2230         io = NULL;
2231     }
2232     if (fp) {
2233         (void)PerlIO_flush(fp);
2234         value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2235     }
2236     else {
2237         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2238             report_evil_fh(gv, io, PL_op->op_type);
2239         value = 0;
2240         SETERRNO(EBADF,RMS$_IFI);
2241     }
2242     PUSHi(value);
2243     RETURN;
2244 #else
2245     DIE(aTHX_ PL_no_func, "flock()");
2246 #endif
2247 }
2248
2249 /* Sockets. */
2250
2251 PP(pp_socket)
2252 {
2253 #ifdef HAS_SOCKET
2254     dSP;
2255     GV *gv;
2256     register IO *io;
2257     int protocol = POPi;
2258     int type = POPi;
2259     int domain = POPi;
2260     int fd;
2261
2262     gv = (GV*)POPs;
2263     io = gv ? GvIOn(gv) : NULL;
2264
2265     if (!gv || !io) {
2266         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2267             report_evil_fh(gv, io, PL_op->op_type);
2268         if (IoIFP(io))
2269             do_close(gv, FALSE);
2270         SETERRNO(EBADF,LIB$_INVARG);
2271         RETPUSHUNDEF;
2272     }
2273
2274     if (IoIFP(io))
2275         do_close(gv, FALSE);
2276
2277     TAINT_PROPER("socket");
2278     fd = PerlSock_socket(domain, type, protocol);
2279     if (fd < 0)
2280         RETPUSHUNDEF;
2281     IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
2282     IoOFP(io) = PerlIO_fdopen(fd, "w");
2283     IoTYPE(io) = IoTYPE_SOCKET;
2284     if (!IoIFP(io) || !IoOFP(io)) {
2285         if (IoIFP(io)) PerlIO_close(IoIFP(io));
2286         if (IoOFP(io)) PerlIO_close(IoOFP(io));
2287         if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2288         RETPUSHUNDEF;
2289     }
2290 #if defined(HAS_FCNTL) && defined(F_SETFD)
2291     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2292 #endif
2293
2294 #ifdef EPOC
2295     setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2296 #endif
2297
2298     RETPUSHYES;
2299 #else
2300     DIE(aTHX_ PL_no_sock_func, "socket");
2301 #endif
2302 }
2303
2304 PP(pp_sockpair)
2305 {
2306 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2307     dSP;
2308     GV *gv1;
2309     GV *gv2;
2310     register IO *io1;
2311     register IO *io2;
2312     int protocol = POPi;
2313     int type = POPi;
2314     int domain = POPi;
2315     int fd[2];
2316
2317     gv2 = (GV*)POPs;
2318     gv1 = (GV*)POPs;
2319     io1 = gv1 ? GvIOn(gv1) : NULL;
2320     io2 = gv2 ? GvIOn(gv2) : NULL;
2321     if (!gv1 || !gv2 || !io1 || !io2) {
2322         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2323             if (!gv1 || !io1)
2324                 report_evil_fh(gv1, io1, PL_op->op_type);
2325             if (!gv2 || !io2)
2326                 report_evil_fh(gv1, io2, PL_op->op_type);
2327         }
2328         if (IoIFP(io1))
2329             do_close(gv1, FALSE);
2330         if (IoIFP(io2))
2331             do_close(gv2, FALSE);
2332         RETPUSHUNDEF;
2333     }
2334
2335     if (IoIFP(io1))
2336         do_close(gv1, FALSE);
2337     if (IoIFP(io2))
2338         do_close(gv2, FALSE);
2339
2340     TAINT_PROPER("socketpair");
2341     if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2342         RETPUSHUNDEF;
2343     IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
2344     IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
2345     IoTYPE(io1) = IoTYPE_SOCKET;
2346     IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
2347     IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
2348     IoTYPE(io2) = IoTYPE_SOCKET;
2349     if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2350         if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2351         if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2352         if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2353         if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2354         if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2355         if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2356         RETPUSHUNDEF;
2357     }
2358 #if defined(HAS_FCNTL) && defined(F_SETFD)
2359     fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);   /* ensure close-on-exec */
2360     fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);   /* ensure close-on-exec */
2361 #endif
2362
2363     RETPUSHYES;
2364 #else
2365     DIE(aTHX_ PL_no_sock_func, "socketpair");
2366 #endif
2367 }
2368
2369 PP(pp_bind)
2370 {
2371 #ifdef HAS_SOCKET
2372     dSP;
2373 #ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
2374     extern void GETPRIVMODE();
2375     extern void GETUSERMODE();
2376 #endif
2377     SV *addrsv = POPs;
2378     char *addr;
2379     GV *gv = (GV*)POPs;
2380     register IO *io = GvIOn(gv);
2381     STRLEN len;
2382     int bind_ok = 0;
2383 #ifdef MPE
2384     int mpeprivmode = 0;
2385 #endif
2386
2387     if (!io || !IoIFP(io))
2388         goto nuts;
2389
2390     addr = SvPV(addrsv, len);
2391     TAINT_PROPER("bind");
2392 #ifdef MPE /* Deal with MPE bind() peculiarities */
2393     if (((struct sockaddr *)addr)->sa_family == AF_INET) {
2394         /* The address *MUST* stupidly be zero. */
2395         ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
2396         /* PRIV mode is required to bind() to ports < 1024. */
2397         if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
2398             ((struct sockaddr_in *)addr)->sin_port > 0) {
2399             GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
2400             mpeprivmode = 1;
2401         }
2402     }
2403 #endif /* MPE */
2404     if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
2405                       (struct sockaddr *)addr, len) >= 0)
2406         bind_ok = 1;
2407
2408 #ifdef MPE /* Switch back to USER mode */
2409     if (mpeprivmode)
2410         GETUSERMODE();
2411 #endif /* MPE */
2412
2413     if (bind_ok)
2414         RETPUSHYES;
2415     else
2416         RETPUSHUNDEF;
2417
2418 nuts:
2419     if (ckWARN(WARN_CLOSED))
2420         report_evil_fh(gv, io, PL_op->op_type);
2421     SETERRNO(EBADF,SS$_IVCHAN);
2422     RETPUSHUNDEF;
2423 #else
2424     DIE(aTHX_ PL_no_sock_func, "bind");
2425 #endif
2426 }
2427
2428 PP(pp_connect)
2429 {
2430 #ifdef HAS_SOCKET
2431     dSP;
2432     SV *addrsv = POPs;
2433     char *addr;
2434     GV *gv = (GV*)POPs;
2435     register IO *io = GvIOn(gv);
2436     STRLEN len;
2437
2438     if (!io || !IoIFP(io))
2439         goto nuts;
2440
2441     addr = SvPV(addrsv, len);
2442     TAINT_PROPER("connect");
2443     if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2444         RETPUSHYES;
2445     else
2446         RETPUSHUNDEF;
2447
2448 nuts:
2449     if (ckWARN(WARN_CLOSED))
2450         report_evil_fh(gv, io, PL_op->op_type);
2451     SETERRNO(EBADF,SS$_IVCHAN);
2452     RETPUSHUNDEF;
2453 #else
2454     DIE(aTHX_ PL_no_sock_func, "connect");
2455 #endif
2456 }
2457
2458 PP(pp_listen)
2459 {
2460 #ifdef HAS_SOCKET
2461     dSP;
2462     int backlog = POPi;
2463     GV *gv = (GV*)POPs;
2464     register IO *io = gv ? GvIOn(gv) : NULL;
2465
2466     if (!gv || !io || !IoIFP(io))
2467         goto nuts;
2468
2469     if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2470         RETPUSHYES;
2471     else
2472         RETPUSHUNDEF;
2473
2474 nuts:
2475     if (ckWARN(WARN_CLOSED))
2476         report_evil_fh(gv, io, PL_op->op_type);
2477     SETERRNO(EBADF,SS$_IVCHAN);
2478     RETPUSHUNDEF;
2479 #else
2480     DIE(aTHX_ PL_no_sock_func, "listen");
2481 #endif
2482 }
2483
2484 PP(pp_accept)
2485 {
2486 #ifdef HAS_SOCKET
2487     dSP; dTARGET;
2488     GV *ngv;
2489     GV *ggv;
2490     register IO *nstio;
2491     register IO *gstio;
2492     struct sockaddr saddr;      /* use a struct to avoid alignment problems */
2493     Sock_size_t len = sizeof saddr;
2494     int fd;
2495     int fd2;
2496
2497     ggv = (GV*)POPs;
2498     ngv = (GV*)POPs;
2499
2500     if (!ngv)
2501         goto badexit;
2502     if (!ggv)
2503         goto nuts;
2504
2505     gstio = GvIO(ggv);
2506     if (!gstio || !IoIFP(gstio))
2507         goto nuts;
2508
2509     nstio = GvIOn(ngv);
2510     fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
2511     if (fd < 0)
2512         goto badexit;
2513     if (IoIFP(nstio))
2514         do_close(ngv, FALSE);
2515     IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2516     /* FIXME: we dup(fd) here so that refcounting of fd's does not inhibit
2517        fclose of IoOFP's FILE * - and hence leak memory.
2518        Special treatment of _this_ case of IoIFP != IoOFP seems wrong.
2519      */
2520     IoOFP(nstio) = PerlIO_fdopen(fd2 = PerlLIO_dup(fd), "w");
2521     IoTYPE(nstio) = IoTYPE_SOCKET;
2522     if (!IoIFP(nstio) || !IoOFP(nstio)) {
2523         if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2524         if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2525         if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2526         goto badexit;
2527     }
2528 #if defined(HAS_FCNTL) && defined(F_SETFD)
2529     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2530     fcntl(fd2, F_SETFD, fd2 > PL_maxsysfd);     /* ensure close-on-exec */
2531 #endif
2532
2533 #ifdef EPOC
2534     len = sizeof saddr;          /* EPOC somehow truncates info */
2535     setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2536 #endif
2537
2538     PUSHp((char *)&saddr, len);
2539     RETURN;
2540
2541 nuts:
2542     if (ckWARN(WARN_CLOSED))
2543         report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2544     SETERRNO(EBADF,SS$_IVCHAN);
2545
2546 badexit:
2547     RETPUSHUNDEF;
2548
2549 #else
2550     DIE(aTHX_ PL_no_sock_func, "accept");
2551 #endif
2552 }
2553
2554 PP(pp_shutdown)
2555 {
2556 #ifdef HAS_SOCKET
2557     dSP; dTARGET;
2558     int how = POPi;
2559     GV *gv = (GV*)POPs;
2560     register IO *io = GvIOn(gv);
2561
2562     if (!io || !IoIFP(io))
2563         goto nuts;
2564
2565     PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2566     RETURN;
2567
2568 nuts:
2569     if (ckWARN(WARN_CLOSED))
2570         report_evil_fh(gv, io, PL_op->op_type);
2571     SETERRNO(EBADF,SS$_IVCHAN);
2572     RETPUSHUNDEF;
2573 #else
2574     DIE(aTHX_ PL_no_sock_func, "shutdown");
2575 #endif
2576 }
2577
2578 PP(pp_gsockopt)
2579 {
2580 #ifdef HAS_SOCKET
2581     return pp_ssockopt();
2582 #else
2583     DIE(aTHX_ PL_no_sock_func, "getsockopt");
2584 #endif
2585 }
2586
2587 PP(pp_ssockopt)
2588 {
2589 #ifdef HAS_SOCKET
2590     dSP;
2591     int optype = PL_op->op_type;
2592     SV *sv;
2593     int fd;
2594     unsigned int optname;
2595     unsigned int lvl;
2596     GV *gv;
2597     register IO *io;
2598     Sock_size_t len;
2599
2600     if (optype == OP_GSOCKOPT)
2601         sv = sv_2mortal(NEWSV(22, 257));
2602     else
2603         sv = POPs;
2604     optname = (unsigned int) POPi;
2605     lvl = (unsigned int) POPi;
2606
2607     gv = (GV*)POPs;
2608     io = GvIOn(gv);
2609     if (!io || !IoIFP(io))
2610         goto nuts;
2611
2612     fd = PerlIO_fileno(IoIFP(io));
2613     switch (optype) {
2614     case OP_GSOCKOPT:
2615         SvGROW(sv, 257);
2616         (void)SvPOK_only(sv);
2617         SvCUR_set(sv,256);
2618         *SvEND(sv) ='\0';
2619         len = SvCUR(sv);
2620         if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2621             goto nuts2;
2622         SvCUR_set(sv, len);
2623         *SvEND(sv) ='\0';
2624         PUSHs(sv);
2625         break;
2626     case OP_SSOCKOPT: {
2627             char *buf;
2628             int aint;
2629             if (SvPOKp(sv)) {
2630                 STRLEN l;
2631                 buf = SvPV(sv, l);
2632                 len = l;
2633             }
2634             else {
2635                 aint = (int)SvIV(sv);
2636                 buf = (char*)&aint;
2637                 len = sizeof(int);
2638             }
2639             if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2640                 goto nuts2;
2641             PUSHs(&PL_sv_yes);
2642         }
2643         break;
2644     }
2645     RETURN;
2646
2647 nuts:
2648     if (ckWARN(WARN_CLOSED))
2649         report_evil_fh(gv, io, optype);
2650     SETERRNO(EBADF,SS$_IVCHAN);
2651 nuts2:
2652     RETPUSHUNDEF;
2653
2654 #else
2655     DIE(aTHX_ PL_no_sock_func, "setsockopt");
2656 #endif
2657 }
2658
2659 PP(pp_getsockname)
2660 {
2661 #ifdef HAS_SOCKET
2662     return pp_getpeername();
2663 #else
2664     DIE(aTHX_ PL_no_sock_func, "getsockname");
2665 #endif
2666 }
2667
2668 PP(pp_getpeername)
2669 {
2670 #ifdef HAS_SOCKET
2671     dSP;
2672     int optype = PL_op->op_type;
2673     SV *sv;
2674     int fd;
2675     GV *gv = (GV*)POPs;
2676     register IO *io = GvIOn(gv);
2677     Sock_size_t len;
2678
2679     if (!io || !IoIFP(io))
2680         goto nuts;
2681
2682     sv = sv_2mortal(NEWSV(22, 257));
2683     (void)SvPOK_only(sv);
2684     len = 256;
2685     SvCUR_set(sv, len);
2686     *SvEND(sv) ='\0';
2687     fd = PerlIO_fileno(IoIFP(io));
2688     switch (optype) {
2689     case OP_GETSOCKNAME:
2690         if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2691             goto nuts2;
2692         break;
2693     case OP_GETPEERNAME:
2694         if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2695             goto nuts2;
2696 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2697         {
2698             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";
2699             /* If the call succeeded, make sure we don't have a zeroed port/addr */
2700             if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2701                 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2702                         sizeof(u_short) + sizeof(struct in_addr))) {
2703                 goto nuts2;
2704             }
2705         }
2706 #endif
2707         break;
2708     }
2709 #ifdef BOGUS_GETNAME_RETURN
2710     /* Interactive Unix, getpeername() and getsockname()
2711       does not return valid namelen */
2712     if (len == BOGUS_GETNAME_RETURN)
2713         len = sizeof(struct sockaddr);
2714 #endif
2715     SvCUR_set(sv, len);
2716     *SvEND(sv) ='\0';
2717     PUSHs(sv);
2718     RETURN;
2719
2720 nuts:
2721     if (ckWARN(WARN_CLOSED))
2722         report_evil_fh(gv, io, optype);
2723     SETERRNO(EBADF,SS$_IVCHAN);
2724 nuts2:
2725     RETPUSHUNDEF;
2726
2727 #else
2728     DIE(aTHX_ PL_no_sock_func, "getpeername");
2729 #endif
2730 }
2731
2732 /* Stat calls. */
2733
2734 PP(pp_lstat)
2735 {
2736     return pp_stat();
2737 }
2738
2739 PP(pp_stat)
2740 {
2741     dSP;
2742     GV *gv;
2743     I32 gimme;
2744     I32 max = 13;
2745     STRLEN n_a;
2746
2747     if (PL_op->op_flags & OPf_REF) {
2748         gv = cGVOP_gv;
2749         if (PL_op->op_type == OP_LSTAT) {
2750             if (gv != PL_defgv) {
2751                 if (ckWARN(WARN_IO))
2752                     Perl_warner(aTHX_ packWARN(WARN_IO),
2753                         "lstat() on filehandle %s", GvENAME(gv));
2754             } else if (PL_laststype != OP_LSTAT)
2755                 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2756         }
2757
2758       do_fstat:
2759         if (gv != PL_defgv) {
2760             PL_laststype = OP_STAT;
2761             PL_statgv = gv;
2762             sv_setpv(PL_statname, "");
2763             PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv))
2764                 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
2765         }
2766         if (PL_laststatval < 0) {
2767             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2768                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2769             max = 0;
2770         }
2771     }
2772     else {
2773         SV* sv = POPs;
2774         if (SvTYPE(sv) == SVt_PVGV) {
2775             gv = (GV*)sv;
2776             goto do_fstat;
2777         }
2778         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2779             gv = (GV*)SvRV(sv);
2780             if (PL_op->op_type == OP_LSTAT && ckWARN(WARN_IO))
2781                 Perl_warner(aTHX_ packWARN(WARN_IO),
2782                         "lstat() on filehandle %s", GvENAME(gv));
2783             goto do_fstat;
2784         }
2785         sv_setpv(PL_statname, SvPV(sv,n_a));
2786         PL_statgv = Nullgv;
2787 #ifdef HAS_LSTAT
2788         PL_laststype = PL_op->op_type;
2789         if (PL_op->op_type == OP_LSTAT)
2790             PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
2791         else
2792 #endif
2793             PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
2794         if (PL_laststatval < 0) {
2795             if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
2796                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2797             max = 0;
2798         }
2799     }
2800
2801     gimme = GIMME_V;
2802     if (gimme != G_ARRAY) {
2803         if (gimme != G_VOID)
2804             XPUSHs(boolSV(max));
2805         RETURN;
2806     }
2807     if (max) {
2808         EXTEND(SP, max);
2809         EXTEND_MORTAL(max);
2810         PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2811         PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2812         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2813         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
2814 #if Uid_t_size > IVSIZE
2815         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2816 #else
2817 #   if Uid_t_sign <= 0
2818         PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2819 #   else
2820         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2821 #   endif
2822 #endif
2823 #if Gid_t_size > IVSIZE
2824         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2825 #else
2826 #   if Gid_t_sign <= 0
2827         PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2828 #   else
2829         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2830 #   endif
2831 #endif
2832 #ifdef USE_STAT_RDEV
2833         PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2834 #else
2835         PUSHs(sv_2mortal(newSVpvn("", 0)));
2836 #endif
2837 #if Off_t_size > IVSIZE
2838         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size)));
2839 #else
2840         PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2841 #endif
2842 #ifdef BIG_TIME
2843         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2844         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2845         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2846 #else
2847         PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2848         PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2849         PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
2850 #endif
2851 #ifdef USE_STAT_BLOCKS
2852         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2853         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
2854 #else
2855         PUSHs(sv_2mortal(newSVpvn("", 0)));
2856         PUSHs(sv_2mortal(newSVpvn("", 0)));
2857 #endif
2858     }
2859     RETURN;
2860 }
2861
2862 PP(pp_ftrread)
2863 {
2864     I32 result;
2865     dSP;
2866 #if defined(HAS_ACCESS) && defined(R_OK)
2867     STRLEN n_a;
2868     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2869         result = access(TOPpx, R_OK);
2870         if (result == 0)
2871             RETPUSHYES;
2872         if (result < 0)
2873             RETPUSHUNDEF;
2874         RETPUSHNO;
2875     }
2876     else
2877         result = my_stat();
2878 #else
2879     result = my_stat();
2880 #endif
2881     SPAGAIN;
2882     if (result < 0)
2883         RETPUSHUNDEF;
2884     if (cando(S_IRUSR, 0, &PL_statcache))
2885         RETPUSHYES;
2886     RETPUSHNO;
2887 }
2888
2889 PP(pp_ftrwrite)
2890 {
2891     I32 result;
2892     dSP;
2893 #if defined(HAS_ACCESS) && defined(W_OK)
2894     STRLEN n_a;
2895     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2896         result = access(TOPpx, W_OK);
2897         if (result == 0)
2898             RETPUSHYES;
2899         if (result < 0)
2900             RETPUSHUNDEF;
2901         RETPUSHNO;
2902     }
2903     else
2904         result = my_stat();
2905 #else
2906     result = my_stat();
2907 #endif
2908     SPAGAIN;
2909     if (result < 0)
2910         RETPUSHUNDEF;
2911     if (cando(S_IWUSR, 0, &PL_statcache))
2912         RETPUSHYES;
2913     RETPUSHNO;
2914 }
2915
2916 PP(pp_ftrexec)
2917 {
2918     I32 result;
2919     dSP;
2920 #if defined(HAS_ACCESS) && defined(X_OK)
2921     STRLEN n_a;
2922     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2923         result = access(TOPpx, X_OK);
2924         if (result == 0)
2925             RETPUSHYES;
2926         if (result < 0)
2927             RETPUSHUNDEF;
2928         RETPUSHNO;
2929     }
2930     else
2931         result = my_stat();
2932 #else
2933     result = my_stat();
2934 #endif
2935     SPAGAIN;
2936     if (result < 0)
2937         RETPUSHUNDEF;
2938     if (cando(S_IXUSR, 0, &PL_statcache))
2939         RETPUSHYES;
2940     RETPUSHNO;
2941 }
2942
2943 PP(pp_fteread)
2944 {
2945     I32 result;
2946     dSP;
2947 #ifdef PERL_EFF_ACCESS_R_OK
2948     STRLEN n_a;
2949     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2950         result = PERL_EFF_ACCESS_R_OK(TOPpx);
2951         if (result == 0)
2952             RETPUSHYES;
2953         if (result < 0)
2954             RETPUSHUNDEF;
2955         RETPUSHNO;
2956     }
2957     else
2958         result = my_stat();
2959 #else
2960     result = my_stat();
2961 #endif
2962     SPAGAIN;
2963     if (result < 0)
2964         RETPUSHUNDEF;
2965     if (cando(S_IRUSR, 1, &PL_statcache))
2966         RETPUSHYES;
2967     RETPUSHNO;
2968 }
2969
2970 PP(pp_ftewrite)
2971 {
2972     I32 result;
2973     dSP;
2974 #ifdef PERL_EFF_ACCESS_W_OK
2975     STRLEN n_a;
2976     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2977         result = PERL_EFF_ACCESS_W_OK(TOPpx);
2978         if (result == 0)
2979             RETPUSHYES;
2980         if (result < 0)
2981             RETPUSHUNDEF;
2982         RETPUSHNO;
2983     }
2984     else
2985         result = my_stat();
2986 #else
2987     result = my_stat();
2988 #endif
2989     SPAGAIN;
2990     if (result < 0)
2991         RETPUSHUNDEF;
2992     if (cando(S_IWUSR, 1, &PL_statcache))
2993         RETPUSHYES;
2994     RETPUSHNO;
2995 }
2996
2997 PP(pp_fteexec)
2998 {
2999     I32 result;
3000     dSP;
3001 #ifdef PERL_EFF_ACCESS_X_OK
3002     STRLEN n_a;
3003     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
3004         result = PERL_EFF_ACCESS_X_OK(TOPpx);
3005         if (result == 0)
3006             RETPUSHYES;
3007         if (result < 0)
3008             RETPUSHUNDEF;
3009         RETPUSHNO;
3010     }
3011     else
3012         result = my_stat();
3013 #else
3014     result = my_stat();
3015 #endif
3016     SPAGAIN;
3017     if (result < 0)
3018         RETPUSHUNDEF;
3019     if (cando(S_IXUSR, 1, &PL_statcache))
3020         RETPUSHYES;
3021     RETPUSHNO;
3022 }
3023
3024 PP(pp_ftis)
3025 {
3026     I32 result = my_stat();
3027     dSP;
3028     if (result < 0)
3029         RETPUSHUNDEF;
3030     RETPUSHYES;
3031 }
3032
3033 PP(pp_fteowned)
3034 {
3035     return pp_ftrowned();
3036 }
3037
3038 PP(pp_ftrowned)
3039 {
3040     I32 result = my_stat();
3041     dSP;
3042     if (result < 0)
3043         RETPUSHUNDEF;
3044     if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
3045                                 PL_euid : PL_uid) )
3046         RETPUSHYES;
3047     RETPUSHNO;
3048 }
3049
3050 PP(pp_ftzero)
3051 {
3052     I32 result = my_stat();
3053     dSP;
3054     if (result < 0)
3055         RETPUSHUNDEF;
3056     if (PL_statcache.st_size == 0)
3057         RETPUSHYES;
3058     RETPUSHNO;
3059 }
3060
3061 PP(pp_ftsize)
3062 {
3063     I32 result = my_stat();
3064     dSP; dTARGET;
3065     if (result < 0)
3066         RETPUSHUNDEF;
3067 #if Off_t_size > IVSIZE
3068     PUSHn(PL_statcache.st_size);
3069 #else
3070     PUSHi(PL_statcache.st_size);
3071 #endif
3072     RETURN;
3073 }
3074
3075 PP(pp_ftmtime)
3076 {
3077     I32 result = my_stat();
3078     dSP; dTARGET;
3079     if (result < 0)
3080         RETPUSHUNDEF;
3081     PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3082     RETURN;
3083 }
3084
3085 PP(pp_ftatime)
3086 {
3087     I32 result = my_stat();
3088     dSP; dTARGET;
3089     if (result < 0)
3090         RETPUSHUNDEF;
3091     PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
3092     RETURN;
3093 }
3094
3095 PP(pp_ftctime)
3096 {
3097     I32 result = my_stat();
3098     dSP; dTARGET;
3099     if (result < 0)
3100         RETPUSHUNDEF;
3101     PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3102     RETURN;
3103 }
3104
3105 PP(pp_ftsock)
3106 {
3107     I32 result = my_stat();
3108     dSP;
3109     if (result < 0)
3110         RETPUSHUNDEF;
3111     if (S_ISSOCK(PL_statcache.st_mode))
3112         RETPUSHYES;
3113     RETPUSHNO;
3114 }
3115
3116 PP(pp_ftchr)
3117 {
3118     I32 result = my_stat();
3119     dSP;
3120     if (result < 0)
3121         RETPUSHUNDEF;
3122     if (S_ISCHR(PL_statcache.st_mode))
3123         RETPUSHYES;
3124     RETPUSHNO;
3125 }
3126
3127 PP(pp_ftblk)
3128 {
3129     I32 result = my_stat();
3130     dSP;
3131     if (result < 0)
3132         RETPUSHUNDEF;
3133     if (S_ISBLK(PL_statcache.st_mode))
3134         RETPUSHYES;
3135     RETPUSHNO;
3136 }
3137
3138 PP(pp_ftfile)
3139 {
3140     I32 result = my_stat();
3141     dSP;
3142     if (result < 0)
3143         RETPUSHUNDEF;
3144     if (S_ISREG(PL_statcache.st_mode))
3145         RETPUSHYES;
3146     RETPUSHNO;
3147 }
3148
3149 PP(pp_ftdir)
3150 {
3151     I32 result = my_stat();
3152     dSP;
3153     if (result < 0)
3154         RETPUSHUNDEF;
3155     if (S_ISDIR(PL_statcache.st_mode))
3156         RETPUSHYES;
3157     RETPUSHNO;
3158 }
3159
3160 PP(pp_ftpipe)
3161 {
3162     I32 result = my_stat();
3163     dSP;
3164     if (result < 0)
3165         RETPUSHUNDEF;
3166     if (S_ISFIFO(PL_statcache.st_mode))
3167         RETPUSHYES;
3168     RETPUSHNO;
3169 }
3170
3171 PP(pp_ftlink)
3172 {
3173     I32 result = my_lstat();
3174     dSP;
3175     if (result < 0)
3176         RETPUSHUNDEF;
3177     if (S_ISLNK(PL_statcache.st_mode))
3178         RETPUSHYES;
3179     RETPUSHNO;
3180 }
3181
3182 PP(pp_ftsuid)
3183 {
3184     dSP;
3185 #ifdef S_ISUID
3186     I32 result = my_stat();
3187     SPAGAIN;
3188     if (result < 0)
3189         RETPUSHUNDEF;
3190     if (PL_statcache.st_mode & S_ISUID)
3191         RETPUSHYES;
3192 #endif
3193     RETPUSHNO;
3194 }
3195
3196 PP(pp_ftsgid)
3197 {
3198     dSP;
3199 #ifdef S_ISGID
3200     I32 result = my_stat();
3201     SPAGAIN;
3202     if (result < 0)
3203         RETPUSHUNDEF;
3204     if (PL_statcache.st_mode & S_ISGID)
3205         RETPUSHYES;
3206 #endif
3207     RETPUSHNO;
3208 }
3209
3210 PP(pp_ftsvtx)
3211 {
3212     dSP;
3213 #ifdef S_ISVTX
3214     I32 result = my_stat();
3215     SPAGAIN;
3216     if (result < 0)
3217         RETPUSHUNDEF;
3218     if (PL_statcache.st_mode & S_ISVTX)
3219         RETPUSHYES;
3220 #endif
3221     RETPUSHNO;
3222 }
3223
3224 PP(pp_fttty)
3225 {
3226     dSP;
3227     int fd;
3228     GV *gv;
3229     char *tmps = Nullch;
3230     STRLEN n_a;
3231
3232     if (PL_op->op_flags & OPf_REF)
3233         gv = cGVOP_gv;
3234     else if (isGV(TOPs))
3235         gv = (GV*)POPs;
3236     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3237         gv = (GV*)SvRV(POPs);
3238     else
3239         gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
3240
3241     if (GvIO(gv) && IoIFP(GvIOp(gv)))
3242         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3243     else if (tmps && isDIGIT(*tmps))
3244         fd = atoi(tmps);
3245     else
3246         RETPUSHUNDEF;
3247     if (PerlLIO_isatty(fd))
3248         RETPUSHYES;
3249     RETPUSHNO;
3250 }
3251
3252 #if defined(atarist) /* this will work with atariST. Configure will
3253                         make guesses for other systems. */
3254 # define FILE_base(f) ((f)->_base)
3255 # define FILE_ptr(f) ((f)->_ptr)
3256 # define FILE_cnt(f) ((f)->_cnt)
3257 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3258 #endif
3259
3260 PP(pp_fttext)
3261 {
3262     dSP;
3263     I32 i;
3264     I32 len;
3265     I32 odd = 0;
3266     STDCHAR tbuf[512];
3267     register STDCHAR *s;
3268     register IO *io;
3269     register SV *sv;
3270     GV *gv;
3271     STRLEN n_a;
3272     PerlIO *fp;
3273
3274     if (PL_op->op_flags & OPf_REF)
3275         gv = cGVOP_gv;
3276     else if (isGV(TOPs))
3277         gv = (GV*)POPs;
3278     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3279         gv = (GV*)SvRV(POPs);
3280     else
3281         gv = Nullgv;
3282
3283     if (gv) {
3284         EXTEND(SP, 1);
3285         if (gv == PL_defgv) {
3286             if (PL_statgv)
3287                 io = GvIO(PL_statgv);
3288             else {
3289                 sv = PL_statname;
3290                 goto really_filename;
3291             }
3292         }
3293         else {
3294             PL_statgv = gv;
3295             PL_laststatval = -1;
3296             sv_setpv(PL_statname, "");
3297             io = GvIO(PL_statgv);
3298         }
3299         if (io && IoIFP(io)) {
3300             if (! PerlIO_has_base(IoIFP(io)))
3301                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3302             PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3303             if (PL_laststatval < 0)
3304                 RETPUSHUNDEF;
3305             if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3306                 if (PL_op->op_type == OP_FTTEXT)
3307                     RETPUSHNO;
3308                 else
3309                     RETPUSHYES;
3310             }
3311             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3312                 i = PerlIO_getc(IoIFP(io));
3313                 if (i != EOF)
3314                     (void)PerlIO_ungetc(IoIFP(io),i);
3315             }
3316             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3317                 RETPUSHYES;
3318             len = PerlIO_get_bufsiz(IoIFP(io));
3319             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3320             /* sfio can have large buffers - limit to 512 */
3321             if (len > 512)
3322                 len = 512;
3323         }
3324         else {
3325             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3326                 gv = cGVOP_gv;
3327                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3328             }
3329             SETERRNO(EBADF,RMS$_IFI);
3330             RETPUSHUNDEF;
3331         }
3332     }
3333     else {
3334         sv = POPs;
3335       really_filename:
3336         PL_statgv = Nullgv;
3337         PL_laststatval = -1;
3338         PL_laststype = OP_STAT;
3339         sv_setpv(PL_statname, SvPV(sv, n_a));
3340         if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
3341             if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
3342                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3343             RETPUSHUNDEF;
3344         }
3345         PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3346         if (PL_laststatval < 0) {
3347             (void)PerlIO_close(fp);
3348             RETPUSHUNDEF;
3349         }
3350         PerlIO_binmode(aTHX_ fp, '<', O_BINARY, Nullch);
3351         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3352         (void)PerlIO_close(fp);
3353         if (len <= 0) {
3354             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3355                 RETPUSHNO;              /* special case NFS directories */
3356             RETPUSHYES;         /* null file is anything */
3357         }
3358         s = tbuf;
3359     }
3360
3361     /* now scan s to look for textiness */
3362     /*   XXX ASCII dependent code */
3363
3364 #if defined(DOSISH) || defined(USEMYBINMODE)
3365     /* ignore trailing ^Z on short files */
3366     if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3367         --len;
3368 #endif
3369
3370     for (i = 0; i < len; i++, s++) {
3371         if (!*s) {                      /* null never allowed in text */
3372             odd += len;
3373             break;
3374         }
3375 #ifdef EBCDIC
3376         else if (!(isPRINT(*s) || isSPACE(*s)))
3377             odd++;
3378 #else
3379         else if (*s & 128) {
3380 #ifdef USE_LOCALE
3381             if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3382                 continue;
3383 #endif
3384             /* utf8 characters don't count as odd */
3385             if (UTF8_IS_START(*s)) {
3386                 int ulen = UTF8SKIP(s);
3387                 if (ulen < len - i) {
3388                     int j;
3389                     for (j = 1; j < ulen; j++) {
3390                         if (!UTF8_IS_CONTINUATION(s[j]))
3391                             goto not_utf8;
3392                     }
3393                     --ulen;     /* loop does extra increment */
3394                     s += ulen;
3395                     i += ulen;
3396                     continue;
3397                 }
3398             }
3399           not_utf8:
3400             odd++;
3401         }
3402         else if (*s < 32 &&
3403           *s != '\n' && *s != '\r' && *s != '\b' &&
3404           *s != '\t' && *s != '\f' && *s != 27)
3405             odd++;
3406 #endif
3407     }
3408
3409     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3410         RETPUSHNO;
3411     else
3412         RETPUSHYES;
3413 }
3414
3415 PP(pp_ftbinary)
3416 {
3417     return pp_fttext();
3418 }
3419
3420 /* File calls. */
3421
3422 PP(pp_chdir)
3423 {
3424     dSP; dTARGET;
3425     char *tmps;
3426     SV **svp;
3427     STRLEN n_a;
3428
3429     if( MAXARG == 1 )
3430         tmps = POPpx;
3431     else
3432         tmps = 0;
3433
3434     if( !tmps || !*tmps ) {
3435         if (    (svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE))
3436              || (svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE))
3437 #ifdef VMS
3438              || (svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE))
3439 #endif
3440            )
3441         {
3442             if( MAXARG == 1 )
3443                 deprecate("chdir('') or chdir(undef) as chdir()");
3444             tmps = SvPV(*svp, n_a);
3445         }
3446         else {
3447             PUSHi(0);
3448             TAINT_PROPER("chdir");
3449             RETURN;
3450         }
3451     }
3452
3453     TAINT_PROPER("chdir");
3454     PUSHi( PerlDir_chdir(tmps) >= 0 );
3455 #ifdef VMS
3456     /* Clear the DEFAULT element of ENV so we'll get the new value
3457      * in the future. */
3458     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3459 #endif
3460     RETURN;
3461 }
3462
3463 PP(pp_chown)
3464 {
3465 #ifdef HAS_CHOWN
3466     dSP; dMARK; dTARGET;
3467     I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3468
3469     SP = MARK;
3470     PUSHi(value);
3471     RETURN;
3472 #else
3473     DIE(aTHX_ PL_no_func, "chown");
3474 #endif
3475 }
3476
3477 PP(pp_chroot)
3478 {
3479 #ifdef HAS_CHROOT
3480     dSP; dTARGET;
3481     STRLEN n_a;
3482     char *tmps = POPpx;
3483     TAINT_PROPER("chroot");
3484     PUSHi( chroot(tmps) >= 0 );
3485     RETURN;
3486 #else
3487     DIE(aTHX_ PL_no_func, "chroot");
3488 #endif
3489 }
3490
3491 PP(pp_unlink)
3492 {
3493     dSP; dMARK; dTARGET;
3494     I32 value;
3495     value = (I32)apply(PL_op->op_type, MARK, SP);
3496     SP = MARK;
3497     PUSHi(value);
3498     RETURN;
3499 }
3500
3501 PP(pp_chmod)
3502 {
3503     dSP; dMARK; dTARGET;
3504     I32 value;
3505     value = (I32)apply(PL_op->op_type, MARK, SP);
3506     SP = MARK;
3507     PUSHi(value);
3508     RETURN;
3509 }
3510
3511 PP(pp_utime)
3512 {
3513     dSP; dMARK; dTARGET;
3514     I32 value;
3515     value = (I32)apply(PL_op->op_type, MARK, SP);
3516     SP = MARK;
3517     PUSHi(value);
3518     RETURN;
3519 }
3520
3521 PP(pp_rename)
3522 {
3523     dSP; dTARGET;
3524     int anum;
3525     STRLEN n_a;
3526
3527     char *tmps2 = POPpx;
3528     char *tmps = SvPV(TOPs, n_a);
3529     TAINT_PROPER("rename");
3530 #ifdef HAS_RENAME
3531     anum = PerlLIO_rename(tmps, tmps2);
3532 #else
3533     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3534         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3535             anum = 1;
3536         else {
3537             if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3538                 (void)UNLINK(tmps2);
3539             if (!(anum = link(tmps, tmps2)))
3540                 anum = UNLINK(tmps);
3541         }
3542     }
3543 #endif
3544     SETi( anum >= 0 );
3545     RETURN;
3546 }
3547
3548 PP(pp_link)
3549 {
3550 #ifdef HAS_LINK
3551     dSP; dTARGET;
3552     STRLEN n_a;
3553     char *tmps2 = POPpx;
3554     char *tmps = SvPV(TOPs, n_a);
3555     TAINT_PROPER("link");
3556     SETi( PerlLIO_link(tmps, tmps2) >= 0 );
3557     RETURN;
3558 #else
3559     DIE(aTHX_ PL_no_func, "link");
3560 #endif
3561 }
3562
3563 PP(pp_symlink)
3564 {
3565 #ifdef HAS_SYMLINK
3566     dSP; dTARGET;
3567     STRLEN n_a;
3568     char *tmps2 = POPpx;
3569     char *tmps = SvPV(TOPs, n_a);
3570     TAINT_PROPER("symlink");
3571     SETi( symlink(tmps, tmps2) >= 0 );
3572     RETURN;
3573 #else
3574     DIE(aTHX_ PL_no_func, "symlink");
3575 #endif
3576 }
3577
3578 PP(pp_readlink)
3579 {
3580     dSP;
3581 #ifdef HAS_SYMLINK
3582     dTARGET;
3583     char *tmps;
3584     char buf[MAXPATHLEN];
3585     int len;
3586     STRLEN n_a;
3587
3588 #ifndef INCOMPLETE_TAINTS
3589     TAINT;
3590 #endif
3591     tmps = POPpx;
3592     len = readlink(tmps, buf, sizeof(buf) - 1);
3593     EXTEND(SP, 1);
3594     if (len < 0)
3595         RETPUSHUNDEF;
3596     PUSHp(buf, len);
3597     RETURN;
3598 #else
3599     EXTEND(SP, 1);
3600     RETSETUNDEF;                /* just pretend it's a normal file */
3601 #endif
3602 }
3603
3604 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3605 STATIC int
3606 S_dooneliner(pTHX_ char *cmd, char *filename)
3607 {
3608     char *save_filename = filename;
3609     char *cmdline;
3610     char *s;
3611     PerlIO *myfp;
3612     int anum = 1;
3613
3614     New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3615     strcpy(cmdline, cmd);
3616     strcat(cmdline, " ");
3617     for (s = cmdline + strlen(cmdline); *filename; ) {
3618         *s++ = '\\';
3619         *s++ = *filename++;
3620     }
3621     strcpy(s, " 2>&1");
3622     myfp = PerlProc_popen(cmdline, "r");
3623     Safefree(cmdline);
3624
3625     if (myfp) {
3626         SV *tmpsv = sv_newmortal();
3627         /* Need to save/restore 'PL_rs' ?? */
3628         s = sv_gets(tmpsv, myfp, 0);
3629         (void)PerlProc_pclose(myfp);
3630         if (s != Nullch) {
3631             int e;
3632             for (e = 1;
3633 #ifdef HAS_SYS_ERRLIST
3634                  e <= sys_nerr
3635 #endif
3636                  ; e++)
3637             {
3638                 /* you don't see this */
3639                 char *errmsg =
3640 #ifdef HAS_SYS_ERRLIST
3641                     sys_errlist[e]
3642 #else
3643                     strerror(e)
3644 #endif
3645                     ;
3646                 if (!errmsg)
3647                     break;
3648                 if (instr(s, errmsg)) {
3649                     SETERRNO(e,0);
3650                     return 0;
3651                 }
3652             }
3653             SETERRNO(0,0);
3654 #ifndef EACCES
3655 #define EACCES EPERM
3656 #endif
3657             if (instr(s, "cannot make"))
3658                 SETERRNO(EEXIST,RMS$_FEX);
3659             else if (instr(s, "existing file"))
3660                 SETERRNO(EEXIST,RMS$_FEX);
3661             else if (instr(s, "ile exists"))
3662                 SETERRNO(EEXIST,RMS$_FEX);
3663             else if (instr(s, "non-exist"))
3664                 SETERRNO(ENOENT,RMS$_FNF);
3665             else if (instr(s, "does not exist"))
3666                 SETERRNO(ENOENT,RMS$_FNF);
3667             else if (instr(s, "not empty"))
3668                 SETERRNO(EBUSY,SS$_DEVOFFLINE);
3669             else if (instr(s, "cannot access"))
3670                 SETERRNO(EACCES,RMS$_PRV);
3671             else
3672                 SETERRNO(EPERM,RMS$_PRV);
3673             return 0;
3674         }
3675         else {  /* some mkdirs return no failure indication */
3676             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3677             if (PL_op->op_type == OP_RMDIR)
3678                 anum = !anum;
3679             if (anum)
3680                 SETERRNO(0,0);
3681             else
3682                 SETERRNO(EACCES,RMS$_PRV);      /* a guess */
3683         }
3684         return anum;
3685     }
3686     else
3687         return 0;
3688 }
3689 #endif
3690
3691 PP(pp_mkdir)
3692 {
3693     dSP; dTARGET;
3694     int mode;
3695 #ifndef HAS_MKDIR
3696     int oldumask;
3697 #endif
3698     STRLEN len;
3699     char *tmps;
3700     bool copy = FALSE;
3701
3702     if (MAXARG > 1)
3703         mode = POPi;
3704     else
3705         mode = 0777;
3706
3707     tmps = SvPV(TOPs, len);
3708     /* Different operating and file systems take differently to
3709      * trailing slashes.  According to POSIX 1003.1 1996 Edition
3710      * any number of trailing slashes should be allowed.
3711      * Thusly we snip them away so that even non-conforming
3712      * systems are happy. */
3713     /* We should probably do this "filtering" for all
3714      * the functions that expect (potentially) directory names:
3715      * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3716      * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3717     if (len > 1 && tmps[len-1] == '/') {
3718         while (tmps[len] == '/' && len > 1)
3719             len--;
3720         tmps = savepvn(tmps, len);
3721         copy = TRUE;
3722     }
3723
3724     TAINT_PROPER("mkdir");
3725 #ifdef HAS_MKDIR
3726     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3727 #else
3728     SETi( dooneliner("mkdir", tmps) );
3729     oldumask = PerlLIO_umask(0);
3730     PerlLIO_umask(oldumask);
3731     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3732 #endif
3733     if (copy)
3734         Safefree(tmps);
3735     RETURN;
3736 }
3737
3738 PP(pp_rmdir)
3739 {
3740     dSP; dTARGET;
3741     char *tmps;
3742     STRLEN n_a;
3743
3744     tmps = POPpx;
3745     TAINT_PROPER("rmdir");
3746 #ifdef HAS_RMDIR
3747     XPUSHi( PerlDir_rmdir(tmps) >= 0 );
3748 #else
3749     XPUSHi( dooneliner("rmdir", tmps) );
3750 #endif
3751     RETURN;
3752 }
3753
3754 /* Directory calls. */
3755
3756 PP(pp_open_dir)
3757 {
3758 #if defined(Direntry_t) && defined(HAS_READDIR)
3759     dSP;
3760     STRLEN n_a;
3761     char *dirname = POPpx;
3762     GV *gv = (GV*)POPs;
3763     register IO *io = GvIOn(gv);
3764
3765     if (!io)
3766         goto nope;
3767
3768     if (IoDIRP(io))
3769         PerlDir_close(IoDIRP(io));
3770     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3771         goto nope;
3772
3773     RETPUSHYES;
3774 nope:
3775     if (!errno)
3776         SETERRNO(EBADF,RMS$_DIR);
3777     RETPUSHUNDEF;
3778 #else
3779     DIE(aTHX_ PL_no_dir_func, "opendir");
3780 #endif
3781 }
3782
3783 PP(pp_readdir)
3784 {
3785 #if defined(Direntry_t) && defined(HAS_READDIR)
3786     dSP;
3787 #if !defined(I_DIRENT) && !defined(VMS)
3788     Direntry_t *readdir (DIR *);
3789 #endif
3790     register Direntry_t *dp;
3791     GV *gv = (GV*)POPs;
3792     register IO *io = GvIOn(gv);
3793     SV *sv;
3794
3795     if (!io || !IoDIRP(io))
3796         goto nope;
3797
3798     if (GIMME == G_ARRAY) {
3799         /*SUPPRESS 560*/
3800         while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
3801 #ifdef DIRNAMLEN
3802             sv = newSVpvn(dp->d_name, dp->d_namlen);
3803 #else
3804             sv = newSVpv(dp->d_name, 0);
3805 #endif
3806 #ifndef INCOMPLETE_TAINTS
3807             if (!(IoFLAGS(io) & IOf_UNTAINT))
3808                 SvTAINTED_on(sv);
3809 #endif
3810             XPUSHs(sv_2mortal(sv));
3811         }
3812     }
3813     else {
3814         if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
3815             goto nope;
3816 #ifdef DIRNAMLEN
3817         sv = newSVpvn(dp->d_name, dp->d_namlen);
3818 #else
3819         sv = newSVpv(dp->d_name, 0);
3820 #endif
3821 #ifndef INCOMPLETE_TAINTS
3822         if (!(IoFLAGS(io) & IOf_UNTAINT))
3823             SvTAINTED_on(sv);
3824 #endif
3825         XPUSHs(sv_2mortal(sv));
3826     }
3827     RETURN;
3828
3829 nope:
3830     if (!errno)
3831         SETERRNO(EBADF,RMS$_ISI);
3832     if (GIMME == G_ARRAY)
3833         RETURN;
3834     else
3835         RETPUSHUNDEF;
3836 #else
3837     DIE(aTHX_ PL_no_dir_func, "readdir");
3838 #endif
3839 }
3840
3841 PP(pp_telldir)
3842 {
3843 #if defined(HAS_TELLDIR) || defined(telldir)
3844     dSP; dTARGET;
3845  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3846  /* XXX netbsd still seemed to.
3847     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3848     --JHI 1999-Feb-02 */
3849 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3850     long telldir (DIR *);
3851 # endif
3852     GV *gv = (GV*)POPs;
3853     register IO *io = GvIOn(gv);
3854
3855     if (!io || !IoDIRP(io))
3856         goto nope;
3857
3858     PUSHi( PerlDir_tell(IoDIRP(io)) );
3859     RETURN;
3860 nope:
3861     if (!errno)
3862         SETERRNO(EBADF,RMS$_ISI);
3863     RETPUSHUNDEF;
3864 #else
3865     DIE(aTHX_ PL_no_dir_func, "telldir");
3866 #endif
3867 }
3868
3869 PP(pp_seekdir)
3870 {
3871 #if defined(HAS_SEEKDIR) || defined(seekdir)
3872     dSP;
3873     long along = POPl;
3874     GV *gv = (GV*)POPs;
3875     register IO *io = GvIOn(gv);
3876
3877     if (!io || !IoDIRP(io))
3878         goto nope;
3879
3880     (void)PerlDir_seek(IoDIRP(io), along);
3881
3882     RETPUSHYES;
3883 nope:
3884     if (!errno)
3885         SETERRNO(EBADF,RMS$_ISI);
3886     RETPUSHUNDEF;
3887 #else
3888     DIE(aTHX_ PL_no_dir_func, "seekdir");
3889 #endif
3890 }
3891
3892 PP(pp_rewinddir)
3893 {
3894 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3895     dSP;
3896     GV *gv = (GV*)POPs;
3897     register IO *io = GvIOn(gv);
3898
3899     if (!io || !IoDIRP(io))
3900         goto nope;
3901
3902     (void)PerlDir_rewind(IoDIRP(io));
3903     RETPUSHYES;
3904 nope:
3905     if (!errno)
3906         SETERRNO(EBADF,RMS$_ISI);
3907     RETPUSHUNDEF;
3908 #else
3909     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3910 #endif
3911 }
3912
3913 PP(pp_closedir)
3914 {
3915 #if defined(Direntry_t) && defined(HAS_READDIR)
3916     dSP;
3917     GV *gv = (GV*)POPs;
3918     register IO *io = GvIOn(gv);
3919
3920     if (!io || !IoDIRP(io))
3921         goto nope;
3922
3923 #ifdef VOID_CLOSEDIR
3924     PerlDir_close(IoDIRP(io));
3925 #else
3926     if (PerlDir_close(IoDIRP(io)) < 0) {
3927         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3928         goto nope;
3929     }
3930 #endif
3931     IoDIRP(io) = 0;
3932
3933     RETPUSHYES;
3934 nope:
3935     if (!errno)
3936         SETERRNO(EBADF,RMS$_IFI);
3937     RETPUSHUNDEF;
3938 #else
3939     DIE(aTHX_ PL_no_dir_func, "closedir");
3940 #endif
3941 }
3942
3943 /* Process control. */
3944
3945 PP(pp_fork)
3946 {
3947 #ifdef HAS_FORK
3948     dSP; dTARGET;
3949     Pid_t childpid;
3950     GV *tmpgv;
3951
3952     EXTEND(SP, 1);
3953     PERL_FLUSHALL_FOR_CHILD;
3954     childpid = PerlProc_fork();
3955     if (childpid < 0)
3956         RETSETUNDEF;
3957     if (!childpid) {
3958         /*SUPPRESS 560*/
3959         if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV))) {
3960             SvREADONLY_off(GvSV(tmpgv));
3961             sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3962             SvREADONLY_on(GvSV(tmpgv));
3963         }
3964         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3965     }
3966     PUSHi(childpid);
3967     RETURN;
3968 #else
3969 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3970     dSP; dTARGET;
3971     Pid_t childpid;
3972
3973     EXTEND(SP, 1);
3974     PERL_FLUSHALL_FOR_CHILD;
3975     childpid = PerlProc_fork();
3976     if (childpid == -1)
3977         RETSETUNDEF;
3978     PUSHi(childpid);
3979     RETURN;
3980 #  else
3981     DIE(aTHX_ PL_no_func, "fork");
3982 #  endif
3983 #endif
3984 }
3985
3986 PP(pp_wait)
3987 {
3988 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3989     dSP; dTARGET;
3990     Pid_t childpid;
3991     int argflags;
3992
3993 #ifdef PERL_OLD_SIGNALS
3994     childpid = wait4pid(-1, &argflags, 0);
3995 #else
3996     while ((childpid = wait4pid(-1, &argflags, 0)) == -1 && errno == EINTR) {
3997         PERL_ASYNC_CHECK();
3998     }
3999 #endif
4000 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4001     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4002     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
4003 #  else
4004     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
4005 #  endif
4006     XPUSHi(childpid);
4007     RETURN;
4008 #else
4009     DIE(aTHX_ PL_no_func, "wait");
4010 #endif
4011 }
4012
4013 PP(pp_waitpid)
4014 {
4015 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4016     dSP; dTARGET;
4017     Pid_t childpid;
4018     int optype;
4019     int argflags;
4020
4021     optype = POPi;
4022     childpid = TOPi;
4023 #ifdef PERL_OLD_SIGNALS
4024     childpid = wait4pid(childpid, &argflags, optype);
4025 #else
4026     while ((childpid = wait4pid(childpid, &argflags, optype)) == -1 && errno == EINTR) {
4027         PERL_ASYNC_CHECK();
4028     }
4029 #endif
4030 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4031     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4032     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
4033 #  else
4034     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
4035 #  endif
4036     SETi(childpid);
4037     RETURN;
4038 #else
4039     DIE(aTHX_ PL_no_func, "waitpid");
4040 #endif
4041 }
4042
4043 PP(pp_system)
4044 {
4045     dSP; dMARK; dORIGMARK; dTARGET;
4046     I32 value;
4047     STRLEN n_a;
4048     int result;
4049     I32 did_pipes = 0;
4050
4051     if (PL_tainting) {
4052         TAINT_ENV();
4053         while (++MARK <= SP) {
4054             (void)SvPV_nolen(*MARK);      /* stringify for taint check */
4055             if (PL_tainted)
4056                 break;
4057         }
4058         MARK = ORIGMARK;
4059         /* XXX Remove warning at end of deprecation cycle --RD 2002-02  */
4060         if (SP - MARK == 1) {
4061             TAINT_PROPER("system");
4062         }
4063         else if (ckWARN2(WARN_TAINT, WARN_DEPRECATED)) {
4064             Perl_warner(aTHX_ packWARN2(WARN_TAINT, WARN_DEPRECATED),
4065                 "Use of tainted arguments in %s is deprecated", "system");
4066         }
4067     }
4068     PERL_FLUSHALL_FOR_CHILD;
4069 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4070     {
4071         Pid_t childpid;
4072         int pp[2];
4073
4074         if (PerlProc_pipe(pp) >= 0)
4075             did_pipes = 1;
4076         while ((childpid = PerlProc_fork()) == -1) {
4077             if (errno != EAGAIN) {
4078                 value = -1;
4079                 SP = ORIGMARK;
4080                 PUSHi(value);
4081                 if (did_pipes) {
4082                     PerlLIO_close(pp[0]);
4083                     PerlLIO_close(pp[1]);
4084                 }
4085                 RETURN;
4086             }
4087             sleep(5);
4088         }
4089         if (childpid > 0) {
4090             Sigsave_t ihand,qhand; /* place to save signals during system() */
4091             int status;
4092
4093             if (did_pipes)
4094                 PerlLIO_close(pp[1]);
4095 #ifndef PERL_MICRO
4096             rsignal_save(SIGINT, SIG_IGN, &ihand);
4097             rsignal_save(SIGQUIT, SIG_IGN, &qhand);
4098 #endif
4099             do {
4100                 result = wait4pid(childpid, &status, 0);
4101             } while (result == -1 && errno == EINTR);
4102 #ifndef PERL_MICRO
4103             (void)rsignal_restore(SIGINT, &ihand);
4104             (void)rsignal_restore(SIGQUIT, &qhand);
4105 #endif
4106             STATUS_NATIVE_SET(result == -1 ? -1 : status);
4107             do_execfree();      /* free any memory child malloced on fork */
4108             SP = ORIGMARK;
4109             if (did_pipes) {
4110                 int errkid;
4111                 int n = 0, n1;
4112
4113                 while (n < sizeof(int)) {
4114                     n1 = PerlLIO_read(pp[0],
4115                                       (void*)(((char*)&errkid)+n),
4116                                       (sizeof(int)) - n);
4117                     if (n1 <= 0)
4118                         break;
4119                     n += n1;
4120                 }
4121                 PerlLIO_close(pp[0]);
4122                 if (n) {                        /* Error */
4123                     if (n != sizeof(int))
4124                         DIE(aTHX_ "panic: kid popen errno read");
4125                     errno = errkid;             /* Propagate errno from kid */
4126                     STATUS_CURRENT = -1;
4127                 }
4128             }
4129             PUSHi(STATUS_CURRENT);
4130             RETURN;
4131         }
4132         if (did_pipes) {
4133             PerlLIO_close(pp[0]);
4134 #if defined(HAS_FCNTL) && defined(F_SETFD)
4135             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4136 #endif
4137         }
4138         if (PL_op->op_flags & OPf_STACKED) {
4139             SV *really = *++MARK;
4140             value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4141         }
4142         else if (SP - MARK != 1)
4143             value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
4144         else {
4145             value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
4146         }
4147         PerlProc__exit(-1);
4148     }
4149 #else /* ! FORK or VMS or OS/2 */
4150     PL_statusvalue = 0;
4151     result = 0;
4152     if (PL_op->op_flags & OPf_STACKED) {
4153         SV *really = *++MARK;
4154         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4155     }
4156     else if (SP - MARK != 1)
4157         value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
4158     else {
4159         value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
4160     }
4161     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4162         result = 1;
4163     STATUS_NATIVE_SET(value);
4164     do_execfree();
4165     SP = ORIGMARK;
4166     PUSHi(result ? value : STATUS_CURRENT);
4167 #endif /* !FORK or VMS */
4168     RETURN;
4169 }
4170
4171 PP(pp_exec)
4172 {
4173     dSP; dMARK; dORIGMARK; dTARGET;
4174     I32 value;
4175     STRLEN n_a;
4176
4177     if (PL_tainting) {
4178         TAINT_ENV();
4179         while (++MARK <= SP) {
4180             (void)SvPV_nolen(*MARK);      /* stringify for taint check */
4181             if (PL_tainted)
4182                 break;
4183         }
4184         MARK = ORIGMARK;
4185         /* XXX Remove warning at end of deprecation cycle --RD 2002-02  */
4186         if (SP - MARK == 1) {
4187             TAINT_PROPER("exec");
4188         }
4189         else if (ckWARN2(WARN_TAINT, WARN_DEPRECATED)) {
4190             Perl_warner(aTHX_ packWARN2(WARN_TAINT, WARN_DEPRECATED),
4191                 "Use of tainted arguments in %s is deprecated", "exec");
4192         }
4193     }
4194     PERL_FLUSHALL_FOR_CHILD;
4195     if (PL_op->op_flags & OPf_STACKED) {
4196         SV *really = *++MARK;
4197         value = (I32)do_aexec(really, MARK, SP);
4198     }
4199     else if (SP - MARK != 1)
4200 #ifdef VMS
4201         value = (I32)vms_do_aexec(Nullsv, MARK, SP);
4202 #else
4203 #  ifdef __OPEN_VM
4204         {
4205            (void ) do_aspawn(Nullsv, MARK, SP);
4206            value = 0;
4207         }
4208 #  else
4209         value = (I32)do_aexec(Nullsv, MARK, SP);
4210 #  endif
4211 #endif
4212     else {
4213 #ifdef VMS
4214         value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
4215 #else
4216 #  ifdef __OPEN_VM
4217         (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
4218         value = 0;
4219 #  else
4220         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
4221 #  endif
4222 #endif
4223     }
4224
4225     SP = ORIGMARK;
4226     PUSHi(value);
4227     RETURN;
4228 }
4229
4230 PP(pp_kill)
4231 {
4232 #ifdef HAS_KILL
4233     dSP; dMARK; dTARGET;
4234     I32 value;
4235     value = (I32)apply(PL_op->op_type, MARK, SP);
4236     SP = MARK;
4237     PUSHi(value);
4238     RETURN;
4239 #else
4240     DIE(aTHX_ PL_no_func, "kill");
4241 #endif
4242 }
4243
4244 PP(pp_getppid)
4245 {
4246 #ifdef HAS_GETPPID
4247     dSP; dTARGET;
4248     XPUSHi( getppid() );
4249     RETURN;
4250 #else
4251     DIE(aTHX_ PL_no_func, "getppid");
4252 #endif
4253 }
4254
4255 PP(pp_getpgrp)
4256 {
4257 #ifdef HAS_GETPGRP
4258     dSP; dTARGET;
4259     Pid_t pid;
4260     Pid_t pgrp;
4261
4262     if (MAXARG < 1)
4263         pid = 0;
4264     else
4265         pid = SvIVx(POPs);
4266 #ifdef BSD_GETPGRP
4267     pgrp = (I32)BSD_GETPGRP(pid);
4268 #else
4269     if (pid != 0 && pid != PerlProc_getpid())
4270         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4271     pgrp = getpgrp();
4272 #endif
4273     XPUSHi(pgrp);
4274     RETURN;
4275 #else
4276     DIE(aTHX_ PL_no_func, "getpgrp()");
4277 #endif
4278 }
4279
4280 PP(pp_setpgrp)
4281 {
4282 #ifdef HAS_SETPGRP
4283     dSP; dTARGET;
4284     Pid_t pgrp;
4285     Pid_t pid;
4286     if (MAXARG < 2) {
4287         pgrp = 0;
4288         pid = 0;
4289     }
4290     else {
4291         pgrp = POPi;
4292         pid = TOPi;
4293     }
4294
4295     TAINT_PROPER("setpgrp");
4296 #ifdef BSD_SETPGRP
4297     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4298 #else
4299     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4300         || (pid != 0 && pid != PerlProc_getpid()))
4301     {
4302         DIE(aTHX_ "setpgrp can't take arguments");
4303     }
4304     SETi( setpgrp() >= 0 );
4305 #endif /* USE_BSDPGRP */
4306     RETURN;
4307 #else
4308     DIE(aTHX_ PL_no_func, "setpgrp()");
4309 #endif
4310 }
4311
4312 PP(pp_getpriority)
4313 {
4314 #ifdef HAS_GETPRIORITY
4315     dSP; dTARGET;
4316     int who = POPi;
4317     int which = TOPi;
4318     SETi( getpriority(which, who) );
4319     RETURN;
4320 #else
4321     DIE(aTHX_ PL_no_func, "getpriority()");
4322 #endif
4323 }
4324
4325 PP(pp_setpriority)
4326 {
4327 #ifdef HAS_SETPRIORITY
4328     dSP; dTARGET;
4329     int niceval = POPi;
4330     int who = POPi;
4331     int which = TOPi;
4332     TAINT_PROPER("setpriority");
4333     SETi( setpriority(which, who, niceval) >= 0 );
4334     RETURN;
4335 #else
4336     DIE(aTHX_ PL_no_func, "setpriority()");
4337 #endif
4338 }
4339
4340 /* Time calls. */
4341
4342 PP(pp_time)
4343 {
4344     dSP; dTARGET;
4345 #ifdef BIG_TIME
4346     XPUSHn( time(Null(Time_t*)) );
4347 #else
4348     XPUSHi( time(Null(Time_t*)) );
4349 #endif
4350     RETURN;
4351 }
4352
4353 /* XXX The POSIX name is CLK_TCK; it is to be preferred
4354    to HZ.  Probably.  For now, assume that if the system
4355    defines HZ, it does so correctly.  (Will this break
4356    on VMS?)
4357    Probably we ought to use _sysconf(_SC_CLK_TCK), if
4358    it's supported.    --AD  9/96.
4359 */
4360
4361 #ifdef __BEOS__
4362 #  define HZ 1000000
4363 #endif
4364
4365 #ifndef HZ
4366 #  ifdef CLK_TCK
4367 #    define HZ CLK_TCK
4368 #  else
4369 #    define HZ 60
4370 #  endif
4371 #endif
4372
4373 PP(pp_tms)
4374 {
4375 #ifdef HAS_TIMES
4376     dSP;
4377     EXTEND(SP, 4);
4378 #ifndef VMS
4379     (void)PerlProc_times(&PL_timesbuf);
4380 #else
4381     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4382                                                    /* struct tms, though same data   */
4383                                                    /* is returned.                   */
4384 #endif
4385
4386     PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
4387     if (GIMME == G_ARRAY) {
4388         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4389         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4390         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
4391     }
4392     RETURN;
4393 #else
4394     DIE(aTHX_ "times not implemented");
4395 #endif /* HAS_TIMES */
4396 }
4397
4398 PP(pp_localtime)
4399 {
4400     return pp_gmtime();
4401 }
4402
4403 PP(pp_gmtime)
4404 {
4405     dSP;
4406     Time_t when;
4407     struct tm *tmbuf;
4408     static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4409     static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4410                               "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4411
4412     if (MAXARG < 1)
4413         (void)time(&when);
4414     else
4415 #ifdef BIG_TIME
4416         when = (Time_t)SvNVx(POPs);
4417 #else
4418         when = (Time_t)SvIVx(POPs);
4419 #endif
4420
4421     if (PL_op->op_type == OP_LOCALTIME)
4422         tmbuf = localtime(&when);
4423     else
4424         tmbuf = gmtime(&when);
4425
4426     if (GIMME != G_ARRAY) {
4427         SV *tsv;
4428         EXTEND(SP, 1);
4429         EXTEND_MORTAL(1);
4430         if (!tmbuf)
4431             RETPUSHUNDEF;
4432         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4433                             dayname[tmbuf->tm_wday],
4434                             monname[tmbuf->tm_mon],
4435                             tmbuf->tm_mday,
4436                             tmbuf->tm_hour,
4437                             tmbuf->tm_min,
4438                             tmbuf->tm_sec,
4439                             tmbuf->tm_year + 1900);
4440         PUSHs(sv_2mortal(tsv));
4441     }
4442     else if (tmbuf) {
4443         EXTEND(SP, 9);
4444         EXTEND_MORTAL(9);
4445         PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4446         PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4447         PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4448         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4449         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4450         PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4451         PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4452         PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4453         PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4454     }
4455     RETURN;
4456 }
4457
4458 PP(pp_alarm)
4459 {
4460 #ifdef HAS_ALARM
4461     dSP; dTARGET;
4462     int anum;
4463     anum = POPi;
4464     anum = alarm((unsigned int)anum);
4465     EXTEND(SP, 1);
4466     if (anum < 0)
4467         RETPUSHUNDEF;
4468     PUSHi(anum);
4469     RETURN;
4470 #else
4471     DIE(aTHX_ PL_no_func, "alarm");
4472 #endif
4473 }
4474
4475 PP(pp_sleep)
4476 {
4477     dSP; dTARGET;
4478     I32 duration;
4479     Time_t lasttime;
4480     Time_t when;
4481
4482     (void)time(&lasttime);
4483     if (MAXARG < 1)
4484         PerlProc_pause();
4485     else {
4486         duration = POPi;
4487         PerlProc_sleep((unsigned int)duration);
4488     }
4489     (void)time(&when);
4490     XPUSHi(when - lasttime);
4491     RETURN;
4492 }
4493
4494 /* Shared memory. */
4495
4496 PP(pp_shmget)
4497 {
4498     return pp_semget();
4499 }
4500
4501 PP(pp_shmctl)
4502 {
4503     return pp_semctl();
4504 }
4505
4506 PP(pp_shmread)
4507 {
4508     return pp_shmwrite();
4509 }
4510
4511 PP(pp_shmwrite)
4512 {
4513 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4514     dSP; dMARK; dTARGET;
4515     I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
4516     SP = MARK;
4517     PUSHi(value);
4518     RETURN;
4519 #else
4520     return pp_semget();
4521 #endif
4522 }
4523
4524 /* Message passing. */
4525
4526 PP(pp_msgget)
4527 {
4528     return pp_semget();
4529 }
4530
4531 PP(pp_msgctl)
4532 {
4533     return pp_semctl();
4534 }
4535
4536 PP(pp_msgsnd)
4537 {
4538 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4539     dSP; dMARK; dTARGET;
4540     I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4541     SP = MARK;
4542     PUSHi(value);
4543     RETURN;
4544 #else
4545     return pp_semget();
4546 #endif
4547 }
4548
4549 PP(pp_msgrcv)
4550 {
4551 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4552     dSP; dMARK; dTARGET;
4553     I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4554     SP = MARK;
4555     PUSHi(value);
4556     RETURN;
4557 #else
4558     return pp_semget();
4559 #endif
4560 }
4561
4562 /* Semaphores. */
4563
4564 PP(pp_semget)
4565 {
4566 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4567     dSP; dMARK; dTARGET;
4568     int anum = do_ipcget(PL_op->op_type, MARK, SP);
4569     SP = MARK;
4570     if (anum == -1)
4571         RETPUSHUNDEF;
4572     PUSHi(anum);
4573     RETURN;
4574 #else
4575     DIE(aTHX_ "System V IPC is not implemented on this machine");
4576 #endif
4577 }
4578
4579 PP(pp_semctl)
4580 {
4581 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4582     dSP; dMARK; dTARGET;
4583     int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4584     SP = MARK;
4585     if (anum == -1)
4586         RETSETUNDEF;
4587     if (anum != 0) {
4588         PUSHi(anum);
4589     }
4590     else {
4591         PUSHp(zero_but_true, ZBTLEN);
4592     }
4593     RETURN;
4594 #else
4595     return pp_semget();
4596 #endif
4597 }
4598
4599 PP(pp_semop)
4600 {
4601 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4602     dSP; dMARK; dTARGET;
4603     I32 value = (I32)(do_semop(MARK, SP) >= 0);
4604     SP = MARK;
4605     PUSHi(value);
4606     RETURN;
4607 #else
4608     return pp_semget();
4609 #endif
4610 }
4611
4612 /* Get system info. */
4613
4614 PP(pp_ghbyname)
4615 {
4616 #ifdef HAS_GETHOSTBYNAME
4617     return pp_ghostent();
4618 #else
4619     DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4620 #endif
4621 }
4622
4623 PP(pp_ghbyaddr)
4624 {
4625 #ifdef HAS_GETHOSTBYADDR
4626     return pp_ghostent();
4627 #else
4628     DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4629 #endif
4630 }
4631
4632 PP(pp_ghostent)
4633 {
4634 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4635     dSP;
4636     I32 which = PL_op->op_type;
4637     register char **elem;
4638     register SV *sv;
4639 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4640     struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4641     struct hostent *gethostbyname(Netdb_name_t);
4642     struct hostent *gethostent(void);
4643 #endif
4644     struct hostent *hent;
4645     unsigned long len;
4646     STRLEN n_a;
4647
4648     EXTEND(SP, 10);
4649     if (which == OP_GHBYNAME) {
4650 #ifdef HAS_GETHOSTBYNAME
4651         char* name = POPpbytex;
4652         hent = PerlSock_gethostbyname(name);
4653 #else
4654         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4655 #endif
4656     }
4657     else if (which == OP_GHBYADDR) {
4658 #ifdef HAS_GETHOSTBYADDR
4659         int addrtype = POPi;
4660         SV *addrsv = POPs;
4661         STRLEN addrlen;
4662         Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
4663
4664         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4665 #else
4666         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4667 #endif
4668     }
4669     else
4670 #ifdef HAS_GETHOSTENT
4671         hent = PerlSock_gethostent();
4672 #else
4673         DIE(aTHX_ PL_no_sock_func, "gethostent");
4674 #endif
4675
4676 #ifdef HOST_NOT_FOUND
4677         if (!hent) {
4678 #ifdef USE_REENTRANT_API
4679 #   ifdef USE_GETHOSTENT_ERRNO
4680             h_errno = PL_reentrant_buffer->_gethostent_errno;
4681 #   endif
4682 #endif
4683             STATUS_NATIVE_SET(h_errno);
4684         }
4685 #endif
4686
4687     if (GIMME != G_ARRAY) {
4688         PUSHs(sv = sv_newmortal());
4689         if (hent) {
4690             if (which == OP_GHBYNAME) {
4691                 if (hent->h_addr)
4692                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4693             }
4694             else
4695                 sv_setpv(sv, (char*)hent->h_name);
4696         }
4697         RETURN;
4698     }
4699
4700     if (hent) {
4701         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4702         sv_setpv(sv, (char*)hent->h_name);
4703         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4704         for (elem = hent->h_aliases; elem && *elem; elem++) {
4705             sv_catpv(sv, *elem);
4706             if (elem[1])
4707                 sv_catpvn(sv, " ", 1);
4708         }
4709         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4710         sv_setiv(sv, (IV)hent->h_addrtype);
4711         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4712         len = hent->h_length;
4713         sv_setiv(sv, (IV)len);
4714 #ifdef h_addr
4715         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4716             XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
4717             sv_setpvn(sv, *elem, len);
4718         }
4719 #else
4720         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4721         if (hent->h_addr)
4722             sv_setpvn(sv, hent->h_addr, len);
4723 #endif /* h_addr */
4724     }
4725     RETURN;
4726 #else
4727     DIE(aTHX_ PL_no_sock_func, "gethostent");
4728 #endif
4729 }
4730
4731 PP(pp_gnbyname)
4732 {
4733 #ifdef HAS_GETNETBYNAME
4734     return pp_gnetent();
4735 #else
4736     DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4737 #endif
4738 }
4739
4740 PP(pp_gnbyaddr)
4741 {
4742 #ifdef HAS_GETNETBYADDR
4743     return pp_gnetent();
4744 #else
4745     DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4746 #endif
4747 }
4748
4749 PP(pp_gnetent)
4750 {
4751 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4752     dSP;
4753     I32 which = PL_op->op_type;
4754     register char **elem;
4755     register SV *sv;
4756 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4757     struct netent *getnetbyaddr(Netdb_net_t, int);
4758     struct netent *getnetbyname(Netdb_name_t);
4759     struct netent *getnetent(void);
4760 #endif
4761     struct netent *nent;
4762     STRLEN n_a;
4763
4764     if (which == OP_GNBYNAME){
4765 #ifdef HAS_GETNETBYNAME
4766         char *name = POPpbytex;
4767         nent = PerlSock_getnetbyname(name);
4768 #else
4769         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4770 #endif
4771     }
4772     else if (which == OP_GNBYADDR) {
4773 #ifdef HAS_GETNETBYADDR
4774         int addrtype = POPi;
4775         Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4776         nent = PerlSock_getnetbyaddr(addr, addrtype);
4777 #else
4778         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4779 #endif
4780     }
4781     else
4782 #ifdef HAS_GETNETENT
4783         nent = PerlSock_getnetent();
4784 #else
4785         DIE(aTHX_ PL_no_sock_func, "getnetent");
4786 #endif
4787
4788 #ifdef HOST_NOT_FOUND
4789         if (!nent) {
4790 #ifdef USE_REENTRANT_API
4791 #   ifdef USE_GETNETENT_ERRNO
4792              h_errno = PL_reentrant_buffer->_getnetent_errno;
4793 #   endif
4794 #endif
4795             STATUS_NATIVE_SET(h_errno);
4796         }
4797 #endif
4798
4799     EXTEND(SP, 4);
4800     if (GIMME != G_ARRAY) {
4801         PUSHs(sv = sv_newmortal());
4802         if (nent) {
4803             if (which == OP_GNBYNAME)
4804                 sv_setiv(sv, (IV)nent->n_net);
4805             else
4806                 sv_setpv(sv, nent->n_name);
4807         }
4808         RETURN;
4809     }
4810
4811     if (nent) {
4812         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4813         sv_setpv(sv, nent->n_name);
4814         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4815         for (elem = nent->n_aliases; elem && *elem; elem++) {
4816             sv_catpv(sv, *elem);
4817             if (elem[1])
4818                 sv_catpvn(sv, " ", 1);
4819         }
4820         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4821         sv_setiv(sv, (IV)nent->n_addrtype);
4822         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4823         sv_setiv(sv, (IV)nent->n_net);
4824     }
4825
4826     RETURN;
4827 #else
4828     DIE(aTHX_ PL_no_sock_func, "getnetent");
4829 #endif
4830 }
4831
4832 PP(pp_gpbyname)
4833 {
4834 #ifdef HAS_GETPROTOBYNAME
4835     return pp_gprotoent();
4836 #else
4837     DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4838 #endif
4839 }
4840
4841 PP(pp_gpbynumber)
4842 {
4843 #ifdef HAS_GETPROTOBYNUMBER
4844     return pp_gprotoent();
4845 #else
4846     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4847 #endif
4848 }
4849
4850 PP(pp_gprotoent)
4851 {
4852 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4853     dSP;
4854     I32 which = PL_op->op_type;
4855     register char **elem;
4856     register SV *sv;
4857 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4858     struct protoent *getprotobyname(Netdb_name_t);
4859     struct protoent *getprotobynumber(int);
4860     struct protoent *getprotoent(void);
4861 #endif
4862     struct protoent *pent;
4863     STRLEN n_a;
4864
4865     if (which == OP_GPBYNAME) {
4866 #ifdef HAS_GETPROTOBYNAME
4867         char* name = POPpbytex;
4868         pent = PerlSock_getprotobyname(name);
4869 #else
4870         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4871 #endif
4872     }
4873     else if (which == OP_GPBYNUMBER) {
4874 #ifdef HAS_GETPROTOBYNUMBER
4875         int number = POPi;
4876         pent = PerlSock_getprotobynumber(number);
4877 #else
4878         DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4879 #endif
4880     }
4881     else
4882 #ifdef HAS_GETPROTOENT
4883         pent = PerlSock_getprotoent();
4884 #else
4885         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4886 #endif
4887
4888     EXTEND(SP, 3);
4889     if (GIMME != G_ARRAY) {
4890         PUSHs(sv = sv_newmortal());
4891         if (pent) {
4892             if (which == OP_GPBYNAME)
4893                 sv_setiv(sv, (IV)pent->p_proto);
4894             else
4895                 sv_setpv(sv, pent->p_name);
4896         }
4897         RETURN;
4898     }
4899
4900     if (pent) {
4901         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4902         sv_setpv(sv, pent->p_name);
4903         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4904         for (elem = pent->p_aliases; elem && *elem; elem++) {
4905             sv_catpv(sv, *elem);
4906             if (elem[1])
4907                 sv_catpvn(sv, " ", 1);
4908         }
4909         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4910         sv_setiv(sv, (IV)pent->p_proto);
4911     }
4912
4913     RETURN;
4914 #else
4915     DIE(aTHX_ PL_no_sock_func, "getprotoent");
4916 #endif
4917 }
4918
4919 PP(pp_gsbyname)
4920 {
4921 #ifdef HAS_GETSERVBYNAME
4922     return pp_gservent();
4923 #else
4924     DIE(aTHX_ PL_no_sock_func, "getservbyname");
4925 #endif
4926 }
4927
4928 PP(pp_gsbyport)
4929 {
4930 #ifdef HAS_GETSERVBYPORT
4931     return pp_gservent();
4932 #else
4933     DIE(aTHX_ PL_no_sock_func, "getservbyport");
4934 #endif
4935 }
4936
4937 PP(pp_gservent)
4938 {
4939 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4940     dSP;
4941     I32 which = PL_op->op_type;
4942     register char **elem;
4943     register SV *sv;
4944 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4945     struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4946     struct servent *getservbyport(int, Netdb_name_t);
4947     struct servent *getservent(void);
4948 #endif
4949     struct servent *sent;
4950     STRLEN n_a;
4951
4952     if (which == OP_GSBYNAME) {
4953 #ifdef HAS_GETSERVBYNAME
4954         char *proto = POPpbytex;
4955         char *name = POPpbytex;
4956
4957         if (proto && !*proto)
4958             proto = Nullch;
4959
4960         sent = PerlSock_getservbyname(name, proto);
4961 #else
4962         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4963 #endif
4964     }
4965     else if (which == OP_GSBYPORT) {
4966 #ifdef HAS_GETSERVBYPORT
4967         char *proto = POPpbytex;
4968         unsigned short port = (unsigned short)POPu;
4969
4970 #ifdef HAS_HTONS
4971         port = PerlSock_htons(port);
4972 #endif
4973         sent = PerlSock_getservbyport(port, proto);
4974 #else
4975         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4976 #endif
4977     }
4978     else
4979 #ifdef HAS_GETSERVENT
4980         sent = PerlSock_getservent();
4981 #else
4982         DIE(aTHX_ PL_no_sock_func, "getservent");
4983 #endif
4984
4985     EXTEND(SP, 4);
4986     if (GIMME != G_ARRAY) {
4987         PUSHs(sv = sv_newmortal());
4988         if (sent) {
4989             if (which == OP_GSBYNAME) {
4990 #ifdef HAS_NTOHS
4991                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4992 #else
4993                 sv_setiv(sv, (IV)(sent->s_port));
4994 #endif
4995             }
4996             else
4997                 sv_setpv(sv, sent->s_name);
4998         }
4999         RETURN;
5000     }
5001
5002     if (sent) {
5003         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5004         sv_setpv(sv, sent->s_name);
5005         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5006         for (elem = sent->s_aliases; elem && *elem; elem++) {
5007             sv_catpv(sv, *elem);
5008             if (elem[1])
5009                 sv_catpvn(sv, " ", 1);
5010         }
5011         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5012 #ifdef HAS_NTOHS
5013         sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5014 #else
5015         sv_setiv(sv, (IV)(sent->s_port));
5016 #endif
5017         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5018         sv_setpv(sv, sent->s_proto);
5019     }
5020
5021     RETURN;
5022 #else
5023     DIE(aTHX_ PL_no_sock_func, "getservent");
5024 #endif
5025 }
5026
5027 PP(pp_shostent)
5028 {
5029 #ifdef HAS_SETHOSTENT
5030     dSP;
5031     PerlSock_sethostent(TOPi);
5032     RETSETYES;
5033 #else
5034     DIE(aTHX_ PL_no_sock_func, "sethostent");
5035 #endif
5036 }
5037
5038 PP(pp_snetent)
5039 {
5040 #ifdef HAS_SETNETENT
5041     dSP;
5042     PerlSock_setnetent(TOPi);
5043     RETSETYES;
5044 #else
5045     DIE(aTHX_ PL_no_sock_func, "setnetent");
5046 #endif
5047 }
5048
5049 PP(pp_sprotoent)
5050 {
5051 #ifdef HAS_SETPROTOENT
5052     dSP;
5053     PerlSock_setprotoent(TOPi);
5054     RETSETYES;
5055 #else
5056     DIE(aTHX_ PL_no_sock_func, "setprotoent");
5057 #endif
5058 }
5059
5060 PP(pp_sservent)
5061 {
5062 #ifdef HAS_SETSERVENT
5063     dSP;
5064     PerlSock_setservent(TOPi);
5065     RETSETYES;
5066 #else
5067     DIE(aTHX_ PL_no_sock_func, "setservent");
5068 #endif
5069 }
5070
5071 PP(pp_ehostent)
5072 {
5073 #ifdef HAS_ENDHOSTENT
5074     dSP;
5075     PerlSock_endhostent();
5076     EXTEND(SP,1);
5077     RETPUSHYES;
5078 #else
5079     DIE(aTHX_ PL_no_sock_func, "endhostent");
5080 #endif
5081 }
5082
5083 PP(pp_enetent)
5084 {
5085 #ifdef HAS_ENDNETENT
5086     dSP;
5087     PerlSock_endnetent();
5088     EXTEND(SP,1);
5089     RETPUSHYES;
5090 #else
5091     DIE(aTHX_ PL_no_sock_func, "endnetent");
5092 #endif
5093 }
5094
5095 PP(pp_eprotoent)
5096 {
5097 #ifdef HAS_ENDPROTOENT
5098     dSP;
5099     PerlSock_endprotoent();
5100     EXTEND(SP,1);
5101     RETPUSHYES;
5102 #else
5103     DIE(aTHX_ PL_no_sock_func, "endprotoent");
5104 #endif
5105 }
5106
5107 PP(pp_eservent)
5108 {
5109 #ifdef HAS_ENDSERVENT
5110     dSP;
5111     PerlSock_endservent();
5112     EXTEND(SP,1);
5113     RETPUSHYES;
5114 #else
5115     DIE(aTHX_ PL_no_sock_func, "endservent");
5116 #endif
5117 }
5118
5119 PP(pp_gpwnam)
5120 {
5121 #ifdef HAS_PASSWD
5122     return pp_gpwent();
5123 #else
5124     DIE(aTHX_ PL_no_func, "getpwnam");
5125 #endif
5126 }
5127
5128 PP(pp_gpwuid)
5129 {
5130 #ifdef HAS_PASSWD
5131     return pp_gpwent();
5132 #else
5133     DIE(aTHX_ PL_no_func, "getpwuid");
5134 #endif
5135 }
5136
5137 PP(pp_gpwent)
5138 {
5139 #ifdef HAS_PASSWD
5140     dSP;
5141     I32 which = PL_op->op_type;
5142     register SV *sv;
5143     STRLEN n_a;
5144     struct passwd *pwent  = NULL;
5145     /*
5146      * We currently support only the SysV getsp* shadow password interface.
5147      * The interface is declared in <shadow.h> and often one needs to link
5148      * with -lsecurity or some such.
5149      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5150      * (and SCO?)
5151      *
5152      * AIX getpwnam() is clever enough to return the encrypted password
5153      * only if the caller (euid?) is root.
5154      *
5155      * There are at least two other shadow password APIs.  Many platforms
5156      * seem to contain more than one interface for accessing the shadow
5157      * password databases, possibly for compatibility reasons.
5158      * The getsp*() is by far he simplest one, the other two interfaces
5159      * are much more complicated, but also very similar to each other.
5160      *
5161      * <sys/types.h>
5162      * <sys/security.h>
5163      * <prot.h>
5164      * struct pr_passwd *getprpw*();
5165      * The password is in
5166      * char getprpw*(...).ufld.fd_encrypt[]
5167      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5168      *
5169      * <sys/types.h>
5170      * <sys/security.h>
5171      * <prot.h>
5172      * struct es_passwd *getespw*();
5173      * The password is in
5174      * char *(getespw*(...).ufld.fd_encrypt)
5175      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5176      *
5177      * Mention I_PROT here so that Configure probes for it.
5178      *
5179      * In HP-UX for getprpw*() the manual page claims that one should include
5180      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5181      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5182      * and pp_sys.c already includes <shadow.h> if there is such.
5183      *
5184      * Note that <sys/security.h> is already probed for, but currently
5185      * it is only included in special cases.
5186      *
5187      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5188      * be preferred interface, even though also the getprpw*() interface
5189      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5190      * One also needs to call set_auth_parameters() in main() before
5191      * doing anything else, whether one is using getespw*() or getprpw*().
5192      *
5193      * Note that accessing the shadow databases can be magnitudes
5194      * slower than accessing the standard databases.
5195      *
5196      * --jhi
5197      */
5198
5199     switch (which) {
5200     case OP_GPWNAM:
5201       {
5202         char* name = POPpbytex;
5203         pwent  = getpwnam(name);
5204       }
5205       break;
5206     case OP_GPWUID:
5207       {
5208         Uid_t uid = POPi;
5209         pwent = getpwuid(uid);
5210       }
5211         break;
5212     case OP_GPWENT:
5213 #   ifdef HAS_GETPWENT
5214         pwent  = getpwent();
5215 #   else
5216         DIE(aTHX_ PL_no_func, "getpwent");
5217 #   endif
5218         break;
5219     }
5220
5221     EXTEND(SP, 10);
5222     if (GIMME != G_ARRAY) {
5223         PUSHs(sv = sv_newmortal());
5224         if (pwent) {
5225             if (which == OP_GPWNAM)
5226 #   if Uid_t_sign <= 0
5227                 sv_setiv(sv, (IV)pwent->pw_uid);
5228 #   else
5229                 sv_setuv(sv, (UV)pwent->pw_uid);
5230 #   endif
5231             else
5232                 sv_setpv(sv, pwent->pw_name);
5233         }
5234         RETURN;
5235     }
5236
5237     if (pwent) {
5238         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5239         sv_setpv(sv, pwent->pw_name);
5240
5241         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5242         SvPOK_off(sv);
5243         /* If we have getspnam(), we try to dig up the shadow
5244          * password.  If we are underprivileged, the shadow
5245          * interface will set the errno to EACCES or similar,
5246          * and return a null pointer.  If this happens, we will
5247          * use the dummy password (usually "*" or "x") from the
5248          * standard password database.
5249          *
5250          * In theory we could skip the shadow call completely
5251          * if euid != 0 but in practice we cannot know which
5252          * security measures are guarding the shadow databases
5253          * on a random platform.
5254          *
5255          * Resist the urge to use additional shadow interfaces.
5256          * Divert the urge to writing an extension instead.
5257          *
5258          * --jhi */
5259 #   ifdef HAS_GETSPNAM
5260         {
5261             struct spwd *spwent;
5262             int saverrno; /* Save and restore errno so that
5263                            * underprivileged attempts seem
5264                            * to have never made the unsccessful
5265                            * attempt to retrieve the shadow password. */
5266
5267             saverrno = errno;
5268             spwent = getspnam(pwent->pw_name);
5269             errno = saverrno;
5270             if (spwent && spwent->sp_pwdp)
5271                 sv_setpv(sv, spwent->sp_pwdp);
5272         }
5273 #   endif
5274 #   ifdef PWPASSWD
5275         if (!SvPOK(sv)) /* Use the standard password, then. */
5276             sv_setpv(sv, pwent->pw_passwd);
5277 #   endif
5278
5279 #   ifndef INCOMPLETE_TAINTS
5280         /* passwd is tainted because user himself can diddle with it.
5281          * admittedly not much and in a very limited way, but nevertheless. */
5282         SvTAINTED_on(sv);
5283 #   endif
5284
5285         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5286 #   if Uid_t_sign <= 0
5287         sv_setiv(sv, (IV)pwent->pw_uid);
5288 #   else
5289         sv_setuv(sv, (UV)pwent->pw_uid);
5290 #   endif
5291
5292         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5293 #   if Uid_t_sign <= 0
5294         sv_setiv(sv, (IV)pwent->pw_gid);
5295 #   else
5296         sv_setuv(sv, (UV)pwent->pw_gid);
5297 #   endif
5298         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5299          * because of the poor interface of the Perl getpw*(),
5300          * not because there's some standard/convention saying so.
5301          * A better interface would have been to return a hash,
5302          * but we are accursed by our history, alas. --jhi.  */
5303         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5304 #   ifdef PWCHANGE
5305         sv_setiv(sv, (IV)pwent->pw_change);
5306 #   else
5307 #       ifdef PWQUOTA
5308         sv_setiv(sv, (IV)pwent->pw_quota);
5309 #       else
5310 #           ifdef PWAGE
5311         sv_setpv(sv, pwent->pw_age);
5312 #           endif
5313 #       endif
5314 #   endif
5315
5316         /* pw_class and pw_comment are mutually exclusive--.
5317          * see the above note for pw_change, pw_quota, and pw_age. */
5318         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5319 #   ifdef PWCLASS
5320         sv_setpv(sv, pwent->pw_class);
5321 #   else
5322 #       ifdef PWCOMMENT
5323         sv_setpv(sv, pwent->pw_comment);
5324 #       endif
5325 #   endif
5326
5327         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5328 #   ifdef PWGECOS
5329         sv_setpv(sv, pwent->pw_gecos);
5330 #   endif
5331 #   ifndef INCOMPLETE_TAINTS
5332         /* pw_gecos is tainted because user himself can diddle with it. */
5333         SvTAINTED_on(sv);
5334 #   endif
5335
5336         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5337         sv_setpv(sv, pwent->pw_dir);
5338
5339         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5340         sv_setpv(sv, pwent->pw_shell);
5341 #   ifndef INCOMPLETE_TAINTS
5342         /* pw_shell is tainted because user himself can diddle with it. */
5343         SvTAINTED_on(sv);
5344 #   endif
5345
5346 #   ifdef PWEXPIRE
5347         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5348         sv_setiv(sv, (IV)pwent->pw_expire);
5349 #   endif
5350     }
5351     RETURN;
5352 #else
5353     DIE(aTHX_ PL_no_func, "getpwent");
5354 #endif
5355 }
5356
5357 PP(pp_spwent)
5358 {
5359 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5360     dSP;
5361     setpwent();
5362     RETPUSHYES;
5363 #else
5364     DIE(aTHX_ PL_no_func, "setpwent");
5365 #endif
5366 }
5367
5368 PP(pp_epwent)
5369 {
5370 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5371     dSP;
5372     endpwent();
5373     RETPUSHYES;
5374 #else
5375     DIE(aTHX_ PL_no_func, "endpwent");
5376 #endif
5377 }
5378
5379 PP(pp_ggrnam)
5380 {
5381 #ifdef HAS_GROUP
5382     return pp_ggrent();
5383 #else
5384     DIE(aTHX_ PL_no_func, "getgrnam");
5385 #endif
5386 }
5387
5388 PP(pp_ggrgid)
5389 {
5390 #ifdef HAS_GROUP
5391     return pp_ggrent();
5392 #else
5393     DIE(aTHX_ PL_no_func, "getgrgid");
5394 #endif
5395 }
5396
5397 PP(pp_ggrent)
5398 {
5399 #ifdef HAS_GROUP
5400     dSP;
5401     I32 which = PL_op->op_type;
5402     register char **elem;
5403     register SV *sv;
5404     struct group *grent;
5405     STRLEN n_a;
5406
5407     if (which == OP_GGRNAM) {
5408         char* name = POPpbytex;
5409         grent = (struct group *)getgrnam(name);
5410     }
5411     else if (which == OP_GGRGID) {
5412         Gid_t gid = POPi;
5413         grent = (struct group *)getgrgid(gid);
5414     }
5415     else
5416 #ifdef HAS_GETGRENT
5417         grent = (struct group *)getgrent();
5418 #else
5419         DIE(aTHX_ PL_no_func, "getgrent");
5420 #endif
5421
5422     EXTEND(SP, 4);
5423     if (GIMME != G_ARRAY) {
5424         PUSHs(sv = sv_newmortal());
5425         if (grent) {
5426             if (which == OP_GGRNAM)
5427                 sv_setiv(sv, (IV)grent->gr_gid);
5428             else
5429                 sv_setpv(sv, grent->gr_name);
5430         }
5431         RETURN;
5432     }
5433
5434     if (grent) {
5435         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5436         sv_setpv(sv, grent->gr_name);
5437
5438         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5439 #ifdef GRPASSWD
5440         sv_setpv(sv, grent->gr_passwd);
5441 #endif
5442
5443         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5444         sv_setiv(sv, (IV)grent->gr_gid);
5445
5446 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5447         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5448         /* In UNICOS/mk (_CRAYMPP) the multithreading
5449          * versions (getgrnam_r, getgrgid_r)
5450          * seem to return an illegal pointer
5451          * as the group members list, gr_mem.
5452          * getgrent() doesn't even have a _r version
5453          * but the gr_mem is poisonous anyway.
5454          * So yes, you cannot get the list of group
5455          * members if building multithreaded in UNICOS/mk. */
5456         for (elem = grent->gr_mem; elem && *elem; elem++) {
5457             sv_catpv(sv, *elem);
5458             if (elem[1])
5459                 sv_catpvn(sv, " ", 1);
5460         }
5461 #endif
5462     }
5463
5464     RETURN;
5465 #else
5466     DIE(aTHX_ PL_no_func, "getgrent");
5467 #endif
5468 }
5469
5470 PP(pp_sgrent)
5471 {
5472 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5473     dSP;
5474     setgrent();
5475     RETPUSHYES;
5476 #else
5477     DIE(aTHX_ PL_no_func, "setgrent");
5478 #endif
5479 }
5480
5481 PP(pp_egrent)
5482 {
5483 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5484     dSP;
5485     endgrent();
5486     RETPUSHYES;
5487 #else
5488     DIE(aTHX_ PL_no_func, "endgrent");
5489 #endif
5490 }
5491
5492 PP(pp_getlogin)
5493 {
5494 #ifdef HAS_GETLOGIN
5495     dSP; dTARGET;
5496     char *tmps;
5497     EXTEND(SP, 1);
5498     if (!(tmps = PerlProc_getlogin()))
5499         RETPUSHUNDEF;
5500     PUSHp(tmps, strlen(tmps));
5501     RETURN;
5502 #else
5503     DIE(aTHX_ PL_no_func, "getlogin");
5504 #endif
5505 }
5506
5507 /* Miscellaneous. */
5508
5509 PP(pp_syscall)
5510 {
5511 #ifdef HAS_SYSCALL
5512     dSP; dMARK; dORIGMARK; dTARGET;
5513     register I32 items = SP - MARK;
5514     unsigned long a[20];
5515     register I32 i = 0;
5516     I32 retval = -1;
5517     STRLEN n_a;
5518
5519     if (PL_tainting) {
5520         while (++MARK <= SP) {
5521             if (SvTAINTED(*MARK)) {
5522                 TAINT;
5523                 break;
5524             }
5525         }
5526         MARK = ORIGMARK;
5527         TAINT_PROPER("syscall");
5528     }
5529
5530     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5531      * or where sizeof(long) != sizeof(char*).  But such machines will
5532      * not likely have syscall implemented either, so who cares?
5533      */
5534     while (++MARK <= SP) {
5535         if (SvNIOK(*MARK) || !i)
5536             a[i++] = SvIV(*MARK);
5537         else if (*MARK == &PL_sv_undef)
5538             a[i++] = 0;
5539         else
5540             a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
5541         if (i > 15)
5542             break;
5543     }
5544     switch (items) {
5545     default:
5546         DIE(aTHX_ "Too many args to syscall");
5547     case 0:
5548         DIE(aTHX_ "Too few args to syscall");
5549     case 1:
5550         retval = syscall(a[0]);
5551         break;
5552     case 2:
5553         retval = syscall(a[0],a[1]);
5554         break;
5555     case 3:
5556         retval = syscall(a[0],a[1],a[2]);
5557         break;
5558     case 4:
5559         retval = syscall(a[0],a[1],a[2],a[3]);
5560         break;
5561     case 5:
5562         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5563         break;
5564     case 6:
5565         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5566         break;
5567     case 7:
5568         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5569         break;
5570     case 8:
5571         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5572         break;
5573 #ifdef atarist
5574     case 9:
5575         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5576         break;
5577     case 10:
5578         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5579         break;
5580     case 11:
5581         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5582           a[10]);
5583         break;
5584     case 12:
5585         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5586           a[10],a[11]);
5587         break;
5588     case 13:
5589         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5590           a[10],a[11],a[12]);
5591         break;
5592     case 14:
5593         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5594           a[10],a[11],a[12],a[13]);
5595         break;
5596 #endif /* atarist */
5597     }
5598     SP = ORIGMARK;
5599     PUSHi(retval);
5600     RETURN;
5601 #else
5602     DIE(aTHX_ PL_no_func, "syscall");
5603 #endif
5604 }
5605
5606 #ifdef FCNTL_EMULATE_FLOCK
5607
5608 /*  XXX Emulate flock() with fcntl().
5609     What's really needed is a good file locking module.
5610 */
5611
5612 static int
5613 fcntl_emulate_flock(int fd, int operation)
5614 {
5615     struct flock flock;
5616
5617     switch (operation & ~LOCK_NB) {
5618     case LOCK_SH:
5619         flock.l_type = F_RDLCK;
5620         break;
5621     case LOCK_EX:
5622         flock.l_type = F_WRLCK;
5623         break;
5624     case LOCK_UN:
5625         flock.l_type = F_UNLCK;
5626         break;
5627     default:
5628         errno = EINVAL;
5629         return -1;
5630     }
5631     flock.l_whence = SEEK_SET;
5632     flock.l_start = flock.l_len = (Off_t)0;
5633
5634     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5635 }
5636
5637 #endif /* FCNTL_EMULATE_FLOCK */
5638
5639 #ifdef LOCKF_EMULATE_FLOCK
5640
5641 /*  XXX Emulate flock() with lockf().  This is just to increase
5642     portability of scripts.  The calls are not completely
5643     interchangeable.  What's really needed is a good file
5644     locking module.
5645 */
5646
5647 /*  The lockf() constants might have been defined in <unistd.h>.
5648     Unfortunately, <unistd.h> causes troubles on some mixed
5649     (BSD/POSIX) systems, such as SunOS 4.1.3.
5650
5651    Further, the lockf() constants aren't POSIX, so they might not be
5652    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5653    just stick in the SVID values and be done with it.  Sigh.
5654 */
5655
5656 # ifndef F_ULOCK
5657 #  define F_ULOCK       0       /* Unlock a previously locked region */
5658 # endif
5659 # ifndef F_LOCK
5660 #  define F_LOCK        1       /* Lock a region for exclusive use */
5661 # endif
5662 # ifndef F_TLOCK
5663 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5664 # endif
5665 # ifndef F_TEST
5666 #  define F_TEST        3       /* Test a region for other processes locks */
5667 # endif
5668
5669 static int
5670 lockf_emulate_flock(int fd, int operation)
5671 {
5672     int i;
5673     int save_errno;
5674     Off_t pos;
5675
5676     /* flock locks entire file so for lockf we need to do the same      */
5677     save_errno = errno;
5678     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5679     if (pos > 0)        /* is seekable and needs to be repositioned     */
5680         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5681             pos = -1;   /* seek failed, so don't seek back afterwards   */
5682     errno = save_errno;
5683
5684     switch (operation) {
5685
5686         /* LOCK_SH - get a shared lock */
5687         case LOCK_SH:
5688         /* LOCK_EX - get an exclusive lock */
5689         case LOCK_EX:
5690             i = lockf (fd, F_LOCK, 0);
5691             break;
5692
5693         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5694         case LOCK_SH|LOCK_NB:
5695         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5696         case LOCK_EX|LOCK_NB:
5697             i = lockf (fd, F_TLOCK, 0);
5698             if (i == -1)
5699                 if ((errno == EAGAIN) || (errno == EACCES))
5700                     errno = EWOULDBLOCK;
5701             break;
5702
5703         /* LOCK_UN - unlock (non-blocking is a no-op) */
5704         case LOCK_UN:
5705         case LOCK_UN|LOCK_NB:
5706             i = lockf (fd, F_ULOCK, 0);
5707             break;
5708
5709         /* Default - can't decipher operation */
5710         default:
5711             i = -1;
5712             errno = EINVAL;
5713             break;
5714     }
5715
5716     if (pos > 0)      /* need to restore position of the handle */
5717         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5718
5719     return (i);
5720 }
5721
5722 #endif /* LOCKF_EMULATE_FLOCK */