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