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_V == 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 #ifdef HAS_FCHDIR
3637  nuts:
3638     report_evil_fh(gv);
3639     SETERRNO(EBADF,RMS_IFI);
3640     PUSHi(0);
3641     RETURN;
3642 #endif
3643 }
3644
3645
3646 /* also used for: pp_chmod() pp_kill() pp_unlink() pp_utime() */
3647
3648 PP(pp_chown)
3649 {
3650     dSP; dMARK; dTARGET;
3651     const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3652
3653     SP = MARK;
3654     XPUSHi(value);
3655     RETURN;
3656 }
3657
3658 PP(pp_chroot)
3659 {
3660 #ifdef HAS_CHROOT
3661     dSP; dTARGET;
3662     char * const tmps = POPpx;
3663     TAINT_PROPER("chroot");
3664     PUSHi( chroot(tmps) >= 0 );
3665     RETURN;
3666 #else
3667     DIE(aTHX_ PL_no_func, "chroot");
3668 #endif
3669 }
3670
3671 PP(pp_rename)
3672 {
3673     dSP; dTARGET;
3674     int anum;
3675     const char * const tmps2 = POPpconstx;
3676     const char * const tmps = SvPV_nolen_const(TOPs);
3677     TAINT_PROPER("rename");
3678 #ifdef HAS_RENAME
3679     anum = PerlLIO_rename(tmps, tmps2);
3680 #else
3681     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3682         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3683             anum = 1;
3684         else {
3685             if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3686                 (void)UNLINK(tmps2);
3687             if (!(anum = link(tmps, tmps2)))
3688                 anum = UNLINK(tmps);
3689         }
3690     }
3691 #endif
3692     SETi( anum >= 0 );
3693     RETURN;
3694 }
3695
3696
3697 /* also used for: pp_symlink() */
3698
3699 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3700 PP(pp_link)
3701 {
3702     dSP; dTARGET;
3703     const int op_type = PL_op->op_type;
3704     int result;
3705
3706 #  ifndef HAS_LINK
3707     if (op_type == OP_LINK)
3708         DIE(aTHX_ PL_no_func, "link");
3709 #  endif
3710 #  ifndef HAS_SYMLINK
3711     if (op_type == OP_SYMLINK)
3712         DIE(aTHX_ PL_no_func, "symlink");
3713 #  endif
3714
3715     {
3716         const char * const tmps2 = POPpconstx;
3717         const char * const tmps = SvPV_nolen_const(TOPs);
3718         TAINT_PROPER(PL_op_desc[op_type]);
3719         result =
3720 #  if defined(HAS_LINK)
3721 #    if defined(HAS_SYMLINK)
3722             /* Both present - need to choose which.  */
3723             (op_type == OP_LINK) ?
3724             PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3725 #    else
3726     /* Only have link, so calls to pp_symlink will have DIE()d above.  */
3727         PerlLIO_link(tmps, tmps2);
3728 #    endif
3729 #  else
3730 #    if defined(HAS_SYMLINK)
3731     /* Only have symlink, so calls to pp_link will have DIE()d above.  */
3732         symlink(tmps, tmps2);
3733 #    endif
3734 #  endif
3735     }
3736
3737     SETi( result >= 0 );
3738     RETURN;
3739 }
3740 #else
3741
3742 /* also used for: pp_symlink() */
3743
3744 PP(pp_link)
3745 {
3746     /* Have neither.  */
3747     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3748 }
3749 #endif
3750
3751 PP(pp_readlink)
3752 {
3753     dSP;
3754 #ifdef HAS_SYMLINK
3755     dTARGET;
3756     const char *tmps;
3757     char buf[MAXPATHLEN];
3758     SSize_t len;
3759
3760     TAINT;
3761     tmps = POPpconstx;
3762     /* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
3763      * it is impossible to know whether the result was truncated. */
3764     len = readlink(tmps, buf, sizeof(buf) - 1);
3765     if (len < 0)
3766         RETPUSHUNDEF;
3767     if (len != -1)
3768         buf[len] = '\0';
3769     PUSHp(buf, len);
3770     RETURN;
3771 #else
3772     EXTEND(SP, 1);
3773     RETSETUNDEF;                /* just pretend it's a normal file */
3774 #endif
3775 }
3776
3777 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3778 STATIC int
3779 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3780 {
3781     char * const save_filename = filename;
3782     char *cmdline;
3783     char *s;
3784     PerlIO *myfp;
3785     int anum = 1;
3786     Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3787
3788     PERL_ARGS_ASSERT_DOONELINER;
3789
3790     Newx(cmdline, size, char);
3791     my_strlcpy(cmdline, cmd, size);
3792     my_strlcat(cmdline, " ", size);
3793     for (s = cmdline + strlen(cmdline); *filename; ) {
3794         *s++ = '\\';
3795         *s++ = *filename++;
3796     }
3797     if (s - cmdline < size)
3798         my_strlcpy(s, " 2>&1", size - (s - cmdline));
3799     myfp = PerlProc_popen(cmdline, "r");
3800     Safefree(cmdline);
3801
3802     if (myfp) {
3803         SV * const tmpsv = sv_newmortal();
3804         /* Need to save/restore 'PL_rs' ?? */
3805         s = sv_gets(tmpsv, myfp, 0);
3806         (void)PerlProc_pclose(myfp);
3807         if (s != NULL) {
3808             int e;
3809             for (e = 1;
3810 #ifdef HAS_SYS_ERRLIST
3811                  e <= sys_nerr
3812 #endif
3813                  ; e++)
3814             {
3815                 /* you don't see this */
3816                 const char * const errmsg = Strerror(e) ;
3817                 if (!errmsg)
3818                     break;
3819                 if (instr(s, errmsg)) {
3820                     SETERRNO(e,0);
3821                     return 0;
3822                 }
3823             }
3824             SETERRNO(0,0);
3825 #ifndef EACCES
3826 #define EACCES EPERM
3827 #endif
3828             if (instr(s, "cannot make"))
3829                 SETERRNO(EEXIST,RMS_FEX);
3830             else if (instr(s, "existing file"))
3831                 SETERRNO(EEXIST,RMS_FEX);
3832             else if (instr(s, "ile exists"))
3833                 SETERRNO(EEXIST,RMS_FEX);
3834             else if (instr(s, "non-exist"))
3835                 SETERRNO(ENOENT,RMS_FNF);
3836             else if (instr(s, "does not exist"))
3837                 SETERRNO(ENOENT,RMS_FNF);
3838             else if (instr(s, "not empty"))
3839                 SETERRNO(EBUSY,SS_DEVOFFLINE);
3840             else if (instr(s, "cannot access"))
3841                 SETERRNO(EACCES,RMS_PRV);
3842             else
3843                 SETERRNO(EPERM,RMS_PRV);
3844             return 0;
3845         }
3846         else {  /* some mkdirs return no failure indication */
3847             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3848             if (PL_op->op_type == OP_RMDIR)
3849                 anum = !anum;
3850             if (anum)
3851                 SETERRNO(0,0);
3852             else
3853                 SETERRNO(EACCES,RMS_PRV);       /* a guess */
3854         }
3855         return anum;
3856     }
3857     else
3858         return 0;
3859 }
3860 #endif
3861
3862 /* This macro removes trailing slashes from a directory name.
3863  * Different operating and file systems take differently to
3864  * trailing slashes.  According to POSIX 1003.1 1996 Edition
3865  * any number of trailing slashes should be allowed.
3866  * Thusly we snip them away so that even non-conforming
3867  * systems are happy.
3868  * We should probably do this "filtering" for all
3869  * the functions that expect (potentially) directory names:
3870  * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3871  * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3872
3873 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3874     if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3875         do { \
3876             (len)--; \
3877         } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3878         (tmps) = savepvn((tmps), (len)); \
3879         (copy) = TRUE; \
3880     }
3881
3882 PP(pp_mkdir)
3883 {
3884     dSP; dTARGET;
3885     STRLEN len;
3886     const char *tmps;
3887     bool copy = FALSE;
3888     const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
3889
3890     TRIMSLASHES(tmps,len,copy);
3891
3892     TAINT_PROPER("mkdir");
3893 #ifdef HAS_MKDIR
3894     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3895 #else
3896     {
3897     int oldumask;
3898     SETi( dooneliner("mkdir", tmps) );
3899     oldumask = PerlLIO_umask(0);
3900     PerlLIO_umask(oldumask);
3901     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3902     }
3903 #endif
3904     if (copy)
3905         Safefree(tmps);
3906     RETURN;
3907 }
3908
3909 PP(pp_rmdir)
3910 {
3911     dSP; dTARGET;
3912     STRLEN len;
3913     const char *tmps;
3914     bool copy = FALSE;
3915
3916     TRIMSLASHES(tmps,len,copy);
3917     TAINT_PROPER("rmdir");
3918 #ifdef HAS_RMDIR
3919     SETi( PerlDir_rmdir(tmps) >= 0 );
3920 #else
3921     SETi( dooneliner("rmdir", tmps) );
3922 #endif
3923     if (copy)
3924         Safefree(tmps);
3925     RETURN;
3926 }
3927
3928 /* Directory calls. */
3929
3930 PP(pp_open_dir)
3931 {
3932 #if defined(Direntry_t) && defined(HAS_READDIR)
3933     dSP;
3934     const char * const dirname = POPpconstx;
3935     GV * const gv = MUTABLE_GV(POPs);
3936     IO * const io = GvIOn(gv);
3937
3938     if ((IoIFP(io) || IoOFP(io)))
3939         Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3940                          "Opening filehandle %"HEKf" also as a directory",
3941                              HEKfARG(GvENAME_HEK(gv)) );
3942     if (IoDIRP(io))
3943         PerlDir_close(IoDIRP(io));
3944     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3945         goto nope;
3946
3947     RETPUSHYES;
3948   nope:
3949     if (!errno)
3950         SETERRNO(EBADF,RMS_DIR);
3951     RETPUSHUNDEF;
3952 #else
3953     DIE(aTHX_ PL_no_dir_func, "opendir");
3954 #endif
3955 }
3956
3957 PP(pp_readdir)
3958 {
3959 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3960     DIE(aTHX_ PL_no_dir_func, "readdir");
3961 #else
3962 #if !defined(I_DIRENT) && !defined(VMS)
3963     Direntry_t *readdir (DIR *);
3964 #endif
3965     dSP;
3966
3967     SV *sv;
3968     const I32 gimme = GIMME_V;
3969     GV * const gv = MUTABLE_GV(POPs);
3970     const Direntry_t *dp;
3971     IO * const io = GvIOn(gv);
3972
3973     if (!IoDIRP(io)) {
3974         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3975                        "readdir() attempted on invalid dirhandle %"HEKf,
3976                             HEKfARG(GvENAME_HEK(gv)));
3977         goto nope;
3978     }
3979
3980     do {
3981         dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3982         if (!dp)
3983             break;
3984 #ifdef DIRNAMLEN
3985         sv = newSVpvn(dp->d_name, dp->d_namlen);
3986 #else
3987         sv = newSVpv(dp->d_name, 0);
3988 #endif
3989         if (!(IoFLAGS(io) & IOf_UNTAINT))
3990             SvTAINTED_on(sv);
3991         mXPUSHs(sv);
3992     } while (gimme == G_ARRAY);
3993
3994     if (!dp && gimme != G_ARRAY)
3995         RETPUSHUNDEF;
3996
3997     RETURN;
3998
3999   nope:
4000     if (!errno)
4001         SETERRNO(EBADF,RMS_ISI);
4002     if (gimme == G_ARRAY)
4003         RETURN;
4004     else
4005         RETPUSHUNDEF;
4006 #endif
4007 }
4008
4009 PP(pp_telldir)
4010 {
4011 #if defined(HAS_TELLDIR) || defined(telldir)
4012     dSP; dTARGET;
4013  /* XXX does _anyone_ need this? --AD 2/20/1998 */
4014  /* XXX netbsd still seemed to.
4015     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
4016     --JHI 1999-Feb-02 */
4017 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
4018     long telldir (DIR *);
4019 # endif
4020     GV * const gv = MUTABLE_GV(POPs);
4021     IO * const io = GvIOn(gv);
4022
4023     if (!IoDIRP(io)) {
4024         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4025                        "telldir() attempted on invalid dirhandle %"HEKf,
4026                             HEKfARG(GvENAME_HEK(gv)));
4027         goto nope;
4028     }
4029
4030     PUSHi( PerlDir_tell(IoDIRP(io)) );
4031     RETURN;
4032   nope:
4033     if (!errno)
4034         SETERRNO(EBADF,RMS_ISI);
4035     RETPUSHUNDEF;
4036 #else
4037     DIE(aTHX_ PL_no_dir_func, "telldir");
4038 #endif
4039 }
4040
4041 PP(pp_seekdir)
4042 {
4043 #if defined(HAS_SEEKDIR) || defined(seekdir)
4044     dSP;
4045     const long along = POPl;
4046     GV * const gv = MUTABLE_GV(POPs);
4047     IO * const io = GvIOn(gv);
4048
4049     if (!IoDIRP(io)) {
4050         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4051                        "seekdir() attempted on invalid dirhandle %"HEKf,
4052                                 HEKfARG(GvENAME_HEK(gv)));
4053         goto nope;
4054     }
4055     (void)PerlDir_seek(IoDIRP(io), along);
4056
4057     RETPUSHYES;
4058   nope:
4059     if (!errno)
4060         SETERRNO(EBADF,RMS_ISI);
4061     RETPUSHUNDEF;
4062 #else
4063     DIE(aTHX_ PL_no_dir_func, "seekdir");
4064 #endif
4065 }
4066
4067 PP(pp_rewinddir)
4068 {
4069 #if defined(HAS_REWINDDIR) || defined(rewinddir)
4070     dSP;
4071     GV * const gv = MUTABLE_GV(POPs);
4072     IO * const io = GvIOn(gv);
4073
4074     if (!IoDIRP(io)) {
4075         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4076                        "rewinddir() attempted on invalid dirhandle %"HEKf,
4077                                 HEKfARG(GvENAME_HEK(gv)));
4078         goto nope;
4079     }
4080     (void)PerlDir_rewind(IoDIRP(io));
4081     RETPUSHYES;
4082   nope:
4083     if (!errno)
4084         SETERRNO(EBADF,RMS_ISI);
4085     RETPUSHUNDEF;
4086 #else
4087     DIE(aTHX_ PL_no_dir_func, "rewinddir");
4088 #endif
4089 }
4090
4091 PP(pp_closedir)
4092 {
4093 #if defined(Direntry_t) && defined(HAS_READDIR)
4094     dSP;
4095     GV * const gv = MUTABLE_GV(POPs);
4096     IO * const io = GvIOn(gv);
4097
4098     if (!IoDIRP(io)) {
4099         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4100                        "closedir() attempted on invalid dirhandle %"HEKf,
4101                                 HEKfARG(GvENAME_HEK(gv)));
4102         goto nope;
4103     }
4104 #ifdef VOID_CLOSEDIR
4105     PerlDir_close(IoDIRP(io));
4106 #else
4107     if (PerlDir_close(IoDIRP(io)) < 0) {
4108         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4109         goto nope;
4110     }
4111 #endif
4112     IoDIRP(io) = 0;
4113
4114     RETPUSHYES;
4115   nope:
4116     if (!errno)
4117         SETERRNO(EBADF,RMS_IFI);
4118     RETPUSHUNDEF;
4119 #else
4120     DIE(aTHX_ PL_no_dir_func, "closedir");
4121 #endif
4122 }
4123
4124 /* Process control. */
4125
4126 PP(pp_fork)
4127 {
4128 #ifdef HAS_FORK
4129     dSP; dTARGET;
4130     Pid_t childpid;
4131 #ifdef HAS_SIGPROCMASK
4132     sigset_t oldmask, newmask;
4133 #endif
4134
4135     EXTEND(SP, 1);
4136     PERL_FLUSHALL_FOR_CHILD;
4137 #ifdef HAS_SIGPROCMASK
4138     sigfillset(&newmask);
4139     sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4140 #endif
4141     childpid = PerlProc_fork();
4142     if (childpid == 0) {
4143         int sig;
4144         PL_sig_pending = 0;
4145         if (PL_psig_pend)
4146             for (sig = 1; sig < SIG_SIZE; sig++)
4147                 PL_psig_pend[sig] = 0;
4148     }
4149 #ifdef HAS_SIGPROCMASK
4150     {
4151         dSAVE_ERRNO;
4152         sigprocmask(SIG_SETMASK, &oldmask, NULL);
4153         RESTORE_ERRNO;
4154     }
4155 #endif
4156     if (childpid < 0)
4157         RETPUSHUNDEF;
4158     if (!childpid) {
4159 #ifdef PERL_USES_PL_PIDSTATUS
4160         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4161 #endif
4162     }
4163     PUSHi(childpid);
4164     RETURN;
4165 #else
4166 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4167     dSP; dTARGET;
4168     Pid_t childpid;
4169
4170     EXTEND(SP, 1);
4171     PERL_FLUSHALL_FOR_CHILD;
4172     childpid = PerlProc_fork();
4173     if (childpid == -1)
4174         RETPUSHUNDEF;
4175     PUSHi(childpid);
4176     RETURN;
4177 #  else
4178     DIE(aTHX_ PL_no_func, "fork");
4179 #  endif
4180 #endif
4181 }
4182
4183 PP(pp_wait)
4184 {
4185 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4186     dSP; dTARGET;
4187     Pid_t childpid;
4188     int argflags;
4189
4190     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4191         childpid = wait4pid(-1, &argflags, 0);
4192     else {
4193         while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4194                errno == EINTR) {
4195           PERL_ASYNC_CHECK();
4196         }
4197     }
4198 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4199     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4200     STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4201 #  else
4202     STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4203 #  endif
4204     XPUSHi(childpid);
4205     RETURN;
4206 #else
4207     DIE(aTHX_ PL_no_func, "wait");
4208 #endif
4209 }
4210
4211 PP(pp_waitpid)
4212 {
4213 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4214     dSP; dTARGET;
4215     const int optype = POPi;
4216     const Pid_t pid = TOPi;
4217     Pid_t result;
4218     int argflags;
4219
4220     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4221         result = wait4pid(pid, &argflags, optype);
4222     else {
4223         while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4224                errno == EINTR) {
4225           PERL_ASYNC_CHECK();
4226         }
4227     }
4228 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4229     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4230     STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4231 #  else
4232     STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4233 #  endif
4234     SETi(result);
4235     RETURN;
4236 #else
4237     DIE(aTHX_ PL_no_func, "waitpid");
4238 #endif
4239 }
4240
4241 PP(pp_system)
4242 {
4243     dSP; dMARK; dORIGMARK; dTARGET;
4244 #if defined(__LIBCATAMOUNT__)
4245     PL_statusvalue = -1;
4246     SP = ORIGMARK;
4247     XPUSHi(-1);
4248 #else
4249     I32 value;
4250     int result;
4251
4252     if (TAINTING_get) {
4253         TAINT_ENV();
4254         while (++MARK <= SP) {
4255             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4256             if (TAINT_get)
4257                 break;
4258         }
4259         MARK = ORIGMARK;
4260         TAINT_PROPER("system");
4261     }
4262     PERL_FLUSHALL_FOR_CHILD;
4263 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4264     {
4265         Pid_t childpid;
4266         int pp[2];
4267         I32 did_pipes = 0;
4268 #ifdef HAS_SIGPROCMASK
4269         sigset_t newset, oldset;
4270 #endif
4271
4272         if (PerlProc_pipe(pp) >= 0)
4273             did_pipes = 1;
4274 #ifdef HAS_SIGPROCMASK
4275         sigemptyset(&newset);
4276         sigaddset(&newset, SIGCHLD);
4277         sigprocmask(SIG_BLOCK, &newset, &oldset);
4278 #endif
4279         while ((childpid = PerlProc_fork()) == -1) {
4280             if (errno != EAGAIN) {
4281                 value = -1;
4282                 SP = ORIGMARK;
4283                 XPUSHi(value);
4284                 if (did_pipes) {
4285                     PerlLIO_close(pp[0]);
4286                     PerlLIO_close(pp[1]);
4287                 }
4288 #ifdef HAS_SIGPROCMASK
4289                 sigprocmask(SIG_SETMASK, &oldset, NULL);
4290 #endif
4291                 RETURN;
4292             }
4293             sleep(5);
4294         }
4295         if (childpid > 0) {
4296             Sigsave_t ihand,qhand; /* place to save signals during system() */
4297             int status;
4298
4299             if (did_pipes)
4300                 PerlLIO_close(pp[1]);
4301 #ifndef PERL_MICRO
4302             rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &ihand);
4303             rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4304 #endif
4305             do {
4306                 result = wait4pid(childpid, &status, 0);
4307             } while (result == -1 && errno == EINTR);
4308 #ifndef PERL_MICRO
4309 #ifdef HAS_SIGPROCMASK
4310             sigprocmask(SIG_SETMASK, &oldset, NULL);
4311 #endif
4312             (void)rsignal_restore(SIGINT, &ihand);
4313             (void)rsignal_restore(SIGQUIT, &qhand);
4314 #endif
4315             STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4316             do_execfree();      /* free any memory child malloced on fork */
4317             SP = ORIGMARK;
4318             if (did_pipes) {
4319                 int errkid;
4320                 unsigned n = 0;
4321                 SSize_t n1;
4322
4323                 while (n < sizeof(int)) {
4324                     n1 = PerlLIO_read(pp[0],
4325                                       (void*)(((char*)&errkid)+n),
4326                                       (sizeof(int)) - n);
4327                     if (n1 <= 0)
4328                         break;
4329                     n += n1;
4330                 }
4331                 PerlLIO_close(pp[0]);
4332                 if (n) {                        /* Error */
4333                     if (n != sizeof(int))
4334                         DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4335                     errno = errkid;             /* Propagate errno from kid */
4336                     STATUS_NATIVE_CHILD_SET(-1);
4337                 }
4338             }
4339             XPUSHi(STATUS_CURRENT);
4340             RETURN;
4341         }
4342 #ifdef HAS_SIGPROCMASK
4343         sigprocmask(SIG_SETMASK, &oldset, NULL);
4344 #endif
4345         if (did_pipes) {
4346             PerlLIO_close(pp[0]);
4347 #if defined(HAS_FCNTL) && defined(F_SETFD)
4348             if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
4349                 RETPUSHUNDEF;
4350 #endif
4351         }
4352         if (PL_op->op_flags & OPf_STACKED) {
4353             SV * const really = *++MARK;
4354             value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4355         }
4356         else if (SP - MARK != 1)
4357             value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4358         else {
4359             value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4360         }
4361         PerlProc__exit(-1);
4362     }
4363 #else /* ! FORK or VMS or OS/2 */
4364     PL_statusvalue = 0;
4365     result = 0;
4366     if (PL_op->op_flags & OPf_STACKED) {
4367         SV * const really = *++MARK;
4368 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4369         value = (I32)do_aspawn(really, MARK, SP);
4370 #  else
4371         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4372 #  endif
4373     }
4374     else if (SP - MARK != 1) {
4375 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4376         value = (I32)do_aspawn(NULL, MARK, SP);
4377 #  else
4378         value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4379 #  endif
4380     }
4381     else {
4382         value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4383     }
4384     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4385         result = 1;
4386     STATUS_NATIVE_CHILD_SET(value);
4387     do_execfree();
4388     SP = ORIGMARK;
4389     XPUSHi(result ? value : STATUS_CURRENT);
4390 #endif /* !FORK or VMS or OS/2 */
4391 #endif
4392     RETURN;
4393 }
4394
4395 PP(pp_exec)
4396 {
4397     dSP; dMARK; dORIGMARK; dTARGET;
4398     I32 value;
4399
4400     if (TAINTING_get) {
4401         TAINT_ENV();
4402         while (++MARK <= SP) {
4403             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4404             if (TAINT_get)
4405                 break;
4406         }
4407         MARK = ORIGMARK;
4408         TAINT_PROPER("exec");
4409     }
4410     PERL_FLUSHALL_FOR_CHILD;
4411     if (PL_op->op_flags & OPf_STACKED) {
4412         SV * const really = *++MARK;
4413         value = (I32)do_aexec(really, MARK, SP);
4414     }
4415     else if (SP - MARK != 1)
4416 #ifdef VMS
4417         value = (I32)vms_do_aexec(NULL, MARK, SP);
4418 #else
4419         value = (I32)do_aexec(NULL, MARK, SP);
4420 #endif
4421     else {
4422 #ifdef VMS
4423         value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4424 #else
4425         value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4426 #endif
4427     }
4428
4429     SP = ORIGMARK;
4430     XPUSHi(value);
4431     RETURN;
4432 }
4433
4434 PP(pp_getppid)
4435 {
4436 #ifdef HAS_GETPPID
4437     dSP; dTARGET;
4438     XPUSHi( getppid() );
4439     RETURN;
4440 #else
4441     DIE(aTHX_ PL_no_func, "getppid");
4442 #endif
4443 }
4444
4445 PP(pp_getpgrp)
4446 {
4447 #ifdef HAS_GETPGRP
4448     dSP; dTARGET;
4449     Pid_t pgrp;
4450     const Pid_t pid =
4451         (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4452
4453 #ifdef BSD_GETPGRP
4454     pgrp = (I32)BSD_GETPGRP(pid);
4455 #else
4456     if (pid != 0 && pid != PerlProc_getpid())
4457         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4458     pgrp = getpgrp();
4459 #endif
4460     XPUSHi(pgrp);
4461     RETURN;
4462 #else
4463     DIE(aTHX_ PL_no_func, "getpgrp");
4464 #endif
4465 }
4466
4467 PP(pp_setpgrp)
4468 {
4469 #ifdef HAS_SETPGRP
4470     dSP; dTARGET;
4471     Pid_t pgrp;
4472     Pid_t pid;
4473     pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4474     if (MAXARG > 0) pid = TOPs ? TOPi : 0;
4475     else {
4476         pid = 0;
4477         EXTEND(SP,1);
4478         SP++;
4479     }
4480
4481     TAINT_PROPER("setpgrp");
4482 #ifdef BSD_SETPGRP
4483     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4484 #else
4485     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4486         || (pid != 0 && pid != PerlProc_getpid()))
4487     {
4488         DIE(aTHX_ "setpgrp can't take arguments");
4489     }
4490     SETi( setpgrp() >= 0 );
4491 #endif /* USE_BSDPGRP */
4492     RETURN;
4493 #else
4494     DIE(aTHX_ PL_no_func, "setpgrp");
4495 #endif
4496 }
4497
4498 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4499 #  define PRIORITY_WHICH_T(which) (__priority_which_t)which
4500 #else
4501 #  define PRIORITY_WHICH_T(which) which
4502 #endif
4503
4504 PP(pp_getpriority)
4505 {
4506 #ifdef HAS_GETPRIORITY
4507     dSP; dTARGET;
4508     const int who = POPi;
4509     const int which = TOPi;
4510     SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4511     RETURN;
4512 #else
4513     DIE(aTHX_ PL_no_func, "getpriority");
4514 #endif
4515 }
4516
4517 PP(pp_setpriority)
4518 {
4519 #ifdef HAS_SETPRIORITY
4520     dSP; dTARGET;
4521     const int niceval = POPi;
4522     const int who = POPi;
4523     const int which = TOPi;
4524     TAINT_PROPER("setpriority");
4525     SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4526     RETURN;
4527 #else
4528     DIE(aTHX_ PL_no_func, "setpriority");
4529 #endif
4530 }
4531
4532 #undef PRIORITY_WHICH_T
4533
4534 /* Time calls. */
4535
4536 PP(pp_time)
4537 {
4538     dSP; dTARGET;
4539 #ifdef BIG_TIME
4540     XPUSHn( time(NULL) );
4541 #else
4542     XPUSHi( time(NULL) );
4543 #endif
4544     RETURN;
4545 }
4546
4547 PP(pp_tms)
4548 {
4549 #ifdef HAS_TIMES
4550     dSP;
4551     struct tms timesbuf;
4552
4553     EXTEND(SP, 4);
4554     (void)PerlProc_times(&timesbuf);
4555
4556     mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick);
4557     if (GIMME_V == G_ARRAY) {
4558         mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick);
4559         mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick);
4560         mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick);
4561     }
4562     RETURN;
4563 #else
4564 #   ifdef PERL_MICRO
4565     dSP;
4566     mPUSHn(0.0);
4567     EXTEND(SP, 4);
4568     if (GIMME_V == G_ARRAY) {
4569          mPUSHn(0.0);
4570          mPUSHn(0.0);
4571          mPUSHn(0.0);
4572     }
4573     RETURN;
4574 #   else
4575     DIE(aTHX_ "times not implemented");
4576 #   endif
4577 #endif /* HAS_TIMES */
4578 }
4579
4580 /* The 32 bit int year limits the times we can represent to these
4581    boundaries with a few days wiggle room to account for time zone
4582    offsets
4583 */
4584 /* Sat Jan  3 00:00:00 -2147481748 */
4585 #define TIME_LOWER_BOUND -67768100567755200.0
4586 /* Sun Dec 29 12:00:00  2147483647 */
4587 #define TIME_UPPER_BOUND  67767976233316800.0
4588
4589
4590 /* also used for: pp_localtime() */
4591
4592 PP(pp_gmtime)
4593 {
4594     dSP;
4595     Time64_T when;
4596     struct TM tmbuf;
4597     struct TM *err;
4598     const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4599     static const char * const dayname[] =
4600         {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4601     static const char * const monname[] =
4602         {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4603          "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4604
4605     if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4606         time_t now;
4607         (void)time(&now);
4608         when = (Time64_T)now;
4609     }
4610     else {
4611         NV input = Perl_floor(POPn);
4612         const bool pl_isnan = Perl_isnan(input);
4613         when = (Time64_T)input;
4614         if (UNLIKELY(pl_isnan || when != input)) {
4615             /* diag_listed_as: gmtime(%f) too large */
4616             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4617                            "%s(%.0" NVff ") too large", opname, input);
4618             if (pl_isnan) {
4619                 err = NULL;
4620                 goto failed;
4621             }
4622         }
4623     }
4624
4625     if ( TIME_LOWER_BOUND > when ) {
4626         /* diag_listed_as: gmtime(%f) too small */
4627         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4628                        "%s(%.0" NVff ") too small", opname, when);
4629         err = NULL;
4630     }
4631     else if( when > TIME_UPPER_BOUND ) {
4632         /* diag_listed_as: gmtime(%f) too small */
4633         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4634                        "%s(%.0" NVff ") too large", opname, when);
4635         err = NULL;
4636     }
4637     else {
4638         if (PL_op->op_type == OP_LOCALTIME)
4639             err = S_localtime64_r(&when, &tmbuf);
4640         else
4641             err = S_gmtime64_r(&when, &tmbuf);
4642     }
4643
4644     if (err == NULL) {
4645         /* diag_listed_as: gmtime(%f) failed */
4646         /* XXX %lld broken for quads */
4647       failed:
4648         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4649                        "%s(%.0" NVff ") failed", opname, when);
4650     }
4651
4652     if (GIMME_V != G_ARRAY) {   /* scalar context */
4653         EXTEND(SP, 1);
4654         if (err == NULL)
4655             RETPUSHUNDEF;
4656        else {
4657            dTARGET;
4658            PUSHs(TARG);
4659            Perl_sv_setpvf_mg(aTHX_ TARG, "%s %s %2d %02d:%02d:%02d %"IVdf,
4660                                 dayname[tmbuf.tm_wday],
4661                                 monname[tmbuf.tm_mon],
4662                                 tmbuf.tm_mday,
4663                                 tmbuf.tm_hour,
4664                                 tmbuf.tm_min,
4665                                 tmbuf.tm_sec,
4666                                 (IV)tmbuf.tm_year + 1900);
4667         }
4668     }
4669     else {                      /* list context */
4670         if ( err == NULL )
4671             RETURN;
4672
4673         EXTEND(SP, 9);
4674         EXTEND_MORTAL(9);
4675         mPUSHi(tmbuf.tm_sec);
4676         mPUSHi(tmbuf.tm_min);
4677         mPUSHi(tmbuf.tm_hour);
4678         mPUSHi(tmbuf.tm_mday);
4679         mPUSHi(tmbuf.tm_mon);
4680         mPUSHn(tmbuf.tm_year);
4681         mPUSHi(tmbuf.tm_wday);
4682         mPUSHi(tmbuf.tm_yday);
4683         mPUSHi(tmbuf.tm_isdst);
4684     }
4685     RETURN;
4686 }
4687
4688 PP(pp_alarm)
4689 {
4690 #ifdef HAS_ALARM
4691     dSP; dTARGET;
4692     int anum;
4693     anum = POPi;
4694     anum = alarm((unsigned int)anum);
4695     if (anum < 0)
4696         RETPUSHUNDEF;
4697     PUSHi(anum);
4698     RETURN;
4699 #else
4700     DIE(aTHX_ PL_no_func, "alarm");
4701 #endif
4702 }
4703
4704 PP(pp_sleep)
4705 {
4706     dSP; dTARGET;
4707     I32 duration;
4708     Time_t lasttime;
4709     Time_t when;
4710
4711     (void)time(&lasttime);
4712     if (MAXARG < 1 || (!TOPs && !POPs))
4713         PerlProc_pause();
4714     else {
4715         duration = POPi;
4716         PerlProc_sleep((unsigned int)duration);
4717     }
4718     (void)time(&when);
4719     XPUSHi(when - lasttime);
4720     RETURN;
4721 }
4722
4723 /* Shared memory. */
4724 /* Merged with some message passing. */
4725
4726 /* also used for: pp_msgrcv() pp_msgsnd() pp_semop() pp_shmread() */
4727
4728 PP(pp_shmwrite)
4729 {
4730 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4731     dSP; dMARK; dTARGET;
4732     const int op_type = PL_op->op_type;
4733     I32 value;
4734
4735     switch (op_type) {
4736     case OP_MSGSND:
4737         value = (I32)(do_msgsnd(MARK, SP) >= 0);
4738         break;
4739     case OP_MSGRCV:
4740         value = (I32)(do_msgrcv(MARK, SP) >= 0);
4741         break;
4742     case OP_SEMOP:
4743         value = (I32)(do_semop(MARK, SP) >= 0);
4744         break;
4745     default:
4746         value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4747         break;
4748     }
4749
4750     SP = MARK;
4751     PUSHi(value);
4752     RETURN;
4753 #else
4754     return Perl_pp_semget(aTHX);
4755 #endif
4756 }
4757
4758 /* Semaphores. */
4759
4760 /* also used for: pp_msgget() pp_shmget() */
4761
4762 PP(pp_semget)
4763 {
4764 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4765     dSP; dMARK; dTARGET;
4766     const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4767     SP = MARK;
4768     if (anum == -1)
4769         RETPUSHUNDEF;
4770     PUSHi(anum);
4771     RETURN;
4772 #else
4773     DIE(aTHX_ "System V IPC is not implemented on this machine");
4774 #endif
4775 }
4776
4777 /* also used for: pp_msgctl() pp_shmctl() */
4778
4779 PP(pp_semctl)
4780 {
4781 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4782     dSP; dMARK; dTARGET;
4783     const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4784     SP = MARK;
4785     if (anum == -1)
4786         RETPUSHUNDEF;
4787     if (anum != 0) {
4788         PUSHi(anum);
4789     }
4790     else {
4791         PUSHp(zero_but_true, ZBTLEN);
4792     }
4793     RETURN;
4794 #else
4795     return Perl_pp_semget(aTHX);
4796 #endif
4797 }
4798
4799 /* I can't const this further without getting warnings about the types of
4800    various arrays passed in from structures.  */
4801 static SV *
4802 S_space_join_names_mortal(pTHX_ char *const *array)
4803 {
4804     SV *target;
4805
4806     PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4807
4808     if (array && *array) {
4809         target = newSVpvs_flags("", SVs_TEMP);
4810         while (1) {
4811             sv_catpv(target, *array);
4812             if (!*++array)
4813                 break;
4814             sv_catpvs(target, " ");
4815         }
4816     } else {
4817         target = sv_mortalcopy(&PL_sv_no);
4818     }
4819     return target;
4820 }
4821
4822 /* Get system info. */
4823
4824 /* also used for: pp_ghbyaddr() pp_ghbyname() */
4825
4826 PP(pp_ghostent)
4827 {
4828 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4829     dSP;
4830     I32 which = PL_op->op_type;
4831     char **elem;
4832     SV *sv;
4833 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4834     struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4835     struct hostent *gethostbyname(Netdb_name_t);
4836     struct hostent *gethostent(void);
4837 #endif
4838     struct hostent *hent = NULL;
4839     unsigned long len;
4840
4841     EXTEND(SP, 10);
4842     if (which == OP_GHBYNAME) {
4843 #ifdef HAS_GETHOSTBYNAME
4844         const char* const name = POPpbytex;
4845         hent = PerlSock_gethostbyname(name);
4846 #else
4847         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4848 #endif
4849     }
4850     else if (which == OP_GHBYADDR) {
4851 #ifdef HAS_GETHOSTBYADDR
4852         const int addrtype = POPi;
4853         SV * const addrsv = POPs;
4854         STRLEN addrlen;
4855         const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4856
4857         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4858 #else
4859         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4860 #endif
4861     }
4862     else
4863 #ifdef HAS_GETHOSTENT
4864         hent = PerlSock_gethostent();
4865 #else
4866         DIE(aTHX_ PL_no_sock_func, "gethostent");
4867 #endif
4868
4869 #ifdef HOST_NOT_FOUND
4870         if (!hent) {
4871 #ifdef USE_REENTRANT_API
4872 #   ifdef USE_GETHOSTENT_ERRNO
4873             h_errno = PL_reentrant_buffer->_gethostent_errno;
4874 #   endif
4875 #endif
4876             STATUS_UNIX_SET(h_errno);
4877         }
4878 #endif
4879
4880     if (GIMME_V != G_ARRAY) {
4881         PUSHs(sv = sv_newmortal());
4882         if (hent) {
4883             if (which == OP_GHBYNAME) {
4884                 if (hent->h_addr)
4885                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4886             }
4887             else
4888                 sv_setpv(sv, (char*)hent->h_name);
4889         }
4890         RETURN;
4891     }
4892
4893     if (hent) {
4894         mPUSHs(newSVpv((char*)hent->h_name, 0));
4895         PUSHs(space_join_names_mortal(hent->h_aliases));
4896         mPUSHi(hent->h_addrtype);
4897         len = hent->h_length;
4898         mPUSHi(len);
4899 #ifdef h_addr
4900         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4901             mXPUSHp(*elem, len);
4902         }
4903 #else
4904         if (hent->h_addr)
4905             mPUSHp(hent->h_addr, len);
4906         else
4907             PUSHs(sv_mortalcopy(&PL_sv_no));
4908 #endif /* h_addr */
4909     }
4910     RETURN;
4911 #else
4912     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4913 #endif
4914 }
4915
4916 /* also used for: pp_gnbyaddr() pp_gnbyname() */
4917
4918 PP(pp_gnetent)
4919 {
4920 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4921     dSP;
4922     I32 which = PL_op->op_type;
4923     SV *sv;
4924 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4925     struct netent *getnetbyaddr(Netdb_net_t, int);
4926     struct netent *getnetbyname(Netdb_name_t);
4927     struct netent *getnetent(void);
4928 #endif
4929     struct netent *nent;
4930
4931     if (which == OP_GNBYNAME){
4932 #ifdef HAS_GETNETBYNAME
4933         const char * const name = POPpbytex;
4934         nent = PerlSock_getnetbyname(name);
4935 #else
4936         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4937 #endif
4938     }
4939     else if (which == OP_GNBYADDR) {
4940 #ifdef HAS_GETNETBYADDR
4941         const int addrtype = POPi;
4942         const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4943         nent = PerlSock_getnetbyaddr(addr, addrtype);
4944 #else
4945         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4946 #endif
4947     }
4948     else
4949 #ifdef HAS_GETNETENT
4950         nent = PerlSock_getnetent();
4951 #else
4952         DIE(aTHX_ PL_no_sock_func, "getnetent");
4953 #endif
4954
4955 #ifdef HOST_NOT_FOUND
4956         if (!nent) {
4957 #ifdef USE_REENTRANT_API
4958 #   ifdef USE_GETNETENT_ERRNO
4959              h_errno = PL_reentrant_buffer->_getnetent_errno;
4960 #   endif
4961 #endif
4962             STATUS_UNIX_SET(h_errno);
4963         }
4964 #endif
4965
4966     EXTEND(SP, 4);
4967     if (GIMME_V != G_ARRAY) {
4968         PUSHs(sv = sv_newmortal());
4969         if (nent) {
4970             if (which == OP_GNBYNAME)
4971                 sv_setiv(sv, (IV)nent->n_net);
4972             else
4973                 sv_setpv(sv, nent->n_name);
4974         }
4975         RETURN;
4976     }
4977
4978     if (nent) {
4979         mPUSHs(newSVpv(nent->n_name, 0));
4980         PUSHs(space_join_names_mortal(nent->n_aliases));
4981         mPUSHi(nent->n_addrtype);
4982         mPUSHi(nent->n_net);
4983     }
4984
4985     RETURN;
4986 #else
4987     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4988 #endif
4989 }
4990
4991
4992 /* also used for: pp_gpbyname() pp_gpbynumber() */
4993
4994 PP(pp_gprotoent)
4995 {
4996 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4997     dSP;
4998     I32 which = PL_op->op_type;
4999     SV *sv;
5000 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
5001     struct protoent *getprotobyname(Netdb_name_t);
5002     struct protoent *getprotobynumber(int);
5003     struct protoent *getprotoent(void);
5004 #endif
5005     struct protoent *pent;
5006
5007     if (which == OP_GPBYNAME) {
5008 #ifdef HAS_GETPROTOBYNAME
5009         const char* const name = POPpbytex;
5010         pent = PerlSock_getprotobyname(name);
5011 #else
5012         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
5013 #endif
5014     }
5015     else if (which == OP_GPBYNUMBER) {
5016 #ifdef HAS_GETPROTOBYNUMBER
5017         const int number = POPi;
5018         pent = PerlSock_getprotobynumber(number);
5019 #else
5020         DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
5021 #endif
5022     }
5023     else
5024 #ifdef HAS_GETPROTOENT
5025         pent = PerlSock_getprotoent();
5026 #else
5027         DIE(aTHX_ PL_no_sock_func, "getprotoent");
5028 #endif
5029
5030     EXTEND(SP, 3);
5031     if (GIMME_V != G_ARRAY) {
5032         PUSHs(sv = sv_newmortal());
5033         if (pent) {
5034             if (which == OP_GPBYNAME)
5035                 sv_setiv(sv, (IV)pent->p_proto);
5036             else
5037                 sv_setpv(sv, pent->p_name);
5038         }
5039         RETURN;
5040     }
5041
5042     if (pent) {
5043         mPUSHs(newSVpv(pent->p_name, 0));
5044         PUSHs(space_join_names_mortal(pent->p_aliases));
5045         mPUSHi(pent->p_proto);
5046     }
5047
5048     RETURN;
5049 #else
5050     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5051 #endif
5052 }
5053
5054
5055 /* also used for: pp_gsbyname() pp_gsbyport() */
5056
5057 PP(pp_gservent)
5058 {
5059 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
5060     dSP;
5061     I32 which = PL_op->op_type;
5062     SV *sv;
5063 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
5064     struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
5065     struct servent *getservbyport(int, Netdb_name_t);
5066     struct servent *getservent(void);
5067 #endif
5068     struct servent *sent;
5069
5070     if (which == OP_GSBYNAME) {
5071 #ifdef HAS_GETSERVBYNAME
5072         const char * const proto = POPpbytex;
5073         const char * const name = POPpbytex;
5074         sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
5075 #else
5076         DIE(aTHX_ PL_no_sock_func, "getservbyname");
5077 #endif
5078     }
5079     else if (which == OP_GSBYPORT) {
5080 #ifdef HAS_GETSERVBYPORT
5081         const char * const proto = POPpbytex;
5082         unsigned short port = (unsigned short)POPu;
5083         port = PerlSock_htons(port);
5084         sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
5085 #else
5086         DIE(aTHX_ PL_no_sock_func, "getservbyport");
5087 #endif
5088     }
5089     else
5090 #ifdef HAS_GETSERVENT
5091         sent = PerlSock_getservent();
5092 #else
5093         DIE(aTHX_ PL_no_sock_func, "getservent");
5094 #endif
5095
5096     EXTEND(SP, 4);
5097     if (GIMME_V != G_ARRAY) {
5098         PUSHs(sv = sv_newmortal());
5099         if (sent) {
5100             if (which == OP_GSBYNAME) {
5101                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5102             }
5103             else
5104                 sv_setpv(sv, sent->s_name);
5105         }
5106         RETURN;
5107     }
5108
5109     if (sent) {
5110         mPUSHs(newSVpv(sent->s_name, 0));
5111         PUSHs(space_join_names_mortal(sent->s_aliases));
5112         mPUSHi(PerlSock_ntohs(sent->s_port));
5113         mPUSHs(newSVpv(sent->s_proto, 0));
5114     }
5115
5116     RETURN;
5117 #else
5118     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5119 #endif
5120 }
5121
5122
5123 /* also used for: pp_snetent() pp_sprotoent() pp_sservent() */
5124
5125 PP(pp_shostent)
5126 {
5127     dSP;
5128     const int stayopen = TOPi;
5129     switch(PL_op->op_type) {
5130     case OP_SHOSTENT:
5131 #ifdef HAS_SETHOSTENT
5132         PerlSock_sethostent(stayopen);
5133 #else
5134         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5135 #endif
5136         break;
5137 #ifdef HAS_SETNETENT
5138     case OP_SNETENT:
5139         PerlSock_setnetent(stayopen);
5140 #else
5141         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5142 #endif
5143         break;
5144     case OP_SPROTOENT:
5145 #ifdef HAS_SETPROTOENT
5146         PerlSock_setprotoent(stayopen);
5147 #else
5148         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5149 #endif
5150         break;
5151     case OP_SSERVENT:
5152 #ifdef HAS_SETSERVENT
5153         PerlSock_setservent(stayopen);
5154 #else
5155         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5156 #endif
5157         break;
5158     }
5159     RETSETYES;
5160 }
5161
5162
5163 /* also used for: pp_egrent() pp_enetent() pp_eprotoent() pp_epwent()
5164  *                pp_eservent() pp_sgrent() pp_spwent() */
5165
5166 PP(pp_ehostent)
5167 {
5168     dSP;
5169     switch(PL_op->op_type) {
5170     case OP_EHOSTENT:
5171 #ifdef HAS_ENDHOSTENT
5172         PerlSock_endhostent();
5173 #else
5174         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5175 #endif
5176         break;
5177     case OP_ENETENT:
5178 #ifdef HAS_ENDNETENT
5179         PerlSock_endnetent();
5180 #else
5181         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5182 #endif
5183         break;
5184     case OP_EPROTOENT:
5185 #ifdef HAS_ENDPROTOENT
5186         PerlSock_endprotoent();
5187 #else
5188         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5189 #endif
5190         break;
5191     case OP_ESERVENT:
5192 #ifdef HAS_ENDSERVENT
5193         PerlSock_endservent();
5194 #else
5195         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5196 #endif
5197         break;
5198     case OP_SGRENT:
5199 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5200         setgrent();
5201 #else
5202         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5203 #endif
5204         break;
5205     case OP_EGRENT:
5206 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5207         endgrent();
5208 #else
5209         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5210 #endif
5211         break;
5212     case OP_SPWENT:
5213 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5214         setpwent();
5215 #else
5216         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5217 #endif
5218         break;
5219     case OP_EPWENT:
5220 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5221         endpwent();
5222 #else
5223         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5224 #endif
5225         break;
5226     }
5227     EXTEND(SP,1);
5228     RETPUSHYES;
5229 }
5230
5231
5232 /* also used for: pp_gpwnam() pp_gpwuid() */
5233
5234 PP(pp_gpwent)
5235 {
5236 #ifdef HAS_PASSWD
5237     dSP;
5238     I32 which = PL_op->op_type;
5239     SV *sv;
5240     struct passwd *pwent  = NULL;
5241     /*
5242      * We currently support only the SysV getsp* shadow password interface.
5243      * The interface is declared in <shadow.h> and often one needs to link
5244      * with -lsecurity or some such.
5245      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5246      * (and SCO?)
5247      *
5248      * AIX getpwnam() is clever enough to return the encrypted password
5249      * only if the caller (euid?) is root.
5250      *
5251      * There are at least three other shadow password APIs.  Many platforms
5252      * seem to contain more than one interface for accessing the shadow
5253      * password databases, possibly for compatibility reasons.
5254      * The getsp*() is by far he simplest one, the other two interfaces
5255      * are much more complicated, but also very similar to each other.
5256      *
5257      * <sys/types.h>
5258      * <sys/security.h>
5259      * <prot.h>
5260      * struct pr_passwd *getprpw*();
5261      * The password is in
5262      * char getprpw*(...).ufld.fd_encrypt[]
5263      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5264      *
5265      * <sys/types.h>
5266      * <sys/security.h>
5267      * <prot.h>
5268      * struct es_passwd *getespw*();
5269      * The password is in
5270      * char *(getespw*(...).ufld.fd_encrypt)
5271      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5272      *
5273      * <userpw.h> (AIX)
5274      * struct userpw *getuserpw();
5275      * The password is in
5276      * char *(getuserpw(...)).spw_upw_passwd
5277      * (but the de facto standard getpwnam() should work okay)
5278      *
5279      * Mention I_PROT here so that Configure probes for it.
5280      *
5281      * In HP-UX for getprpw*() the manual page claims that one should include
5282      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5283      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5284      * and pp_sys.c already includes <shadow.h> if there is such.
5285      *
5286      * Note that <sys/security.h> is already probed for, but currently
5287      * it is only included in special cases.
5288      *
5289      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5290      * be preferred interface, even though also the getprpw*() interface
5291      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5292      * One also needs to call set_auth_parameters() in main() before
5293      * doing anything else, whether one is using getespw*() or getprpw*().
5294      *
5295      * Note that accessing the shadow databases can be magnitudes
5296      * slower than accessing the standard databases.
5297      *
5298      * --jhi
5299      */
5300
5301 #   if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5302     /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5303      * the pw_comment is left uninitialized. */
5304     PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5305 #   endif
5306
5307     switch (which) {
5308     case OP_GPWNAM:
5309       {
5310         const char* const name = POPpbytex;
5311         pwent  = getpwnam(name);
5312       }
5313       break;
5314     case OP_GPWUID:
5315       {
5316         Uid_t uid = POPi;
5317         pwent = getpwuid(uid);
5318       }
5319         break;
5320     case OP_GPWENT:
5321 #   ifdef HAS_GETPWENT
5322         pwent  = getpwent();
5323 #ifdef POSIX_BC   /* In some cases pw_passwd has invalid addresses */
5324         if (pwent) pwent = getpwnam(pwent->pw_name);
5325 #endif
5326 #   else
5327         DIE(aTHX_ PL_no_func, "getpwent");
5328 #   endif
5329         break;
5330     }
5331
5332     EXTEND(SP, 10);
5333     if (GIMME_V != G_ARRAY) {
5334         PUSHs(sv = sv_newmortal());
5335         if (pwent) {
5336             if (which == OP_GPWNAM)
5337                 sv_setuid(sv, pwent->pw_uid);
5338             else
5339                 sv_setpv(sv, pwent->pw_name);
5340         }
5341         RETURN;
5342     }
5343
5344     if (pwent) {
5345         mPUSHs(newSVpv(pwent->pw_name, 0));
5346
5347         sv = newSViv(0);
5348         mPUSHs(sv);
5349         /* If we have getspnam(), we try to dig up the shadow
5350          * password.  If we are underprivileged, the shadow
5351          * interface will set the errno to EACCES or similar,
5352          * and return a null pointer.  If this happens, we will
5353          * use the dummy password (usually "*" or "x") from the
5354          * standard password database.
5355          *
5356          * In theory we could skip the shadow call completely
5357          * if euid != 0 but in practice we cannot know which
5358          * security measures are guarding the shadow databases
5359          * on a random platform.
5360          *
5361          * Resist the urge to use additional shadow interfaces.
5362          * Divert the urge to writing an extension instead.
5363          *
5364          * --jhi */
5365         /* Some AIX setups falsely(?) detect some getspnam(), which
5366          * has a different API than the Solaris/IRIX one. */
5367 #   if defined(HAS_GETSPNAM) && !defined(_AIX)
5368         {
5369             dSAVE_ERRNO;
5370             const struct spwd * const spwent = getspnam(pwent->pw_name);
5371                           /* Save and restore errno so that
5372                            * underprivileged attempts seem
5373                            * to have never made the unsuccessful
5374                            * attempt to retrieve the shadow password. */
5375             RESTORE_ERRNO;
5376             if (spwent && spwent->sp_pwdp)
5377                 sv_setpv(sv, spwent->sp_pwdp);
5378         }
5379 #   endif
5380 #   ifdef PWPASSWD
5381         if (!SvPOK(sv)) /* Use the standard password, then. */
5382             sv_setpv(sv, pwent->pw_passwd);
5383 #   endif
5384
5385         /* passwd is tainted because user himself can diddle with it.
5386          * admittedly not much and in a very limited way, but nevertheless. */
5387         SvTAINTED_on(sv);
5388
5389         sv_setuid(PUSHmortal, pwent->pw_uid);
5390         sv_setgid(PUSHmortal, pwent->pw_gid);
5391
5392         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5393          * because of the poor interface of the Perl getpw*(),
5394          * not because there's some standard/convention saying so.
5395          * A better interface would have been to return a hash,
5396          * but we are accursed by our history, alas. --jhi.  */
5397 #   ifdef PWCHANGE
5398         mPUSHi(pwent->pw_change);
5399 #   else
5400 #       ifdef PWQUOTA
5401         mPUSHi(pwent->pw_quota);
5402 #       else
5403 #           ifdef PWAGE
5404         mPUSHs(newSVpv(pwent->pw_age, 0));
5405 #           else
5406         /* I think that you can never get this compiled, but just in case.  */
5407         PUSHs(sv_mortalcopy(&PL_sv_no));
5408 #           endif
5409 #       endif
5410 #   endif
5411
5412         /* pw_class and pw_comment are mutually exclusive--.
5413          * see the above note for pw_change, pw_quota, and pw_age. */
5414 #   ifdef PWCLASS
5415         mPUSHs(newSVpv(pwent->pw_class, 0));
5416 #   else
5417 #       ifdef PWCOMMENT
5418         mPUSHs(newSVpv(pwent->pw_comment, 0));
5419 #       else
5420         /* I think that you can never get this compiled, but just in case.  */
5421         PUSHs(sv_mortalcopy(&PL_sv_no));
5422 #       endif
5423 #   endif
5424
5425 #   ifdef PWGECOS
5426         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5427 #   else
5428         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5429 #   endif
5430         /* pw_gecos is tainted because user himself can diddle with it. */
5431         SvTAINTED_on(sv);
5432
5433         mPUSHs(newSVpv(pwent->pw_dir, 0));
5434
5435         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5436         /* pw_shell is tainted because user himself can diddle with it. */
5437         SvTAINTED_on(sv);
5438
5439 #   ifdef PWEXPIRE
5440         mPUSHi(pwent->pw_expire);
5441 #   endif
5442     }
5443     RETURN;
5444 #else
5445     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5446 #endif
5447 }
5448
5449
5450 /* also used for: pp_ggrgid() pp_ggrnam() */
5451
5452 PP(pp_ggrent)
5453 {
5454 #ifdef HAS_GROUP
5455     dSP;
5456     const I32 which = PL_op->op_type;
5457     const struct group *grent;
5458
5459     if (which == OP_GGRNAM) {
5460         const char* const name = POPpbytex;
5461         grent = (const struct group *)getgrnam(name);
5462     }
5463     else if (which == OP_GGRGID) {
5464         const Gid_t gid = POPi;
5465         grent = (const struct group *)getgrgid(gid);
5466     }
5467     else
5468 #ifdef HAS_GETGRENT
5469         grent = (struct group *)getgrent();
5470 #else
5471         DIE(aTHX_ PL_no_func, "getgrent");
5472 #endif
5473
5474     EXTEND(SP, 4);
5475     if (GIMME_V != G_ARRAY) {
5476         SV * const sv = sv_newmortal();
5477
5478         PUSHs(sv);
5479         if (grent) {
5480             if (which == OP_GGRNAM)
5481                 sv_setgid(sv, grent->gr_gid);
5482             else
5483                 sv_setpv(sv, grent->gr_name);
5484         }
5485         RETURN;
5486     }
5487
5488     if (grent) {
5489         mPUSHs(newSVpv(grent->gr_name, 0));
5490
5491 #ifdef GRPASSWD
5492         mPUSHs(newSVpv(grent->gr_passwd, 0));
5493 #else
5494         PUSHs(sv_mortalcopy(&PL_sv_no));
5495 #endif
5496
5497         sv_setgid(PUSHmortal, grent->gr_gid);
5498
5499 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5500         /* In UNICOS/mk (_CRAYMPP) the multithreading
5501          * versions (getgrnam_r, getgrgid_r)
5502          * seem to return an illegal pointer
5503          * as the group members list, gr_mem.
5504          * getgrent() doesn't even have a _r version
5505          * but the gr_mem is poisonous anyway.
5506          * So yes, you cannot get the list of group
5507          * members if building multithreaded in UNICOS/mk. */
5508         PUSHs(space_join_names_mortal(grent->gr_mem));
5509 #endif
5510     }
5511
5512     RETURN;
5513 #else
5514     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5515 #endif
5516 }
5517
5518 PP(pp_getlogin)
5519 {
5520 #ifdef HAS_GETLOGIN
5521     dSP; dTARGET;
5522     char *tmps;
5523     EXTEND(SP, 1);
5524     if (!(tmps = PerlProc_getlogin()))
5525         RETPUSHUNDEF;
5526     sv_setpv_mg(TARG, tmps);
5527     PUSHs(TARG);
5528     RETURN;
5529 #else
5530     DIE(aTHX_ PL_no_func, "getlogin");
5531 #endif
5532 }
5533
5534 /* Miscellaneous. */
5535
5536 PP(pp_syscall)
5537 {
5538 #ifdef HAS_SYSCALL
5539     dSP; dMARK; dORIGMARK; dTARGET;
5540     I32 items = SP - MARK;
5541     unsigned long a[20];
5542     I32 i = 0;
5543     IV retval = -1;
5544
5545     if (TAINTING_get) {
5546         while (++MARK <= SP) {
5547             if (SvTAINTED(*MARK)) {
5548                 TAINT;
5549                 break;
5550             }
5551         }
5552         MARK = ORIGMARK;
5553         TAINT_PROPER("syscall");
5554     }
5555
5556     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5557      * or where sizeof(long) != sizeof(char*).  But such machines will
5558      * not likely have syscall implemented either, so who cares?
5559      */
5560     while (++MARK <= SP) {
5561         if (SvNIOK(*MARK) || !i)
5562             a[i++] = SvIV(*MARK);
5563         else if (*MARK == &PL_sv_undef)
5564             a[i++] = 0;
5565         else
5566             a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5567         if (i > 15)
5568             break;
5569     }
5570     switch (items) {
5571     default:
5572         DIE(aTHX_ "Too many args to syscall");
5573     case 0:
5574         DIE(aTHX_ "Too few args to syscall");
5575     case 1:
5576         retval = syscall(a[0]);
5577         break;
5578     case 2:
5579         retval = syscall(a[0],a[1]);
5580         break;
5581     case 3:
5582         retval = syscall(a[0],a[1],a[2]);
5583         break;
5584     case 4:
5585         retval = syscall(a[0],a[1],a[2],a[3]);
5586         break;
5587     case 5:
5588         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5589         break;
5590     case 6:
5591         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5592         break;
5593     case 7:
5594         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5595         break;
5596     case 8:
5597         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5598         break;
5599     }
5600     SP = ORIGMARK;
5601     PUSHi(retval);
5602     RETURN;
5603 #else
5604     DIE(aTHX_ PL_no_func, "syscall");
5605 #endif
5606 }
5607
5608 #ifdef FCNTL_EMULATE_FLOCK
5609
5610 /*  XXX Emulate flock() with fcntl().
5611     What's really needed is a good file locking module.
5612 */
5613
5614 static int
5615 fcntl_emulate_flock(int fd, int operation)
5616 {
5617     int res;
5618     struct flock flock;
5619
5620     switch (operation & ~LOCK_NB) {
5621     case LOCK_SH:
5622         flock.l_type = F_RDLCK;
5623         break;
5624     case LOCK_EX:
5625         flock.l_type = F_WRLCK;
5626         break;
5627     case LOCK_UN:
5628         flock.l_type = F_UNLCK;
5629         break;
5630     default:
5631         errno = EINVAL;
5632         return -1;
5633     }
5634     flock.l_whence = SEEK_SET;
5635     flock.l_start = flock.l_len = (Off_t)0;
5636
5637     res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5638     if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5639         errno = EWOULDBLOCK;
5640     return res;
5641 }
5642
5643 #endif /* FCNTL_EMULATE_FLOCK */
5644
5645 #ifdef LOCKF_EMULATE_FLOCK
5646
5647 /*  XXX Emulate flock() with lockf().  This is just to increase
5648     portability of scripts.  The calls are not completely
5649     interchangeable.  What's really needed is a good file
5650     locking module.
5651 */
5652
5653 /*  The lockf() constants might have been defined in <unistd.h>.
5654     Unfortunately, <unistd.h> causes troubles on some mixed
5655     (BSD/POSIX) systems, such as SunOS 4.1.3.
5656
5657    Further, the lockf() constants aren't POSIX, so they might not be
5658    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5659    just stick in the SVID values and be done with it.  Sigh.
5660 */
5661
5662 # ifndef F_ULOCK
5663 #  define F_ULOCK       0       /* Unlock a previously locked region */
5664 # endif
5665 # ifndef F_LOCK
5666 #  define F_LOCK        1       /* Lock a region for exclusive use */
5667 # endif
5668 # ifndef F_TLOCK
5669 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5670 # endif
5671 # ifndef F_TEST
5672 #  define F_TEST        3       /* Test a region for other processes locks */
5673 # endif
5674
5675 static int
5676 lockf_emulate_flock(int fd, int operation)
5677 {
5678     int i;
5679     Off_t pos;
5680     dSAVE_ERRNO;
5681
5682     /* flock locks entire file so for lockf we need to do the same      */
5683     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5684     if (pos > 0)        /* is seekable and needs to be repositioned     */
5685         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5686             pos = -1;   /* seek failed, so don't seek back afterwards   */
5687     RESTORE_ERRNO;
5688
5689     switch (operation) {
5690
5691         /* LOCK_SH - get a shared lock */
5692         case LOCK_SH:
5693         /* LOCK_EX - get an exclusive lock */
5694         case LOCK_EX:
5695             i = lockf (fd, F_LOCK, 0);
5696             break;
5697
5698         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5699         case LOCK_SH|LOCK_NB:
5700         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5701         case LOCK_EX|LOCK_NB:
5702             i = lockf (fd, F_TLOCK, 0);
5703             if (i == -1)
5704                 if ((errno == EAGAIN) || (errno == EACCES))
5705                     errno = EWOULDBLOCK;
5706             break;
5707
5708         /* LOCK_UN - unlock (non-blocking is a no-op) */
5709         case LOCK_UN:
5710         case LOCK_UN|LOCK_NB:
5711             i = lockf (fd, F_ULOCK, 0);
5712             break;
5713
5714         /* Default - can't decipher operation */
5715         default:
5716             i = -1;
5717             errno = EINVAL;
5718             break;
5719     }
5720
5721     if (pos > 0)      /* need to restore position of the handle */
5722         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5723
5724     return (i);
5725 }
5726
5727 #endif /* LOCKF_EMULATE_FLOCK */
5728
5729 /*
5730  * Local variables:
5731  * c-indentation-style: bsd
5732  * c-basic-offset: 4
5733  * indent-tabs-mode: nil
5734  * End:
5735  *
5736  * ex: set ts=8 sts=4 sw=4 et:
5737  */