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