pp_sys.c

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