pp_sys.c

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