pp_sys.c

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