pp_sys.c

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