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