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