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