pp_sys.c

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