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 (PL_laststype != OP_LSTAT)
2730                 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2731             if (ckWARN(WARN_IO) && gv != PL_defgv)
2732                 Perl_warner(aTHX_ WARN_IO,
2733                         "lstat() on filehandle %s", GvENAME(gv));
2734                 /* Perl_my_lstat (-l) croak's on filehandle, why warn here? */
2735         }
2736
2737       do_fstat:
2738         if (gv != PL_defgv) {
2739             PL_laststype = OP_STAT;
2740             PL_statgv = gv;
2741             sv_setpv(PL_statname, "");
2742             PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv))
2743                 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
2744         }
2745         if (PL_laststatval < 0) {
2746             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2747                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2748             max = 0;
2749         }
2750     }
2751     else {
2752         SV* sv = POPs;
2753         if (SvTYPE(sv) == SVt_PVGV) {
2754             gv = (GV*)sv;
2755             goto do_fstat;
2756         }
2757         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2758             gv = (GV*)SvRV(sv);
2759             goto do_fstat;
2760         }
2761         sv_setpv(PL_statname, SvPV(sv,n_a));
2762         PL_statgv = Nullgv;
2763 #ifdef HAS_LSTAT
2764         PL_laststype = PL_op->op_type;
2765         if (PL_op->op_type == OP_LSTAT)
2766             PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
2767         else
2768 #endif
2769             PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
2770         if (PL_laststatval < 0) {
2771             if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
2772                 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
2773             max = 0;
2774         }
2775     }
2776
2777     gimme = GIMME_V;
2778     if (gimme != G_ARRAY) {
2779         if (gimme != G_VOID)
2780             XPUSHs(boolSV(max));
2781         RETURN;
2782     }
2783     if (max) {
2784         EXTEND(SP, max);
2785         EXTEND_MORTAL(max);
2786         PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2787         PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2788         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2789         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
2790 #if Uid_t_size > IVSIZE
2791         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2792 #else
2793 #   if Uid_t_sign <= 0
2794         PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2795 #   else
2796         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2797 #   endif
2798 #endif
2799 #if Gid_t_size > IVSIZE
2800         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2801 #else
2802 #   if Gid_t_sign <= 0
2803         PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2804 #   else
2805         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2806 #   endif
2807 #endif
2808 #ifdef USE_STAT_RDEV
2809         PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2810 #else
2811         PUSHs(sv_2mortal(newSVpvn("", 0)));
2812 #endif
2813 #if Off_t_size > IVSIZE
2814         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size)));
2815 #else
2816         PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2817 #endif
2818 #ifdef BIG_TIME
2819         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2820         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2821         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2822 #else
2823         PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2824         PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2825         PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
2826 #endif
2827 #ifdef USE_STAT_BLOCKS
2828         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2829         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
2830 #else
2831         PUSHs(sv_2mortal(newSVpvn("", 0)));
2832         PUSHs(sv_2mortal(newSVpvn("", 0)));
2833 #endif
2834     }
2835     RETURN;
2836 }
2837
2838 PP(pp_ftrread)
2839 {
2840     I32 result;
2841     dSP;
2842 #if defined(HAS_ACCESS) && defined(R_OK)
2843     STRLEN n_a;
2844     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2845         result = access(TOPpx, R_OK);
2846         if (result == 0)
2847             RETPUSHYES;
2848         if (result < 0)
2849             RETPUSHUNDEF;
2850         RETPUSHNO;
2851     }
2852     else
2853         result = my_stat();
2854 #else
2855     result = my_stat();
2856 #endif
2857     SPAGAIN;
2858     if (result < 0)
2859         RETPUSHUNDEF;
2860     if (cando(S_IRUSR, 0, &PL_statcache))
2861         RETPUSHYES;
2862     RETPUSHNO;
2863 }
2864
2865 PP(pp_ftrwrite)
2866 {
2867     I32 result;
2868     dSP;
2869 #if defined(HAS_ACCESS) && defined(W_OK)
2870     STRLEN n_a;
2871     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2872         result = access(TOPpx, W_OK);
2873         if (result == 0)
2874             RETPUSHYES;
2875         if (result < 0)
2876             RETPUSHUNDEF;
2877         RETPUSHNO;
2878     }
2879     else
2880         result = my_stat();
2881 #else
2882     result = my_stat();
2883 #endif
2884     SPAGAIN;
2885     if (result < 0)
2886         RETPUSHUNDEF;
2887     if (cando(S_IWUSR, 0, &PL_statcache))
2888         RETPUSHYES;
2889     RETPUSHNO;
2890 }
2891
2892 PP(pp_ftrexec)
2893 {
2894     I32 result;
2895     dSP;
2896 #if defined(HAS_ACCESS) && defined(X_OK)
2897     STRLEN n_a;
2898     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2899         result = access(TOPpx, X_OK);
2900         if (result == 0)
2901             RETPUSHYES;
2902         if (result < 0)
2903             RETPUSHUNDEF;
2904         RETPUSHNO;
2905     }
2906     else
2907         result = my_stat();
2908 #else
2909     result = my_stat();
2910 #endif
2911     SPAGAIN;
2912     if (result < 0)
2913         RETPUSHUNDEF;
2914     if (cando(S_IXUSR, 0, &PL_statcache))
2915         RETPUSHYES;
2916     RETPUSHNO;
2917 }
2918
2919 PP(pp_fteread)
2920 {
2921     I32 result;
2922     dSP;
2923 #ifdef PERL_EFF_ACCESS_R_OK
2924     STRLEN n_a;
2925     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2926         result = PERL_EFF_ACCESS_R_OK(TOPpx);
2927         if (result == 0)
2928             RETPUSHYES;
2929         if (result < 0)
2930             RETPUSHUNDEF;
2931         RETPUSHNO;
2932     }
2933     else
2934         result = my_stat();
2935 #else
2936     result = my_stat();
2937 #endif
2938     SPAGAIN;
2939     if (result < 0)
2940         RETPUSHUNDEF;
2941     if (cando(S_IRUSR, 1, &PL_statcache))
2942         RETPUSHYES;
2943     RETPUSHNO;
2944 }
2945
2946 PP(pp_ftewrite)
2947 {
2948     I32 result;
2949     dSP;
2950 #ifdef PERL_EFF_ACCESS_W_OK
2951     STRLEN n_a;
2952     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2953         result = PERL_EFF_ACCESS_W_OK(TOPpx);
2954         if (result == 0)
2955             RETPUSHYES;
2956         if (result < 0)
2957             RETPUSHUNDEF;
2958         RETPUSHNO;
2959     }
2960     else
2961         result = my_stat();
2962 #else
2963     result = my_stat();
2964 #endif
2965     SPAGAIN;
2966     if (result < 0)
2967         RETPUSHUNDEF;
2968     if (cando(S_IWUSR, 1, &PL_statcache))
2969         RETPUSHYES;
2970     RETPUSHNO;
2971 }
2972
2973 PP(pp_fteexec)
2974 {
2975     I32 result;
2976     dSP;
2977 #ifdef PERL_EFF_ACCESS_X_OK
2978     STRLEN n_a;
2979     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2980         result = PERL_EFF_ACCESS_X_OK(TOPpx);
2981         if (result == 0)
2982             RETPUSHYES;
2983         if (result < 0)
2984             RETPUSHUNDEF;
2985         RETPUSHNO;
2986     }
2987     else
2988         result = my_stat();
2989 #else
2990     result = my_stat();
2991 #endif
2992     SPAGAIN;
2993     if (result < 0)
2994         RETPUSHUNDEF;
2995     if (cando(S_IXUSR, 1, &PL_statcache))
2996         RETPUSHYES;
2997     RETPUSHNO;
2998 }
2999
3000 PP(pp_ftis)
3001 {
3002     I32 result = my_stat();
3003     dSP;
3004     if (result < 0)
3005         RETPUSHUNDEF;
3006     RETPUSHYES;
3007 }
3008
3009 PP(pp_fteowned)
3010 {
3011     return pp_ftrowned();
3012 }
3013
3014 PP(pp_ftrowned)
3015 {
3016     I32 result = my_stat();
3017     dSP;
3018     if (result < 0)
3019         RETPUSHUNDEF;
3020     if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
3021                                 PL_euid : PL_uid) )
3022         RETPUSHYES;
3023     RETPUSHNO;
3024 }
3025
3026 PP(pp_ftzero)
3027 {
3028     I32 result = my_stat();
3029     dSP;
3030     if (result < 0)
3031         RETPUSHUNDEF;
3032     if (PL_statcache.st_size == 0)
3033         RETPUSHYES;
3034     RETPUSHNO;
3035 }
3036
3037 PP(pp_ftsize)
3038 {
3039     I32 result = my_stat();
3040     dSP; dTARGET;
3041     if (result < 0)
3042         RETPUSHUNDEF;
3043 #if Off_t_size > IVSIZE
3044     PUSHn(PL_statcache.st_size);
3045 #else
3046     PUSHi(PL_statcache.st_size);
3047 #endif
3048     RETURN;
3049 }
3050
3051 PP(pp_ftmtime)
3052 {
3053     I32 result = my_stat();
3054     dSP; dTARGET;
3055     if (result < 0)
3056         RETPUSHUNDEF;
3057     PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3058     RETURN;
3059 }
3060
3061 PP(pp_ftatime)
3062 {
3063     I32 result = my_stat();
3064     dSP; dTARGET;
3065     if (result < 0)
3066         RETPUSHUNDEF;
3067     PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
3068     RETURN;
3069 }
3070
3071 PP(pp_ftctime)
3072 {
3073     I32 result = my_stat();
3074     dSP; dTARGET;
3075     if (result < 0)
3076         RETPUSHUNDEF;
3077     PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3078     RETURN;
3079 }
3080
3081 PP(pp_ftsock)
3082 {
3083     I32 result = my_stat();
3084     dSP;
3085     if (result < 0)
3086         RETPUSHUNDEF;
3087     if (S_ISSOCK(PL_statcache.st_mode))
3088         RETPUSHYES;
3089     RETPUSHNO;
3090 }
3091
3092 PP(pp_ftchr)
3093 {
3094     I32 result = my_stat();
3095     dSP;
3096     if (result < 0)
3097         RETPUSHUNDEF;
3098     if (S_ISCHR(PL_statcache.st_mode))
3099         RETPUSHYES;
3100     RETPUSHNO;
3101 }
3102
3103 PP(pp_ftblk)
3104 {
3105     I32 result = my_stat();
3106     dSP;
3107     if (result < 0)
3108         RETPUSHUNDEF;
3109     if (S_ISBLK(PL_statcache.st_mode))
3110         RETPUSHYES;
3111     RETPUSHNO;
3112 }
3113
3114 PP(pp_ftfile)
3115 {
3116     I32 result = my_stat();
3117     dSP;
3118     if (result < 0)
3119         RETPUSHUNDEF;
3120     if (S_ISREG(PL_statcache.st_mode))
3121         RETPUSHYES;
3122     RETPUSHNO;
3123 }
3124
3125 PP(pp_ftdir)
3126 {
3127     I32 result = my_stat();
3128     dSP;
3129     if (result < 0)
3130         RETPUSHUNDEF;
3131     if (S_ISDIR(PL_statcache.st_mode))
3132         RETPUSHYES;
3133     RETPUSHNO;
3134 }
3135
3136 PP(pp_ftpipe)
3137 {
3138     I32 result = my_stat();
3139     dSP;
3140     if (result < 0)
3141         RETPUSHUNDEF;
3142     if (S_ISFIFO(PL_statcache.st_mode))
3143         RETPUSHYES;
3144     RETPUSHNO;
3145 }
3146
3147 PP(pp_ftlink)
3148 {
3149     I32 result = my_lstat();
3150     dSP;
3151     if (result < 0)
3152         RETPUSHUNDEF;
3153     if (S_ISLNK(PL_statcache.st_mode))
3154         RETPUSHYES;
3155     RETPUSHNO;
3156 }
3157
3158 PP(pp_ftsuid)
3159 {
3160     dSP;
3161 #ifdef S_ISUID
3162     I32 result = my_stat();
3163     SPAGAIN;
3164     if (result < 0)
3165         RETPUSHUNDEF;
3166     if (PL_statcache.st_mode & S_ISUID)
3167         RETPUSHYES;
3168 #endif
3169     RETPUSHNO;
3170 }
3171
3172 PP(pp_ftsgid)
3173 {
3174     dSP;
3175 #ifdef S_ISGID
3176     I32 result = my_stat();
3177     SPAGAIN;
3178     if (result < 0)
3179         RETPUSHUNDEF;
3180     if (PL_statcache.st_mode & S_ISGID)
3181         RETPUSHYES;
3182 #endif
3183     RETPUSHNO;
3184 }
3185
3186 PP(pp_ftsvtx)
3187 {
3188     dSP;
3189 #ifdef S_ISVTX
3190     I32 result = my_stat();
3191     SPAGAIN;
3192     if (result < 0)
3193         RETPUSHUNDEF;
3194     if (PL_statcache.st_mode & S_ISVTX)
3195         RETPUSHYES;
3196 #endif
3197     RETPUSHNO;
3198 }
3199
3200 PP(pp_fttty)
3201 {
3202     dSP;
3203     int fd;
3204     GV *gv;
3205     char *tmps = Nullch;
3206     STRLEN n_a;
3207
3208     if (PL_op->op_flags & OPf_REF)
3209         gv = cGVOP_gv;
3210     else if (isGV(TOPs))
3211         gv = (GV*)POPs;
3212     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3213         gv = (GV*)SvRV(POPs);
3214     else
3215         gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
3216
3217     if (GvIO(gv) && IoIFP(GvIOp(gv)))
3218         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3219     else if (tmps && isDIGIT(*tmps))
3220         fd = atoi(tmps);
3221     else
3222         RETPUSHUNDEF;
3223     if (PerlLIO_isatty(fd))
3224         RETPUSHYES;
3225     RETPUSHNO;
3226 }
3227
3228 #if defined(atarist) /* this will work with atariST. Configure will
3229                         make guesses for other systems. */
3230 # define FILE_base(f) ((f)->_base)
3231 # define FILE_ptr(f) ((f)->_ptr)
3232 # define FILE_cnt(f) ((f)->_cnt)
3233 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3234 #endif
3235
3236 PP(pp_fttext)
3237 {
3238     dSP;
3239     I32 i;
3240     I32 len;
3241     I32 odd = 0;
3242     STDCHAR tbuf[512];
3243     register STDCHAR *s;
3244     register IO *io;
3245     register SV *sv;
3246     GV *gv;
3247     STRLEN n_a;
3248     PerlIO *fp;
3249
3250     if (PL_op->op_flags & OPf_REF)
3251         gv = cGVOP_gv;
3252     else if (isGV(TOPs))
3253         gv = (GV*)POPs;
3254     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3255         gv = (GV*)SvRV(POPs);
3256     else
3257         gv = Nullgv;
3258
3259     if (gv) {
3260         EXTEND(SP, 1);
3261         if (gv == PL_defgv) {
3262             if (PL_statgv)
3263                 io = GvIO(PL_statgv);
3264             else {
3265                 sv = PL_statname;
3266                 goto really_filename;
3267             }
3268         }
3269         else {
3270             PL_statgv = gv;
3271             PL_laststatval = -1;
3272             sv_setpv(PL_statname, "");
3273             io = GvIO(PL_statgv);
3274         }
3275         if (io && IoIFP(io)) {
3276             if (! PerlIO_has_base(IoIFP(io)))
3277                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3278             PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3279             if (PL_laststatval < 0)
3280                 RETPUSHUNDEF;
3281             if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3282                 if (PL_op->op_type == OP_FTTEXT)
3283                     RETPUSHNO;
3284                 else
3285                     RETPUSHYES;
3286             }
3287             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3288                 i = PerlIO_getc(IoIFP(io));
3289                 if (i != EOF)
3290                     (void)PerlIO_ungetc(IoIFP(io),i);
3291             }
3292             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3293                 RETPUSHYES;
3294             len = PerlIO_get_bufsiz(IoIFP(io));
3295             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3296             /* sfio can have large buffers - limit to 512 */
3297             if (len > 512)
3298                 len = 512;
3299         }
3300         else {
3301             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3302                 gv = cGVOP_gv;
3303                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3304             }
3305             SETERRNO(EBADF,RMS$_IFI);
3306             RETPUSHUNDEF;
3307         }
3308     }
3309     else {
3310         sv = POPs;
3311       really_filename:
3312         PL_statgv = Nullgv;
3313         PL_laststatval = -1;
3314         sv_setpv(PL_statname, SvPV(sv, n_a));
3315         if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
3316             if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
3317                 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
3318             RETPUSHUNDEF;
3319         }
3320         PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3321         if (PL_laststatval < 0) {
3322             (void)PerlIO_close(fp);
3323             RETPUSHUNDEF;
3324         }
3325         PerlIO_binmode(aTHX_ fp, '<', O_BINARY, Nullch);
3326         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3327         (void)PerlIO_close(fp);
3328         if (len <= 0) {
3329             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3330                 RETPUSHNO;              /* special case NFS directories */
3331             RETPUSHYES;         /* null file is anything */
3332         }
3333         s = tbuf;
3334     }
3335
3336     /* now scan s to look for textiness */
3337     /*   XXX ASCII dependent code */
3338
3339 #if defined(DOSISH) || defined(USEMYBINMODE)
3340     /* ignore trailing ^Z on short files */
3341     if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3342         --len;
3343 #endif
3344
3345     for (i = 0; i < len; i++, s++) {
3346         if (!*s) {                      /* null never allowed in text */
3347             odd += len;
3348             break;
3349         }
3350 #ifdef EBCDIC
3351         else if (!(isPRINT(*s) || isSPACE(*s)))
3352             odd++;
3353 #else
3354         else if (*s & 128) {
3355 #ifdef USE_LOCALE
3356             if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3357                 continue;
3358 #endif
3359             /* utf8 characters don't count as odd */
3360             if (UTF8_IS_START(*s)) {
3361                 int ulen = UTF8SKIP(s);
3362                 if (ulen < len - i) {
3363                     int j;
3364                     for (j = 1; j < ulen; j++) {
3365                         if (!UTF8_IS_CONTINUATION(s[j]))
3366                             goto not_utf8;
3367                     }
3368                     --ulen;     /* loop does extra increment */
3369                     s += ulen;
3370                     i += ulen;
3371                     continue;
3372                 }
3373             }
3374           not_utf8:
3375             odd++;
3376         }
3377         else if (*s < 32 &&
3378           *s != '\n' && *s != '\r' && *s != '\b' &&
3379           *s != '\t' && *s != '\f' && *s != 27)
3380             odd++;
3381 #endif
3382     }
3383
3384     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3385         RETPUSHNO;
3386     else
3387         RETPUSHYES;
3388 }
3389
3390 PP(pp_ftbinary)
3391 {
3392     return pp_fttext();
3393 }
3394
3395 /* File calls. */
3396
3397 PP(pp_chdir)
3398 {
3399     dSP; dTARGET;
3400     char *tmps;
3401     SV **svp;
3402     STRLEN n_a;
3403
3404     if( MAXARG == 1 )
3405         tmps = POPpx;
3406     else
3407         tmps = 0;
3408
3409     if( !tmps || !*tmps ) {
3410         if (    (svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE))
3411              || (svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE))
3412 #ifdef VMS
3413              || (svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE))
3414 #endif
3415            )
3416         {
3417             if( MAXARG == 1 )
3418                 deprecate("chdir('') or chdir(undef) as chdir()");
3419             tmps = SvPV(*svp, n_a);
3420         }
3421         else {
3422             PUSHi(0);
3423             TAINT_PROPER("chdir");
3424             RETURN;
3425         }
3426     }
3427
3428     TAINT_PROPER("chdir");
3429     PUSHi( PerlDir_chdir(tmps) >= 0 );
3430 #ifdef VMS
3431     /* Clear the DEFAULT element of ENV so we'll get the new value
3432      * in the future. */
3433     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3434 #endif
3435     RETURN;
3436 }
3437
3438 PP(pp_chown)
3439 {
3440 #ifdef HAS_CHOWN
3441     dSP; dMARK; dTARGET;
3442     I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3443
3444     SP = MARK;
3445     PUSHi(value);
3446     RETURN;
3447 #else
3448     DIE(aTHX_ PL_no_func, "chown");
3449 #endif
3450 }
3451
3452 PP(pp_chroot)
3453 {
3454 #ifdef HAS_CHROOT
3455     dSP; dTARGET;
3456     STRLEN n_a;
3457     char *tmps = POPpx;
3458     TAINT_PROPER("chroot");
3459     PUSHi( chroot(tmps) >= 0 );
3460     RETURN;
3461 #else
3462     DIE(aTHX_ PL_no_func, "chroot");
3463 #endif
3464 }
3465
3466 PP(pp_unlink)
3467 {
3468     dSP; dMARK; dTARGET;
3469     I32 value;
3470     value = (I32)apply(PL_op->op_type, MARK, SP);
3471     SP = MARK;
3472     PUSHi(value);
3473     RETURN;
3474 }
3475
3476 PP(pp_chmod)
3477 {
3478     dSP; dMARK; dTARGET;
3479     I32 value;
3480     value = (I32)apply(PL_op->op_type, MARK, SP);
3481     SP = MARK;
3482     PUSHi(value);
3483     RETURN;
3484 }
3485
3486 PP(pp_utime)
3487 {
3488     dSP; dMARK; dTARGET;
3489     I32 value;
3490     value = (I32)apply(PL_op->op_type, MARK, SP);
3491     SP = MARK;
3492     PUSHi(value);
3493     RETURN;
3494 }
3495
3496 PP(pp_rename)
3497 {
3498     dSP; dTARGET;
3499     int anum;
3500     STRLEN n_a;
3501
3502     char *tmps2 = POPpx;
3503     char *tmps = SvPV(TOPs, n_a);
3504     TAINT_PROPER("rename");
3505 #ifdef HAS_RENAME
3506     anum = PerlLIO_rename(tmps, tmps2);
3507 #else
3508     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3509         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3510             anum = 1;
3511         else {
3512             if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3513                 (void)UNLINK(tmps2);
3514             if (!(anum = link(tmps, tmps2)))
3515                 anum = UNLINK(tmps);
3516         }
3517     }
3518 #endif
3519     SETi( anum >= 0 );
3520     RETURN;
3521 }
3522
3523 PP(pp_link)
3524 {
3525 #ifdef HAS_LINK
3526     dSP; dTARGET;
3527     STRLEN n_a;
3528     char *tmps2 = POPpx;
3529     char *tmps = SvPV(TOPs, n_a);
3530     TAINT_PROPER("link");
3531     SETi( PerlLIO_link(tmps, tmps2) >= 0 );
3532     RETURN;
3533 #else
3534     DIE(aTHX_ PL_no_func, "link");
3535 #endif
3536 }
3537
3538 PP(pp_symlink)
3539 {
3540 #ifdef HAS_SYMLINK
3541     dSP; dTARGET;
3542     STRLEN n_a;
3543     char *tmps2 = POPpx;
3544     char *tmps = SvPV(TOPs, n_a);
3545     TAINT_PROPER("symlink");
3546     SETi( symlink(tmps, tmps2) >= 0 );
3547     RETURN;
3548 #else
3549     DIE(aTHX_ PL_no_func, "symlink");
3550 #endif
3551 }
3552
3553 PP(pp_readlink)
3554 {
3555     dSP;
3556 #ifdef HAS_SYMLINK
3557     dTARGET;
3558     char *tmps;
3559     char buf[MAXPATHLEN];
3560     int len;
3561     STRLEN n_a;
3562
3563 #ifndef INCOMPLETE_TAINTS
3564     TAINT;
3565 #endif
3566     tmps = POPpx;
3567     len = readlink(tmps, buf, sizeof(buf) - 1);
3568     EXTEND(SP, 1);
3569     if (len < 0)
3570         RETPUSHUNDEF;
3571     PUSHp(buf, len);
3572     RETURN;
3573 #else
3574     EXTEND(SP, 1);
3575     RETSETUNDEF;                /* just pretend it's a normal file */
3576 #endif
3577 }
3578
3579 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3580 STATIC int
3581 S_dooneliner(pTHX_ char *cmd, char *filename)
3582 {
3583     char *save_filename = filename;
3584     char *cmdline;
3585     char *s;
3586     PerlIO *myfp;
3587     int anum = 1;
3588
3589     New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3590     strcpy(cmdline, cmd);
3591     strcat(cmdline, " ");
3592     for (s = cmdline + strlen(cmdline); *filename; ) {
3593         *s++ = '\\';
3594         *s++ = *filename++;
3595     }
3596     strcpy(s, " 2>&1");
3597     myfp = PerlProc_popen(cmdline, "r");
3598     Safefree(cmdline);
3599
3600     if (myfp) {
3601         SV *tmpsv = sv_newmortal();
3602         /* Need to save/restore 'PL_rs' ?? */
3603         s = sv_gets(tmpsv, myfp, 0);
3604         (void)PerlProc_pclose(myfp);
3605         if (s != Nullch) {
3606             int e;
3607             for (e = 1;
3608 #ifdef HAS_SYS_ERRLIST
3609                  e <= sys_nerr
3610 #endif
3611                  ; e++)
3612             {
3613                 /* you don't see this */
3614                 char *errmsg =
3615 #ifdef HAS_SYS_ERRLIST
3616                     sys_errlist[e]
3617 #else
3618                     strerror(e)
3619 #endif
3620                     ;
3621                 if (!errmsg)
3622                     break;
3623                 if (instr(s, errmsg)) {
3624                     SETERRNO(e,0);
3625                     return 0;
3626                 }
3627             }
3628             SETERRNO(0,0);
3629 #ifndef EACCES
3630 #define EACCES EPERM
3631 #endif
3632             if (instr(s, "cannot make"))
3633                 SETERRNO(EEXIST,RMS$_FEX);
3634             else if (instr(s, "existing file"))
3635                 SETERRNO(EEXIST,RMS$_FEX);
3636             else if (instr(s, "ile exists"))
3637                 SETERRNO(EEXIST,RMS$_FEX);
3638             else if (instr(s, "non-exist"))
3639                 SETERRNO(ENOENT,RMS$_FNF);
3640             else if (instr(s, "does not exist"))
3641                 SETERRNO(ENOENT,RMS$_FNF);
3642             else if (instr(s, "not empty"))
3643                 SETERRNO(EBUSY,SS$_DEVOFFLINE);
3644             else if (instr(s, "cannot access"))
3645                 SETERRNO(EACCES,RMS$_PRV);
3646             else
3647                 SETERRNO(EPERM,RMS$_PRV);
3648             return 0;
3649         }
3650         else {  /* some mkdirs return no failure indication */
3651             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3652             if (PL_op->op_type == OP_RMDIR)
3653                 anum = !anum;
3654             if (anum)
3655                 SETERRNO(0,0);
3656             else
3657                 SETERRNO(EACCES,RMS$_PRV);      /* a guess */
3658         }
3659         return anum;
3660     }
3661     else
3662         return 0;
3663 }
3664 #endif
3665
3666 PP(pp_mkdir)
3667 {
3668     dSP; dTARGET;
3669     int mode;
3670 #ifndef HAS_MKDIR
3671     int oldumask;
3672 #endif
3673     STRLEN len;
3674     char *tmps;
3675     bool copy = FALSE;
3676
3677     if (MAXARG > 1)
3678         mode = POPi;
3679     else
3680         mode = 0777;
3681
3682     tmps = SvPV(TOPs, len);
3683     /* Different operating and file systems take differently to
3684      * trailing slashes.  According to POSIX 1003.1 1996 Edition
3685      * any number of trailing slashes should be allowed.
3686      * Thusly we snip them away so that even non-conforming
3687      * systems are happy. */
3688     /* We should probably do this "filtering" for all
3689      * the functions that expect (potentially) directory names:
3690      * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3691      * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3692     if (len > 1 && tmps[len-1] == '/') {
3693         while (tmps[len] == '/' && len > 1)
3694             len--;
3695         tmps = savepvn(tmps, len);
3696         copy = TRUE;
3697     }
3698
3699     TAINT_PROPER("mkdir");
3700 #ifdef HAS_MKDIR
3701     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3702 #else
3703     SETi( dooneliner("mkdir", tmps) );
3704     oldumask = PerlLIO_umask(0);
3705     PerlLIO_umask(oldumask);
3706     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3707 #endif
3708     if (copy)
3709         Safefree(tmps);
3710     RETURN;
3711 }
3712
3713 PP(pp_rmdir)
3714 {
3715     dSP; dTARGET;
3716     char *tmps;
3717     STRLEN n_a;
3718
3719     tmps = POPpx;
3720     TAINT_PROPER("rmdir");
3721 #ifdef HAS_RMDIR
3722     XPUSHi( PerlDir_rmdir(tmps) >= 0 );
3723 #else
3724     XPUSHi( dooneliner("rmdir", tmps) );
3725 #endif
3726     RETURN;
3727 }
3728
3729 /* Directory calls. */
3730
3731 PP(pp_open_dir)
3732 {
3733 #if defined(Direntry_t) && defined(HAS_READDIR)
3734     dSP;
3735     STRLEN n_a;
3736     char *dirname = POPpx;
3737     GV *gv = (GV*)POPs;
3738     register IO *io = GvIOn(gv);
3739
3740     if (!io)
3741         goto nope;
3742
3743     if (IoDIRP(io))
3744         PerlDir_close(IoDIRP(io));
3745     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3746         goto nope;
3747
3748     RETPUSHYES;
3749 nope:
3750     if (!errno)
3751         SETERRNO(EBADF,RMS$_DIR);
3752     RETPUSHUNDEF;
3753 #else
3754     DIE(aTHX_ PL_no_dir_func, "opendir");
3755 #endif
3756 }
3757
3758 PP(pp_readdir)
3759 {
3760 #if defined(Direntry_t) && defined(HAS_READDIR)
3761     dSP;
3762 #if !defined(I_DIRENT) && !defined(VMS)
3763     Direntry_t *readdir (DIR *);
3764 #endif
3765     register Direntry_t *dp;
3766     GV *gv = (GV*)POPs;
3767     register IO *io = GvIOn(gv);
3768     SV *sv;
3769
3770     if (!io || !IoDIRP(io))
3771         goto nope;
3772
3773     if (GIMME == G_ARRAY) {
3774         /*SUPPRESS 560*/
3775         while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
3776 #ifdef DIRNAMLEN
3777             sv = newSVpvn(dp->d_name, dp->d_namlen);
3778 #else
3779             sv = newSVpv(dp->d_name, 0);
3780 #endif
3781 #ifndef INCOMPLETE_TAINTS
3782             if (!(IoFLAGS(io) & IOf_UNTAINT))
3783                 SvTAINTED_on(sv);
3784 #endif
3785             XPUSHs(sv_2mortal(sv));
3786         }
3787     }
3788     else {
3789         if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
3790             goto nope;
3791 #ifdef DIRNAMLEN
3792         sv = newSVpvn(dp->d_name, dp->d_namlen);
3793 #else
3794         sv = newSVpv(dp->d_name, 0);
3795 #endif
3796 #ifndef INCOMPLETE_TAINTS
3797         if (!(IoFLAGS(io) & IOf_UNTAINT))
3798             SvTAINTED_on(sv);
3799 #endif
3800         XPUSHs(sv_2mortal(sv));
3801     }
3802     RETURN;
3803
3804 nope:
3805     if (!errno)
3806         SETERRNO(EBADF,RMS$_ISI);
3807     if (GIMME == G_ARRAY)
3808         RETURN;
3809     else
3810         RETPUSHUNDEF;
3811 #else
3812     DIE(aTHX_ PL_no_dir_func, "readdir");
3813 #endif
3814 }
3815
3816 PP(pp_telldir)
3817 {
3818 #if defined(HAS_TELLDIR) || defined(telldir)
3819     dSP; dTARGET;
3820  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3821  /* XXX netbsd still seemed to.
3822     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3823     --JHI 1999-Feb-02 */
3824 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3825     long telldir (DIR *);
3826 # endif
3827     GV *gv = (GV*)POPs;
3828     register IO *io = GvIOn(gv);
3829
3830     if (!io || !IoDIRP(io))
3831         goto nope;
3832
3833     PUSHi( PerlDir_tell(IoDIRP(io)) );
3834     RETURN;
3835 nope:
3836     if (!errno)
3837         SETERRNO(EBADF,RMS$_ISI);
3838     RETPUSHUNDEF;
3839 #else
3840     DIE(aTHX_ PL_no_dir_func, "telldir");
3841 #endif
3842 }
3843
3844 PP(pp_seekdir)
3845 {
3846 #if defined(HAS_SEEKDIR) || defined(seekdir)
3847     dSP;
3848     long along = POPl;
3849     GV *gv = (GV*)POPs;
3850     register IO *io = GvIOn(gv);
3851
3852     if (!io || !IoDIRP(io))
3853         goto nope;
3854
3855     (void)PerlDir_seek(IoDIRP(io), along);
3856
3857     RETPUSHYES;
3858 nope:
3859     if (!errno)
3860         SETERRNO(EBADF,RMS$_ISI);
3861     RETPUSHUNDEF;
3862 #else
3863     DIE(aTHX_ PL_no_dir_func, "seekdir");
3864 #endif
3865 }
3866
3867 PP(pp_rewinddir)
3868 {
3869 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3870     dSP;
3871     GV *gv = (GV*)POPs;
3872     register IO *io = GvIOn(gv);
3873
3874     if (!io || !IoDIRP(io))
3875         goto nope;
3876
3877     (void)PerlDir_rewind(IoDIRP(io));
3878     RETPUSHYES;
3879 nope:
3880     if (!errno)
3881         SETERRNO(EBADF,RMS$_ISI);
3882     RETPUSHUNDEF;
3883 #else
3884     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3885 #endif
3886 }
3887
3888 PP(pp_closedir)
3889 {
3890 #if defined(Direntry_t) && defined(HAS_READDIR)
3891     dSP;
3892     GV *gv = (GV*)POPs;
3893     register IO *io = GvIOn(gv);
3894
3895     if (!io || !IoDIRP(io))
3896         goto nope;
3897
3898 #ifdef VOID_CLOSEDIR
3899     PerlDir_close(IoDIRP(io));
3900 #else
3901     if (PerlDir_close(IoDIRP(io)) < 0) {
3902         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3903         goto nope;
3904     }
3905 #endif
3906     IoDIRP(io) = 0;
3907
3908     RETPUSHYES;
3909 nope:
3910     if (!errno)
3911         SETERRNO(EBADF,RMS$_IFI);
3912     RETPUSHUNDEF;
3913 #else
3914     DIE(aTHX_ PL_no_dir_func, "closedir");
3915 #endif
3916 }
3917
3918 /* Process control. */
3919
3920 PP(pp_fork)
3921 {
3922 #ifdef HAS_FORK
3923     dSP; dTARGET;
3924     Pid_t childpid;
3925     GV *tmpgv;
3926
3927     EXTEND(SP, 1);
3928     PERL_FLUSHALL_FOR_CHILD;
3929     childpid = PerlProc_fork();
3930     if (childpid < 0)
3931         RETSETUNDEF;
3932     if (!childpid) {
3933         /*SUPPRESS 560*/
3934         if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV))) {
3935             SvREADONLY_off(GvSV(tmpgv));
3936             sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3937             SvREADONLY_on(GvSV(tmpgv));
3938         }
3939         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3940     }
3941     PUSHi(childpid);
3942     RETURN;
3943 #else
3944 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3945     dSP; dTARGET;
3946     Pid_t childpid;
3947
3948     EXTEND(SP, 1);
3949     PERL_FLUSHALL_FOR_CHILD;
3950     childpid = PerlProc_fork();
3951     if (childpid == -1)
3952         RETSETUNDEF;
3953     PUSHi(childpid);
3954     RETURN;
3955 #  else
3956     DIE(aTHX_ PL_no_func, "fork");
3957 #  endif
3958 #endif
3959 }
3960
3961 PP(pp_wait)
3962 {
3963 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3964     dSP; dTARGET;
3965     Pid_t childpid;
3966     int argflags;
3967
3968 #ifdef PERL_OLD_SIGNALS
3969     childpid = wait4pid(-1, &argflags, 0);
3970 #else
3971     while ((childpid = wait4pid(-1, &argflags, 0)) == -1 && errno == EINTR) {
3972         PERL_ASYNC_CHECK();
3973     }
3974 #endif
3975 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3976     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3977     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3978 #  else
3979     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3980 #  endif
3981     XPUSHi(childpid);
3982     RETURN;
3983 #else
3984     DIE(aTHX_ PL_no_func, "wait");
3985 #endif
3986 }
3987
3988 PP(pp_waitpid)
3989 {
3990 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3991     dSP; dTARGET;
3992     Pid_t childpid;
3993     int optype;
3994     int argflags;
3995
3996     optype = POPi;
3997     childpid = TOPi;
3998 #ifdef PERL_OLD_SIGNALS
3999     childpid = wait4pid(childpid, &argflags, optype);
4000 #else
4001     while ((childpid = wait4pid(childpid, &argflags, optype)) == -1 && errno == EINTR) {
4002         PERL_ASYNC_CHECK();
4003     }
4004 #endif
4005 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4006     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4007     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
4008 #  else
4009     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
4010 #  endif
4011     SETi(childpid);
4012     RETURN;
4013 #else
4014     DIE(aTHX_ PL_no_func, "waitpid");
4015 #endif
4016 }
4017
4018 PP(pp_system)
4019 {
4020     dSP; dMARK; dORIGMARK; dTARGET;
4021     I32 value;
4022     STRLEN n_a;
4023     int result;
4024     int pp[2];
4025     I32 did_pipes = 0;
4026
4027     if (SP - MARK == 1) {
4028         if (PL_tainting) {
4029             (void)SvPV_nolen(TOPs);      /* stringify for taint check */
4030             TAINT_ENV();
4031             TAINT_PROPER("system");
4032         }
4033     }
4034     PERL_FLUSHALL_FOR_CHILD;
4035 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4036     {
4037          Pid_t childpid;
4038          int status;
4039          Sigsave_t ihand,qhand;     /* place to save signals during system() */
4040
4041          if (PL_tainting) {
4042              SV *cmd = NULL;
4043              if (PL_op->op_flags & OPf_STACKED)
4044                 cmd = *(MARK + 1);
4045              else if (SP - MARK != 1)
4046                 cmd = *SP;
4047              if (cmd && *(SvPV_nolen(cmd)) != '/')
4048                 TAINT_ENV();
4049          }
4050
4051          if (PerlProc_pipe(pp) >= 0)
4052               did_pipes = 1;
4053          while ((childpid = PerlProc_fork()) == -1) {
4054               if (errno != EAGAIN) {
4055                    value = -1;
4056                    SP = ORIGMARK;
4057                    PUSHi(value);
4058                    if (did_pipes) {
4059                         PerlLIO_close(pp[0]);
4060                         PerlLIO_close(pp[1]);
4061                    }
4062                    RETURN;
4063               }
4064               sleep(5);
4065          }
4066          if (childpid > 0) {
4067               if (did_pipes)
4068                    PerlLIO_close(pp[1]);
4069 #ifndef PERL_MICRO
4070               rsignal_save(SIGINT, SIG_IGN, &ihand);
4071               rsignal_save(SIGQUIT, SIG_IGN, &qhand);
4072 #endif
4073               do {
4074                    result = wait4pid(childpid, &status, 0);
4075               } while (result == -1 && errno == EINTR);
4076 #ifndef PERL_MICRO
4077               (void)rsignal_restore(SIGINT, &ihand);
4078               (void)rsignal_restore(SIGQUIT, &qhand);
4079 #endif
4080               STATUS_NATIVE_SET(result == -1 ? -1 : status);
4081               do_execfree();    /* free any memory child malloced on fork */
4082               SP = ORIGMARK;
4083               if (did_pipes) {
4084                    int errkid;
4085                    int n = 0, n1;
4086
4087                    while (n < sizeof(int)) {
4088                         n1 = PerlLIO_read(pp[0],
4089                                           (void*)(((char*)&errkid)+n),
4090                                           (sizeof(int)) - n);
4091                         if (n1 <= 0)
4092                              break;
4093                         n += n1;
4094                    }
4095                    PerlLIO_close(pp[0]);
4096                    if (n) {                     /* Error */
4097                         if (n != sizeof(int))
4098                              DIE(aTHX_ "panic: kid popen errno read");
4099                         errno = errkid;         /* Propagate errno from kid */
4100                         STATUS_CURRENT = -1;
4101                    }
4102               }
4103               PUSHi(STATUS_CURRENT);
4104               RETURN;
4105          }
4106          if (did_pipes) {
4107               PerlLIO_close(pp[0]);
4108 #if defined(HAS_FCNTL) && defined(F_SETFD)
4109               fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4110 #endif
4111          }
4112     }
4113     if (PL_op->op_flags & OPf_STACKED) {
4114         SV *really = *++MARK;
4115         value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4116     }
4117     else if (SP - MARK != 1)
4118         value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
4119     else {
4120         value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
4121     }
4122     PerlProc__exit(-1);
4123 #else /* ! FORK or VMS or OS/2 */
4124     PL_statusvalue = 0;
4125     result = 0;
4126     if (PL_op->op_flags & OPf_STACKED) {
4127         SV *really = *++MARK;
4128         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4129     }
4130     else if (SP - MARK != 1)
4131         value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
4132     else {
4133         value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
4134     }
4135     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4136         result = 1;
4137     STATUS_NATIVE_SET(value);
4138     do_execfree();
4139     SP = ORIGMARK;
4140     PUSHi(result ? value : STATUS_CURRENT);
4141 #endif /* !FORK or VMS */
4142     RETURN;
4143 }
4144
4145 PP(pp_exec)
4146 {
4147     dSP; dMARK; dORIGMARK; dTARGET;
4148     I32 value;
4149     STRLEN n_a;
4150
4151     PERL_FLUSHALL_FOR_CHILD;
4152     if (PL_op->op_flags & OPf_STACKED) {
4153         SV *really = *++MARK;
4154         value = (I32)do_aexec(really, MARK, SP);
4155     }
4156     else if (SP - MARK != 1)
4157 #ifdef VMS
4158         value = (I32)vms_do_aexec(Nullsv, MARK, SP);
4159 #else
4160 #  ifdef __OPEN_VM
4161         {
4162            (void ) do_aspawn(Nullsv, MARK, SP);
4163            value = 0;
4164         }
4165 #  else
4166         value = (I32)do_aexec(Nullsv, MARK, SP);
4167 #  endif
4168 #endif
4169     else {
4170         if (PL_tainting) {
4171             (void)SvPV_nolen(*SP);      /* stringify for taint check */
4172             TAINT_ENV();
4173             TAINT_PROPER("exec");
4174         }
4175 #ifdef VMS
4176         value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
4177 #else
4178 #  ifdef __OPEN_VM
4179         (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
4180         value = 0;
4181 #  else
4182         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
4183 #  endif
4184 #endif
4185     }
4186
4187     SP = ORIGMARK;
4188     PUSHi(value);
4189     RETURN;
4190 }
4191
4192 PP(pp_kill)
4193 {
4194 #ifdef HAS_KILL
4195     dSP; dMARK; dTARGET;
4196     I32 value;
4197     value = (I32)apply(PL_op->op_type, MARK, SP);
4198     SP = MARK;
4199     PUSHi(value);
4200     RETURN;
4201 #else
4202     DIE(aTHX_ PL_no_func, "kill");
4203 #endif
4204 }
4205
4206 PP(pp_getppid)
4207 {
4208 #ifdef HAS_GETPPID
4209     dSP; dTARGET;
4210     XPUSHi( getppid() );
4211     RETURN;
4212 #else
4213     DIE(aTHX_ PL_no_func, "getppid");
4214 #endif
4215 }
4216
4217 PP(pp_getpgrp)
4218 {
4219 #ifdef HAS_GETPGRP
4220     dSP; dTARGET;
4221     Pid_t pid;
4222     Pid_t pgrp;
4223
4224     if (MAXARG < 1)
4225         pid = 0;
4226     else
4227         pid = SvIVx(POPs);
4228 #ifdef BSD_GETPGRP
4229     pgrp = (I32)BSD_GETPGRP(pid);
4230 #else
4231     if (pid != 0 && pid != PerlProc_getpid())
4232         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4233     pgrp = getpgrp();
4234 #endif
4235     XPUSHi(pgrp);
4236     RETURN;
4237 #else
4238     DIE(aTHX_ PL_no_func, "getpgrp()");
4239 #endif
4240 }
4241
4242 PP(pp_setpgrp)
4243 {
4244 #ifdef HAS_SETPGRP
4245     dSP; dTARGET;
4246     Pid_t pgrp;
4247     Pid_t pid;
4248     if (MAXARG < 2) {
4249         pgrp = 0;
4250         pid = 0;
4251     }
4252     else {
4253         pgrp = POPi;
4254         pid = TOPi;
4255     }
4256
4257     TAINT_PROPER("setpgrp");
4258 #ifdef BSD_SETPGRP
4259     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4260 #else
4261     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4262         || (pid != 0 && pid != PerlProc_getpid()))
4263     {
4264         DIE(aTHX_ "setpgrp can't take arguments");
4265     }
4266     SETi( setpgrp() >= 0 );
4267 #endif /* USE_BSDPGRP */
4268     RETURN;
4269 #else
4270     DIE(aTHX_ PL_no_func, "setpgrp()");
4271 #endif
4272 }
4273
4274 PP(pp_getpriority)
4275 {
4276 #ifdef HAS_GETPRIORITY
4277     dSP; dTARGET;
4278     int who = POPi;
4279     int which = TOPi;
4280     SETi( getpriority(which, who) );
4281     RETURN;
4282 #else
4283     DIE(aTHX_ PL_no_func, "getpriority()");
4284 #endif
4285 }
4286
4287 PP(pp_setpriority)
4288 {
4289 #ifdef HAS_SETPRIORITY
4290     dSP; dTARGET;
4291     int niceval = POPi;
4292     int who = POPi;
4293     int which = TOPi;
4294     TAINT_PROPER("setpriority");
4295     SETi( setpriority(which, who, niceval) >= 0 );
4296     RETURN;
4297 #else
4298     DIE(aTHX_ PL_no_func, "setpriority()");
4299 #endif
4300 }
4301
4302 /* Time calls. */
4303
4304 PP(pp_time)
4305 {
4306     dSP; dTARGET;
4307 #ifdef BIG_TIME
4308     XPUSHn( time(Null(Time_t*)) );
4309 #else
4310     XPUSHi( time(Null(Time_t*)) );
4311 #endif
4312     RETURN;
4313 }
4314
4315 /* XXX The POSIX name is CLK_TCK; it is to be preferred
4316    to HZ.  Probably.  For now, assume that if the system
4317    defines HZ, it does so correctly.  (Will this break
4318    on VMS?)
4319    Probably we ought to use _sysconf(_SC_CLK_TCK), if
4320    it's supported.    --AD  9/96.
4321 */
4322
4323 #ifdef __BEOS__
4324 #  define HZ 1000000
4325 #endif
4326
4327 #ifndef HZ
4328 #  ifdef CLK_TCK
4329 #    define HZ CLK_TCK
4330 #  else
4331 #    define HZ 60
4332 #  endif
4333 #endif
4334
4335 PP(pp_tms)
4336 {
4337 #ifdef HAS_TIMES
4338     dSP;
4339     EXTEND(SP, 4);
4340 #ifndef VMS
4341     (void)PerlProc_times(&PL_timesbuf);
4342 #else
4343     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4344                                                    /* struct tms, though same data   */
4345                                                    /* is returned.                   */
4346 #endif
4347
4348     PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
4349     if (GIMME == G_ARRAY) {
4350         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4351         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4352         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
4353     }
4354     RETURN;
4355 #else
4356     DIE(aTHX_ "times not implemented");
4357 #endif /* HAS_TIMES */
4358 }
4359
4360 PP(pp_localtime)
4361 {
4362     return pp_gmtime();
4363 }
4364
4365 PP(pp_gmtime)
4366 {
4367     dSP;
4368     Time_t when;
4369     struct tm *tmbuf;
4370     static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4371     static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4372                               "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4373
4374     if (MAXARG < 1)
4375         (void)time(&when);
4376     else
4377 #ifdef BIG_TIME
4378         when = (Time_t)SvNVx(POPs);
4379 #else
4380         when = (Time_t)SvIVx(POPs);
4381 #endif
4382
4383     if (PL_op->op_type == OP_LOCALTIME)
4384         tmbuf = localtime(&when);
4385     else
4386         tmbuf = gmtime(&when);
4387
4388     if (GIMME != G_ARRAY) {
4389         SV *tsv;
4390         EXTEND(SP, 1);
4391         EXTEND_MORTAL(1);
4392         if (!tmbuf)
4393             RETPUSHUNDEF;
4394         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4395                             dayname[tmbuf->tm_wday],
4396                             monname[tmbuf->tm_mon],
4397                             tmbuf->tm_mday,
4398                             tmbuf->tm_hour,
4399                             tmbuf->tm_min,
4400                             tmbuf->tm_sec,
4401                             tmbuf->tm_year + 1900);
4402         PUSHs(sv_2mortal(tsv));
4403     }
4404     else if (tmbuf) {
4405         EXTEND(SP, 9);
4406         EXTEND_MORTAL(9);
4407         PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4408         PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4409         PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4410         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4411         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4412         PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4413         PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4414         PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4415         PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4416     }
4417     RETURN;
4418 }
4419
4420 PP(pp_alarm)
4421 {
4422 #ifdef HAS_ALARM
4423     dSP; dTARGET;
4424     int anum;
4425     anum = POPi;
4426     anum = alarm((unsigned int)anum);
4427     EXTEND(SP, 1);
4428     if (anum < 0)
4429         RETPUSHUNDEF;
4430     PUSHi(anum);
4431     RETURN;
4432 #else
4433     DIE(aTHX_ PL_no_func, "alarm");
4434 #endif
4435 }
4436
4437 PP(pp_sleep)
4438 {
4439     dSP; dTARGET;
4440     I32 duration;
4441     Time_t lasttime;
4442     Time_t when;
4443
4444     (void)time(&lasttime);
4445     if (MAXARG < 1)
4446         PerlProc_pause();
4447     else {
4448         duration = POPi;
4449         PerlProc_sleep((unsigned int)duration);
4450     }
4451     (void)time(&when);
4452     XPUSHi(when - lasttime);
4453     RETURN;
4454 }
4455
4456 /* Shared memory. */
4457
4458 PP(pp_shmget)
4459 {
4460     return pp_semget();
4461 }
4462
4463 PP(pp_shmctl)
4464 {
4465     return pp_semctl();
4466 }
4467
4468 PP(pp_shmread)
4469 {
4470     return pp_shmwrite();
4471 }
4472
4473 PP(pp_shmwrite)
4474 {
4475 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4476     dSP; dMARK; dTARGET;
4477     I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
4478     SP = MARK;
4479     PUSHi(value);
4480     RETURN;
4481 #else
4482     return pp_semget();
4483 #endif
4484 }
4485
4486 /* Message passing. */
4487
4488 PP(pp_msgget)
4489 {
4490     return pp_semget();
4491 }
4492
4493 PP(pp_msgctl)
4494 {
4495     return pp_semctl();
4496 }
4497
4498 PP(pp_msgsnd)
4499 {
4500 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4501     dSP; dMARK; dTARGET;
4502     I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4503     SP = MARK;
4504     PUSHi(value);
4505     RETURN;
4506 #else
4507     return pp_semget();
4508 #endif
4509 }
4510
4511 PP(pp_msgrcv)
4512 {
4513 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4514     dSP; dMARK; dTARGET;
4515     I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4516     SP = MARK;
4517     PUSHi(value);
4518     RETURN;
4519 #else
4520     return pp_semget();
4521 #endif
4522 }
4523
4524 /* Semaphores. */
4525
4526 PP(pp_semget)
4527 {
4528 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4529     dSP; dMARK; dTARGET;
4530     int anum = do_ipcget(PL_op->op_type, MARK, SP);
4531     SP = MARK;
4532     if (anum == -1)
4533         RETPUSHUNDEF;
4534     PUSHi(anum);
4535     RETURN;
4536 #else
4537     DIE(aTHX_ "System V IPC is not implemented on this machine");
4538 #endif
4539 }
4540
4541 PP(pp_semctl)
4542 {
4543 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4544     dSP; dMARK; dTARGET;
4545     int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4546     SP = MARK;
4547     if (anum == -1)
4548         RETSETUNDEF;
4549     if (anum != 0) {
4550         PUSHi(anum);
4551     }
4552     else {
4553         PUSHp(zero_but_true, ZBTLEN);
4554     }
4555     RETURN;
4556 #else
4557     return pp_semget();
4558 #endif
4559 }
4560
4561 PP(pp_semop)
4562 {
4563 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4564     dSP; dMARK; dTARGET;
4565     I32 value = (I32)(do_semop(MARK, SP) >= 0);
4566     SP = MARK;
4567     PUSHi(value);
4568     RETURN;
4569 #else
4570     return pp_semget();
4571 #endif
4572 }
4573
4574 /* Get system info. */
4575
4576 PP(pp_ghbyname)
4577 {
4578 #ifdef HAS_GETHOSTBYNAME
4579     return pp_ghostent();
4580 #else
4581     DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4582 #endif
4583 }
4584
4585 PP(pp_ghbyaddr)
4586 {
4587 #ifdef HAS_GETHOSTBYADDR
4588     return pp_ghostent();
4589 #else
4590     DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4591 #endif
4592 }
4593
4594 PP(pp_ghostent)
4595 {
4596 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4597     dSP;
4598     I32 which = PL_op->op_type;
4599     register char **elem;
4600     register SV *sv;
4601 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4602     struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4603     struct hostent *PerlSock_gethostbyname(Netdb_name_t);
4604     struct hostent *PerlSock_gethostent(void);
4605 #endif
4606     struct hostent *hent;
4607     unsigned long len;
4608     STRLEN n_a;
4609
4610     EXTEND(SP, 10);
4611     if (which == OP_GHBYNAME)
4612 #ifdef HAS_GETHOSTBYNAME
4613         hent = PerlSock_gethostbyname(POPpbytex);
4614 #else
4615         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4616 #endif
4617     else if (which == OP_GHBYADDR) {
4618 #ifdef HAS_GETHOSTBYADDR
4619         int addrtype = POPi;
4620         SV *addrsv = POPs;
4621         STRLEN addrlen;
4622         Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
4623
4624         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4625 #else
4626         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4627 #endif
4628     }
4629     else
4630 #ifdef HAS_GETHOSTENT
4631         hent = PerlSock_gethostent();
4632 #else
4633         DIE(aTHX_ PL_no_sock_func, "gethostent");
4634 #endif
4635
4636 #ifdef HOST_NOT_FOUND
4637     if (!hent)
4638         STATUS_NATIVE_SET(h_errno);
4639 #endif
4640
4641     if (GIMME != G_ARRAY) {
4642         PUSHs(sv = sv_newmortal());
4643         if (hent) {
4644             if (which == OP_GHBYNAME) {
4645                 if (hent->h_addr)
4646                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4647             }
4648             else
4649                 sv_setpv(sv, (char*)hent->h_name);
4650         }
4651         RETURN;
4652     }
4653
4654     if (hent) {
4655         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4656         sv_setpv(sv, (char*)hent->h_name);
4657         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4658         for (elem = hent->h_aliases; elem && *elem; elem++) {
4659             sv_catpv(sv, *elem);
4660             if (elem[1])
4661                 sv_catpvn(sv, " ", 1);
4662         }
4663         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4664         sv_setiv(sv, (IV)hent->h_addrtype);
4665         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4666         len = hent->h_length;
4667         sv_setiv(sv, (IV)len);
4668 #ifdef h_addr
4669         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4670             XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
4671             sv_setpvn(sv, *elem, len);
4672         }
4673 #else
4674         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4675         if (hent->h_addr)
4676             sv_setpvn(sv, hent->h_addr, len);
4677 #endif /* h_addr */
4678     }
4679     RETURN;
4680 #else
4681     DIE(aTHX_ PL_no_sock_func, "gethostent");
4682 #endif
4683 }
4684
4685 PP(pp_gnbyname)
4686 {
4687 #ifdef HAS_GETNETBYNAME
4688     return pp_gnetent();
4689 #else
4690     DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4691 #endif
4692 }
4693
4694 PP(pp_gnbyaddr)
4695 {
4696 #ifdef HAS_GETNETBYADDR
4697     return pp_gnetent();
4698 #else
4699     DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4700 #endif
4701 }
4702
4703 PP(pp_gnetent)
4704 {
4705 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4706     dSP;
4707     I32 which = PL_op->op_type;
4708     register char **elem;
4709     register SV *sv;
4710 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4711     struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4712     struct netent *PerlSock_getnetbyname(Netdb_name_t);
4713     struct netent *PerlSock_getnetent(void);
4714 #endif
4715     struct netent *nent;
4716     STRLEN n_a;
4717
4718     if (which == OP_GNBYNAME)
4719 #ifdef HAS_GETNETBYNAME
4720         nent = PerlSock_getnetbyname(POPpbytex);
4721 #else
4722         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4723 #endif
4724     else if (which == OP_GNBYADDR) {
4725 #ifdef HAS_GETNETBYADDR
4726         int addrtype = POPi;
4727         Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4728         nent = PerlSock_getnetbyaddr(addr, addrtype);
4729 #else
4730         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4731 #endif
4732     }
4733     else
4734 #ifdef HAS_GETNETENT
4735         nent = PerlSock_getnetent();
4736 #else
4737         DIE(aTHX_ PL_no_sock_func, "getnetent");
4738 #endif
4739
4740     EXTEND(SP, 4);
4741     if (GIMME != G_ARRAY) {
4742         PUSHs(sv = sv_newmortal());
4743         if (nent) {
4744             if (which == OP_GNBYNAME)
4745                 sv_setiv(sv, (IV)nent->n_net);
4746             else
4747                 sv_setpv(sv, nent->n_name);
4748         }
4749         RETURN;
4750     }
4751
4752     if (nent) {
4753         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4754         sv_setpv(sv, nent->n_name);
4755         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4756         for (elem = nent->n_aliases; elem && *elem; elem++) {
4757             sv_catpv(sv, *elem);
4758             if (elem[1])
4759                 sv_catpvn(sv, " ", 1);
4760         }
4761         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4762         sv_setiv(sv, (IV)nent->n_addrtype);
4763         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4764         sv_setiv(sv, (IV)nent->n_net);
4765     }
4766
4767     RETURN;
4768 #else
4769     DIE(aTHX_ PL_no_sock_func, "getnetent");
4770 #endif
4771 }
4772
4773 PP(pp_gpbyname)
4774 {
4775 #ifdef HAS_GETPROTOBYNAME
4776     return pp_gprotoent();
4777 #else
4778     DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4779 #endif
4780 }
4781
4782 PP(pp_gpbynumber)
4783 {
4784 #ifdef HAS_GETPROTOBYNUMBER
4785     return pp_gprotoent();
4786 #else
4787     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4788 #endif
4789 }
4790
4791 PP(pp_gprotoent)
4792 {
4793 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4794     dSP;
4795     I32 which = PL_op->op_type;
4796     register char **elem;
4797     register SV *sv;
4798 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4799     struct protoent *PerlSock_getprotobyname(Netdb_name_t);
4800     struct protoent *PerlSock_getprotobynumber(int);
4801     struct protoent *PerlSock_getprotoent(void);
4802 #endif
4803     struct protoent *pent;
4804     STRLEN n_a;
4805
4806     if (which == OP_GPBYNAME)
4807 #ifdef HAS_GETPROTOBYNAME
4808         pent = PerlSock_getprotobyname(POPpbytex);
4809 #else
4810         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4811 #endif
4812     else if (which == OP_GPBYNUMBER)
4813 #ifdef HAS_GETPROTOBYNUMBER
4814         pent = PerlSock_getprotobynumber(POPi);
4815 #else
4816     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4817 #endif
4818     else
4819 #ifdef HAS_GETPROTOENT
4820         pent = PerlSock_getprotoent();
4821 #else
4822         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4823 #endif
4824
4825     EXTEND(SP, 3);
4826     if (GIMME != G_ARRAY) {
4827         PUSHs(sv = sv_newmortal());
4828         if (pent) {
4829             if (which == OP_GPBYNAME)
4830                 sv_setiv(sv, (IV)pent->p_proto);
4831             else
4832                 sv_setpv(sv, pent->p_name);
4833         }
4834         RETURN;
4835     }
4836
4837     if (pent) {
4838         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4839         sv_setpv(sv, pent->p_name);
4840         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4841         for (elem = pent->p_aliases; elem && *elem; elem++) {
4842             sv_catpv(sv, *elem);
4843             if (elem[1])
4844                 sv_catpvn(sv, " ", 1);
4845         }
4846         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4847         sv_setiv(sv, (IV)pent->p_proto);
4848     }
4849
4850     RETURN;
4851 #else
4852     DIE(aTHX_ PL_no_sock_func, "getprotoent");
4853 #endif
4854 }
4855
4856 PP(pp_gsbyname)
4857 {
4858 #ifdef HAS_GETSERVBYNAME
4859     return pp_gservent();
4860 #else
4861     DIE(aTHX_ PL_no_sock_func, "getservbyname");
4862 #endif
4863 }
4864
4865 PP(pp_gsbyport)
4866 {
4867 #ifdef HAS_GETSERVBYPORT
4868     return pp_gservent();
4869 #else
4870     DIE(aTHX_ PL_no_sock_func, "getservbyport");
4871 #endif
4872 }
4873
4874 PP(pp_gservent)
4875 {
4876 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4877     dSP;
4878     I32 which = PL_op->op_type;
4879     register char **elem;
4880     register SV *sv;
4881 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4882     struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4883     struct servent *PerlSock_getservbyport(int, Netdb_name_t);
4884     struct servent *PerlSock_getservent(void);
4885 #endif
4886     struct servent *sent;
4887     STRLEN n_a;
4888
4889     if (which == OP_GSBYNAME) {
4890 #ifdef HAS_GETSERVBYNAME
4891         char *proto = POPpbytex;
4892         char *name = POPpbytex;
4893
4894         if (proto && !*proto)
4895             proto = Nullch;
4896
4897         sent = PerlSock_getservbyname(name, proto);
4898 #else
4899         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4900 #endif
4901     }
4902     else if (which == OP_GSBYPORT) {
4903 #ifdef HAS_GETSERVBYPORT
4904         char *proto = POPpbytex;
4905         unsigned short port = POPu;
4906
4907 #ifdef HAS_HTONS
4908         port = PerlSock_htons(port);
4909 #endif
4910         sent = PerlSock_getservbyport(port, proto);
4911 #else
4912         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4913 #endif
4914     }
4915     else
4916 #ifdef HAS_GETSERVENT
4917         sent = PerlSock_getservent();
4918 #else
4919         DIE(aTHX_ PL_no_sock_func, "getservent");
4920 #endif
4921
4922     EXTEND(SP, 4);
4923     if (GIMME != G_ARRAY) {
4924         PUSHs(sv = sv_newmortal());
4925         if (sent) {
4926             if (which == OP_GSBYNAME) {
4927 #ifdef HAS_NTOHS
4928                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4929 #else
4930                 sv_setiv(sv, (IV)(sent->s_port));
4931 #endif
4932             }
4933             else
4934                 sv_setpv(sv, sent->s_name);
4935         }
4936         RETURN;
4937     }
4938
4939     if (sent) {
4940         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4941         sv_setpv(sv, sent->s_name);
4942         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4943         for (elem = sent->s_aliases; elem && *elem; elem++) {
4944             sv_catpv(sv, *elem);
4945             if (elem[1])
4946                 sv_catpvn(sv, " ", 1);
4947         }
4948         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4949 #ifdef HAS_NTOHS
4950         sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4951 #else
4952         sv_setiv(sv, (IV)(sent->s_port));
4953 #endif
4954         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4955         sv_setpv(sv, sent->s_proto);
4956     }
4957
4958     RETURN;
4959 #else
4960     DIE(aTHX_ PL_no_sock_func, "getservent");
4961 #endif
4962 }
4963
4964 PP(pp_shostent)
4965 {
4966 #ifdef HAS_SETHOSTENT
4967     dSP;
4968     PerlSock_sethostent(TOPi);
4969     RETSETYES;
4970 #else
4971     DIE(aTHX_ PL_no_sock_func, "sethostent");
4972 #endif
4973 }
4974
4975 PP(pp_snetent)
4976 {
4977 #ifdef HAS_SETNETENT
4978     dSP;
4979     PerlSock_setnetent(TOPi);
4980     RETSETYES;
4981 #else
4982     DIE(aTHX_ PL_no_sock_func, "setnetent");
4983 #endif
4984 }
4985
4986 PP(pp_sprotoent)
4987 {
4988 #ifdef HAS_SETPROTOENT
4989     dSP;
4990     PerlSock_setprotoent(TOPi);
4991     RETSETYES;
4992 #else
4993     DIE(aTHX_ PL_no_sock_func, "setprotoent");
4994 #endif
4995 }
4996
4997 PP(pp_sservent)
4998 {
4999 #ifdef HAS_SETSERVENT
5000     dSP;
5001     PerlSock_setservent(TOPi);
5002     RETSETYES;
5003 #else
5004     DIE(aTHX_ PL_no_sock_func, "setservent");
5005 #endif
5006 }
5007
5008 PP(pp_ehostent)
5009 {
5010 #ifdef HAS_ENDHOSTENT
5011     dSP;
5012     PerlSock_endhostent();
5013     EXTEND(SP,1);
5014     RETPUSHYES;
5015 #else
5016     DIE(aTHX_ PL_no_sock_func, "endhostent");
5017 #endif
5018 }
5019
5020 PP(pp_enetent)
5021 {
5022 #ifdef HAS_ENDNETENT
5023     dSP;
5024     PerlSock_endnetent();
5025     EXTEND(SP,1);
5026     RETPUSHYES;
5027 #else
5028     DIE(aTHX_ PL_no_sock_func, "endnetent");
5029 #endif
5030 }
5031
5032 PP(pp_eprotoent)
5033 {
5034 #ifdef HAS_ENDPROTOENT
5035     dSP;
5036     PerlSock_endprotoent();
5037     EXTEND(SP,1);
5038     RETPUSHYES;
5039 #else
5040     DIE(aTHX_ PL_no_sock_func, "endprotoent");
5041 #endif
5042 }
5043
5044 PP(pp_eservent)
5045 {
5046 #ifdef HAS_ENDSERVENT
5047     dSP;
5048     PerlSock_endservent();
5049     EXTEND(SP,1);
5050     RETPUSHYES;
5051 #else
5052     DIE(aTHX_ PL_no_sock_func, "endservent");
5053 #endif
5054 }
5055
5056 PP(pp_gpwnam)
5057 {
5058 #ifdef HAS_PASSWD
5059     return pp_gpwent();
5060 #else
5061     DIE(aTHX_ PL_no_func, "getpwnam");
5062 #endif
5063 }
5064
5065 PP(pp_gpwuid)
5066 {
5067 #ifdef HAS_PASSWD
5068     return pp_gpwent();
5069 #else
5070     DIE(aTHX_ PL_no_func, "getpwuid");
5071 #endif
5072 }
5073
5074 PP(pp_gpwent)
5075 {
5076 #ifdef HAS_PASSWD
5077     dSP;
5078     I32 which = PL_op->op_type;
5079     register SV *sv;
5080     STRLEN n_a;
5081     struct passwd *pwent  = NULL;
5082     /*
5083      * We currently support only the SysV getsp* shadow password interface.
5084      * The interface is declared in <shadow.h> and often one needs to link
5085      * with -lsecurity or some such.
5086      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5087      * (and SCO?)
5088      *
5089      * AIX getpwnam() is clever enough to return the encrypted password
5090      * only if the caller (euid?) is root.
5091      *
5092      * There are at least two other shadow password APIs.  Many platforms
5093      * seem to contain more than one interface for accessing the shadow
5094      * password databases, possibly for compatibility reasons.
5095      * The getsp*() is by far he simplest one, the other two interfaces
5096      * are much more complicated, but also very similar to each other.
5097      *
5098      * <sys/types.h>
5099      * <sys/security.h>
5100      * <prot.h>
5101      * struct pr_passwd *getprpw*();
5102      * The password is in
5103      * char getprpw*(...).ufld.fd_encrypt[]
5104      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5105      *
5106      * <sys/types.h>
5107      * <sys/security.h>
5108      * <prot.h>
5109      * struct es_passwd *getespw*();
5110      * The password is in
5111      * char *(getespw*(...).ufld.fd_encrypt)
5112      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5113      *
5114      * Mention I_PROT here so that Configure probes for it.
5115      *
5116      * In HP-UX for getprpw*() the manual page claims that one should include
5117      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5118      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5119      * and pp_sys.c already includes <shadow.h> if there is such.
5120      *
5121      * Note that <sys/security.h> is already probed for, but currently
5122      * it is only included in special cases.
5123      *
5124      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5125      * be preferred interface, even though also the getprpw*() interface
5126      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5127      * One also needs to call set_auth_parameters() in main() before
5128      * doing anything else, whether one is using getespw*() or getprpw*().
5129      *
5130      * Note that accessing the shadow databases can be magnitudes
5131      * slower than accessing the standard databases.
5132      *
5133      * --jhi
5134      */
5135
5136     switch (which) {
5137     case OP_GPWNAM:
5138         pwent  = getpwnam(POPpbytex);
5139         break;
5140     case OP_GPWUID:
5141         pwent = getpwuid((Uid_t)POPi);
5142         break;
5143     case OP_GPWENT:
5144 #   ifdef HAS_GETPWENT
5145         pwent  = getpwent();
5146 #   else
5147         DIE(aTHX_ PL_no_func, "getpwent");
5148 #   endif
5149         break;
5150     }
5151
5152     EXTEND(SP, 10);
5153     if (GIMME != G_ARRAY) {
5154         PUSHs(sv = sv_newmortal());
5155         if (pwent) {
5156             if (which == OP_GPWNAM)
5157 #   if Uid_t_sign <= 0
5158                 sv_setiv(sv, (IV)pwent->pw_uid);
5159 #   else
5160                 sv_setuv(sv, (UV)pwent->pw_uid);
5161 #   endif
5162             else
5163                 sv_setpv(sv, pwent->pw_name);
5164         }
5165         RETURN;
5166     }
5167
5168     if (pwent) {
5169         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5170         sv_setpv(sv, pwent->pw_name);
5171
5172         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5173         SvPOK_off(sv);
5174         /* If we have getspnam(), we try to dig up the shadow
5175          * password.  If we are underprivileged, the shadow
5176          * interface will set the errno to EACCES or similar,
5177          * and return a null pointer.  If this happens, we will
5178          * use the dummy password (usually "*" or "x") from the
5179          * standard password database.
5180          *
5181          * In theory we could skip the shadow call completely
5182          * if euid != 0 but in practice we cannot know which
5183          * security measures are guarding the shadow databases
5184          * on a random platform.
5185          *
5186          * Resist the urge to use additional shadow interfaces.
5187          * Divert the urge to writing an extension instead.
5188          *
5189          * --jhi */
5190 #   ifdef HAS_GETSPNAM
5191         {
5192             struct spwd *spwent;
5193             int saverrno; /* Save and restore errno so that
5194                            * underprivileged attempts seem
5195                            * to have never made the unsccessful
5196                            * attempt to retrieve the shadow password. */
5197
5198             saverrno = errno;
5199             spwent = getspnam(pwent->pw_name);
5200             errno = saverrno;
5201             if (spwent && spwent->sp_pwdp)
5202                 sv_setpv(sv, spwent->sp_pwdp);
5203         }
5204 #   endif
5205 #   ifdef PWPASSWD
5206         if (!SvPOK(sv)) /* Use the standard password, then. */
5207             sv_setpv(sv, pwent->pw_passwd);
5208 #   endif
5209
5210 #   ifndef INCOMPLETE_TAINTS
5211         /* passwd is tainted because user himself can diddle with it.
5212          * admittedly not much and in a very limited way, but nevertheless. */
5213         SvTAINTED_on(sv);
5214 #   endif
5215
5216         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5217 #   if Uid_t_sign <= 0
5218         sv_setiv(sv, (IV)pwent->pw_uid);
5219 #   else
5220         sv_setuv(sv, (UV)pwent->pw_uid);
5221 #   endif
5222
5223         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5224 #   if Uid_t_sign <= 0
5225         sv_setiv(sv, (IV)pwent->pw_gid);
5226 #   else
5227         sv_setuv(sv, (UV)pwent->pw_gid);
5228 #   endif
5229         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5230          * because of the poor interface of the Perl getpw*(),
5231          * not because there's some standard/convention saying so.
5232          * A better interface would have been to return a hash,
5233          * but we are accursed by our history, alas. --jhi.  */
5234         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5235 #   ifdef PWCHANGE
5236         sv_setiv(sv, (IV)pwent->pw_change);
5237 #   else
5238 #       ifdef PWQUOTA
5239         sv_setiv(sv, (IV)pwent->pw_quota);
5240 #       else
5241 #           ifdef PWAGE
5242         sv_setpv(sv, pwent->pw_age);
5243 #           endif
5244 #       endif
5245 #   endif
5246
5247         /* pw_class and pw_comment are mutually exclusive--.
5248          * see the above note for pw_change, pw_quota, and pw_age. */
5249         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5250 #   ifdef PWCLASS
5251         sv_setpv(sv, pwent->pw_class);
5252 #   else
5253 #       ifdef PWCOMMENT
5254         sv_setpv(sv, pwent->pw_comment);
5255 #       endif
5256 #   endif
5257
5258         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5259 #   ifdef PWGECOS
5260         sv_setpv(sv, pwent->pw_gecos);
5261 #   endif
5262 #   ifndef INCOMPLETE_TAINTS
5263         /* pw_gecos is tainted because user himself can diddle with it. */
5264         SvTAINTED_on(sv);
5265 #   endif
5266
5267         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5268         sv_setpv(sv, pwent->pw_dir);
5269
5270         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5271         sv_setpv(sv, pwent->pw_shell);
5272 #   ifndef INCOMPLETE_TAINTS
5273         /* pw_shell is tainted because user himself can diddle with it. */
5274         SvTAINTED_on(sv);
5275 #   endif
5276
5277 #   ifdef PWEXPIRE
5278         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5279         sv_setiv(sv, (IV)pwent->pw_expire);
5280 #   endif
5281     }
5282     RETURN;
5283 #else
5284     DIE(aTHX_ PL_no_func, "getpwent");
5285 #endif
5286 }
5287
5288 PP(pp_spwent)
5289 {
5290 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5291     dSP;
5292     setpwent();
5293     RETPUSHYES;
5294 #else
5295     DIE(aTHX_ PL_no_func, "setpwent");
5296 #endif
5297 }
5298
5299 PP(pp_epwent)
5300 {
5301 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5302     dSP;
5303     endpwent();
5304     RETPUSHYES;
5305 #else
5306     DIE(aTHX_ PL_no_func, "endpwent");
5307 #endif
5308 }
5309
5310 PP(pp_ggrnam)
5311 {
5312 #ifdef HAS_GROUP
5313     return pp_ggrent();
5314 #else
5315     DIE(aTHX_ PL_no_func, "getgrnam");
5316 #endif
5317 }
5318
5319 PP(pp_ggrgid)
5320 {
5321 #ifdef HAS_GROUP
5322     return pp_ggrent();
5323 #else
5324     DIE(aTHX_ PL_no_func, "getgrgid");
5325 #endif
5326 }
5327
5328 PP(pp_ggrent)
5329 {
5330 #ifdef HAS_GROUP
5331     dSP;
5332     I32 which = PL_op->op_type;
5333     register char **elem;
5334     register SV *sv;
5335     struct group *grent;
5336     STRLEN n_a;
5337
5338     if (which == OP_GGRNAM)
5339         grent = (struct group *)getgrnam(POPpbytex);
5340     else if (which == OP_GGRGID)
5341         grent = (struct group *)getgrgid(POPi);
5342     else
5343 #ifdef HAS_GETGRENT
5344         grent = (struct group *)getgrent();
5345 #else
5346         DIE(aTHX_ PL_no_func, "getgrent");
5347 #endif
5348
5349     EXTEND(SP, 4);
5350     if (GIMME != G_ARRAY) {
5351         PUSHs(sv = sv_newmortal());
5352         if (grent) {
5353             if (which == OP_GGRNAM)
5354                 sv_setiv(sv, (IV)grent->gr_gid);
5355             else
5356                 sv_setpv(sv, grent->gr_name);
5357         }
5358         RETURN;
5359     }
5360
5361     if (grent) {
5362         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5363         sv_setpv(sv, grent->gr_name);
5364
5365         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5366 #ifdef GRPASSWD
5367         sv_setpv(sv, grent->gr_passwd);
5368 #endif
5369
5370         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5371         sv_setiv(sv, (IV)grent->gr_gid);
5372
5373         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5374         for (elem = grent->gr_mem; elem && *elem; elem++) {
5375             sv_catpv(sv, *elem);
5376             if (elem[1])
5377                 sv_catpvn(sv, " ", 1);
5378         }
5379     }
5380
5381     RETURN;
5382 #else
5383     DIE(aTHX_ PL_no_func, "getgrent");
5384 #endif
5385 }
5386
5387 PP(pp_sgrent)
5388 {
5389 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5390     dSP;
5391     setgrent();
5392     RETPUSHYES;
5393 #else
5394     DIE(aTHX_ PL_no_func, "setgrent");
5395 #endif
5396 }
5397
5398 PP(pp_egrent)
5399 {
5400 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5401     dSP;
5402     endgrent();
5403     RETPUSHYES;
5404 #else
5405     DIE(aTHX_ PL_no_func, "endgrent");
5406 #endif
5407 }
5408
5409 PP(pp_getlogin)
5410 {
5411 #ifdef HAS_GETLOGIN
5412     dSP; dTARGET;
5413     char *tmps;
5414     EXTEND(SP, 1);
5415     if (!(tmps = PerlProc_getlogin()))
5416         RETPUSHUNDEF;
5417     PUSHp(tmps, strlen(tmps));
5418     RETURN;
5419 #else
5420     DIE(aTHX_ PL_no_func, "getlogin");
5421 #endif
5422 }
5423
5424 /* Miscellaneous. */
5425
5426 PP(pp_syscall)
5427 {
5428 #ifdef HAS_SYSCALL
5429     dSP; dMARK; dORIGMARK; dTARGET;
5430     register I32 items = SP - MARK;
5431     unsigned long a[20];
5432     register I32 i = 0;
5433     I32 retval = -1;
5434     STRLEN n_a;
5435
5436     if (PL_tainting) {
5437         while (++MARK <= SP) {
5438             if (SvTAINTED(*MARK)) {
5439                 TAINT;
5440                 break;
5441             }
5442         }
5443         MARK = ORIGMARK;
5444         TAINT_PROPER("syscall");
5445     }
5446
5447     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5448      * or where sizeof(long) != sizeof(char*).  But such machines will
5449      * not likely have syscall implemented either, so who cares?
5450      */
5451     while (++MARK <= SP) {
5452         if (SvNIOK(*MARK) || !i)
5453             a[i++] = SvIV(*MARK);
5454         else if (*MARK == &PL_sv_undef)
5455             a[i++] = 0;
5456         else
5457             a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
5458         if (i > 15)
5459             break;
5460     }
5461     switch (items) {
5462     default:
5463         DIE(aTHX_ "Too many args to syscall");
5464     case 0:
5465         DIE(aTHX_ "Too few args to syscall");
5466     case 1:
5467         retval = syscall(a[0]);
5468         break;
5469     case 2:
5470         retval = syscall(a[0],a[1]);
5471         break;
5472     case 3:
5473         retval = syscall(a[0],a[1],a[2]);
5474         break;
5475     case 4:
5476         retval = syscall(a[0],a[1],a[2],a[3]);
5477         break;
5478     case 5:
5479         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5480         break;
5481     case 6:
5482         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5483         break;
5484     case 7:
5485         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5486         break;
5487     case 8:
5488         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5489         break;
5490 #ifdef atarist
5491     case 9:
5492         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5493         break;
5494     case 10:
5495         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5496         break;
5497     case 11:
5498         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5499           a[10]);
5500         break;
5501     case 12:
5502         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5503           a[10],a[11]);
5504         break;
5505     case 13:
5506         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5507           a[10],a[11],a[12]);
5508         break;
5509     case 14:
5510         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5511           a[10],a[11],a[12],a[13]);
5512         break;
5513 #endif /* atarist */
5514     }
5515     SP = ORIGMARK;
5516     PUSHi(retval);
5517     RETURN;
5518 #else
5519     DIE(aTHX_ PL_no_func, "syscall");
5520 #endif
5521 }
5522
5523 #ifdef FCNTL_EMULATE_FLOCK
5524
5525 /*  XXX Emulate flock() with fcntl().
5526     What's really needed is a good file locking module.
5527 */
5528
5529 static int
5530 fcntl_emulate_flock(int fd, int operation)
5531 {
5532     struct flock flock;
5533
5534     switch (operation & ~LOCK_NB) {
5535     case LOCK_SH:
5536         flock.l_type = F_RDLCK;
5537         break;
5538     case LOCK_EX:
5539         flock.l_type = F_WRLCK;
5540         break;
5541     case LOCK_UN:
5542         flock.l_type = F_UNLCK;
5543         break;
5544     default:
5545         errno = EINVAL;
5546         return -1;
5547     }
5548     flock.l_whence = SEEK_SET;
5549     flock.l_start = flock.l_len = (Off_t)0;
5550
5551     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5552 }
5553
5554 #endif /* FCNTL_EMULATE_FLOCK */
5555
5556 #ifdef LOCKF_EMULATE_FLOCK
5557
5558 /*  XXX Emulate flock() with lockf().  This is just to increase
5559     portability of scripts.  The calls are not completely
5560     interchangeable.  What's really needed is a good file
5561     locking module.
5562 */
5563
5564 /*  The lockf() constants might have been defined in <unistd.h>.
5565     Unfortunately, <unistd.h> causes troubles on some mixed
5566     (BSD/POSIX) systems, such as SunOS 4.1.3.
5567
5568    Further, the lockf() constants aren't POSIX, so they might not be
5569    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5570    just stick in the SVID values and be done with it.  Sigh.
5571 */
5572
5573 # ifndef F_ULOCK
5574 #  define F_ULOCK       0       /* Unlock a previously locked region */
5575 # endif
5576 # ifndef F_LOCK
5577 #  define F_LOCK        1       /* Lock a region for exclusive use */
5578 # endif
5579 # ifndef F_TLOCK
5580 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5581 # endif
5582 # ifndef F_TEST
5583 #  define F_TEST        3       /* Test a region for other processes locks */
5584 # endif
5585
5586 static int
5587 lockf_emulate_flock(int fd, int operation)
5588 {
5589     int i;
5590     int save_errno;
5591     Off_t pos;
5592
5593     /* flock locks entire file so for lockf we need to do the same      */
5594     save_errno = errno;
5595     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5596     if (pos > 0)        /* is seekable and needs to be repositioned     */
5597         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5598             pos = -1;   /* seek failed, so don't seek back afterwards   */
5599     errno = save_errno;
5600
5601     switch (operation) {
5602
5603         /* LOCK_SH - get a shared lock */
5604         case LOCK_SH:
5605         /* LOCK_EX - get an exclusive lock */
5606         case LOCK_EX:
5607             i = lockf (fd, F_LOCK, 0);
5608             break;
5609
5610         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5611         case LOCK_SH|LOCK_NB:
5612         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5613         case LOCK_EX|LOCK_NB:
5614             i = lockf (fd, F_TLOCK, 0);
5615             if (i == -1)
5616                 if ((errno == EAGAIN) || (errno == EACCES))
5617                     errno = EWOULDBLOCK;
5618             break;
5619
5620         /* LOCK_UN - unlock (non-blocking is a no-op) */
5621         case LOCK_UN:
5622         case LOCK_UN|LOCK_NB:
5623             i = lockf (fd, F_ULOCK, 0);
5624             break;
5625
5626         /* Default - can't decipher operation */
5627         default:
5628             i = -1;
5629             errno = EINVAL;
5630             break;
5631     }
5632
5633     if (pos > 0)      /* need to restore position of the handle */
5634         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5635
5636     return (i);
5637 }
5638
5639 #endif /* LOCKF_EMULATE_FLOCK */