pp_sys.c

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