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