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