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