pp_sys.c

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