pp_sys.c

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