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