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