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