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