pp_sys.c

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