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)
 712     /* ensure close-on-exec */
 713     if ((fcntl(fd[0], F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
 714         (fcntl(fd[1], F_SETFD,fd[1] > PL_maxsysfd) < 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 PL_defoutgv, the default file handle for output, to the passed in
1269 typeglob.  As 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 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         buffer = SvPVutf8_force(bufsv, blen);
1695         /* UTF-8 may not have been set if they are all low bytes */
1696         SvUTF8_on(bufsv);
1697         buffer_utf8 = 0;
1698     }
1699     else {
1700         buffer = SvPV_force(bufsv, blen);
1701         buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1702     }
1703     if (DO_UTF8(bufsv)) {
1704         blen = sv_len_utf8_nomg(bufsv);
1705     }
1706
1707     charstart = TRUE;
1708     charskip  = 0;
1709     skip = 0;
1710     wanted = length;
1711
1712 #ifdef HAS_SOCKET
1713     if (PL_op->op_type == OP_RECV) {
1714         Sock_size_t bufsize;
1715         char namebuf[MAXPATHLEN];
1716         if (fd < 0) {
1717             SETERRNO(EBADF,SS_IVCHAN);
1718             RETPUSHUNDEF;
1719         }
1720 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
1721         bufsize = sizeof (struct sockaddr_in);
1722 #else
1723         bufsize = sizeof namebuf;
1724 #endif
1725 #ifdef OS2      /* At least Warp3+IAK: only the first byte of bufsize set */
1726         if (bufsize >= 256)
1727             bufsize = 255;
1728 #endif
1729         buffer = SvGROW(bufsv, (STRLEN)(length+1));
1730         /* 'offset' means 'flags' here */
1731         count = PerlSock_recvfrom(fd, buffer, length, offset,
1732                                   (struct sockaddr *)namebuf, &bufsize);
1733         if (count < 0)
1734             RETPUSHUNDEF;
1735         /* MSG_TRUNC can give oversized count; quietly lose it */
1736         if (count > length)
1737             count = length;
1738         SvCUR_set(bufsv, count);
1739         *SvEND(bufsv) = '\0';
1740         (void)SvPOK_only(bufsv);
1741         if (fp_utf8)
1742             SvUTF8_on(bufsv);
1743         SvSETMAGIC(bufsv);
1744         /* This should not be marked tainted if the fp is marked clean */
1745         if (!(IoFLAGS(io) & IOf_UNTAINT))
1746             SvTAINTED_on(bufsv);
1747         SP = ORIGMARK;
1748 #if defined(__CYGWIN__)
1749         /* recvfrom() on cygwin doesn't set bufsize at all for
1750            connected sockets, leaving us with trash in the returned
1751            name, so use the same test as the Win32 code to check if it
1752            wasn't set, and set it [perl #118843] */
1753         if (bufsize == sizeof namebuf)
1754             bufsize = 0;
1755 #endif
1756         sv_setpvn(TARG, namebuf, bufsize);
1757         PUSHs(TARG);
1758         RETURN;
1759     }
1760 #endif
1761     if (offset < 0) {
1762         if (-offset > (SSize_t)blen)
1763             DIE(aTHX_ "Offset outside string");
1764         offset += blen;
1765     }
1766     if (DO_UTF8(bufsv)) {
1767         /* convert offset-as-chars to offset-as-bytes */
1768         if (offset >= (SSize_t)blen)
1769             offset += SvCUR(bufsv) - blen;
1770         else
1771             offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1772     }
1773
1774  more_bytes:
1775     /* Reestablish the fd in case it shifted from underneath us. */
1776     fd = PerlIO_fileno(IoIFP(io));
1777
1778     orig_size = SvCUR(bufsv);
1779     /* Allocating length + offset + 1 isn't perfect in the case of reading
1780        bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1781        unduly.
1782        (should be 2 * length + offset + 1, or possibly something longer if
1783        IN_ENCODING Is true) */
1784     buffer  = SvGROW(bufsv, (STRLEN)(length+offset+1));
1785     if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1786         Zero(buffer+orig_size, offset-orig_size, char);
1787     }
1788     buffer = buffer + offset;
1789     if (!buffer_utf8) {
1790         read_target = bufsv;
1791     } else {
1792         /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1793            concatenate it to the current buffer.  */
1794
1795         /* Truncate the existing buffer to the start of where we will be
1796            reading to:  */
1797         SvCUR_set(bufsv, offset);
1798
1799         read_target = sv_newmortal();
1800         SvUPGRADE(read_target, SVt_PV);
1801         buffer = SvGROW(read_target, (STRLEN)(length + 1));
1802     }
1803
1804     if (PL_op->op_type == OP_SYSREAD) {
1805 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1806         if (IoTYPE(io) == IoTYPE_SOCKET) {
1807             if (fd < 0) {
1808                 SETERRNO(EBADF,SS_IVCHAN);
1809                 count = -1;
1810             }
1811             else
1812                 count = PerlSock_recv(fd, buffer, length, 0);
1813         }
1814         else
1815 #endif
1816         {
1817             if (fd < 0) {
1818                 SETERRNO(EBADF,RMS_IFI);
1819                 count = -1;
1820             }
1821             else
1822                 count = PerlLIO_read(fd, buffer, length);
1823         }
1824     }
1825     else
1826     {
1827         count = PerlIO_read(IoIFP(io), buffer, length);
1828         /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1829         if (count == 0 && PerlIO_error(IoIFP(io)))
1830             count = -1;
1831     }
1832     if (count < 0) {
1833         if (IoTYPE(io) == IoTYPE_WRONLY)
1834             report_wrongway_fh(gv, '>');
1835         goto say_undef;
1836     }
1837     SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1838     *SvEND(read_target) = '\0';
1839     (void)SvPOK_only(read_target);
1840     if (fp_utf8 && !IN_BYTES) {
1841         /* Look at utf8 we got back and count the characters */
1842         const char *bend = buffer + count;
1843         while (buffer < bend) {
1844             if (charstart) {
1845                 skip = UTF8SKIP(buffer);
1846                 charskip = 0;
1847             }
1848             if (buffer - charskip + skip > bend) {
1849                 /* partial character - try for rest of it */
1850                 length = skip - (bend-buffer);
1851                 offset = bend - SvPVX_const(bufsv);
1852                 charstart = FALSE;
1853                 charskip += count;
1854                 goto more_bytes;
1855             }
1856             else {
1857                 got++;
1858                 buffer += skip;
1859                 charstart = TRUE;
1860                 charskip  = 0;
1861             }
1862         }
1863         /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1864            provided amount read (count) was what was requested (length)
1865          */
1866         if (got < wanted && count == length) {
1867             length = wanted - got;
1868             offset = bend - SvPVX_const(bufsv);
1869             goto more_bytes;
1870         }
1871         /* return value is character count */
1872         count = got;
1873         SvUTF8_on(bufsv);
1874     }
1875     else if (buffer_utf8) {
1876         /* Let svcatsv upgrade the bytes we read in to utf8.
1877            The buffer is a mortal so will be freed soon.  */
1878         sv_catsv_nomg(bufsv, read_target);
1879     }
1880     SvSETMAGIC(bufsv);
1881     /* This should not be marked tainted if the fp is marked clean */
1882     if (!(IoFLAGS(io) & IOf_UNTAINT))
1883         SvTAINTED_on(bufsv);
1884     SP = ORIGMARK;
1885     PUSHi(count);
1886     RETURN;
1887
1888   say_undef:
1889     SP = ORIGMARK;
1890     RETPUSHUNDEF;
1891 }
1892
1893
1894 /* also used for: pp_send() where defined */
1895
1896 PP(pp_syswrite)
1897 {
1898     dSP; dMARK; dORIGMARK; dTARGET;
1899     SV *bufsv;
1900     const char *buffer;
1901     SSize_t retval;
1902     STRLEN blen;
1903     STRLEN orig_blen_bytes;
1904     const int op_type = PL_op->op_type;
1905     bool doing_utf8;
1906     U8 *tmpbuf = NULL;
1907     GV *const gv = MUTABLE_GV(*++MARK);
1908     IO *const io = GvIO(gv);
1909     int fd;
1910
1911     if (op_type == OP_SYSWRITE && io) {
1912         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1913         if (mg) {
1914             if (MARK == SP - 1) {
1915                 SV *sv = *SP;
1916                 mXPUSHi(sv_len(sv));
1917                 PUTBACK;
1918             }
1919
1920             return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
1921                                     G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1922                                     sp - mark);
1923         }
1924     }
1925     if (!gv)
1926         goto say_undef;
1927
1928     bufsv = *++MARK;
1929
1930     SETERRNO(0,0);
1931     if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1932         retval = -1;
1933         if (io && IoIFP(io))
1934             report_wrongway_fh(gv, '<');
1935         else
1936             report_evil_fh(gv);
1937         SETERRNO(EBADF,RMS_IFI);
1938         goto say_undef;
1939     }
1940     fd = PerlIO_fileno(IoIFP(io));
1941     if (fd < 0) {
1942         SETERRNO(EBADF,SS_IVCHAN);
1943         retval = -1;
1944         goto say_undef;
1945     }
1946
1947     /* Do this first to trigger any overloading.  */
1948     buffer = SvPV_const(bufsv, blen);
1949     orig_blen_bytes = blen;
1950     doing_utf8 = DO_UTF8(bufsv);
1951
1952     if (PerlIO_isutf8(IoIFP(io))) {
1953         if (!SvUTF8(bufsv)) {
1954             /* We don't modify the original scalar.  */
1955             tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1956             buffer = (char *) tmpbuf;
1957             doing_utf8 = TRUE;
1958         }
1959     }
1960     else if (doing_utf8) {
1961         STRLEN tmplen = blen;
1962         U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1963         if (!doing_utf8) {
1964             tmpbuf = result;
1965             buffer = (char *) tmpbuf;
1966             blen = tmplen;
1967         }
1968         else {
1969             assert((char *)result == buffer);
1970             Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1971         }
1972     }
1973
1974 #ifdef HAS_SOCKET
1975     if (op_type == OP_SEND) {
1976         const int flags = SvIVx(*++MARK);
1977         if (SP > MARK) {
1978             STRLEN mlen;
1979             char * const sockbuf = SvPVx(*++MARK, mlen);
1980             retval = PerlSock_sendto(fd, buffer, blen,
1981                                      flags, (struct sockaddr *)sockbuf, mlen);
1982         }
1983         else {
1984             retval = PerlSock_send(fd, buffer, blen, flags);
1985         }
1986     }
1987     else
1988 #endif
1989     {
1990         Size_t length = 0; /* This length is in characters.  */
1991         STRLEN blen_chars;
1992         IV offset;
1993
1994         if (doing_utf8) {
1995             if (tmpbuf) {
1996                 /* The SV is bytes, and we've had to upgrade it.  */
1997                 blen_chars = orig_blen_bytes;
1998             } else {
1999                 /* The SV really is UTF-8.  */
2000                 /* Don't call sv_len_utf8 on a magical or overloaded
2001                    scalar, as we might get back a different result.  */
2002                 blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
2003             }
2004         } else {
2005             blen_chars = blen;
2006         }
2007
2008         if (MARK >= SP) {
2009             length = blen_chars;
2010         } else {
2011 #if Size_t_size > IVSIZE
2012             length = (Size_t)SvNVx(*++MARK);
2013 #else
2014             length = (Size_t)SvIVx(*++MARK);
2015 #endif
2016             if ((SSize_t)length < 0) {
2017                 Safefree(tmpbuf);
2018                 DIE(aTHX_ "Negative length");
2019             }
2020         }
2021
2022         if (MARK < SP) {
2023             offset = SvIVx(*++MARK);
2024             if (offset < 0) {
2025                 if (-offset > (IV)blen_chars) {
2026                     Safefree(tmpbuf);
2027                     DIE(aTHX_ "Offset outside string");
2028                 }
2029                 offset += blen_chars;
2030             } else if (offset > (IV)blen_chars) {
2031                 Safefree(tmpbuf);
2032                 DIE(aTHX_ "Offset outside string");
2033             }
2034         } else
2035             offset = 0;
2036         if (length > blen_chars - offset)
2037             length = blen_chars - offset;
2038         if (doing_utf8) {
2039             /* Here we convert length from characters to bytes.  */
2040             if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
2041                 /* Either we had to convert the SV, or the SV is magical, or
2042                    the SV has overloading, in which case we can't or mustn't
2043                    or mustn't call it again.  */
2044
2045                 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
2046                 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
2047             } else {
2048                 /* It's a real UTF-8 SV, and it's not going to change under
2049                    us.  Take advantage of any cache.  */
2050                 I32 start = offset;
2051                 I32 len_I32 = length;
2052
2053                 /* Convert the start and end character positions to bytes.
2054                    Remember that the second argument to sv_pos_u2b is relative
2055                    to the first.  */
2056                 sv_pos_u2b(bufsv, &start, &len_I32);
2057
2058                 buffer += start;
2059                 length = len_I32;
2060             }
2061         }
2062         else {
2063             buffer = buffer+offset;
2064         }
2065 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2066         if (IoTYPE(io) == IoTYPE_SOCKET) {
2067             retval = PerlSock_send(fd, buffer, length, 0);
2068         }
2069         else
2070 #endif
2071         {
2072             /* See the note at doio.c:do_print about filesize limits. --jhi */
2073             retval = PerlLIO_write(fd, buffer, length);
2074         }
2075     }
2076
2077     if (retval < 0)
2078         goto say_undef;
2079     SP = ORIGMARK;
2080     if (doing_utf8)
2081         retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2082
2083     Safefree(tmpbuf);
2084 #if Size_t_size > IVSIZE
2085     PUSHn(retval);
2086 #else
2087     PUSHi(retval);
2088 #endif
2089     RETURN;
2090
2091   say_undef:
2092     Safefree(tmpbuf);
2093     SP = ORIGMARK;
2094     RETPUSHUNDEF;
2095 }
2096
2097 PP(pp_eof)
2098 {
2099     dSP;
2100     GV *gv;
2101     IO *io;
2102     const MAGIC *mg;
2103     /*
2104      * in Perl 5.12 and later, the additional parameter is a bitmask:
2105      * 0 = eof
2106      * 1 = eof(FH)
2107      * 2 = eof()  <- ARGV magic
2108      *
2109      * I'll rely on the compiler's trace flow analysis to decide whether to
2110      * actually assign this out here, or punt it into the only block where it is
2111      * used. Doing it out here is DRY on the condition logic.
2112      */
2113     unsigned int which;
2114
2115     if (MAXARG) {
2116         gv = PL_last_in_gv = MUTABLE_GV(POPs);  /* eof(FH) */
2117         which = 1;
2118     }
2119     else {
2120         EXTEND(SP, 1);
2121
2122         if (PL_op->op_flags & OPf_SPECIAL) {
2123             gv = PL_last_in_gv = GvEGVx(PL_argvgv);     /* eof() - ARGV magic */
2124             which = 2;
2125         }
2126         else {
2127             gv = PL_last_in_gv;                 /* eof */
2128             which = 0;
2129         }
2130     }
2131
2132     if (!gv)
2133         RETPUSHNO;
2134
2135     if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2136         return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
2137     }
2138
2139     if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) {   /* eof() */
2140         if (io && !IoIFP(io)) {
2141             if ((IoFLAGS(io) & IOf_START) && av_tindex(GvAVn(gv)) < 0) {
2142                 SV ** svp;
2143                 IoLINES(io) = 0;
2144                 IoFLAGS(io) &= ~IOf_START;
2145                 do_open6(gv, "-", 1, NULL, NULL, 0);
2146                 svp = &GvSV(gv);
2147                 if (*svp) {
2148                     SV * sv = *svp;
2149                     sv_setpvs(sv, "-");
2150                     SvSETMAGIC(sv);
2151                 }
2152                 else
2153                     *svp = newSVpvs("-");
2154             }
2155             else if (!nextargv(gv, FALSE))
2156                 RETPUSHYES;
2157         }
2158     }
2159
2160     PUSHs(boolSV(do_eof(gv)));
2161     RETURN;
2162 }
2163
2164 PP(pp_tell)
2165 {
2166     dSP; dTARGET;
2167     GV *gv;
2168     IO *io;
2169
2170     if (MAXARG != 0 && (TOPs || POPs))
2171         PL_last_in_gv = MUTABLE_GV(POPs);
2172     else
2173         EXTEND(SP, 1);
2174     gv = PL_last_in_gv;
2175
2176     io = GvIO(gv);
2177     if (io) {
2178         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2179         if (mg) {
2180             return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
2181         }
2182     }
2183     else if (!gv) {
2184         if (!errno)
2185             SETERRNO(EBADF,RMS_IFI);
2186         PUSHi(-1);
2187         RETURN;
2188     }
2189
2190 #if LSEEKSIZE > IVSIZE
2191     PUSHn( do_tell(gv) );
2192 #else
2193     PUSHi( do_tell(gv) );
2194 #endif
2195     RETURN;
2196 }
2197
2198
2199 /* also used for: pp_seek() */
2200
2201 PP(pp_sysseek)
2202 {
2203     dSP;
2204     const int whence = POPi;
2205 #if LSEEKSIZE > IVSIZE
2206     const Off_t offset = (Off_t)SvNVx(POPs);
2207 #else
2208     const Off_t offset = (Off_t)SvIVx(POPs);
2209 #endif
2210
2211     GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2212     IO *const io = GvIO(gv);
2213
2214     if (io) {
2215         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2216         if (mg) {
2217 #if LSEEKSIZE > IVSIZE
2218             SV *const offset_sv = newSVnv((NV) offset);
2219 #else
2220             SV *const offset_sv = newSViv(offset);
2221 #endif
2222
2223             return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
2224                                 newSViv(whence));
2225         }
2226     }
2227
2228     if (PL_op->op_type == OP_SEEK)
2229         PUSHs(boolSV(do_seek(gv, offset, whence)));
2230     else {
2231         const Off_t sought = do_sysseek(gv, offset, whence);
2232         if (sought < 0)
2233             PUSHs(&PL_sv_undef);
2234         else {
2235             SV* const sv = sought ?
2236 #if LSEEKSIZE > IVSIZE
2237                 newSVnv((NV)sought)
2238 #else
2239                 newSViv(sought)
2240 #endif
2241                 : newSVpvn(zero_but_true, ZBTLEN);
2242             mPUSHs(sv);
2243         }
2244     }
2245     RETURN;
2246 }
2247
2248 PP(pp_truncate)
2249 {
2250     dSP;
2251     /* There seems to be no consensus on the length type of truncate()
2252      * and ftruncate(), both off_t and size_t have supporters. In
2253      * general one would think that when using large files, off_t is
2254      * at least as wide as size_t, so using an off_t should be okay. */
2255     /* XXX Configure probe for the length type of *truncate() needed XXX */
2256     Off_t len;
2257
2258 #if Off_t_size > IVSIZE
2259     len = (Off_t)POPn;
2260 #else
2261     len = (Off_t)POPi;
2262 #endif
2263     /* Checking for length < 0 is problematic as the type might or
2264      * might not be signed: if it is not, clever compilers will moan. */
2265     /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2266     SETERRNO(0,0);
2267     {
2268         SV * const sv = POPs;
2269         int result = 1;
2270         GV *tmpgv;
2271         IO *io;
2272
2273         if (PL_op->op_flags & OPf_SPECIAL
2274                        ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2275                        : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2276             io = GvIO(tmpgv);
2277             if (!io)
2278                 result = 0;
2279             else {
2280                 PerlIO *fp;
2281             do_ftruncate_io:
2282                 TAINT_PROPER("truncate");
2283                 if (!(fp = IoIFP(io))) {
2284                     result = 0;
2285                 }
2286                 else {
2287                     int fd = PerlIO_fileno(fp);
2288                     if (fd < 0) {
2289                         SETERRNO(EBADF,RMS_IFI);
2290                         result = 0;
2291                     } else {
2292                         if (len < 0) {
2293                             SETERRNO(EINVAL, LIB_INVARG);
2294                             result = 0;
2295                         } else {
2296                            PerlIO_flush(fp);
2297 #ifdef HAS_TRUNCATE
2298                            if (ftruncate(fd, len) < 0)
2299 #else
2300                            if (my_chsize(fd, len) < 0)
2301 #endif
2302                                result = 0;
2303                         }
2304                     }
2305                 }
2306             }
2307         }
2308         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2309                 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2310                 goto do_ftruncate_io;
2311         }
2312         else {
2313             const char * const name = SvPV_nomg_const_nolen(sv);
2314             TAINT_PROPER("truncate");
2315 #ifdef HAS_TRUNCATE
2316             if (truncate(name, len) < 0)
2317                 result = 0;
2318 #else
2319             {
2320                 int mode = O_RDWR;
2321                 int tmpfd;
2322
2323 #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
2324                 mode |= O_LARGEFILE;    /* Transparently largefiley. */
2325 #endif
2326 #ifdef O_BINARY
2327                 /* On open(), the Win32 CRT tries to seek around text
2328                  * files using 32-bit offsets, which causes the open()
2329                  * to fail on large files, so open in binary mode.
2330                  */
2331                 mode |= O_BINARY;
2332 #endif
2333                 tmpfd = PerlLIO_open(name, mode);
2334
2335                 if (tmpfd < 0) {
2336                     result = 0;
2337                 } else {
2338                     if (my_chsize(tmpfd, len) < 0)
2339                         result = 0;
2340                     PerlLIO_close(tmpfd);
2341                 }
2342             }
2343 #endif
2344         }
2345
2346         if (result)
2347             RETPUSHYES;
2348         if (!errno)
2349             SETERRNO(EBADF,RMS_IFI);
2350         RETPUSHUNDEF;
2351     }
2352 }
2353
2354
2355 /* also used for: pp_fcntl() */
2356
2357 PP(pp_ioctl)
2358 {
2359     dSP; dTARGET;
2360     SV * const argsv = POPs;
2361     const unsigned int func = POPu;
2362     int optype;
2363     GV * const gv = MUTABLE_GV(POPs);
2364     IO * const io = GvIOn(gv);
2365     char *s;
2366     IV retval;
2367
2368     if (!IoIFP(io)) {
2369         report_evil_fh(gv);
2370         SETERRNO(EBADF,RMS_IFI);        /* well, sort of... */
2371         RETPUSHUNDEF;
2372     }
2373
2374     if (SvPOK(argsv) || !SvNIOK(argsv)) {
2375         STRLEN len;
2376         STRLEN need;
2377         s = SvPV_force(argsv, len);
2378         need = IOCPARM_LEN(func);
2379         if (len < need) {
2380             s = Sv_Grow(argsv, need + 1);
2381             SvCUR_set(argsv, need);
2382         }
2383
2384         s[SvCUR(argsv)] = 17;   /* a little sanity check here */
2385     }
2386     else {
2387         retval = SvIV(argsv);
2388         s = INT2PTR(char*,retval);              /* ouch */
2389     }
2390
2391     optype = PL_op->op_type;
2392     TAINT_PROPER(PL_op_desc[optype]);
2393
2394     if (optype == OP_IOCTL)
2395 #ifdef HAS_IOCTL
2396         retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2397 #else
2398         DIE(aTHX_ "ioctl is not implemented");
2399 #endif
2400     else
2401 #ifndef HAS_FCNTL
2402       DIE(aTHX_ "fcntl is not implemented");
2403 #else
2404 #if defined(OS2) && defined(__EMX__)
2405         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2406 #else
2407         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2408 #endif
2409 #endif
2410
2411 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2412     if (SvPOK(argsv)) {
2413         if (s[SvCUR(argsv)] != 17)
2414             DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2415                 OP_NAME(PL_op));
2416         s[SvCUR(argsv)] = 0;            /* put our null back */
2417         SvSETMAGIC(argsv);              /* Assume it has changed */
2418     }
2419
2420     if (retval == -1)
2421         RETPUSHUNDEF;
2422     if (retval != 0) {
2423         PUSHi(retval);
2424     }
2425     else {
2426         PUSHp(zero_but_true, ZBTLEN);
2427     }
2428 #endif
2429     RETURN;
2430 }
2431
2432 PP(pp_flock)
2433 {
2434 #ifdef FLOCK
2435     dSP; dTARGET;
2436     I32 value;
2437     const int argtype = POPi;
2438     GV * const gv = MUTABLE_GV(POPs);
2439     IO *const io = GvIO(gv);
2440     PerlIO *const fp = io ? IoIFP(io) : NULL;
2441
2442     /* XXX Looks to me like io is always NULL at this point */
2443     if (fp) {
2444         (void)PerlIO_flush(fp);
2445         value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2446     }
2447     else {
2448         report_evil_fh(gv);
2449         value = 0;
2450         SETERRNO(EBADF,RMS_IFI);
2451     }
2452     PUSHi(value);
2453     RETURN;
2454 #else
2455     DIE(aTHX_ PL_no_func, "flock");
2456 #endif
2457 }
2458
2459 /* Sockets. */
2460
2461 #ifdef HAS_SOCKET
2462
2463 PP(pp_socket)
2464 {
2465     dSP;
2466     const int protocol = POPi;
2467     const int type = POPi;
2468     const int domain = POPi;
2469     GV * const gv = MUTABLE_GV(POPs);
2470     IO * const io = GvIOn(gv);
2471     int fd;
2472
2473     if (IoIFP(io))
2474         do_close(gv, FALSE);
2475
2476     TAINT_PROPER("socket");
2477     fd = PerlSock_socket(domain, type, protocol);
2478     if (fd < 0) {
2479         SETERRNO(EBADF,RMS_IFI);
2480         RETPUSHUNDEF;
2481     }
2482     IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2483     IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2484     IoTYPE(io) = IoTYPE_SOCKET;
2485     if (!IoIFP(io) || !IoOFP(io)) {
2486         if (IoIFP(io)) PerlIO_close(IoIFP(io));
2487         if (IoOFP(io)) PerlIO_close(IoOFP(io));
2488         if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2489         RETPUSHUNDEF;
2490     }
2491 #if defined(HAS_FCNTL) && defined(F_SETFD)
2492     if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0)       /* ensure close-on-exec */
2493         RETPUSHUNDEF;
2494 #endif
2495
2496     RETPUSHYES;
2497 }
2498 #endif
2499
2500 PP(pp_sockpair)
2501 {
2502 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2503     dSP;
2504     int fd[2];
2505     const int protocol = POPi;
2506     const int type = POPi;
2507     const int domain = POPi;
2508
2509     GV * const gv2 = MUTABLE_GV(POPs);
2510     IO * const io2 = GvIOn(gv2);
2511     GV * const gv1 = MUTABLE_GV(POPs);
2512     IO * const io1 = GvIOn(gv1);
2513
2514     if (IoIFP(io1))
2515         do_close(gv1, FALSE);
2516     if (IoIFP(io2))
2517         do_close(gv2, FALSE);
2518
2519     TAINT_PROPER("socketpair");
2520     if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2521         RETPUSHUNDEF;
2522     IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2523     IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2524     IoTYPE(io1) = IoTYPE_SOCKET;
2525     IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2526     IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2527     IoTYPE(io2) = IoTYPE_SOCKET;
2528     if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2529         if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2530         if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2531         if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2532         if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2533         if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2534         if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2535         RETPUSHUNDEF;
2536     }
2537 #if defined(HAS_FCNTL) && defined(F_SETFD)
2538     /* ensure close-on-exec */
2539     if ((fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
2540         (fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd) < 0))
2541         RETPUSHUNDEF;
2542 #endif
2543
2544     RETPUSHYES;
2545 #else
2546     DIE(aTHX_ PL_no_sock_func, "socketpair");
2547 #endif
2548 }
2549
2550 #ifdef HAS_SOCKET
2551
2552 /* also used for: pp_connect() */
2553
2554 PP(pp_bind)
2555 {
2556     dSP;
2557     SV * const addrsv = POPs;
2558     /* OK, so on what platform does bind modify addr?  */
2559     const char *addr;
2560     GV * const gv = MUTABLE_GV(POPs);
2561     IO * const io = GvIOn(gv);
2562     STRLEN len;
2563     int op_type;
2564     int fd;
2565
2566     if (!IoIFP(io))
2567         goto nuts;
2568     fd = PerlIO_fileno(IoIFP(io));
2569     if (fd < 0)
2570         goto nuts;
2571
2572     addr = SvPV_const(addrsv, len);
2573     op_type = PL_op->op_type;
2574     TAINT_PROPER(PL_op_desc[op_type]);
2575     if ((op_type == OP_BIND
2576          ? PerlSock_bind(fd, (struct sockaddr *)addr, len)
2577          : PerlSock_connect(fd, (struct sockaddr *)addr, len))
2578         >= 0)
2579         RETPUSHYES;
2580     else
2581         RETPUSHUNDEF;
2582
2583   nuts:
2584     report_evil_fh(gv);
2585     SETERRNO(EBADF,SS_IVCHAN);
2586     RETPUSHUNDEF;
2587 }
2588
2589 PP(pp_listen)
2590 {
2591     dSP;
2592     const int backlog = POPi;
2593     GV * const gv = MUTABLE_GV(POPs);
2594     IO * const io = GvIOn(gv);
2595
2596     if (!IoIFP(io))
2597         goto nuts;
2598
2599     if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2600         RETPUSHYES;
2601     else
2602         RETPUSHUNDEF;
2603
2604   nuts:
2605     report_evil_fh(gv);
2606     SETERRNO(EBADF,SS_IVCHAN);
2607     RETPUSHUNDEF;
2608 }
2609
2610 PP(pp_accept)
2611 {
2612     dSP; dTARGET;
2613     IO *nstio;
2614     char namebuf[MAXPATHLEN];
2615 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2616     Sock_size_t len = sizeof (struct sockaddr_in);
2617 #else
2618     Sock_size_t len = sizeof namebuf;
2619 #endif
2620     GV * const ggv = MUTABLE_GV(POPs);
2621     GV * const ngv = MUTABLE_GV(POPs);
2622     int fd;
2623
2624     IO * const gstio = GvIO(ggv);
2625     if (!gstio || !IoIFP(gstio))
2626         goto nuts;
2627
2628     nstio = GvIOn(ngv);
2629     fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2630 #if defined(OEMVS)
2631     if (len == 0) {
2632         /* Some platforms indicate zero length when an AF_UNIX client is
2633          * not bound. Simulate a non-zero-length sockaddr structure in
2634          * this case. */
2635         namebuf[0] = 0;        /* sun_len */
2636         namebuf[1] = AF_UNIX;  /* sun_family */
2637         len = 2;
2638     }
2639 #endif
2640
2641     if (fd < 0)
2642         goto badexit;
2643     if (IoIFP(nstio))
2644         do_close(ngv, FALSE);
2645     IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2646     IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2647     IoTYPE(nstio) = IoTYPE_SOCKET;
2648     if (!IoIFP(nstio) || !IoOFP(nstio)) {
2649         if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2650         if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2651         if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2652         goto badexit;
2653     }
2654 #if defined(HAS_FCNTL) && defined(F_SETFD)
2655     if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0)       /* ensure close-on-exec */
2656         goto badexit;
2657 #endif
2658
2659 #ifdef __SCO_VERSION__
2660     len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2661 #endif
2662
2663     PUSHp(namebuf, len);
2664     RETURN;
2665
2666   nuts:
2667     report_evil_fh(ggv);
2668     SETERRNO(EBADF,SS_IVCHAN);
2669
2670   badexit:
2671     RETPUSHUNDEF;
2672
2673 }
2674
2675 PP(pp_shutdown)
2676 {
2677     dSP; dTARGET;
2678     const int how = POPi;
2679     GV * const gv = MUTABLE_GV(POPs);
2680     IO * const io = GvIOn(gv);
2681
2682     if (!IoIFP(io))
2683         goto nuts;
2684
2685     PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2686     RETURN;
2687
2688   nuts:
2689     report_evil_fh(gv);
2690     SETERRNO(EBADF,SS_IVCHAN);
2691     RETPUSHUNDEF;
2692 }
2693
2694
2695 /* also used for: pp_gsockopt() */
2696
2697 PP(pp_ssockopt)
2698 {
2699     dSP;
2700     const int optype = PL_op->op_type;
2701     SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2702     const unsigned int optname = (unsigned int) POPi;
2703     const unsigned int lvl = (unsigned int) POPi;
2704     GV * const gv = MUTABLE_GV(POPs);
2705     IO * const io = GvIOn(gv);
2706     int fd;
2707     Sock_size_t len;
2708
2709     if (!IoIFP(io))
2710         goto nuts;
2711
2712     fd = PerlIO_fileno(IoIFP(io));
2713     if (fd < 0)
2714         goto nuts;
2715     switch (optype) {
2716     case OP_GSOCKOPT:
2717         SvGROW(sv, 257);
2718         (void)SvPOK_only(sv);
2719         SvCUR_set(sv,256);
2720         *SvEND(sv) ='\0';
2721         len = SvCUR(sv);
2722         if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2723             goto nuts2;
2724 #if defined(_AIX)
2725         /* XXX Configure test: does getsockopt set the length properly? */
2726         if (len == 256)
2727             len = sizeof(int);
2728 #endif
2729         SvCUR_set(sv, len);
2730         *SvEND(sv) ='\0';
2731         PUSHs(sv);
2732         break;
2733     case OP_SSOCKOPT: {
2734 #if defined(__SYMBIAN32__)
2735 # define SETSOCKOPT_OPTION_VALUE_T void *
2736 #else
2737 # define SETSOCKOPT_OPTION_VALUE_T const char *
2738 #endif
2739         /* XXX TODO: We need to have a proper type (a Configure probe,
2740          * etc.) for what the C headers think of the third argument of
2741          * setsockopt(), the option_value read-only buffer: is it
2742          * a "char *", or a "void *", const or not.  Some compilers
2743          * don't take kindly to e.g. assuming that "char *" implicitly
2744          * promotes to a "void *", or to explicitly promoting/demoting
2745          * consts to non/vice versa.  The "const void *" is the SUS
2746          * definition, but that does not fly everywhere for the above
2747          * reasons. */
2748             SETSOCKOPT_OPTION_VALUE_T buf;
2749             int aint;
2750             if (SvPOKp(sv)) {
2751                 STRLEN l;
2752                 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2753                 len = l;
2754             }
2755             else {
2756                 aint = (int)SvIV(sv);
2757                 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2758                 len = sizeof(int);
2759             }
2760             if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2761                 goto nuts2;
2762             PUSHs(&PL_sv_yes);
2763         }
2764         break;
2765     }
2766     RETURN;
2767
2768   nuts:
2769     report_evil_fh(gv);
2770     SETERRNO(EBADF,SS_IVCHAN);
2771   nuts2:
2772     RETPUSHUNDEF;
2773
2774 }
2775
2776
2777 /* also used for: pp_getsockname() */
2778
2779 PP(pp_getpeername)
2780 {
2781     dSP;
2782     const int optype = PL_op->op_type;
2783     GV * const gv = MUTABLE_GV(POPs);
2784     IO * const io = GvIOn(gv);
2785     Sock_size_t len;
2786     SV *sv;
2787     int fd;
2788
2789     if (!IoIFP(io))
2790         goto nuts;
2791
2792     sv = sv_2mortal(newSV(257));
2793     (void)SvPOK_only(sv);
2794     len = 256;
2795     SvCUR_set(sv, len);
2796     *SvEND(sv) ='\0';
2797     fd = PerlIO_fileno(IoIFP(io));
2798     if (fd < 0)
2799         goto nuts;
2800     switch (optype) {
2801     case OP_GETSOCKNAME:
2802         if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2803             goto nuts2;
2804         break;
2805     case OP_GETPEERNAME:
2806         if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2807             goto nuts2;
2808 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2809         {
2810             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";
2811             /* If the call succeeded, make sure we don't have a zeroed port/addr */
2812             if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2813                 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2814                         sizeof(u_short) + sizeof(struct in_addr))) {
2815                 goto nuts2;
2816             }
2817         }
2818 #endif
2819         break;
2820     }
2821 #ifdef BOGUS_GETNAME_RETURN
2822     /* Interactive Unix, getpeername() and getsockname()
2823       does not return valid namelen */
2824     if (len == BOGUS_GETNAME_RETURN)
2825         len = sizeof(struct sockaddr);
2826 #endif
2827     SvCUR_set(sv, len);
2828     *SvEND(sv) ='\0';
2829     PUSHs(sv);
2830     RETURN;
2831
2832   nuts:
2833     report_evil_fh(gv);
2834     SETERRNO(EBADF,SS_IVCHAN);
2835   nuts2:
2836     RETPUSHUNDEF;
2837 }
2838
2839 #endif
2840
2841 /* Stat calls. */
2842
2843 /* also used for: pp_lstat() */
2844
2845 PP(pp_stat)
2846 {
2847     dSP;
2848     GV *gv = NULL;
2849     IO *io = NULL;
2850     I32 gimme;
2851     I32 max = 13;
2852     SV* sv;
2853
2854     if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2855                                   : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2856         if (PL_op->op_type == OP_LSTAT) {
2857             if (gv != PL_defgv) {
2858             do_fstat_warning_check:
2859                 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2860                                "lstat() on filehandle%s%"SVf,
2861                                 gv ? " " : "",
2862                                 SVfARG(gv
2863                                         ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2864                                         : &PL_sv_no));
2865             } else if (PL_laststype != OP_LSTAT)
2866                 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2867                 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2868         }
2869
2870         if (gv != PL_defgv) {
2871             bool havefp;
2872           do_fstat_have_io:
2873             havefp = FALSE;
2874             PL_laststype = OP_STAT;
2875             PL_statgv = gv ? gv : (GV *)io;
2876             sv_setpvs(PL_statname, "");
2877             if(gv) {
2878                 io = GvIO(gv);
2879             }
2880             if (io) {
2881                     if (IoIFP(io)) {
2882                         int fd = PerlIO_fileno(IoIFP(io));
2883                         if (fd < 0) {
2884                             PL_laststatval = -1;
2885                             SETERRNO(EBADF,RMS_IFI);
2886                         } else {
2887                             PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
2888                             havefp = TRUE;
2889                         }
2890                     } else if (IoDIRP(io)) {
2891                         PL_laststatval =
2892                             PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2893                         havefp = TRUE;
2894                     } else {
2895                         PL_laststatval = -1;
2896                     }
2897             }
2898             else PL_laststatval = -1;
2899             if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
2900         }
2901
2902         if (PL_laststatval < 0) {
2903             max = 0;
2904         }
2905     }
2906     else {
2907         const char *file;
2908         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2909             io = MUTABLE_IO(SvRV(sv));
2910             if (PL_op->op_type == OP_LSTAT)
2911                 goto do_fstat_warning_check;
2912             goto do_fstat_have_io;
2913         }
2914
2915         SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2916         sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2917         PL_statgv = NULL;
2918         PL_laststype = PL_op->op_type;
2919         file = SvPV_nolen_const(PL_statname);
2920         if (PL_op->op_type == OP_LSTAT)
2921             PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
2922         else
2923             PL_laststatval = PerlLIO_stat(file, &PL_statcache);
2924         if (PL_laststatval < 0) {
2925             if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
2926                 /* PL_warn_nl is constant */
2927                 GCC_DIAG_IGNORE(-Wformat-nonliteral);
2928                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2929                 GCC_DIAG_RESTORE;
2930             }
2931             max = 0;
2932         }
2933     }
2934
2935     gimme = GIMME_V;
2936     if (gimme != G_ARRAY) {
2937         if (gimme != G_VOID)
2938             XPUSHs(boolSV(max));
2939         RETURN;
2940     }
2941     if (max) {
2942         EXTEND(SP, max);
2943         EXTEND_MORTAL(max);
2944         mPUSHi(PL_statcache.st_dev);
2945 #if ST_INO_SIZE > IVSIZE
2946         mPUSHn(PL_statcache.st_ino);
2947 #else
2948 #   if ST_INO_SIGN <= 0
2949         mPUSHi(PL_statcache.st_ino);
2950 #   else
2951         mPUSHu(PL_statcache.st_ino);
2952 #   endif
2953 #endif
2954         mPUSHu(PL_statcache.st_mode);
2955         mPUSHu(PL_statcache.st_nlink);
2956
2957         sv_setuid(PUSHmortal, PL_statcache.st_uid);
2958         sv_setgid(PUSHmortal, PL_statcache.st_gid);
2959
2960 #ifdef USE_STAT_RDEV
2961         mPUSHi(PL_statcache.st_rdev);
2962 #else
2963         PUSHs(newSVpvs_flags("", SVs_TEMP));
2964 #endif
2965 #if Off_t_size > IVSIZE
2966         mPUSHn(PL_statcache.st_size);
2967 #else
2968         mPUSHi(PL_statcache.st_size);
2969 #endif
2970 #ifdef BIG_TIME
2971         mPUSHn(PL_statcache.st_atime);
2972         mPUSHn(PL_statcache.st_mtime);
2973         mPUSHn(PL_statcache.st_ctime);
2974 #else
2975         mPUSHi(PL_statcache.st_atime);
2976         mPUSHi(PL_statcache.st_mtime);
2977         mPUSHi(PL_statcache.st_ctime);
2978 #endif
2979 #ifdef USE_STAT_BLOCKS
2980         mPUSHu(PL_statcache.st_blksize);
2981         mPUSHu(PL_statcache.st_blocks);
2982 #else
2983         PUSHs(newSVpvs_flags("", SVs_TEMP));
2984         PUSHs(newSVpvs_flags("", SVs_TEMP));
2985 #endif
2986     }
2987     RETURN;
2988 }
2989
2990 /* All filetest ops avoid manipulating the perl stack pointer in their main
2991    bodies (since commit d2c4d2d1e22d3125), and return using either
2992    S_ft_return_false() or S_ft_return_true().  These two helper functions are
2993    the only two which manipulate the perl stack.  To ensure that no stack
2994    manipulation macros are used, the filetest ops avoid defining a local copy
2995    of the stack pointer with dSP.  */
2996
2997 /* If the next filetest is stacked up with this one
2998    (PL_op->op_private & OPpFT_STACKING), we leave
2999    the original argument on the stack for success,
3000    and skip the stacked operators on failure.
3001    The next few macros/functions take care of this.
3002 */
3003
3004 static OP *
3005 S_ft_return_false(pTHX_ SV *ret) {
3006     OP *next = NORMAL;
3007     dSP;
3008
3009     if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
3010     else                           SETs(ret);
3011     PUTBACK;
3012
3013     if (PL_op->op_private & OPpFT_STACKING) {
3014         while (OP_IS_FILETEST(next->op_type)
3015                && next->op_private & OPpFT_STACKED)
3016             next = next->op_next;
3017     }
3018     return next;
3019 }
3020
3021 PERL_STATIC_INLINE OP *
3022 S_ft_return_true(pTHX_ SV *ret) {
3023     dSP;
3024     if (PL_op->op_flags & OPf_REF)
3025         XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
3026     else if (!(PL_op->op_private & OPpFT_STACKING))
3027         SETs(ret);
3028     PUTBACK;
3029     return NORMAL;
3030 }
3031
3032 #define FT_RETURNNO     return S_ft_return_false(aTHX_ &PL_sv_no)
3033 #define FT_RETURNUNDEF  return S_ft_return_false(aTHX_ &PL_sv_undef)
3034 #define FT_RETURNYES    return S_ft_return_true(aTHX_ &PL_sv_yes)
3035
3036 #define tryAMAGICftest_MG(chr) STMT_START { \
3037         if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
3038                 && PL_op->op_flags & OPf_KIDS) {     \
3039             OP *next = S_try_amagic_ftest(aTHX_ chr);   \
3040             if (next) return next;                        \
3041         }                                                  \
3042     } STMT_END
3043
3044 STATIC OP *
3045 S_try_amagic_ftest(pTHX_ char chr) {
3046     SV *const arg = *PL_stack_sp;
3047
3048     assert(chr != '?');
3049     if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
3050
3051     if (SvAMAGIC(arg))
3052     {
3053         const char tmpchr = chr;
3054         SV * const tmpsv = amagic_call(arg,
3055                                 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
3056                                 ftest_amg, AMGf_unary);
3057
3058         if (!tmpsv)
3059             return NULL;
3060
3061         return SvTRUE(tmpsv)
3062             ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
3063     }
3064     return NULL;
3065 }
3066
3067
3068 /* also used for: pp_fteexec() pp_fteread() pp_ftewrite() pp_ftrexec()
3069  *                pp_ftrwrite() */
3070
3071 PP(pp_ftrread)
3072 {
3073     I32 result;
3074     /* Not const, because things tweak this below. Not bool, because there's
3075        no guarantee that OPpFT_ACCESS is <= CHAR_MAX  */
3076 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3077     I32 use_access = PL_op->op_private & OPpFT_ACCESS;
3078     /* Giving some sort of initial value silences compilers.  */
3079 #  ifdef R_OK
3080     int access_mode = R_OK;
3081 #  else
3082     int access_mode = 0;
3083 #  endif
3084 #else
3085     /* access_mode is never used, but leaving use_access in makes the
3086        conditional compiling below much clearer.  */
3087     I32 use_access = 0;
3088 #endif
3089     Mode_t stat_mode = S_IRUSR;
3090
3091     bool effective = FALSE;
3092     char opchar = '?';
3093
3094     switch (PL_op->op_type) {
3095     case OP_FTRREAD:    opchar = 'R'; break;
3096     case OP_FTRWRITE:   opchar = 'W'; break;
3097     case OP_FTREXEC:    opchar = 'X'; break;
3098     case OP_FTEREAD:    opchar = 'r'; break;
3099     case OP_FTEWRITE:   opchar = 'w'; break;
3100     case OP_FTEEXEC:    opchar = 'x'; break;
3101     }
3102     tryAMAGICftest_MG(opchar);
3103
3104     switch (PL_op->op_type) {
3105     case OP_FTRREAD:
3106 #if !(defined(HAS_ACCESS) && defined(R_OK))
3107         use_access = 0;
3108 #endif
3109         break;
3110
3111     case OP_FTRWRITE:
3112 #if defined(HAS_ACCESS) && defined(W_OK)
3113         access_mode = W_OK;
3114 #else
3115         use_access = 0;
3116 #endif
3117         stat_mode = S_IWUSR;
3118         break;
3119
3120     case OP_FTREXEC:
3121 #if defined(HAS_ACCESS) && defined(X_OK)
3122         access_mode = X_OK;
3123 #else
3124         use_access = 0;
3125 #endif
3126         stat_mode = S_IXUSR;
3127         break;
3128
3129     case OP_FTEWRITE:
3130 #ifdef PERL_EFF_ACCESS
3131         access_mode = W_OK;
3132 #endif
3133         stat_mode = S_IWUSR;
3134         /* FALLTHROUGH */
3135
3136     case OP_FTEREAD:
3137 #ifndef PERL_EFF_ACCESS
3138         use_access = 0;
3139 #endif
3140         effective = TRUE;
3141         break;
3142
3143     case OP_FTEEXEC:
3144 #ifdef PERL_EFF_ACCESS
3145         access_mode = X_OK;
3146 #else
3147         use_access = 0;
3148 #endif
3149         stat_mode = S_IXUSR;
3150         effective = TRUE;
3151         break;
3152     }
3153
3154     if (use_access) {
3155 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3156         const char *name = SvPV_nolen(*PL_stack_sp);
3157         if (effective) {
3158 #  ifdef PERL_EFF_ACCESS
3159             result = PERL_EFF_ACCESS(name, access_mode);
3160 #  else
3161             DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3162                 OP_NAME(PL_op));
3163 #  endif
3164         }
3165         else {
3166 #  ifdef HAS_ACCESS
3167             result = access(name, access_mode);
3168 #  else
3169             DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3170 #  endif
3171         }
3172         if (result == 0)
3173             FT_RETURNYES;
3174         if (result < 0)
3175             FT_RETURNUNDEF;
3176         FT_RETURNNO;
3177 #endif
3178     }
3179
3180     result = my_stat_flags(0);
3181     if (result < 0)
3182         FT_RETURNUNDEF;
3183     if (cando(stat_mode, effective, &PL_statcache))
3184         FT_RETURNYES;
3185     FT_RETURNNO;
3186 }
3187
3188
3189 /* also used for: pp_ftatime() pp_ftctime() pp_ftmtime() pp_ftsize() */
3190
3191 PP(pp_ftis)
3192 {
3193     I32 result;
3194     const int op_type = PL_op->op_type;
3195     char opchar = '?';
3196
3197     switch (op_type) {
3198     case OP_FTIS:       opchar = 'e'; break;
3199     case OP_FTSIZE:     opchar = 's'; break;
3200     case OP_FTMTIME:    opchar = 'M'; break;
3201     case OP_FTCTIME:    opchar = 'C'; break;
3202     case OP_FTATIME:    opchar = 'A'; break;
3203     }
3204     tryAMAGICftest_MG(opchar);
3205
3206     result = my_stat_flags(0);
3207     if (result < 0)
3208         FT_RETURNUNDEF;
3209     if (op_type == OP_FTIS)
3210         FT_RETURNYES;
3211     {
3212         /* You can't dTARGET inside OP_FTIS, because you'll get
3213            "panic: pad_sv po" - the op is not flagged to have a target.  */
3214         dTARGET;
3215         switch (op_type) {
3216         case OP_FTSIZE:
3217 #if Off_t_size > IVSIZE
3218             sv_setnv(TARG, (NV)PL_statcache.st_size);
3219 #else
3220             sv_setiv(TARG, (IV)PL_statcache.st_size);
3221 #endif
3222             break;
3223         case OP_FTMTIME:
3224             sv_setnv(TARG,
3225                     ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3226             break;
3227         case OP_FTATIME:
3228             sv_setnv(TARG,
3229                     ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3230             break;
3231         case OP_FTCTIME:
3232             sv_setnv(TARG,
3233                     ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3234             break;
3235         }
3236         SvSETMAGIC(TARG);
3237         return SvTRUE_nomg(TARG)
3238             ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3239     }
3240 }
3241
3242
3243 /* also used for: pp_ftblk() pp_ftchr() pp_ftdir() pp_fteowned()
3244  *                pp_ftfile() pp_ftpipe() pp_ftsgid() pp_ftsock()
3245  *                pp_ftsuid() pp_ftsvtx() pp_ftzero() */
3246
3247 PP(pp_ftrowned)
3248 {
3249     I32 result;
3250     char opchar = '?';
3251
3252     switch (PL_op->op_type) {
3253     case OP_FTROWNED:   opchar = 'O'; break;
3254     case OP_FTEOWNED:   opchar = 'o'; break;
3255     case OP_FTZERO:     opchar = 'z'; break;
3256     case OP_FTSOCK:     opchar = 'S'; break;
3257     case OP_FTCHR:      opchar = 'c'; break;
3258     case OP_FTBLK:      opchar = 'b'; break;
3259     case OP_FTFILE:     opchar = 'f'; break;
3260     case OP_FTDIR:      opchar = 'd'; break;
3261     case OP_FTPIPE:     opchar = 'p'; break;
3262     case OP_FTSUID:     opchar = 'u'; break;
3263     case OP_FTSGID:     opchar = 'g'; break;
3264     case OP_FTSVTX:     opchar = 'k'; break;
3265     }
3266     tryAMAGICftest_MG(opchar);
3267
3268     /* I believe that all these three are likely to be defined on most every
3269        system these days.  */
3270 #ifndef S_ISUID
3271     if(PL_op->op_type == OP_FTSUID) {
3272         FT_RETURNNO;
3273     }
3274 #endif
3275 #ifndef S_ISGID
3276     if(PL_op->op_type == OP_FTSGID) {
3277         FT_RETURNNO;
3278     }
3279 #endif
3280 #ifndef S_ISVTX
3281     if(PL_op->op_type == OP_FTSVTX) {
3282         FT_RETURNNO;
3283     }
3284 #endif
3285
3286     result = my_stat_flags(0);
3287     if (result < 0)
3288         FT_RETURNUNDEF;
3289     switch (PL_op->op_type) {
3290     case OP_FTROWNED:
3291         if (PL_statcache.st_uid == PerlProc_getuid())
3292             FT_RETURNYES;
3293         break;
3294     case OP_FTEOWNED:
3295         if (PL_statcache.st_uid == PerlProc_geteuid())
3296             FT_RETURNYES;
3297         break;
3298     case OP_FTZERO:
3299         if (PL_statcache.st_size == 0)
3300             FT_RETURNYES;
3301         break;
3302     case OP_FTSOCK:
3303         if (S_ISSOCK(PL_statcache.st_mode))
3304             FT_RETURNYES;
3305         break;
3306     case OP_FTCHR:
3307         if (S_ISCHR(PL_statcache.st_mode))
3308             FT_RETURNYES;
3309         break;
3310     case OP_FTBLK:
3311         if (S_ISBLK(PL_statcache.st_mode))
3312             FT_RETURNYES;
3313         break;
3314     case OP_FTFILE:
3315         if (S_ISREG(PL_statcache.st_mode))
3316             FT_RETURNYES;
3317         break;
3318     case OP_FTDIR:
3319         if (S_ISDIR(PL_statcache.st_mode))
3320             FT_RETURNYES;
3321         break;
3322     case OP_FTPIPE:
3323         if (S_ISFIFO(PL_statcache.st_mode))
3324             FT_RETURNYES;
3325         break;
3326 #ifdef S_ISUID
3327     case OP_FTSUID:
3328         if (PL_statcache.st_mode & S_ISUID)
3329             FT_RETURNYES;
3330         break;
3331 #endif
3332 #ifdef S_ISGID
3333     case OP_FTSGID:
3334         if (PL_statcache.st_mode & S_ISGID)
3335             FT_RETURNYES;
3336         break;
3337 #endif
3338 #ifdef S_ISVTX
3339     case OP_FTSVTX:
3340         if (PL_statcache.st_mode & S_ISVTX)
3341             FT_RETURNYES;
3342         break;
3343 #endif
3344     }
3345     FT_RETURNNO;
3346 }
3347
3348 PP(pp_ftlink)
3349 {
3350     I32 result;
3351
3352     tryAMAGICftest_MG('l');
3353     result = my_lstat_flags(0);
3354
3355     if (result < 0)
3356         FT_RETURNUNDEF;
3357     if (S_ISLNK(PL_statcache.st_mode))
3358         FT_RETURNYES;
3359     FT_RETURNNO;
3360 }
3361
3362 PP(pp_fttty)
3363 {
3364     int fd;
3365     GV *gv;
3366     char *name = NULL;
3367     STRLEN namelen;
3368     UV uv;
3369
3370     tryAMAGICftest_MG('t');
3371
3372     if (PL_op->op_flags & OPf_REF)
3373         gv = cGVOP_gv;
3374     else {
3375       SV *tmpsv = *PL_stack_sp;
3376       if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3377         name = SvPV_nomg(tmpsv, namelen);
3378         gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3379       }
3380     }
3381
3382     if (GvIO(gv) && IoIFP(GvIOp(gv)))
3383         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3384     else if (name && isDIGIT(*name) && grok_atoUV(name, &uv, NULL) && uv <= PERL_INT_MAX)
3385         fd = (int)uv;
3386     else
3387         FT_RETURNUNDEF;
3388     if (fd < 0) {
3389         SETERRNO(EBADF,RMS_IFI);
3390         FT_RETURNUNDEF;
3391     }
3392     if (PerlLIO_isatty(fd))
3393         FT_RETURNYES;
3394     FT_RETURNNO;
3395 }
3396
3397
3398 /* also used for: pp_ftbinary() */
3399
3400 PP(pp_fttext)
3401 {
3402     I32 i;
3403     SSize_t len;
3404     I32 odd = 0;
3405     STDCHAR tbuf[512];
3406     STDCHAR *s;
3407     IO *io;
3408     SV *sv = NULL;
3409     GV *gv;
3410     PerlIO *fp;
3411
3412     tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3413
3414     if (PL_op->op_flags & OPf_REF)
3415         gv = cGVOP_gv;
3416     else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3417              == OPpFT_STACKED)
3418         gv = PL_defgv;
3419     else {
3420         sv = *PL_stack_sp;
3421         gv = MAYBE_DEREF_GV_nomg(sv);
3422     }
3423
3424     if (gv) {
3425         if (gv == PL_defgv) {
3426             if (PL_statgv)
3427                 io = SvTYPE(PL_statgv) == SVt_PVIO
3428                     ? (IO *)PL_statgv
3429                     : GvIO(PL_statgv);
3430             else {
3431                 goto really_filename;
3432             }
3433         }
3434         else {
3435             PL_statgv = gv;
3436             sv_setpvs(PL_statname, "");
3437             io = GvIO(PL_statgv);
3438         }
3439         PL_laststatval = -1;
3440         PL_laststype = OP_STAT;
3441         if (io && IoIFP(io)) {
3442             int fd;
3443             if (! PerlIO_has_base(IoIFP(io)))
3444                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3445             fd = PerlIO_fileno(IoIFP(io));
3446             if (fd < 0) {
3447                 SETERRNO(EBADF,RMS_IFI);
3448                 FT_RETURNUNDEF;
3449             }
3450             PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3451             if (PL_laststatval < 0)
3452                 FT_RETURNUNDEF;
3453             if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3454                 if (PL_op->op_type == OP_FTTEXT)
3455                     FT_RETURNNO;
3456                 else
3457                     FT_RETURNYES;
3458             }
3459             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3460                 i = PerlIO_getc(IoIFP(io));
3461                 if (i != EOF)
3462                     (void)PerlIO_ungetc(IoIFP(io),i);
3463                 else
3464                     /* null file is anything */
3465                     FT_RETURNYES;
3466             }
3467             len = PerlIO_get_bufsiz(IoIFP(io));
3468             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3469             /* sfio can have large buffers - limit to 512 */
3470             if (len > 512)
3471                 len = 512;
3472         }
3473         else {
3474             SETERRNO(EBADF,RMS_IFI);
3475             report_evil_fh(gv);
3476             SETERRNO(EBADF,RMS_IFI);
3477             FT_RETURNUNDEF;
3478         }
3479     }
3480     else {
3481         const char *file;
3482         int fd;
3483
3484         assert(sv);
3485         sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3486       really_filename:
3487         file = SvPVX_const(PL_statname);
3488         PL_statgv = NULL;
3489         if (!(fp = PerlIO_open(file, "r"))) {
3490             if (!gv) {
3491                 PL_laststatval = -1;
3492                 PL_laststype = OP_STAT;
3493             }
3494             if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
3495                 /* PL_warn_nl is constant */
3496                 GCC_DIAG_IGNORE(-Wformat-nonliteral);
3497                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3498                 GCC_DIAG_RESTORE;
3499             }
3500             FT_RETURNUNDEF;
3501         }
3502         PL_laststype = OP_STAT;
3503         fd = PerlIO_fileno(fp);
3504         if (fd < 0) {
3505             (void)PerlIO_close(fp);
3506             SETERRNO(EBADF,RMS_IFI);
3507             FT_RETURNUNDEF;
3508         }
3509         PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3510         if (PL_laststatval < 0) {
3511             (void)PerlIO_close(fp);
3512             SETERRNO(EBADF,RMS_IFI);
3513             FT_RETURNUNDEF;
3514         }
3515         PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3516         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3517         (void)PerlIO_close(fp);
3518         if (len <= 0) {
3519             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3520                 FT_RETURNNO;            /* special case NFS directories */
3521             FT_RETURNYES;               /* null file is anything */
3522         }
3523         s = tbuf;
3524     }
3525
3526     /* now scan s to look for textiness */
3527
3528 #if defined(DOSISH) || defined(USEMYBINMODE)
3529     /* ignore trailing ^Z on short files */
3530     if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3531         --len;
3532 #endif
3533
3534     assert(len);
3535     if (! is_invariant_string((U8 *) s, len)) {
3536         const U8 *ep;
3537
3538         /* Here contains a variant under UTF-8 .  See if the entire string is
3539          * UTF-8.  But the buffer may end in a partial character, so consider
3540          * it UTF-8 if the first non-UTF8 char is an ending partial */
3541         if (is_utf8_string_loc((U8 *) s, len, &ep)
3542             || ep + UTF8SKIP(ep)  > (U8 *) (s + len))
3543         {
3544             if (PL_op->op_type == OP_FTTEXT) {
3545                 FT_RETURNYES;
3546             }
3547             else {
3548                 FT_RETURNNO;
3549             }
3550         }
3551     }
3552
3553     /* Here, is not UTF-8 or is entirely ASCII.  Look through the buffer for
3554      * things that wouldn't be in ASCII text or rich ASCII text.  Count these
3555      * in 'odd' */
3556     for (i = 0; i < len; i++, s++) {
3557         if (!*s) {                      /* null never allowed in text */
3558             odd += len;
3559             break;
3560         }
3561 #ifdef USE_LOCALE_CTYPE
3562         if (IN_LC_RUNTIME(LC_CTYPE)) {
3563             if ( isPRINT_LC(*s) || isSPACE_LC(*s)) {
3564                 continue;
3565             }
3566         }
3567         else
3568 #endif
3569         if (isPRINT_A(*s)
3570                    /* VT occurs so rarely in text, that we consider it odd */
3571                 || (isSPACE_A(*s) && *s != VT_NATIVE)
3572
3573                     /* But there is a fair amount of backspaces and escapes in
3574                      * some text */
3575                 || *s == '\b'
3576                 || *s == ESC_NATIVE)
3577         {
3578             continue;
3579         }
3580         odd++;
3581     }
3582
3583     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3584         FT_RETURNNO;
3585     else
3586         FT_RETURNYES;
3587 }
3588
3589 /* File calls. */
3590
3591 PP(pp_chdir)
3592 {
3593     dSP; dTARGET;
3594     const char *tmps = NULL;
3595     GV *gv = NULL;
3596
3597     if( MAXARG == 1 ) {
3598         SV * const sv = POPs;
3599         if (PL_op->op_flags & OPf_SPECIAL) {
3600             gv = gv_fetchsv(sv, 0, SVt_PVIO);
3601             if (!gv) {
3602                 if (ckWARN(WARN_UNOPENED)) {
3603                     Perl_warner(aTHX_ packWARN(WARN_UNOPENED),
3604                                 "chdir() on unopened filehandle %" SVf, sv);
3605                 }
3606                 SETERRNO(EBADF,RMS_IFI);
3607                 PUSHi(0);
3608                 TAINT_PROPER("chdir");
3609                 RETURN;
3610             }
3611         }
3612         else if (!(gv = MAYBE_DEREF_GV(sv)))
3613                 tmps = SvPV_nomg_const_nolen(sv);
3614     }
3615     else {
3616         HV * const table = GvHVn(PL_envgv);
3617         SV **svp;
3618
3619         if (    (svp = hv_fetchs(table, "HOME", FALSE))
3620              || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3621 #ifdef VMS
3622              || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3623 #endif
3624            )
3625         {
3626             tmps = SvPV_nolen_const(*svp);
3627         }
3628         else {
3629             PUSHi(0);
3630             SETERRNO(EINVAL, LIB_INVARG);
3631             TAINT_PROPER("chdir");
3632             RETURN;
3633         }
3634     }
3635
3636     TAINT_PROPER("chdir");
3637     if (gv) {
3638 #ifdef HAS_FCHDIR
3639         IO* const io = GvIO(gv);
3640         if (io) {
3641             if (IoDIRP(io)) {
3642                 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3643             } else if (IoIFP(io)) {
3644                 int fd = PerlIO_fileno(IoIFP(io));
3645                 if (fd < 0) {
3646                     goto nuts;
3647                 }
3648                 PUSHi(fchdir(fd) >= 0);
3649             }
3650             else {
3651                 goto nuts;
3652             }
3653         } else {
3654             goto nuts;
3655         }
3656
3657 #else
3658         DIE(aTHX_ PL_no_func, "fchdir");
3659 #endif
3660     }
3661     else
3662         PUSHi( PerlDir_chdir(tmps) >= 0 );
3663 #ifdef VMS
3664     /* Clear the DEFAULT element of ENV so we'll get the new value
3665      * in the future. */
3666     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3667 #endif
3668     RETURN;
3669
3670 #ifdef HAS_FCHDIR
3671  nuts:
3672     report_evil_fh(gv);
3673     SETERRNO(EBADF,RMS_IFI);
3674     PUSHi(0);
3675     RETURN;
3676 #endif
3677 }
3678
3679
3680 /* also used for: pp_chmod() pp_kill() pp_unlink() pp_utime() */
3681
3682 PP(pp_chown)
3683 {
3684     dSP; dMARK; dTARGET;
3685     const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3686
3687     SP = MARK;
3688     XPUSHi(value);
3689     RETURN;
3690 }
3691
3692 PP(pp_chroot)
3693 {
3694 #ifdef HAS_CHROOT
3695     dSP; dTARGET;
3696     char * const tmps = POPpx;
3697     TAINT_PROPER("chroot");
3698     PUSHi( chroot(tmps) >= 0 );
3699     RETURN;
3700 #else
3701     DIE(aTHX_ PL_no_func, "chroot");
3702 #endif
3703 }
3704
3705 PP(pp_rename)
3706 {
3707     dSP; dTARGET;
3708     int anum;
3709     const char * const tmps2 = POPpconstx;
3710     const char * const tmps = SvPV_nolen_const(TOPs);
3711     TAINT_PROPER("rename");
3712 #ifdef HAS_RENAME
3713     anum = PerlLIO_rename(tmps, tmps2);
3714 #else
3715     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3716         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3717             anum = 1;
3718         else {
3719             if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3720                 (void)UNLINK(tmps2);
3721             if (!(anum = link(tmps, tmps2)))
3722                 anum = UNLINK(tmps);
3723         }
3724     }
3725 #endif
3726     SETi( anum >= 0 );
3727     RETURN;
3728 }
3729
3730
3731 /* also used for: pp_symlink() */
3732
3733 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3734 PP(pp_link)
3735 {
3736     dSP; dTARGET;
3737     const int op_type = PL_op->op_type;
3738     int result;
3739
3740 #  ifndef HAS_LINK
3741     if (op_type == OP_LINK)
3742         DIE(aTHX_ PL_no_func, "link");
3743 #  endif
3744 #  ifndef HAS_SYMLINK
3745     if (op_type == OP_SYMLINK)
3746         DIE(aTHX_ PL_no_func, "symlink");
3747 #  endif
3748
3749     {
3750         const char * const tmps2 = POPpconstx;
3751         const char * const tmps = SvPV_nolen_const(TOPs);
3752         TAINT_PROPER(PL_op_desc[op_type]);
3753         result =
3754 #  if defined(HAS_LINK)
3755 #    if defined(HAS_SYMLINK)
3756             /* Both present - need to choose which.  */
3757             (op_type == OP_LINK) ?
3758             PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3759 #    else
3760     /* Only have link, so calls to pp_symlink will have DIE()d above.  */
3761         PerlLIO_link(tmps, tmps2);
3762 #    endif
3763 #  else
3764 #    if defined(HAS_SYMLINK)
3765     /* Only have symlink, so calls to pp_link will have DIE()d above.  */
3766         symlink(tmps, tmps2);
3767 #    endif
3768 #  endif
3769     }
3770
3771     SETi( result >= 0 );
3772     RETURN;
3773 }
3774 #else
3775
3776 /* also used for: pp_symlink() */
3777
3778 PP(pp_link)
3779 {
3780     /* Have neither.  */
3781     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3782 }
3783 #endif
3784
3785 PP(pp_readlink)
3786 {
3787     dSP;
3788 #ifdef HAS_SYMLINK
3789     dTARGET;
3790     const char *tmps;
3791     char buf[MAXPATHLEN];
3792     SSize_t len;
3793
3794     TAINT;
3795     tmps = POPpconstx;
3796     /* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
3797      * it is impossible to know whether the result was truncated. */
3798     len = readlink(tmps, buf, sizeof(buf) - 1);
3799     if (len < 0)
3800         RETPUSHUNDEF;
3801     if (len != -1)
3802         buf[len] = '\0';
3803     PUSHp(buf, len);
3804     RETURN;
3805 #else
3806     EXTEND(SP, 1);
3807     RETSETUNDEF;                /* just pretend it's a normal file */
3808 #endif
3809 }
3810
3811 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3812 STATIC int
3813 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3814 {
3815     char * const save_filename = filename;
3816     char *cmdline;
3817     char *s;
3818     PerlIO *myfp;
3819     int anum = 1;
3820     Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3821
3822     PERL_ARGS_ASSERT_DOONELINER;
3823
3824     Newx(cmdline, size, char);
3825     my_strlcpy(cmdline, cmd, size);
3826     my_strlcat(cmdline, " ", size);
3827     for (s = cmdline + strlen(cmdline); *filename; ) {
3828         *s++ = '\\';
3829         *s++ = *filename++;
3830     }
3831     if (s - cmdline < size)
3832         my_strlcpy(s, " 2>&1", size - (s - cmdline));
3833     myfp = PerlProc_popen(cmdline, "r");
3834     Safefree(cmdline);
3835
3836     if (myfp) {
3837         SV * const tmpsv = sv_newmortal();
3838         /* Need to save/restore 'PL_rs' ?? */
3839         s = sv_gets(tmpsv, myfp, 0);
3840         (void)PerlProc_pclose(myfp);
3841         if (s != NULL) {
3842             int e;
3843             for (e = 1;
3844 #ifdef HAS_SYS_ERRLIST
3845                  e <= sys_nerr
3846 #endif
3847                  ; e++)
3848             {
3849                 /* you don't see this */
3850                 const char * const errmsg = Strerror(e) ;
3851                 if (!errmsg)
3852                     break;
3853                 if (instr(s, errmsg)) {
3854                     SETERRNO(e,0);
3855                     return 0;
3856                 }
3857             }
3858             SETERRNO(0,0);
3859 #ifndef EACCES
3860 #define EACCES EPERM
3861 #endif
3862             if (instr(s, "cannot make"))
3863                 SETERRNO(EEXIST,RMS_FEX);
3864             else if (instr(s, "existing file"))
3865                 SETERRNO(EEXIST,RMS_FEX);
3866             else if (instr(s, "ile exists"))
3867                 SETERRNO(EEXIST,RMS_FEX);
3868             else if (instr(s, "non-exist"))
3869                 SETERRNO(ENOENT,RMS_FNF);
3870             else if (instr(s, "does not exist"))
3871                 SETERRNO(ENOENT,RMS_FNF);
3872             else if (instr(s, "not empty"))
3873                 SETERRNO(EBUSY,SS_DEVOFFLINE);
3874             else if (instr(s, "cannot access"))
3875                 SETERRNO(EACCES,RMS_PRV);
3876             else
3877                 SETERRNO(EPERM,RMS_PRV);
3878             return 0;
3879         }
3880         else {  /* some mkdirs return no failure indication */
3881             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3882             if (PL_op->op_type == OP_RMDIR)
3883                 anum = !anum;
3884             if (anum)
3885                 SETERRNO(0,0);
3886             else
3887                 SETERRNO(EACCES,RMS_PRV);       /* a guess */
3888         }
3889         return anum;
3890     }
3891     else
3892         return 0;
3893 }
3894 #endif
3895
3896 /* This macro removes trailing slashes from a directory name.
3897  * Different operating and file systems take differently to
3898  * trailing slashes.  According to POSIX 1003.1 1996 Edition
3899  * any number of trailing slashes should be allowed.
3900  * Thusly we snip them away so that even non-conforming
3901  * systems are happy.
3902  * We should probably do this "filtering" for all
3903  * the functions that expect (potentially) directory names:
3904  * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3905  * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3906
3907 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3908     if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3909         do { \
3910             (len)--; \
3911         } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3912         (tmps) = savepvn((tmps), (len)); \
3913         (copy) = TRUE; \
3914     }
3915
3916 PP(pp_mkdir)
3917 {
3918     dSP; dTARGET;
3919     STRLEN len;
3920     const char *tmps;
3921     bool copy = FALSE;
3922     const unsigned int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPu : 0777;
3923
3924     TRIMSLASHES(tmps,len,copy);
3925
3926     TAINT_PROPER("mkdir");
3927 #ifdef HAS_MKDIR
3928     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3929 #else
3930     {
3931     int oldumask;
3932     SETi( dooneliner("mkdir", tmps) );
3933     oldumask = PerlLIO_umask(0);
3934     PerlLIO_umask(oldumask);
3935     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3936     }
3937 #endif
3938     if (copy)
3939         Safefree(tmps);
3940     RETURN;
3941 }
3942
3943 PP(pp_rmdir)
3944 {
3945     dSP; dTARGET;
3946     STRLEN len;
3947     const char *tmps;
3948     bool copy = FALSE;
3949
3950     TRIMSLASHES(tmps,len,copy);
3951     TAINT_PROPER("rmdir");
3952 #ifdef HAS_RMDIR
3953     SETi( PerlDir_rmdir(tmps) >= 0 );
3954 #else
3955     SETi( dooneliner("rmdir", tmps) );
3956 #endif
3957     if (copy)
3958         Safefree(tmps);
3959     RETURN;
3960 }
3961
3962 /* Directory calls. */
3963
3964 PP(pp_open_dir)
3965 {
3966 #if defined(Direntry_t) && defined(HAS_READDIR)
3967     dSP;
3968     const char * const dirname = POPpconstx;
3969     GV * const gv = MUTABLE_GV(POPs);
3970     IO * const io = GvIOn(gv);
3971
3972     if ((IoIFP(io) || IoOFP(io)))
3973         Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3974                          "Opening filehandle %"HEKf" also as a directory",
3975                              HEKfARG(GvENAME_HEK(gv)) );
3976     if (IoDIRP(io))
3977         PerlDir_close(IoDIRP(io));
3978     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3979         goto nope;
3980
3981     RETPUSHYES;
3982   nope:
3983     if (!errno)
3984         SETERRNO(EBADF,RMS_DIR);
3985     RETPUSHUNDEF;
3986 #else
3987     DIE(aTHX_ PL_no_dir_func, "opendir");
3988 #endif
3989 }
3990
3991 PP(pp_readdir)
3992 {
3993 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3994     DIE(aTHX_ PL_no_dir_func, "readdir");
3995 #else
3996 #if !defined(I_DIRENT) && !defined(VMS)
3997     Direntry_t *readdir (DIR *);
3998 #endif
3999     dSP;
4000
4001     SV *sv;
4002     const I32 gimme = GIMME_V;
4003     GV * const gv = MUTABLE_GV(POPs);
4004     const Direntry_t *dp;
4005     IO * const io = GvIOn(gv);
4006
4007     if (!IoDIRP(io)) {
4008         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4009                        "readdir() attempted on invalid dirhandle %"HEKf,
4010                             HEKfARG(GvENAME_HEK(gv)));
4011         goto nope;
4012     }
4013
4014     do {
4015         dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
4016         if (!dp)
4017             break;
4018 #ifdef DIRNAMLEN
4019         sv = newSVpvn(dp->d_name, dp->d_namlen);
4020 #else
4021         sv = newSVpv(dp->d_name, 0);
4022 #endif
4023         if (!(IoFLAGS(io) & IOf_UNTAINT))
4024             SvTAINTED_on(sv);
4025         mXPUSHs(sv);
4026     } while (gimme == G_ARRAY);
4027
4028     if (!dp && gimme != G_ARRAY)
4029         RETPUSHUNDEF;
4030
4031     RETURN;
4032
4033   nope:
4034     if (!errno)
4035         SETERRNO(EBADF,RMS_ISI);
4036     if (gimme == G_ARRAY)
4037         RETURN;
4038     else
4039         RETPUSHUNDEF;
4040 #endif
4041 }
4042
4043 PP(pp_telldir)
4044 {
4045 #if defined(HAS_TELLDIR) || defined(telldir)
4046     dSP; dTARGET;
4047  /* XXX does _anyone_ need this? --AD 2/20/1998 */
4048  /* XXX netbsd still seemed to.
4049     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
4050     --JHI 1999-Feb-02 */
4051 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
4052     long telldir (DIR *);
4053 # endif
4054     GV * const gv = MUTABLE_GV(POPs);
4055     IO * const io = GvIOn(gv);
4056
4057     if (!IoDIRP(io)) {
4058         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4059                        "telldir() attempted on invalid dirhandle %"HEKf,
4060                             HEKfARG(GvENAME_HEK(gv)));
4061         goto nope;
4062     }
4063
4064     PUSHi( PerlDir_tell(IoDIRP(io)) );
4065     RETURN;
4066   nope:
4067     if (!errno)
4068         SETERRNO(EBADF,RMS_ISI);
4069     RETPUSHUNDEF;
4070 #else
4071     DIE(aTHX_ PL_no_dir_func, "telldir");
4072 #endif
4073 }
4074
4075 PP(pp_seekdir)
4076 {
4077 #if defined(HAS_SEEKDIR) || defined(seekdir)
4078     dSP;
4079     const long along = POPl;
4080     GV * const gv = MUTABLE_GV(POPs);
4081     IO * const io = GvIOn(gv);
4082
4083     if (!IoDIRP(io)) {
4084         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4085                        "seekdir() attempted on invalid dirhandle %"HEKf,
4086                                 HEKfARG(GvENAME_HEK(gv)));
4087         goto nope;
4088     }
4089     (void)PerlDir_seek(IoDIRP(io), along);
4090
4091     RETPUSHYES;
4092   nope:
4093     if (!errno)
4094         SETERRNO(EBADF,RMS_ISI);
4095     RETPUSHUNDEF;
4096 #else
4097     DIE(aTHX_ PL_no_dir_func, "seekdir");
4098 #endif
4099 }
4100
4101 PP(pp_rewinddir)
4102 {
4103 #if defined(HAS_REWINDDIR) || defined(rewinddir)
4104     dSP;
4105     GV * const gv = MUTABLE_GV(POPs);
4106     IO * const io = GvIOn(gv);
4107
4108     if (!IoDIRP(io)) {
4109         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4110                        "rewinddir() attempted on invalid dirhandle %"HEKf,
4111                                 HEKfARG(GvENAME_HEK(gv)));
4112         goto nope;
4113     }
4114     (void)PerlDir_rewind(IoDIRP(io));
4115     RETPUSHYES;
4116   nope:
4117     if (!errno)
4118         SETERRNO(EBADF,RMS_ISI);
4119     RETPUSHUNDEF;
4120 #else
4121     DIE(aTHX_ PL_no_dir_func, "rewinddir");
4122 #endif
4123 }
4124
4125 PP(pp_closedir)
4126 {
4127 #if defined(Direntry_t) && defined(HAS_READDIR)
4128     dSP;
4129     GV * const gv = MUTABLE_GV(POPs);
4130     IO * const io = GvIOn(gv);
4131
4132     if (!IoDIRP(io)) {
4133         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4134                        "closedir() attempted on invalid dirhandle %"HEKf,
4135                                 HEKfARG(GvENAME_HEK(gv)));
4136         goto nope;
4137     }
4138 #ifdef VOID_CLOSEDIR
4139     PerlDir_close(IoDIRP(io));
4140 #else
4141     if (PerlDir_close(IoDIRP(io)) < 0) {
4142         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4143         goto nope;
4144     }
4145 #endif
4146     IoDIRP(io) = 0;
4147
4148     RETPUSHYES;
4149   nope:
4150     if (!errno)
4151         SETERRNO(EBADF,RMS_IFI);
4152     RETPUSHUNDEF;
4153 #else
4154     DIE(aTHX_ PL_no_dir_func, "closedir");
4155 #endif
4156 }
4157
4158 /* Process control. */
4159
4160 PP(pp_fork)
4161 {
4162 #ifdef HAS_FORK
4163     dSP; dTARGET;
4164     Pid_t childpid;
4165 #ifdef HAS_SIGPROCMASK
4166     sigset_t oldmask, newmask;
4167 #endif
4168
4169     EXTEND(SP, 1);
4170     PERL_FLUSHALL_FOR_CHILD;
4171 #ifdef HAS_SIGPROCMASK
4172     sigfillset(&newmask);
4173     sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4174 #endif
4175     childpid = PerlProc_fork();
4176     if (childpid == 0) {
4177         int sig;
4178         PL_sig_pending = 0;
4179         if (PL_psig_pend)
4180             for (sig = 1; sig < SIG_SIZE; sig++)
4181                 PL_psig_pend[sig] = 0;
4182     }
4183 #ifdef HAS_SIGPROCMASK
4184     {
4185         dSAVE_ERRNO;
4186         sigprocmask(SIG_SETMASK, &oldmask, NULL);
4187         RESTORE_ERRNO;
4188     }
4189 #endif
4190     if (childpid < 0)
4191         RETPUSHUNDEF;
4192     if (!childpid) {
4193 #ifdef PERL_USES_PL_PIDSTATUS
4194         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4195 #endif
4196     }
4197     PUSHi(childpid);
4198     RETURN;
4199 #else
4200 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4201     dSP; dTARGET;
4202     Pid_t childpid;
4203
4204     EXTEND(SP, 1);
4205     PERL_FLUSHALL_FOR_CHILD;
4206     childpid = PerlProc_fork();
4207     if (childpid == -1)
4208         RETPUSHUNDEF;
4209     PUSHi(childpid);
4210     RETURN;
4211 #  else
4212     DIE(aTHX_ PL_no_func, "fork");
4213 #  endif
4214 #endif
4215 }
4216
4217 PP(pp_wait)
4218 {
4219 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4220     dSP; dTARGET;
4221     Pid_t childpid;
4222     int argflags;
4223
4224     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4225         childpid = wait4pid(-1, &argflags, 0);
4226     else {
4227         while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4228                errno == EINTR) {
4229           PERL_ASYNC_CHECK();
4230         }
4231     }
4232 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4233     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4234     STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4235 #  else
4236     STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4237 #  endif
4238     XPUSHi(childpid);
4239     RETURN;
4240 #else
4241     DIE(aTHX_ PL_no_func, "wait");
4242 #endif
4243 }
4244
4245 PP(pp_waitpid)
4246 {
4247 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4248     dSP; dTARGET;
4249     const int optype = POPi;
4250     const Pid_t pid = TOPi;
4251     Pid_t result;
4252     int argflags;
4253
4254     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4255         result = wait4pid(pid, &argflags, optype);
4256     else {
4257         while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4258                errno == EINTR) {
4259           PERL_ASYNC_CHECK();
4260         }
4261     }
4262 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4263     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4264     STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4265 #  else
4266     STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4267 #  endif
4268     SETi(result);
4269     RETURN;
4270 #else
4271     DIE(aTHX_ PL_no_func, "waitpid");
4272 #endif
4273 }
4274
4275 PP(pp_system)
4276 {
4277     dSP; dMARK; dORIGMARK; dTARGET;
4278 #if defined(__LIBCATAMOUNT__)
4279     PL_statusvalue = -1;
4280     SP = ORIGMARK;
4281     XPUSHi(-1);
4282 #else
4283     I32 value;
4284     int result;
4285
4286     if (TAINTING_get) {
4287         TAINT_ENV();
4288         while (++MARK <= SP) {
4289             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4290             if (TAINT_get)
4291                 break;
4292         }
4293         MARK = ORIGMARK;
4294         TAINT_PROPER("system");
4295     }
4296     PERL_FLUSHALL_FOR_CHILD;
4297 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4298     {
4299         Pid_t childpid;
4300         int pp[2];
4301         I32 did_pipes = 0;
4302 #ifdef HAS_SIGPROCMASK
4303         sigset_t newset, oldset;
4304 #endif
4305
4306         if (PerlProc_pipe(pp) >= 0)
4307             did_pipes = 1;
4308 #ifdef HAS_SIGPROCMASK
4309         sigemptyset(&newset);
4310         sigaddset(&newset, SIGCHLD);
4311         sigprocmask(SIG_BLOCK, &newset, &oldset);
4312 #endif
4313         while ((childpid = PerlProc_fork()) == -1) {
4314             if (errno != EAGAIN) {
4315                 value = -1;
4316                 SP = ORIGMARK;
4317                 XPUSHi(value);
4318                 if (did_pipes) {
4319                     PerlLIO_close(pp[0]);
4320                     PerlLIO_close(pp[1]);
4321                 }
4322 #ifdef HAS_SIGPROCMASK
4323                 sigprocmask(SIG_SETMASK, &oldset, NULL);
4324 #endif
4325                 RETURN;
4326             }
4327             sleep(5);
4328         }
4329         if (childpid > 0) {
4330             Sigsave_t ihand,qhand; /* place to save signals during system() */
4331             int status;
4332
4333             if (did_pipes)
4334                 PerlLIO_close(pp[1]);
4335 #ifndef PERL_MICRO
4336             rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &ihand);
4337             rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4338 #endif
4339             do {
4340                 result = wait4pid(childpid, &status, 0);
4341             } while (result == -1 && errno == EINTR);
4342 #ifndef PERL_MICRO
4343 #ifdef HAS_SIGPROCMASK
4344             sigprocmask(SIG_SETMASK, &oldset, NULL);
4345 #endif
4346             (void)rsignal_restore(SIGINT, &ihand);
4347             (void)rsignal_restore(SIGQUIT, &qhand);
4348 #endif
4349             STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4350             do_execfree();      /* free any memory child malloced on fork */
4351             SP = ORIGMARK;
4352             if (did_pipes) {
4353                 int errkid;
4354                 unsigned n = 0;
4355                 SSize_t n1;
4356
4357                 while (n < sizeof(int)) {
4358                     n1 = PerlLIO_read(pp[0],
4359                                       (void*)(((char*)&errkid)+n),
4360                                       (sizeof(int)) - n);
4361                     if (n1 <= 0)
4362                         break;
4363                     n += n1;
4364                 }
4365                 PerlLIO_close(pp[0]);
4366                 if (n) {                        /* Error */
4367                     if (n != sizeof(int))
4368                         DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4369                     errno = errkid;             /* Propagate errno from kid */
4370                     STATUS_NATIVE_CHILD_SET(-1);
4371                 }
4372             }
4373             XPUSHi(STATUS_CURRENT);
4374             RETURN;
4375         }
4376 #ifdef HAS_SIGPROCMASK
4377         sigprocmask(SIG_SETMASK, &oldset, NULL);
4378 #endif
4379         if (did_pipes) {
4380             PerlLIO_close(pp[0]);
4381 #if defined(HAS_FCNTL) && defined(F_SETFD)
4382             if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
4383                 RETPUSHUNDEF;
4384 #endif
4385         }
4386         if (PL_op->op_flags & OPf_STACKED) {
4387             SV * const really = *++MARK;
4388             value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4389         }
4390         else if (SP - MARK != 1)
4391             value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4392         else {
4393             value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4394         }
4395         PerlProc__exit(-1);
4396     }
4397 #else /* ! FORK or VMS or OS/2 */
4398     PL_statusvalue = 0;
4399     result = 0;
4400     if (PL_op->op_flags & OPf_STACKED) {
4401         SV * const really = *++MARK;
4402 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4403         value = (I32)do_aspawn(really, MARK, SP);
4404 #  else
4405         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4406 #  endif
4407     }
4408     else if (SP - MARK != 1) {
4409 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4410         value = (I32)do_aspawn(NULL, MARK, SP);
4411 #  else
4412         value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4413 #  endif
4414     }
4415     else {
4416         value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4417     }
4418     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4419         result = 1;
4420     STATUS_NATIVE_CHILD_SET(value);
4421     do_execfree();
4422     SP = ORIGMARK;
4423     XPUSHi(result ? value : STATUS_CURRENT);
4424 #endif /* !FORK or VMS or OS/2 */
4425 #endif
4426     RETURN;
4427 }
4428
4429 PP(pp_exec)
4430 {
4431     dSP; dMARK; dORIGMARK; dTARGET;
4432     I32 value;
4433
4434     if (TAINTING_get) {
4435         TAINT_ENV();
4436         while (++MARK <= SP) {
4437             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4438             if (TAINT_get)
4439                 break;
4440         }
4441         MARK = ORIGMARK;
4442         TAINT_PROPER("exec");
4443     }
4444     PERL_FLUSHALL_FOR_CHILD;
4445     if (PL_op->op_flags & OPf_STACKED) {
4446         SV * const really = *++MARK;
4447         value = (I32)do_aexec(really, MARK, SP);
4448     }
4449     else if (SP - MARK != 1)
4450 #ifdef VMS
4451         value = (I32)vms_do_aexec(NULL, MARK, SP);
4452 #else
4453         value = (I32)do_aexec(NULL, MARK, SP);
4454 #endif
4455     else {
4456 #ifdef VMS
4457         value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4458 #else
4459         value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4460 #endif
4461     }
4462
4463     SP = ORIGMARK;
4464     XPUSHi(value);
4465     RETURN;
4466 }
4467
4468 PP(pp_getppid)
4469 {
4470 #ifdef HAS_GETPPID
4471     dSP; dTARGET;
4472     XPUSHi( getppid() );
4473     RETURN;
4474 #else
4475     DIE(aTHX_ PL_no_func, "getppid");
4476 #endif
4477 }
4478
4479 PP(pp_getpgrp)
4480 {
4481 #ifdef HAS_GETPGRP
4482     dSP; dTARGET;
4483     Pid_t pgrp;
4484     const Pid_t pid =
4485         (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4486
4487 #ifdef BSD_GETPGRP
4488     pgrp = (I32)BSD_GETPGRP(pid);
4489 #else
4490     if (pid != 0 && pid != PerlProc_getpid())
4491         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4492     pgrp = getpgrp();
4493 #endif
4494     XPUSHi(pgrp);
4495     RETURN;
4496 #else
4497     DIE(aTHX_ PL_no_func, "getpgrp");
4498 #endif
4499 }
4500
4501 PP(pp_setpgrp)
4502 {
4503 #ifdef HAS_SETPGRP
4504     dSP; dTARGET;
4505     Pid_t pgrp;
4506     Pid_t pid;
4507     pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4508     if (MAXARG > 0) pid = TOPs ? TOPi : 0;
4509     else {
4510         pid = 0;
4511         EXTEND(SP,1);
4512         SP++;
4513     }
4514
4515     TAINT_PROPER("setpgrp");
4516 #ifdef BSD_SETPGRP
4517     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4518 #else
4519     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4520         || (pid != 0 && pid != PerlProc_getpid()))
4521     {
4522         DIE(aTHX_ "setpgrp can't take arguments");
4523     }
4524     SETi( setpgrp() >= 0 );
4525 #endif /* USE_BSDPGRP */
4526     RETURN;
4527 #else
4528     DIE(aTHX_ PL_no_func, "setpgrp");
4529 #endif
4530 }
4531
4532 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4533 #  define PRIORITY_WHICH_T(which) (__priority_which_t)which
4534 #else
4535 #  define PRIORITY_WHICH_T(which) which
4536 #endif
4537
4538 PP(pp_getpriority)
4539 {
4540 #ifdef HAS_GETPRIORITY
4541     dSP; dTARGET;
4542     const int who = POPi;
4543     const int which = TOPi;
4544     SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4545     RETURN;
4546 #else
4547     DIE(aTHX_ PL_no_func, "getpriority");
4548 #endif
4549 }
4550
4551 PP(pp_setpriority)
4552 {
4553 #ifdef HAS_SETPRIORITY
4554     dSP; dTARGET;
4555     const int niceval = POPi;
4556     const int who = POPi;
4557     const int which = TOPi;
4558     TAINT_PROPER("setpriority");
4559     SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4560     RETURN;
4561 #else
4562     DIE(aTHX_ PL_no_func, "setpriority");
4563 #endif
4564 }
4565
4566 #undef PRIORITY_WHICH_T
4567
4568 /* Time calls. */
4569
4570 PP(pp_time)
4571 {
4572     dSP; dTARGET;
4573 #ifdef BIG_TIME
4574     XPUSHn( time(NULL) );
4575 #else
4576     XPUSHi( time(NULL) );
4577 #endif
4578     RETURN;
4579 }
4580
4581 PP(pp_tms)
4582 {
4583 #ifdef HAS_TIMES
4584     dSP;
4585     struct tms timesbuf;
4586
4587     EXTEND(SP, 4);
4588     (void)PerlProc_times(&timesbuf);
4589
4590     mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick);
4591     if (GIMME_V == G_ARRAY) {
4592         mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick);
4593         mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick);
4594         mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick);
4595     }
4596     RETURN;
4597 #else
4598 #   ifdef PERL_MICRO
4599     dSP;
4600     mPUSHn(0.0);
4601     EXTEND(SP, 4);
4602     if (GIMME_V == G_ARRAY) {
4603          mPUSHn(0.0);
4604          mPUSHn(0.0);
4605          mPUSHn(0.0);
4606     }
4607     RETURN;
4608 #   else
4609     DIE(aTHX_ "times not implemented");
4610 #   endif
4611 #endif /* HAS_TIMES */
4612 }
4613
4614 /* The 32 bit int year limits the times we can represent to these
4615    boundaries with a few days wiggle room to account for time zone
4616    offsets
4617 */
4618 /* Sat Jan  3 00:00:00 -2147481748 */
4619 #define TIME_LOWER_BOUND -67768100567755200.0
4620 /* Sun Dec 29 12:00:00  2147483647 */
4621 #define TIME_UPPER_BOUND  67767976233316800.0
4622
4623
4624 /* also used for: pp_localtime() */
4625
4626 PP(pp_gmtime)
4627 {
4628     dSP;
4629     Time64_T when;
4630     struct TM tmbuf;
4631     struct TM *err;
4632     const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4633     static const char * const dayname[] =
4634         {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4635     static const char * const monname[] =
4636         {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4637          "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4638
4639     if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4640         time_t now;
4641         (void)time(&now);
4642         when = (Time64_T)now;
4643     }
4644     else {
4645         NV input = Perl_floor(POPn);
4646         const bool pl_isnan = Perl_isnan(input);
4647         when = (Time64_T)input;
4648         if (UNLIKELY(pl_isnan || when != input)) {
4649             /* diag_listed_as: gmtime(%f) too large */
4650             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4651                            "%s(%.0" NVff ") too large", opname, input);
4652             if (pl_isnan) {
4653                 err = NULL;
4654                 goto failed;
4655             }
4656         }
4657     }
4658
4659     if ( TIME_LOWER_BOUND > when ) {
4660         /* diag_listed_as: gmtime(%f) too small */
4661         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4662                        "%s(%.0" NVff ") too small", opname, when);
4663         err = NULL;
4664     }
4665     else if( when > TIME_UPPER_BOUND ) {
4666         /* diag_listed_as: gmtime(%f) too small */
4667         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4668                        "%s(%.0" NVff ") too large", opname, when);
4669         err = NULL;
4670     }
4671     else {
4672         if (PL_op->op_type == OP_LOCALTIME)
4673             err = Perl_localtime64_r(&when, &tmbuf);
4674         else
4675             err = Perl_gmtime64_r(&when, &tmbuf);
4676     }
4677
4678     if (err == NULL) {
4679         /* diag_listed_as: gmtime(%f) failed */
4680         /* XXX %lld broken for quads */
4681       failed:
4682         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4683                        "%s(%.0" NVff ") failed", opname, when);
4684     }
4685
4686     if (GIMME_V != G_ARRAY) {   /* scalar context */
4687         EXTEND(SP, 1);
4688         if (err == NULL)
4689             RETPUSHUNDEF;
4690        else {
4691            dTARGET;
4692            PUSHs(TARG);
4693            Perl_sv_setpvf_mg(aTHX_ TARG, "%s %s %2d %02d:%02d:%02d %"IVdf,
4694                                 dayname[tmbuf.tm_wday],
4695                                 monname[tmbuf.tm_mon],
4696                                 tmbuf.tm_mday,
4697                                 tmbuf.tm_hour,
4698                                 tmbuf.tm_min,
4699                                 tmbuf.tm_sec,
4700                                 (IV)tmbuf.tm_year + 1900);
4701         }
4702     }
4703     else {                      /* list context */
4704         if ( err == NULL )
4705             RETURN;
4706
4707         EXTEND(SP, 9);
4708         EXTEND_MORTAL(9);
4709         mPUSHi(tmbuf.tm_sec);
4710         mPUSHi(tmbuf.tm_min);
4711         mPUSHi(tmbuf.tm_hour);
4712         mPUSHi(tmbuf.tm_mday);
4713         mPUSHi(tmbuf.tm_mon);
4714         mPUSHn(tmbuf.tm_year);
4715         mPUSHi(tmbuf.tm_wday);
4716         mPUSHi(tmbuf.tm_yday);
4717         mPUSHi(tmbuf.tm_isdst);
4718     }
4719     RETURN;
4720 }
4721
4722 PP(pp_alarm)
4723 {
4724 #ifdef HAS_ALARM
4725     dSP; dTARGET;
4726     /* alarm() takes an unsigned int number of seconds, and return the
4727      * unsigned int number of seconds remaining in the previous alarm
4728      * (alarms don't stack).  Therefore negative return values are not
4729      * possible. */
4730     int anum = POPi;
4731     if (anum < 0) {
4732         /* Note that while the C library function alarm() as such has
4733          * no errors defined (or in other words, properly behaving client
4734          * code shouldn't expect any), alarm() being obsoleted by
4735          * setitimer() and often being implemented in terms of
4736          * setitimer(), can fail. */
4737         /* diag_listed_as: %s() with negative argument */
4738         Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
4739                          "alarm() with negative argument");
4740         SETERRNO(EINVAL, LIB_INVARG);
4741         RETPUSHUNDEF;
4742     }
4743     else {
4744         unsigned int retval = alarm(anum);
4745         if ((int)retval < 0) /* Strictly speaking "cannot happen". */
4746             RETPUSHUNDEF;
4747         PUSHu(retval);
4748         RETURN;
4749     }
4750 #else
4751     DIE(aTHX_ PL_no_func, "alarm");
4752 #endif
4753 }
4754
4755 PP(pp_sleep)
4756 {
4757     dSP; dTARGET;
4758     I32 duration;
4759     Time_t lasttime;
4760     Time_t when;
4761
4762     (void)time(&lasttime);
4763     if (MAXARG < 1 || (!TOPs && !POPs))
4764         PerlProc_pause();
4765     else {
4766         duration = POPi;
4767         if (duration < 0) {
4768           /* diag_listed_as: %s() with negative argument */
4769           Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
4770                            "sleep() with negative argument");
4771           SETERRNO(EINVAL, LIB_INVARG);
4772           XPUSHi(0);
4773           RETURN;
4774         } else {
4775           PerlProc_sleep((unsigned int)duration);
4776         }
4777     }
4778     (void)time(&when);
4779     XPUSHi(when - lasttime);
4780     RETURN;
4781 }
4782
4783 /* Shared memory. */
4784 /* Merged with some message passing. */
4785
4786 /* also used for: pp_msgrcv() pp_msgsnd() pp_semop() pp_shmread() */
4787
4788 PP(pp_shmwrite)
4789 {
4790 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4791     dSP; dMARK; dTARGET;
4792     const int op_type = PL_op->op_type;
4793     I32 value;
4794
4795     switch (op_type) {
4796     case OP_MSGSND:
4797         value = (I32)(do_msgsnd(MARK, SP) >= 0);
4798         break;
4799     case OP_MSGRCV:
4800         value = (I32)(do_msgrcv(MARK, SP) >= 0);
4801         break;
4802     case OP_SEMOP:
4803         value = (I32)(do_semop(MARK, SP) >= 0);
4804         break;
4805     default:
4806         value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4807         break;
4808     }
4809
4810     SP = MARK;
4811     PUSHi(value);
4812     RETURN;
4813 #else
4814     return Perl_pp_semget(aTHX);
4815 #endif
4816 }
4817
4818 /* Semaphores. */
4819
4820 /* also used for: pp_msgget() pp_shmget() */
4821
4822 PP(pp_semget)
4823 {
4824 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4825     dSP; dMARK; dTARGET;
4826     const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4827     SP = MARK;
4828     if (anum == -1)
4829         RETPUSHUNDEF;
4830     PUSHi(anum);
4831     RETURN;
4832 #else
4833     DIE(aTHX_ "System V IPC is not implemented on this machine");
4834 #endif
4835 }
4836
4837 /* also used for: pp_msgctl() pp_shmctl() */
4838
4839 PP(pp_semctl)
4840 {
4841 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4842     dSP; dMARK; dTARGET;
4843     const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4844     SP = MARK;
4845     if (anum == -1)
4846         RETPUSHUNDEF;
4847     if (anum != 0) {
4848         PUSHi(anum);
4849     }
4850     else {
4851         PUSHp(zero_but_true, ZBTLEN);
4852     }
4853     RETURN;
4854 #else
4855     return Perl_pp_semget(aTHX);
4856 #endif
4857 }
4858
4859 /* I can't const this further without getting warnings about the types of
4860    various arrays passed in from structures.  */
4861 static SV *
4862 S_space_join_names_mortal(pTHX_ char *const *array)
4863 {
4864     SV *target;
4865
4866     PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4867
4868     if (*array) {
4869         target = newSVpvs_flags("", SVs_TEMP);
4870         while (1) {
4871             sv_catpv(target, *array);
4872             if (!*++array)
4873                 break;
4874             sv_catpvs(target, " ");
4875         }
4876     } else {
4877         target = sv_mortalcopy(&PL_sv_no);
4878     }
4879     return target;
4880 }
4881
4882 /* Get system info. */
4883
4884 /* also used for: pp_ghbyaddr() pp_ghbyname() */
4885
4886 PP(pp_ghostent)
4887 {
4888 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4889     dSP;
4890     I32 which = PL_op->op_type;
4891     char **elem;
4892     SV *sv;
4893 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4894     struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4895     struct hostent *gethostbyname(Netdb_name_t);
4896     struct hostent *gethostent(void);
4897 #endif
4898     struct hostent *hent = NULL;
4899     unsigned long len;
4900
4901     EXTEND(SP, 10);
4902     if (which == OP_GHBYNAME) {
4903 #ifdef HAS_GETHOSTBYNAME
4904         const char* const name = POPpbytex;
4905         hent = PerlSock_gethostbyname(name);
4906 #else
4907         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4908 #endif
4909     }
4910     else if (which == OP_GHBYADDR) {
4911 #ifdef HAS_GETHOSTBYADDR
4912         const int addrtype = POPi;
4913         SV * const addrsv = POPs;
4914         STRLEN addrlen;
4915         const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4916
4917         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4918 #else
4919         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4920 #endif
4921     }
4922     else
4923 #ifdef HAS_GETHOSTENT
4924         hent = PerlSock_gethostent();
4925 #else
4926         DIE(aTHX_ PL_no_sock_func, "gethostent");
4927 #endif
4928
4929 #ifdef HOST_NOT_FOUND
4930         if (!hent) {
4931 #ifdef USE_REENTRANT_API
4932 #   ifdef USE_GETHOSTENT_ERRNO
4933             h_errno = PL_reentrant_buffer->_gethostent_errno;
4934 #   endif
4935 #endif
4936             STATUS_UNIX_SET(h_errno);
4937         }
4938 #endif
4939
4940     if (GIMME_V != G_ARRAY) {
4941         PUSHs(sv = sv_newmortal());
4942         if (hent) {
4943             if (which == OP_GHBYNAME) {
4944                 if (hent->h_addr)
4945                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4946             }
4947             else
4948                 sv_setpv(sv, (char*)hent->h_name);
4949         }
4950         RETURN;
4951     }
4952
4953     if (hent) {
4954         mPUSHs(newSVpv((char*)hent->h_name, 0));
4955         PUSHs(space_join_names_mortal(hent->h_aliases));
4956         mPUSHi(hent->h_addrtype);
4957         len = hent->h_length;
4958         mPUSHi(len);
4959 #ifdef h_addr
4960         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4961             mXPUSHp(*elem, len);
4962         }
4963 #else
4964         if (hent->h_addr)
4965             mPUSHp(hent->h_addr, len);
4966         else
4967             PUSHs(sv_mortalcopy(&PL_sv_no));
4968 #endif /* h_addr */
4969     }
4970     RETURN;
4971 #else
4972     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4973 #endif
4974 }
4975
4976 /* also used for: pp_gnbyaddr() pp_gnbyname() */
4977
4978 PP(pp_gnetent)
4979 {
4980 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4981     dSP;
4982     I32 which = PL_op->op_type;
4983     SV *sv;
4984 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4985     struct netent *getnetbyaddr(Netdb_net_t, int);
4986     struct netent *getnetbyname(Netdb_name_t);
4987     struct netent *getnetent(void);
4988 #endif
4989     struct netent *nent;
4990
4991     if (which == OP_GNBYNAME){
4992 #ifdef HAS_GETNETBYNAME
4993         const char * const name = POPpbytex;
4994         nent = PerlSock_getnetbyname(name);
4995 #else
4996         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4997 #endif
4998     }
4999     else if (which == OP_GNBYADDR) {
5000 #ifdef HAS_GETNETBYADDR
5001         const int addrtype = POPi;
5002         const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
5003         nent = PerlSock_getnetbyaddr(addr, addrtype);
5004 #else
5005         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
5006 #endif
5007     }
5008     else
5009 #ifdef HAS_GETNETENT
5010         nent = PerlSock_getnetent();
5011 #else
5012         DIE(aTHX_ PL_no_sock_func, "getnetent");
5013 #endif
5014
5015 #ifdef HOST_NOT_FOUND
5016         if (!nent) {
5017 #ifdef USE_REENTRANT_API
5018 #   ifdef USE_GETNETENT_ERRNO
5019              h_errno = PL_reentrant_buffer->_getnetent_errno;
5020 #   endif
5021 #endif
5022             STATUS_UNIX_SET(h_errno);
5023         }
5024 #endif
5025
5026     EXTEND(SP, 4);
5027     if (GIMME_V != G_ARRAY) {
5028         PUSHs(sv = sv_newmortal());
5029         if (nent) {
5030             if (which == OP_GNBYNAME)
5031                 sv_setiv(sv, (IV)nent->n_net);
5032             else
5033                 sv_setpv(sv, nent->n_name);
5034         }
5035         RETURN;
5036     }
5037
5038     if (nent) {
5039         mPUSHs(newSVpv(nent->n_name, 0));
5040         PUSHs(space_join_names_mortal(nent->n_aliases));
5041         mPUSHi(nent->n_addrtype);
5042         mPUSHi(nent->n_net);
5043     }
5044
5045     RETURN;
5046 #else
5047     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5048 #endif
5049 }
5050
5051
5052 /* also used for: pp_gpbyname() pp_gpbynumber() */
5053
5054 PP(pp_gprotoent)
5055 {
5056 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
5057     dSP;
5058     I32 which = PL_op->op_type;
5059     SV *sv;
5060 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
5061     struct protoent *getprotobyname(Netdb_name_t);
5062     struct protoent *getprotobynumber(int);
5063     struct protoent *getprotoent(void);
5064 #endif
5065     struct protoent *pent;
5066
5067     if (which == OP_GPBYNAME) {
5068 #ifdef HAS_GETPROTOBYNAME
5069         const char* const name = POPpbytex;
5070         pent = PerlSock_getprotobyname(name);
5071 #else
5072         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
5073 #endif
5074     }
5075     else if (which == OP_GPBYNUMBER) {
5076 #ifdef HAS_GETPROTOBYNUMBER
5077         const int number = POPi;
5078         pent = PerlSock_getprotobynumber(number);
5079 #else
5080         DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
5081 #endif
5082     }
5083     else
5084 #ifdef HAS_GETPROTOENT
5085         pent = PerlSock_getprotoent();
5086 #else
5087         DIE(aTHX_ PL_no_sock_func, "getprotoent");
5088 #endif
5089
5090     EXTEND(SP, 3);
5091     if (GIMME_V != G_ARRAY) {
5092         PUSHs(sv = sv_newmortal());
5093         if (pent) {
5094             if (which == OP_GPBYNAME)
5095                 sv_setiv(sv, (IV)pent->p_proto);
5096             else
5097                 sv_setpv(sv, pent->p_name);
5098         }
5099         RETURN;
5100     }
5101
5102     if (pent) {
5103         mPUSHs(newSVpv(pent->p_name, 0));
5104         PUSHs(space_join_names_mortal(pent->p_aliases));
5105         mPUSHi(pent->p_proto);
5106     }
5107
5108     RETURN;
5109 #else
5110     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5111 #endif
5112 }
5113
5114
5115 /* also used for: pp_gsbyname() pp_gsbyport() */
5116
5117 PP(pp_gservent)
5118 {
5119 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
5120     dSP;
5121     I32 which = PL_op->op_type;
5122     SV *sv;
5123 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
5124     struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
5125     struct servent *getservbyport(int, Netdb_name_t);
5126     struct servent *getservent(void);
5127 #endif
5128     struct servent *sent;
5129
5130     if (which == OP_GSBYNAME) {
5131 #ifdef HAS_GETSERVBYNAME
5132         const char * const proto = POPpbytex;
5133         const char * const name = POPpbytex;
5134         sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
5135 #else
5136         DIE(aTHX_ PL_no_sock_func, "getservbyname");
5137 #endif
5138     }
5139     else if (which == OP_GSBYPORT) {
5140 #ifdef HAS_GETSERVBYPORT
5141         const char * const proto = POPpbytex;
5142         unsigned short port = (unsigned short)POPu;
5143         port = PerlSock_htons(port);
5144         sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
5145 #else
5146         DIE(aTHX_ PL_no_sock_func, "getservbyport");
5147 #endif
5148     }
5149     else
5150 #ifdef HAS_GETSERVENT
5151         sent = PerlSock_getservent();
5152 #else
5153         DIE(aTHX_ PL_no_sock_func, "getservent");
5154 #endif
5155
5156     EXTEND(SP, 4);
5157     if (GIMME_V != G_ARRAY) {
5158         PUSHs(sv = sv_newmortal());
5159         if (sent) {
5160             if (which == OP_GSBYNAME) {
5161                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5162             }
5163             else
5164                 sv_setpv(sv, sent->s_name);
5165         }
5166         RETURN;
5167     }
5168
5169     if (sent) {
5170         mPUSHs(newSVpv(sent->s_name, 0));
5171         PUSHs(space_join_names_mortal(sent->s_aliases));
5172         mPUSHi(PerlSock_ntohs(sent->s_port));
5173         mPUSHs(newSVpv(sent->s_proto, 0));
5174     }
5175
5176     RETURN;
5177 #else
5178     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5179 #endif
5180 }
5181
5182
5183 /* also used for: pp_snetent() pp_sprotoent() pp_sservent() */
5184
5185 PP(pp_shostent)
5186 {
5187     dSP;
5188     const int stayopen = TOPi;
5189     switch(PL_op->op_type) {
5190     case OP_SHOSTENT:
5191 #ifdef HAS_SETHOSTENT
5192         PerlSock_sethostent(stayopen);
5193 #else
5194         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5195 #endif
5196         break;
5197 #ifdef HAS_SETNETENT
5198     case OP_SNETENT:
5199         PerlSock_setnetent(stayopen);
5200 #else
5201         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5202 #endif
5203         break;
5204     case OP_SPROTOENT:
5205 #ifdef HAS_SETPROTOENT
5206         PerlSock_setprotoent(stayopen);
5207 #else
5208         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5209 #endif
5210         break;
5211     case OP_SSERVENT:
5212 #ifdef HAS_SETSERVENT
5213         PerlSock_setservent(stayopen);
5214 #else
5215         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5216 #endif
5217         break;
5218     }
5219     RETSETYES;
5220 }
5221
5222
5223 /* also used for: pp_egrent() pp_enetent() pp_eprotoent() pp_epwent()
5224  *                pp_eservent() pp_sgrent() pp_spwent() */
5225
5226 PP(pp_ehostent)
5227 {
5228     dSP;
5229     switch(PL_op->op_type) {
5230     case OP_EHOSTENT:
5231 #ifdef HAS_ENDHOSTENT
5232         PerlSock_endhostent();
5233 #else
5234         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5235 #endif
5236         break;
5237     case OP_ENETENT:
5238 #ifdef HAS_ENDNETENT
5239         PerlSock_endnetent();
5240 #else
5241         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5242 #endif
5243         break;
5244     case OP_EPROTOENT:
5245 #ifdef HAS_ENDPROTOENT
5246         PerlSock_endprotoent();
5247 #else
5248         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5249 #endif
5250         break;
5251     case OP_ESERVENT:
5252 #ifdef HAS_ENDSERVENT
5253         PerlSock_endservent();
5254 #else
5255         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5256 #endif
5257         break;
5258     case OP_SGRENT:
5259 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5260         setgrent();
5261 #else
5262         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5263 #endif
5264         break;
5265     case OP_EGRENT:
5266 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5267         endgrent();
5268 #else
5269         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5270 #endif
5271         break;
5272     case OP_SPWENT:
5273 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5274         setpwent();
5275 #else
5276         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5277 #endif
5278         break;
5279     case OP_EPWENT:
5280 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5281         endpwent();
5282 #else
5283         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5284 #endif
5285         break;
5286     }
5287     EXTEND(SP,1);
5288     RETPUSHYES;
5289 }
5290
5291
5292 /* also used for: pp_gpwnam() pp_gpwuid() */
5293
5294 PP(pp_gpwent)
5295 {
5296 #ifdef HAS_PASSWD
5297     dSP;
5298     I32 which = PL_op->op_type;
5299     SV *sv;
5300     struct passwd *pwent  = NULL;
5301     /*
5302      * We currently support only the SysV getsp* shadow password interface.
5303      * The interface is declared in <shadow.h> and often one needs to link
5304      * with -lsecurity or some such.
5305      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5306      * (and SCO?)
5307      *
5308      * AIX getpwnam() is clever enough to return the encrypted password
5309      * only if the caller (euid?) is root.
5310      *
5311      * There are at least three other shadow password APIs.  Many platforms
5312      * seem to contain more than one interface for accessing the shadow
5313      * password databases, possibly for compatibility reasons.
5314      * The getsp*() is by far he simplest one, the other two interfaces
5315      * are much more complicated, but also very similar to each other.
5316      *
5317      * <sys/types.h>
5318      * <sys/security.h>
5319      * <prot.h>
5320      * struct pr_passwd *getprpw*();
5321      * The password is in
5322      * char getprpw*(...).ufld.fd_encrypt[]
5323      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5324      *
5325      * <sys/types.h>
5326      * <sys/security.h>
5327      * <prot.h>
5328      * struct es_passwd *getespw*();
5329      * The password is in
5330      * char *(getespw*(...).ufld.fd_encrypt)
5331      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5332      *
5333      * <userpw.h> (AIX)
5334      * struct userpw *getuserpw();
5335      * The password is in
5336      * char *(getuserpw(...)).spw_upw_passwd
5337      * (but the de facto standard getpwnam() should work okay)
5338      *
5339      * Mention I_PROT here so that Configure probes for it.
5340      *
5341      * In HP-UX for getprpw*() the manual page claims that one should include
5342      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5343      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5344      * and pp_sys.c already includes <shadow.h> if there is such.
5345      *
5346      * Note that <sys/security.h> is already probed for, but currently
5347      * it is only included in special cases.
5348      *
5349      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5350      * be preferred interface, even though also the getprpw*() interface
5351      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5352      * One also needs to call set_auth_parameters() in main() before
5353      * doing anything else, whether one is using getespw*() or getprpw*().
5354      *
5355      * Note that accessing the shadow databases can be magnitudes
5356      * slower than accessing the standard databases.
5357      *
5358      * --jhi
5359      */
5360
5361 #   if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5362     /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5363      * the pw_comment is left uninitialized. */
5364     PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5365 #   endif
5366
5367     switch (which) {
5368     case OP_GPWNAM:
5369       {
5370         const char* const name = POPpbytex;
5371         pwent  = getpwnam(name);
5372       }
5373       break;
5374     case OP_GPWUID:
5375       {
5376         Uid_t uid = POPi;
5377         pwent = getpwuid(uid);
5378       }
5379         break;
5380     case OP_GPWENT:
5381 #   ifdef HAS_GETPWENT
5382         pwent  = getpwent();
5383 #ifdef POSIX_BC   /* In some cases pw_passwd has invalid addresses */
5384         if (pwent) pwent = getpwnam(pwent->pw_name);
5385 #endif
5386 #   else
5387         DIE(aTHX_ PL_no_func, "getpwent");
5388 #   endif
5389         break;
5390     }
5391
5392     EXTEND(SP, 10);
5393     if (GIMME_V != G_ARRAY) {
5394         PUSHs(sv = sv_newmortal());
5395         if (pwent) {
5396             if (which == OP_GPWNAM)
5397                 sv_setuid(sv, pwent->pw_uid);
5398             else
5399                 sv_setpv(sv, pwent->pw_name);
5400         }
5401         RETURN;
5402     }
5403
5404     if (pwent) {
5405         mPUSHs(newSVpv(pwent->pw_name, 0));
5406
5407         sv = newSViv(0);
5408         mPUSHs(sv);
5409         /* If we have getspnam(), we try to dig up the shadow
5410          * password.  If we are underprivileged, the shadow
5411          * interface will set the errno to EACCES or similar,
5412          * and return a null pointer.  If this happens, we will
5413          * use the dummy password (usually "*" or "x") from the
5414          * standard password database.
5415          *
5416          * In theory we could skip the shadow call completely
5417          * if euid != 0 but in practice we cannot know which
5418          * security measures are guarding the shadow databases
5419          * on a random platform.
5420          *
5421          * Resist the urge to use additional shadow interfaces.
5422          * Divert the urge to writing an extension instead.
5423          *
5424          * --jhi */
5425         /* Some AIX setups falsely(?) detect some getspnam(), which
5426          * has a different API than the Solaris/IRIX one. */
5427 #   if defined(HAS_GETSPNAM) && !defined(_AIX)
5428         {
5429             dSAVE_ERRNO;
5430             const struct spwd * const spwent = getspnam(pwent->pw_name);
5431                           /* Save and restore errno so that
5432                            * underprivileged attempts seem
5433                            * to have never made the unsuccessful
5434                            * attempt to retrieve the shadow password. */
5435             RESTORE_ERRNO;
5436             if (spwent && spwent->sp_pwdp)
5437                 sv_setpv(sv, spwent->sp_pwdp);
5438         }
5439 #   endif
5440 #   ifdef PWPASSWD
5441         if (!SvPOK(sv)) /* Use the standard password, then. */
5442             sv_setpv(sv, pwent->pw_passwd);
5443 #   endif
5444
5445         /* passwd is tainted because user himself can diddle with it.
5446          * admittedly not much and in a very limited way, but nevertheless. */
5447         SvTAINTED_on(sv);
5448
5449         sv_setuid(PUSHmortal, pwent->pw_uid);
5450         sv_setgid(PUSHmortal, pwent->pw_gid);
5451
5452         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5453          * because of the poor interface of the Perl getpw*(),
5454          * not because there's some standard/convention saying so.
5455          * A better interface would have been to return a hash,
5456          * but we are accursed by our history, alas. --jhi.  */
5457 #   ifdef PWCHANGE
5458         mPUSHi(pwent->pw_change);
5459 #   else
5460 #       ifdef PWQUOTA
5461         mPUSHi(pwent->pw_quota);
5462 #       else
5463 #           ifdef PWAGE
5464         mPUSHs(newSVpv(pwent->pw_age, 0));
5465 #           else
5466         /* I think that you can never get this compiled, but just in case.  */
5467         PUSHs(sv_mortalcopy(&PL_sv_no));
5468 #           endif
5469 #       endif
5470 #   endif
5471
5472         /* pw_class and pw_comment are mutually exclusive--.
5473          * see the above note for pw_change, pw_quota, and pw_age. */
5474 #   ifdef PWCLASS
5475         mPUSHs(newSVpv(pwent->pw_class, 0));
5476 #   else
5477 #       ifdef PWCOMMENT
5478         mPUSHs(newSVpv(pwent->pw_comment, 0));
5479 #       else
5480         /* I think that you can never get this compiled, but just in case.  */
5481         PUSHs(sv_mortalcopy(&PL_sv_no));
5482 #       endif
5483 #   endif
5484
5485 #   ifdef PWGECOS
5486         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5487 #   else
5488         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5489 #   endif
5490         /* pw_gecos is tainted because user himself can diddle with it. */
5491         SvTAINTED_on(sv);
5492
5493         mPUSHs(newSVpv(pwent->pw_dir, 0));
5494
5495         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5496         /* pw_shell is tainted because user himself can diddle with it. */
5497         SvTAINTED_on(sv);
5498
5499 #   ifdef PWEXPIRE
5500         mPUSHi(pwent->pw_expire);
5501 #   endif
5502     }
5503     RETURN;
5504 #else
5505     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5506 #endif
5507 }
5508
5509
5510 /* also used for: pp_ggrgid() pp_ggrnam() */
5511
5512 PP(pp_ggrent)
5513 {
5514 #ifdef HAS_GROUP
5515     dSP;
5516     const I32 which = PL_op->op_type;
5517     const struct group *grent;
5518
5519     if (which == OP_GGRNAM) {
5520         const char* const name = POPpbytex;
5521         grent = (const struct group *)getgrnam(name);
5522     }
5523     else if (which == OP_GGRGID) {
5524 #if Gid_t_sign == 1
5525         const Gid_t gid = POPu;
5526 #elif Gid_t_sign == -1
5527         const Gid_t gid = POPi;
5528 #else
5529 #  error "Unexpected Gid_t_sign"
5530 #endif
5531         grent = (const struct group *)getgrgid(gid);
5532     }
5533     else
5534 #ifdef HAS_GETGRENT
5535         grent = (struct group *)getgrent();
5536 #else
5537         DIE(aTHX_ PL_no_func, "getgrent");
5538 #endif
5539
5540     EXTEND(SP, 4);
5541     if (GIMME_V != G_ARRAY) {
5542         SV * const sv = sv_newmortal();
5543
5544         PUSHs(sv);
5545         if (grent) {
5546             if (which == OP_GGRNAM)
5547                 sv_setgid(sv, grent->gr_gid);
5548             else
5549                 sv_setpv(sv, grent->gr_name);
5550         }
5551         RETURN;
5552     }
5553
5554     if (grent) {
5555         mPUSHs(newSVpv(grent->gr_name, 0));
5556
5557 #ifdef GRPASSWD
5558         mPUSHs(newSVpv(grent->gr_passwd, 0));
5559 #else
5560         PUSHs(sv_mortalcopy(&PL_sv_no));
5561 #endif
5562
5563         sv_setgid(PUSHmortal, grent->gr_gid);
5564
5565 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5566         /* In UNICOS/mk (_CRAYMPP) the multithreading
5567          * versions (getgrnam_r, getgrgid_r)
5568          * seem to return an illegal pointer
5569          * as the group members list, gr_mem.
5570          * getgrent() doesn't even have a _r version
5571          * but the gr_mem is poisonous anyway.
5572          * So yes, you cannot get the list of group
5573          * members if building multithreaded in UNICOS/mk. */
5574         PUSHs(space_join_names_mortal(grent->gr_mem));
5575 #endif
5576     }
5577
5578     RETURN;
5579 #else
5580     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5581 #endif
5582 }
5583
5584 PP(pp_getlogin)
5585 {
5586 #ifdef HAS_GETLOGIN
5587     dSP; dTARGET;
5588     char *tmps;
5589     EXTEND(SP, 1);
5590     if (!(tmps = PerlProc_getlogin()))
5591         RETPUSHUNDEF;
5592     sv_setpv_mg(TARG, tmps);
5593     PUSHs(TARG);
5594     RETURN;
5595 #else
5596     DIE(aTHX_ PL_no_func, "getlogin");
5597 #endif
5598 }
5599
5600 /* Miscellaneous. */
5601
5602 PP(pp_syscall)
5603 {
5604 #ifdef HAS_SYSCALL
5605     dSP; dMARK; dORIGMARK; dTARGET;
5606     I32 items = SP - MARK;
5607     unsigned long a[20];
5608     I32 i = 0;
5609     IV retval = -1;
5610
5611     if (TAINTING_get) {
5612         while (++MARK <= SP) {
5613             if (SvTAINTED(*MARK)) {
5614                 TAINT;
5615                 break;
5616             }
5617         }
5618         MARK = ORIGMARK;
5619         TAINT_PROPER("syscall");
5620     }
5621
5622     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5623      * or where sizeof(long) != sizeof(char*).  But such machines will
5624      * not likely have syscall implemented either, so who cares?
5625      */
5626     while (++MARK <= SP) {
5627         if (SvNIOK(*MARK) || !i)
5628             a[i++] = SvIV(*MARK);
5629         else if (*MARK == &PL_sv_undef)
5630             a[i++] = 0;
5631         else
5632             a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5633         if (i > 15)
5634             break;
5635     }
5636     switch (items) {
5637     default:
5638         DIE(aTHX_ "Too many args to syscall");
5639     case 0:
5640         DIE(aTHX_ "Too few args to syscall");
5641     case 1:
5642         retval = syscall(a[0]);
5643         break;
5644     case 2:
5645         retval = syscall(a[0],a[1]);
5646         break;
5647     case 3:
5648         retval = syscall(a[0],a[1],a[2]);
5649         break;
5650     case 4:
5651         retval = syscall(a[0],a[1],a[2],a[3]);
5652         break;
5653     case 5:
5654         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5655         break;
5656     case 6:
5657         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5658         break;
5659     case 7:
5660         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5661         break;
5662     case 8:
5663         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5664         break;
5665     }
5666     SP = ORIGMARK;
5667     PUSHi(retval);
5668     RETURN;
5669 #else
5670     DIE(aTHX_ PL_no_func, "syscall");
5671 #endif
5672 }
5673
5674 #ifdef FCNTL_EMULATE_FLOCK
5675
5676 /*  XXX Emulate flock() with fcntl().
5677     What's really needed is a good file locking module.
5678 */
5679
5680 static int
5681 fcntl_emulate_flock(int fd, int operation)
5682 {
5683     int res;
5684     struct flock flock;
5685
5686     switch (operation & ~LOCK_NB) {
5687     case LOCK_SH:
5688         flock.l_type = F_RDLCK;
5689         break;
5690     case LOCK_EX:
5691         flock.l_type = F_WRLCK;
5692         break;
5693     case LOCK_UN:
5694         flock.l_type = F_UNLCK;
5695         break;
5696     default:
5697         errno = EINVAL;
5698         return -1;
5699     }
5700     flock.l_whence = SEEK_SET;
5701     flock.l_start = flock.l_len = (Off_t)0;
5702
5703     res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5704     if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5705         errno = EWOULDBLOCK;
5706     return res;
5707 }
5708
5709 #endif /* FCNTL_EMULATE_FLOCK */
5710
5711 #ifdef LOCKF_EMULATE_FLOCK
5712
5713 /*  XXX Emulate flock() with lockf().  This is just to increase
5714     portability of scripts.  The calls are not completely
5715     interchangeable.  What's really needed is a good file
5716     locking module.
5717 */
5718
5719 /*  The lockf() constants might have been defined in <unistd.h>.
5720     Unfortunately, <unistd.h> causes troubles on some mixed
5721     (BSD/POSIX) systems, such as SunOS 4.1.3.
5722
5723    Further, the lockf() constants aren't POSIX, so they might not be
5724    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5725    just stick in the SVID values and be done with it.  Sigh.
5726 */
5727
5728 # ifndef F_ULOCK
5729 #  define F_ULOCK       0       /* Unlock a previously locked region */
5730 # endif
5731 # ifndef F_LOCK
5732 #  define F_LOCK        1       /* Lock a region for exclusive use */
5733 # endif
5734 # ifndef F_TLOCK
5735 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5736 # endif
5737 # ifndef F_TEST
5738 #  define F_TEST        3       /* Test a region for other processes locks */
5739 # endif
5740
5741 static int
5742 lockf_emulate_flock(int fd, int operation)
5743 {
5744     int i;
5745     Off_t pos;
5746     dSAVE_ERRNO;
5747
5748     /* flock locks entire file so for lockf we need to do the same      */
5749     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5750     if (pos > 0)        /* is seekable and needs to be repositioned     */
5751         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5752             pos = -1;   /* seek failed, so don't seek back afterwards   */
5753     RESTORE_ERRNO;
5754
5755     switch (operation) {
5756
5757         /* LOCK_SH - get a shared lock */
5758         case LOCK_SH:
5759         /* LOCK_EX - get an exclusive lock */
5760         case LOCK_EX:
5761             i = lockf (fd, F_LOCK, 0);
5762             break;
5763
5764         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5765         case LOCK_SH|LOCK_NB:
5766         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5767         case LOCK_EX|LOCK_NB:
5768             i = lockf (fd, F_TLOCK, 0);
5769             if (i == -1)
5770                 if ((errno == EAGAIN) || (errno == EACCES))
5771                     errno = EWOULDBLOCK;
5772             break;
5773
5774         /* LOCK_UN - unlock (non-blocking is a no-op) */
5775         case LOCK_UN:
5776         case LOCK_UN|LOCK_NB:
5777             i = lockf (fd, F_ULOCK, 0);
5778             break;
5779
5780         /* Default - can't decipher operation */
5781         default:
5782             i = -1;
5783             errno = EINVAL;
5784             break;
5785     }
5786
5787     if (pos > 0)      /* need to restore position of the handle */
5788         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5789
5790     return (i);
5791 }
5792
5793 #endif /* LOCKF_EMULATE_FLOCK */
5794
5795 /*
5796  * ex: set ts=8 sts=4 sw=4 et:
5797  */