pp_sys.c

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