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