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