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