pp_sys.c

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