pp_sys.c

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