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