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