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