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