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