pp_sys.c

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