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