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