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