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