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