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