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