pp_sys.c

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