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