pp_sys.c

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