pp_sys.c

   1 /*    pp_sys.c
   2  *
   3  *    Copyright (c) 1991-2000, 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 (*s & 0x40) {
3282                 int ulen = UTF8SKIP(s);
3283                 if (ulen < len - i) {
3284                     int j;
3285                     for (j = 1; j < ulen; j++) {
3286                         if ((s[j] & 0xc0) != 0x80)
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 n_a;
3592     char *tmps;
3593
3594     if (MAXARG > 1)
3595         mode = POPi;
3596     else
3597         mode = 0777;
3598
3599     tmps = SvPV(TOPs, n_a);
3600
3601     TAINT_PROPER("mkdir");
3602 #ifdef HAS_MKDIR
3603     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3604 #else
3605     SETi( dooneliner("mkdir", tmps) );
3606     oldumask = PerlLIO_umask(0);
3607     PerlLIO_umask(oldumask);
3608     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3609 #endif
3610     RETURN;
3611 }
3612
3613 PP(pp_rmdir)
3614 {
3615     djSP; dTARGET;
3616     char *tmps;
3617     STRLEN n_a;
3618
3619     tmps = POPpx;
3620     TAINT_PROPER("rmdir");
3621 #ifdef HAS_RMDIR
3622     XPUSHi( PerlDir_rmdir(tmps) >= 0 );
3623 #else
3624     XPUSHi( dooneliner("rmdir", tmps) );
3625 #endif
3626     RETURN;
3627 }
3628
3629 /* Directory calls. */
3630
3631 PP(pp_open_dir)
3632 {
3633     djSP;
3634 #if defined(Direntry_t) && defined(HAS_READDIR)
3635     STRLEN n_a;
3636     char *dirname = POPpx;
3637     GV *gv = (GV*)POPs;
3638     register IO *io = GvIOn(gv);
3639
3640     if (!io)
3641         goto nope;
3642
3643     if (IoDIRP(io))
3644         PerlDir_close(IoDIRP(io));
3645     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3646         goto nope;
3647
3648     RETPUSHYES;
3649 nope:
3650     if (!errno)
3651         SETERRNO(EBADF,RMS$_DIR);
3652     RETPUSHUNDEF;
3653 #else
3654     DIE(aTHX_ PL_no_dir_func, "opendir");
3655 #endif
3656 }
3657
3658 PP(pp_readdir)
3659 {
3660     djSP;
3661 #if defined(Direntry_t) && defined(HAS_READDIR)
3662 #ifndef I_DIRENT
3663     Direntry_t *readdir (DIR *);
3664 #endif
3665     register Direntry_t *dp;
3666     GV *gv = (GV*)POPs;
3667     register IO *io = GvIOn(gv);
3668     SV *sv;
3669
3670     if (!io || !IoDIRP(io))
3671         goto nope;
3672
3673     if (GIMME == G_ARRAY) {
3674         /*SUPPRESS 560*/
3675         while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
3676 #ifdef DIRNAMLEN
3677             sv = newSVpvn(dp->d_name, dp->d_namlen);
3678 #else
3679             sv = newSVpv(dp->d_name, 0);
3680 #endif
3681 #ifndef INCOMPLETE_TAINTS
3682             if (!(IoFLAGS(io) & IOf_UNTAINT))
3683                 SvTAINTED_on(sv);
3684 #endif
3685             XPUSHs(sv_2mortal(sv));
3686         }
3687     }
3688     else {
3689         if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
3690             goto nope;
3691 #ifdef DIRNAMLEN
3692         sv = newSVpvn(dp->d_name, dp->d_namlen);
3693 #else
3694         sv = newSVpv(dp->d_name, 0);
3695 #endif
3696 #ifndef INCOMPLETE_TAINTS
3697         if (!(IoFLAGS(io) & IOf_UNTAINT))
3698             SvTAINTED_on(sv);
3699 #endif
3700         XPUSHs(sv_2mortal(sv));
3701     }
3702     RETURN;
3703
3704 nope:
3705     if (!errno)
3706         SETERRNO(EBADF,RMS$_ISI);
3707     if (GIMME == G_ARRAY)
3708         RETURN;
3709     else
3710         RETPUSHUNDEF;
3711 #else
3712     DIE(aTHX_ PL_no_dir_func, "readdir");
3713 #endif
3714 }
3715
3716 PP(pp_telldir)
3717 {
3718     djSP; dTARGET;
3719 #if defined(HAS_TELLDIR) || defined(telldir)
3720  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3721  /* XXX netbsd still seemed to.
3722     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3723     --JHI 1999-Feb-02 */
3724 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3725     long telldir (DIR *);
3726 # endif
3727     GV *gv = (GV*)POPs;
3728     register IO *io = GvIOn(gv);
3729
3730     if (!io || !IoDIRP(io))
3731         goto nope;
3732
3733     PUSHi( PerlDir_tell(IoDIRP(io)) );
3734     RETURN;
3735 nope:
3736     if (!errno)
3737         SETERRNO(EBADF,RMS$_ISI);
3738     RETPUSHUNDEF;
3739 #else
3740     DIE(aTHX_ PL_no_dir_func, "telldir");
3741 #endif
3742 }
3743
3744 PP(pp_seekdir)
3745 {
3746     djSP;
3747 #if defined(HAS_SEEKDIR) || defined(seekdir)
3748     long along = POPl;
3749     GV *gv = (GV*)POPs;
3750     register IO *io = GvIOn(gv);
3751
3752     if (!io || !IoDIRP(io))
3753         goto nope;
3754
3755     (void)PerlDir_seek(IoDIRP(io), along);
3756
3757     RETPUSHYES;
3758 nope:
3759     if (!errno)
3760         SETERRNO(EBADF,RMS$_ISI);
3761     RETPUSHUNDEF;
3762 #else
3763     DIE(aTHX_ PL_no_dir_func, "seekdir");
3764 #endif
3765 }
3766
3767 PP(pp_rewinddir)
3768 {
3769     djSP;
3770 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3771     GV *gv = (GV*)POPs;
3772     register IO *io = GvIOn(gv);
3773
3774     if (!io || !IoDIRP(io))
3775         goto nope;
3776
3777     (void)PerlDir_rewind(IoDIRP(io));
3778     RETPUSHYES;
3779 nope:
3780     if (!errno)
3781         SETERRNO(EBADF,RMS$_ISI);
3782     RETPUSHUNDEF;
3783 #else
3784     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3785 #endif
3786 }
3787
3788 PP(pp_closedir)
3789 {
3790     djSP;
3791 #if defined(Direntry_t) && defined(HAS_READDIR)
3792     GV *gv = (GV*)POPs;
3793     register IO *io = GvIOn(gv);
3794
3795     if (!io || !IoDIRP(io))
3796         goto nope;
3797
3798 #ifdef VOID_CLOSEDIR
3799     PerlDir_close(IoDIRP(io));
3800 #else
3801     if (PerlDir_close(IoDIRP(io)) < 0) {
3802         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3803         goto nope;
3804     }
3805 #endif
3806     IoDIRP(io) = 0;
3807
3808     RETPUSHYES;
3809 nope:
3810     if (!errno)
3811         SETERRNO(EBADF,RMS$_IFI);
3812     RETPUSHUNDEF;
3813 #else
3814     DIE(aTHX_ PL_no_dir_func, "closedir");
3815 #endif
3816 }
3817
3818 /* Process control. */
3819
3820 PP(pp_fork)
3821 {
3822 #ifdef HAS_FORK
3823     djSP; dTARGET;
3824     Pid_t childpid;
3825     GV *tmpgv;
3826
3827     EXTEND(SP, 1);
3828     PERL_FLUSHALL_FOR_CHILD;
3829     childpid = fork();
3830     if (childpid < 0)
3831         RETSETUNDEF;
3832     if (!childpid) {
3833 #ifdef SOCKS_64BIT_BUG
3834         Perl_do_s64_init_buffer();
3835 #endif
3836         /*SUPPRESS 560*/
3837         if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
3838             sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3839         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3840     }
3841     PUSHi(childpid);
3842     RETURN;
3843 #else
3844 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3845     djSP; dTARGET;
3846     Pid_t childpid;
3847
3848     EXTEND(SP, 1);
3849     PERL_FLUSHALL_FOR_CHILD;
3850     childpid = PerlProc_fork();
3851     if (childpid == -1)
3852         RETSETUNDEF;
3853     PUSHi(childpid);
3854     RETURN;
3855 #  else
3856     DIE(aTHX_ PL_no_func, "Unsupported function fork");
3857 #  endif
3858 #endif
3859 }
3860
3861 PP(pp_wait)
3862 {
3863 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3864     djSP; dTARGET;
3865     Pid_t childpid;
3866     int argflags;
3867
3868     childpid = wait4pid(-1, &argflags, 0);
3869 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3870     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3871     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3872 #  else
3873     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3874 #  endif
3875     XPUSHi(childpid);
3876     RETURN;
3877 #else
3878     DIE(aTHX_ PL_no_func, "Unsupported function wait");
3879 #endif
3880 }
3881
3882 PP(pp_waitpid)
3883 {
3884 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3885     djSP; dTARGET;
3886     Pid_t childpid;
3887     int optype;
3888     int argflags;
3889
3890     optype = POPi;
3891     childpid = TOPi;
3892     childpid = wait4pid(childpid, &argflags, optype);
3893 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3894     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3895     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3896 #  else
3897     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3898 #  endif
3899     SETi(childpid);
3900     RETURN;
3901 #else
3902     DIE(aTHX_ PL_no_func, "Unsupported function waitpid");
3903 #endif
3904 }
3905
3906 PP(pp_system)
3907 {
3908     djSP; dMARK; dORIGMARK; dTARGET;
3909     I32 value;
3910     Pid_t childpid;
3911     int result;
3912     int status;
3913     Sigsave_t ihand,qhand;     /* place to save signals during system() */
3914     STRLEN n_a;
3915     I32 did_pipes = 0;
3916     int pp[2];
3917
3918     if (SP - MARK == 1) {
3919         if (PL_tainting) {
3920             char *junk = SvPV(TOPs, n_a);
3921             TAINT_ENV();
3922             TAINT_PROPER("system");
3923         }
3924     }
3925     PERL_FLUSHALL_FOR_CHILD;
3926 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) && !defined(__CYGWIN__) || defined(PERL_MICRO)
3927     if (PerlProc_pipe(pp) >= 0)
3928         did_pipes = 1;
3929     while ((childpid = vfork()) == -1) {
3930         if (errno != EAGAIN) {
3931             value = -1;
3932             SP = ORIGMARK;
3933             PUSHi(value);
3934             if (did_pipes) {
3935                 PerlLIO_close(pp[0]);
3936                 PerlLIO_close(pp[1]);
3937             }
3938             RETURN;
3939         }
3940         sleep(5);
3941     }
3942     if (childpid > 0) {
3943         if (did_pipes)
3944             PerlLIO_close(pp[1]);
3945 #ifndef PERL_MICRO
3946         rsignal_save(SIGINT, SIG_IGN, &ihand);
3947         rsignal_save(SIGQUIT, SIG_IGN, &qhand);
3948 #endif
3949         do {
3950             result = wait4pid(childpid, &status, 0);
3951         } while (result == -1 && errno == EINTR);
3952 #ifndef PERL_MICRO
3953         (void)rsignal_restore(SIGINT, &ihand);
3954         (void)rsignal_restore(SIGQUIT, &qhand);
3955 #endif
3956         STATUS_NATIVE_SET(result == -1 ? -1 : status);
3957         do_execfree();  /* free any memory child malloced on vfork */
3958         SP = ORIGMARK;
3959         if (did_pipes) {
3960             int errkid;
3961             int n = 0, n1;
3962
3963             while (n < sizeof(int)) {
3964                 n1 = PerlLIO_read(pp[0],
3965                                   (void*)(((char*)&errkid)+n),
3966                                   (sizeof(int)) - n);
3967                 if (n1 <= 0)
3968                     break;
3969                 n += n1;
3970             }
3971             PerlLIO_close(pp[0]);
3972             if (n) {                    /* Error */
3973                 if (n != sizeof(int))
3974                     DIE(aTHX_ "panic: kid popen errno read");
3975                 errno = errkid;         /* Propagate errno from kid */
3976                 STATUS_CURRENT = -1;
3977             }
3978         }
3979         PUSHi(STATUS_CURRENT);
3980         RETURN;
3981     }
3982     if (did_pipes) {
3983         PerlLIO_close(pp[0]);
3984 #if defined(HAS_FCNTL) && defined(F_SETFD)
3985         fcntl(pp[1], F_SETFD, FD_CLOEXEC);
3986 #endif
3987     }
3988     if (PL_op->op_flags & OPf_STACKED) {
3989         SV *really = *++MARK;
3990         value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
3991     }
3992     else if (SP - MARK != 1)
3993         value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
3994     else {
3995         value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
3996     }
3997     PerlProc__exit(-1);
3998 #else /* ! FORK or VMS or OS/2 */
3999     PL_statusvalue = 0;
4000     result = 0;
4001     if (PL_op->op_flags & OPf_STACKED) {
4002         SV *really = *++MARK;
4003         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4004     }
4005     else if (SP - MARK != 1)
4006         value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
4007     else {
4008         value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
4009     }
4010     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4011         result = 1;
4012     STATUS_NATIVE_SET(value);
4013     do_execfree();
4014     SP = ORIGMARK;
4015     PUSHi(result ? value : STATUS_CURRENT);
4016 #endif /* !FORK or VMS */
4017     RETURN;
4018 }
4019
4020 PP(pp_exec)
4021 {
4022     djSP; dMARK; dORIGMARK; dTARGET;
4023     I32 value;
4024     STRLEN n_a;
4025
4026     PERL_FLUSHALL_FOR_CHILD;
4027     if (PL_op->op_flags & OPf_STACKED) {
4028         SV *really = *++MARK;
4029         value = (I32)do_aexec(really, MARK, SP);
4030     }
4031     else if (SP - MARK != 1)
4032 #ifdef VMS
4033         value = (I32)vms_do_aexec(Nullsv, MARK, SP);
4034 #else
4035 #  ifdef __OPEN_VM
4036         {
4037            (void ) do_aspawn(Nullsv, MARK, SP);
4038            value = 0;
4039         }
4040 #  else
4041         value = (I32)do_aexec(Nullsv, MARK, SP);
4042 #  endif
4043 #endif
4044     else {
4045         if (PL_tainting) {
4046             char *junk = SvPV(*SP, n_a);
4047             TAINT_ENV();
4048             TAINT_PROPER("exec");
4049         }
4050 #ifdef VMS
4051         value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
4052 #else
4053 #  ifdef __OPEN_VM
4054         (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
4055         value = 0;
4056 #  else
4057         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
4058 #  endif
4059 #endif
4060     }
4061
4062 #if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4063     if (value >= 0)
4064         my_exit(value);
4065 #endif
4066
4067     SP = ORIGMARK;
4068     PUSHi(value);
4069     RETURN;
4070 }
4071
4072 PP(pp_kill)
4073 {
4074     djSP; dMARK; dTARGET;
4075     I32 value;
4076 #ifdef HAS_KILL
4077     value = (I32)apply(PL_op->op_type, MARK, SP);
4078     SP = MARK;
4079     PUSHi(value);
4080     RETURN;
4081 #else
4082     DIE(aTHX_ PL_no_func, "Unsupported function kill");
4083 #endif
4084 }
4085
4086 PP(pp_getppid)
4087 {
4088 #ifdef HAS_GETPPID
4089     djSP; dTARGET;
4090     XPUSHi( getppid() );
4091     RETURN;
4092 #else
4093     DIE(aTHX_ PL_no_func, "getppid");
4094 #endif
4095 }
4096
4097 PP(pp_getpgrp)
4098 {
4099 #ifdef HAS_GETPGRP
4100     djSP; dTARGET;
4101     Pid_t pid;
4102     Pid_t pgrp;
4103
4104     if (MAXARG < 1)
4105         pid = 0;
4106     else
4107         pid = SvIVx(POPs);
4108 #ifdef BSD_GETPGRP
4109     pgrp = (I32)BSD_GETPGRP(pid);
4110 #else
4111     if (pid != 0 && pid != PerlProc_getpid())
4112         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4113     pgrp = getpgrp();
4114 #endif
4115     XPUSHi(pgrp);
4116     RETURN;
4117 #else
4118     DIE(aTHX_ PL_no_func, "getpgrp()");
4119 #endif
4120 }
4121
4122 PP(pp_setpgrp)
4123 {
4124 #ifdef HAS_SETPGRP
4125     djSP; dTARGET;
4126     Pid_t pgrp;
4127     Pid_t pid;
4128     if (MAXARG < 2) {
4129         pgrp = 0;
4130         pid = 0;
4131     }
4132     else {
4133         pgrp = POPi;
4134         pid = TOPi;
4135     }
4136
4137     TAINT_PROPER("setpgrp");
4138 #ifdef BSD_SETPGRP
4139     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4140 #else
4141     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4142         || (pid != 0 && pid != PerlProc_getpid()))
4143     {
4144         DIE(aTHX_ "setpgrp can't take arguments");
4145     }
4146     SETi( setpgrp() >= 0 );
4147 #endif /* USE_BSDPGRP */
4148     RETURN;
4149 #else
4150     DIE(aTHX_ PL_no_func, "setpgrp()");
4151 #endif
4152 }
4153
4154 PP(pp_getpriority)
4155 {
4156     djSP; dTARGET;
4157     int which;
4158     int who;
4159 #ifdef HAS_GETPRIORITY
4160     who = POPi;
4161     which = TOPi;
4162     SETi( getpriority(which, who) );
4163     RETURN;
4164 #else
4165     DIE(aTHX_ PL_no_func, "getpriority()");
4166 #endif
4167 }
4168
4169 PP(pp_setpriority)
4170 {
4171     djSP; dTARGET;
4172     int which;
4173     int who;
4174     int niceval;
4175 #ifdef HAS_SETPRIORITY
4176     niceval = POPi;
4177     who = POPi;
4178     which = TOPi;
4179     TAINT_PROPER("setpriority");
4180     SETi( setpriority(which, who, niceval) >= 0 );
4181     RETURN;
4182 #else
4183     DIE(aTHX_ PL_no_func, "setpriority()");
4184 #endif
4185 }
4186
4187 /* Time calls. */
4188
4189 PP(pp_time)
4190 {
4191     djSP; dTARGET;
4192 #ifdef BIG_TIME
4193     XPUSHn( time(Null(Time_t*)) );
4194 #else
4195     XPUSHi( time(Null(Time_t*)) );
4196 #endif
4197     RETURN;
4198 }
4199
4200 /* XXX The POSIX name is CLK_TCK; it is to be preferred
4201    to HZ.  Probably.  For now, assume that if the system
4202    defines HZ, it does so correctly.  (Will this break
4203    on VMS?)
4204    Probably we ought to use _sysconf(_SC_CLK_TCK), if
4205    it's supported.    --AD  9/96.
4206 */
4207
4208 #ifndef HZ
4209 #  ifdef CLK_TCK
4210 #    define HZ CLK_TCK
4211 #  else
4212 #    define HZ 60
4213 #  endif
4214 #endif
4215
4216 PP(pp_tms)
4217 {
4218     djSP;
4219
4220 #ifndef HAS_TIMES
4221     DIE(aTHX_ "times not implemented");
4222 #else
4223     EXTEND(SP, 4);
4224
4225 #ifndef VMS
4226     (void)PerlProc_times(&PL_timesbuf);
4227 #else
4228     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4229                                                    /* struct tms, though same data   */
4230                                                    /* is returned.                   */
4231 #endif
4232
4233     PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
4234     if (GIMME == G_ARRAY) {
4235         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4236         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4237         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
4238     }
4239     RETURN;
4240 #endif /* HAS_TIMES */
4241 }
4242
4243 PP(pp_localtime)
4244 {
4245     return pp_gmtime();
4246 }
4247
4248 PP(pp_gmtime)
4249 {
4250     djSP;
4251     Time_t when;
4252     struct tm *tmbuf;
4253     static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4254     static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4255                               "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4256
4257     if (MAXARG < 1)
4258         (void)time(&when);
4259     else
4260 #ifdef BIG_TIME
4261         when = (Time_t)SvNVx(POPs);
4262 #else
4263         when = (Time_t)SvIVx(POPs);
4264 #endif
4265
4266     if (PL_op->op_type == OP_LOCALTIME)
4267         tmbuf = localtime(&when);
4268     else
4269         tmbuf = gmtime(&when);
4270
4271     EXTEND(SP, 9);
4272     EXTEND_MORTAL(9);
4273     if (GIMME != G_ARRAY) {
4274         SV *tsv;
4275         if (!tmbuf)
4276             RETPUSHUNDEF;
4277         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4278                             dayname[tmbuf->tm_wday],
4279                             monname[tmbuf->tm_mon],
4280                             tmbuf->tm_mday,
4281                             tmbuf->tm_hour,
4282                             tmbuf->tm_min,
4283                             tmbuf->tm_sec,
4284                             tmbuf->tm_year + 1900);
4285         PUSHs(sv_2mortal(tsv));
4286     }
4287     else if (tmbuf) {
4288         PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4289         PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4290         PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4291         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4292         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4293         PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4294         PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4295         PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4296         PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4297     }
4298     RETURN;
4299 }
4300
4301 PP(pp_alarm)
4302 {
4303     djSP; dTARGET;
4304     int anum;
4305 #ifdef HAS_ALARM
4306     anum = POPi;
4307     anum = alarm((unsigned int)anum);
4308     EXTEND(SP, 1);
4309     if (anum < 0)
4310         RETPUSHUNDEF;
4311     PUSHi(anum);
4312     RETURN;
4313 #else
4314     DIE(aTHX_ PL_no_func, "Unsupported function alarm");
4315 #endif
4316 }
4317
4318 PP(pp_sleep)
4319 {
4320     djSP; dTARGET;
4321     I32 duration;
4322     Time_t lasttime;
4323     Time_t when;
4324
4325     (void)time(&lasttime);
4326     if (MAXARG < 1)
4327         PerlProc_pause();
4328     else {
4329         duration = POPi;
4330         PerlProc_sleep((unsigned int)duration);
4331     }
4332     (void)time(&when);
4333     XPUSHi(when - lasttime);
4334     RETURN;
4335 }
4336
4337 /* Shared memory. */
4338
4339 PP(pp_shmget)
4340 {
4341     return pp_semget();
4342 }
4343
4344 PP(pp_shmctl)
4345 {
4346     return pp_semctl();
4347 }
4348
4349 PP(pp_shmread)
4350 {
4351     return pp_shmwrite();
4352 }
4353
4354 PP(pp_shmwrite)
4355 {
4356 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4357     djSP; dMARK; dTARGET;
4358     I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
4359     SP = MARK;
4360     PUSHi(value);
4361     RETURN;
4362 #else
4363     return pp_semget();
4364 #endif
4365 }
4366
4367 /* Message passing. */
4368
4369 PP(pp_msgget)
4370 {
4371     return pp_semget();
4372 }
4373
4374 PP(pp_msgctl)
4375 {
4376     return pp_semctl();
4377 }
4378
4379 PP(pp_msgsnd)
4380 {
4381 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4382     djSP; dMARK; dTARGET;
4383     I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4384     SP = MARK;
4385     PUSHi(value);
4386     RETURN;
4387 #else
4388     return pp_semget();
4389 #endif
4390 }
4391
4392 PP(pp_msgrcv)
4393 {
4394 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4395     djSP; dMARK; dTARGET;
4396     I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4397     SP = MARK;
4398     PUSHi(value);
4399     RETURN;
4400 #else
4401     return pp_semget();
4402 #endif
4403 }
4404
4405 /* Semaphores. */
4406
4407 PP(pp_semget)
4408 {
4409 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4410     djSP; dMARK; dTARGET;
4411     int anum = do_ipcget(PL_op->op_type, MARK, SP);
4412     SP = MARK;
4413     if (anum == -1)
4414         RETPUSHUNDEF;
4415     PUSHi(anum);
4416     RETURN;
4417 #else
4418     DIE(aTHX_ "System V IPC is not implemented on this machine");
4419 #endif
4420 }
4421
4422 PP(pp_semctl)
4423 {
4424 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4425     djSP; dMARK; dTARGET;
4426     int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4427     SP = MARK;
4428     if (anum == -1)
4429         RETSETUNDEF;
4430     if (anum != 0) {
4431         PUSHi(anum);
4432     }
4433     else {
4434         PUSHp(zero_but_true, ZBTLEN);
4435     }
4436     RETURN;
4437 #else
4438     return pp_semget();
4439 #endif
4440 }
4441
4442 PP(pp_semop)
4443 {
4444 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4445     djSP; dMARK; dTARGET;
4446     I32 value = (I32)(do_semop(MARK, SP) >= 0);
4447     SP = MARK;
4448     PUSHi(value);
4449     RETURN;
4450 #else
4451     return pp_semget();
4452 #endif
4453 }
4454
4455 /* Get system info. */
4456
4457 PP(pp_ghbyname)
4458 {
4459 #ifdef HAS_GETHOSTBYNAME
4460     return pp_ghostent();
4461 #else
4462     DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4463 #endif
4464 }
4465
4466 PP(pp_ghbyaddr)
4467 {
4468 #ifdef HAS_GETHOSTBYADDR
4469     return pp_ghostent();
4470 #else
4471     DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4472 #endif
4473 }
4474
4475 PP(pp_ghostent)
4476 {
4477     djSP;
4478 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4479     I32 which = PL_op->op_type;
4480     register char **elem;
4481     register SV *sv;
4482 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4483     struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4484     struct hostent *PerlSock_gethostbyname(Netdb_name_t);
4485     struct hostent *PerlSock_gethostent(void);
4486 #endif
4487     struct hostent *hent;
4488     unsigned long len;
4489     STRLEN n_a;
4490
4491     EXTEND(SP, 10);
4492     if (which == OP_GHBYNAME)
4493 #ifdef HAS_GETHOSTBYNAME
4494         hent = PerlSock_gethostbyname(POPpx);
4495 #else
4496         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4497 #endif
4498     else if (which == OP_GHBYADDR) {
4499 #ifdef HAS_GETHOSTBYADDR
4500         int addrtype = POPi;
4501         SV *addrsv = POPs;
4502         STRLEN addrlen;
4503         Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen);
4504
4505         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4506 #else
4507         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4508 #endif
4509     }
4510     else
4511 #ifdef HAS_GETHOSTENT
4512         hent = PerlSock_gethostent();
4513 #else
4514         DIE(aTHX_ PL_no_sock_func, "gethostent");
4515 #endif
4516
4517 #ifdef HOST_NOT_FOUND
4518     if (!hent)
4519         STATUS_NATIVE_SET(h_errno);
4520 #endif
4521
4522     if (GIMME != G_ARRAY) {
4523         PUSHs(sv = sv_newmortal());
4524         if (hent) {
4525             if (which == OP_GHBYNAME) {
4526                 if (hent->h_addr)
4527                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4528             }
4529             else
4530                 sv_setpv(sv, (char*)hent->h_name);
4531         }
4532         RETURN;
4533     }
4534
4535     if (hent) {
4536         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4537         sv_setpv(sv, (char*)hent->h_name);
4538         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4539         for (elem = hent->h_aliases; elem && *elem; elem++) {
4540             sv_catpv(sv, *elem);
4541             if (elem[1])
4542                 sv_catpvn(sv, " ", 1);
4543         }
4544         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4545         sv_setiv(sv, (IV)hent->h_addrtype);
4546         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4547         len = hent->h_length;
4548         sv_setiv(sv, (IV)len);
4549 #ifdef h_addr
4550         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4551             XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
4552             sv_setpvn(sv, *elem, len);
4553         }
4554 #else
4555         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4556         if (hent->h_addr)
4557             sv_setpvn(sv, hent->h_addr, len);
4558 #endif /* h_addr */
4559     }
4560     RETURN;
4561 #else
4562     DIE(aTHX_ PL_no_sock_func, "gethostent");
4563 #endif
4564 }
4565
4566 PP(pp_gnbyname)
4567 {
4568 #ifdef HAS_GETNETBYNAME
4569     return pp_gnetent();
4570 #else
4571     DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4572 #endif
4573 }
4574
4575 PP(pp_gnbyaddr)
4576 {
4577 #ifdef HAS_GETNETBYADDR
4578     return pp_gnetent();
4579 #else
4580     DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4581 #endif
4582 }
4583
4584 PP(pp_gnetent)
4585 {
4586     djSP;
4587 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4588     I32 which = PL_op->op_type;
4589     register char **elem;
4590     register SV *sv;
4591 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4592     struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4593     struct netent *PerlSock_getnetbyname(Netdb_name_t);
4594     struct netent *PerlSock_getnetent(void);
4595 #endif
4596     struct netent *nent;
4597     STRLEN n_a;
4598
4599     if (which == OP_GNBYNAME)
4600 #ifdef HAS_GETNETBYNAME
4601         nent = PerlSock_getnetbyname(POPpx);
4602 #else
4603         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4604 #endif
4605     else if (which == OP_GNBYADDR) {
4606 #ifdef HAS_GETNETBYADDR
4607         int addrtype = POPi;
4608         Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
4609         nent = PerlSock_getnetbyaddr(addr, addrtype);
4610 #else
4611         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4612 #endif
4613     }
4614     else
4615 #ifdef HAS_GETNETENT
4616         nent = PerlSock_getnetent();
4617 #else
4618         DIE(aTHX_ PL_no_sock_func, "getnetent");
4619 #endif
4620
4621     EXTEND(SP, 4);
4622     if (GIMME != G_ARRAY) {
4623         PUSHs(sv = sv_newmortal());
4624         if (nent) {
4625             if (which == OP_GNBYNAME)
4626                 sv_setiv(sv, (IV)nent->n_net);
4627             else
4628                 sv_setpv(sv, nent->n_name);
4629         }
4630         RETURN;
4631     }
4632
4633     if (nent) {
4634         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4635         sv_setpv(sv, nent->n_name);
4636         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4637         for (elem = nent->n_aliases; elem && *elem; elem++) {
4638             sv_catpv(sv, *elem);
4639             if (elem[1])
4640                 sv_catpvn(sv, " ", 1);
4641         }
4642         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4643         sv_setiv(sv, (IV)nent->n_addrtype);
4644         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4645         sv_setiv(sv, (IV)nent->n_net);
4646     }
4647
4648     RETURN;
4649 #else
4650     DIE(aTHX_ PL_no_sock_func, "getnetent");
4651 #endif
4652 }
4653
4654 PP(pp_gpbyname)
4655 {
4656 #ifdef HAS_GETPROTOBYNAME
4657     return pp_gprotoent();
4658 #else
4659     DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4660 #endif
4661 }
4662
4663 PP(pp_gpbynumber)
4664 {
4665 #ifdef HAS_GETPROTOBYNUMBER
4666     return pp_gprotoent();
4667 #else
4668     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4669 #endif
4670 }
4671
4672 PP(pp_gprotoent)
4673 {
4674     djSP;
4675 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4676     I32 which = PL_op->op_type;
4677     register char **elem;
4678     register SV *sv;
4679 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4680     struct protoent *PerlSock_getprotobyname(Netdb_name_t);
4681     struct protoent *PerlSock_getprotobynumber(int);
4682     struct protoent *PerlSock_getprotoent(void);
4683 #endif
4684     struct protoent *pent;
4685     STRLEN n_a;
4686
4687     if (which == OP_GPBYNAME)
4688 #ifdef HAS_GETPROTOBYNAME
4689         pent = PerlSock_getprotobyname(POPpx);
4690 #else
4691         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4692 #endif
4693     else if (which == OP_GPBYNUMBER)
4694 #ifdef HAS_GETPROTOBYNUMBER
4695         pent = PerlSock_getprotobynumber(POPi);
4696 #else
4697     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4698 #endif
4699     else
4700 #ifdef HAS_GETPROTOENT
4701         pent = PerlSock_getprotoent();
4702 #else
4703         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4704 #endif
4705
4706     EXTEND(SP, 3);
4707     if (GIMME != G_ARRAY) {
4708         PUSHs(sv = sv_newmortal());
4709         if (pent) {
4710             if (which == OP_GPBYNAME)
4711                 sv_setiv(sv, (IV)pent->p_proto);
4712             else
4713                 sv_setpv(sv, pent->p_name);
4714         }
4715         RETURN;
4716     }
4717
4718     if (pent) {
4719         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4720         sv_setpv(sv, pent->p_name);
4721         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4722         for (elem = pent->p_aliases; elem && *elem; elem++) {
4723             sv_catpv(sv, *elem);
4724             if (elem[1])
4725                 sv_catpvn(sv, " ", 1);
4726         }
4727         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4728         sv_setiv(sv, (IV)pent->p_proto);
4729     }
4730
4731     RETURN;
4732 #else
4733     DIE(aTHX_ PL_no_sock_func, "getprotoent");
4734 #endif
4735 }
4736
4737 PP(pp_gsbyname)
4738 {
4739 #ifdef HAS_GETSERVBYNAME
4740     return pp_gservent();
4741 #else
4742     DIE(aTHX_ PL_no_sock_func, "getservbyname");
4743 #endif
4744 }
4745
4746 PP(pp_gsbyport)
4747 {
4748 #ifdef HAS_GETSERVBYPORT
4749     return pp_gservent();
4750 #else
4751     DIE(aTHX_ PL_no_sock_func, "getservbyport");
4752 #endif
4753 }
4754
4755 PP(pp_gservent)
4756 {
4757     djSP;
4758 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4759     I32 which = PL_op->op_type;
4760     register char **elem;
4761     register SV *sv;
4762 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4763     struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4764     struct servent *PerlSock_getservbyport(int, Netdb_name_t);
4765     struct servent *PerlSock_getservent(void);
4766 #endif
4767     struct servent *sent;
4768     STRLEN n_a;
4769
4770     if (which == OP_GSBYNAME) {
4771 #ifdef HAS_GETSERVBYNAME
4772         char *proto = POPpx;
4773         char *name = POPpx;
4774
4775         if (proto && !*proto)
4776             proto = Nullch;
4777
4778         sent = PerlSock_getservbyname(name, proto);
4779 #else
4780         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4781 #endif
4782     }
4783     else if (which == OP_GSBYPORT) {
4784 #ifdef HAS_GETSERVBYPORT
4785         char *proto = POPpx;
4786         unsigned short port = POPu;
4787
4788 #ifdef HAS_HTONS
4789         port = PerlSock_htons(port);
4790 #endif
4791         sent = PerlSock_getservbyport(port, proto);
4792 #else
4793         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4794 #endif
4795     }
4796     else
4797 #ifdef HAS_GETSERVENT
4798         sent = PerlSock_getservent();
4799 #else
4800         DIE(aTHX_ PL_no_sock_func, "getservent");
4801 #endif
4802
4803     EXTEND(SP, 4);
4804     if (GIMME != G_ARRAY) {
4805         PUSHs(sv = sv_newmortal());
4806         if (sent) {
4807             if (which == OP_GSBYNAME) {
4808 #ifdef HAS_NTOHS
4809                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4810 #else
4811                 sv_setiv(sv, (IV)(sent->s_port));
4812 #endif
4813             }
4814             else
4815                 sv_setpv(sv, sent->s_name);
4816         }
4817         RETURN;
4818     }
4819
4820     if (sent) {
4821         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4822         sv_setpv(sv, sent->s_name);
4823         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4824         for (elem = sent->s_aliases; elem && *elem; elem++) {
4825             sv_catpv(sv, *elem);
4826             if (elem[1])
4827                 sv_catpvn(sv, " ", 1);
4828         }
4829         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4830 #ifdef HAS_NTOHS
4831         sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4832 #else
4833         sv_setiv(sv, (IV)(sent->s_port));
4834 #endif
4835         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4836         sv_setpv(sv, sent->s_proto);
4837     }
4838
4839     RETURN;
4840 #else
4841     DIE(aTHX_ PL_no_sock_func, "getservent");
4842 #endif
4843 }
4844
4845 PP(pp_shostent)
4846 {
4847     djSP;
4848 #ifdef HAS_SETHOSTENT
4849     PerlSock_sethostent(TOPi);
4850     RETSETYES;
4851 #else
4852     DIE(aTHX_ PL_no_sock_func, "sethostent");
4853 #endif
4854 }
4855
4856 PP(pp_snetent)
4857 {
4858     djSP;
4859 #ifdef HAS_SETNETENT
4860     PerlSock_setnetent(TOPi);
4861     RETSETYES;
4862 #else
4863     DIE(aTHX_ PL_no_sock_func, "setnetent");
4864 #endif
4865 }
4866
4867 PP(pp_sprotoent)
4868 {
4869     djSP;
4870 #ifdef HAS_SETPROTOENT
4871     PerlSock_setprotoent(TOPi);
4872     RETSETYES;
4873 #else
4874     DIE(aTHX_ PL_no_sock_func, "setprotoent");
4875 #endif
4876 }
4877
4878 PP(pp_sservent)
4879 {
4880     djSP;
4881 #ifdef HAS_SETSERVENT
4882     PerlSock_setservent(TOPi);
4883     RETSETYES;
4884 #else
4885     DIE(aTHX_ PL_no_sock_func, "setservent");
4886 #endif
4887 }
4888
4889 PP(pp_ehostent)
4890 {
4891     djSP;
4892 #ifdef HAS_ENDHOSTENT
4893     PerlSock_endhostent();
4894     EXTEND(SP,1);
4895     RETPUSHYES;
4896 #else
4897     DIE(aTHX_ PL_no_sock_func, "endhostent");
4898 #endif
4899 }
4900
4901 PP(pp_enetent)
4902 {
4903     djSP;
4904 #ifdef HAS_ENDNETENT
4905     PerlSock_endnetent();
4906     EXTEND(SP,1);
4907     RETPUSHYES;
4908 #else
4909     DIE(aTHX_ PL_no_sock_func, "endnetent");
4910 #endif
4911 }
4912
4913 PP(pp_eprotoent)
4914 {
4915     djSP;
4916 #ifdef HAS_ENDPROTOENT
4917     PerlSock_endprotoent();
4918     EXTEND(SP,1);
4919     RETPUSHYES;
4920 #else
4921     DIE(aTHX_ PL_no_sock_func, "endprotoent");
4922 #endif
4923 }
4924
4925 PP(pp_eservent)
4926 {
4927     djSP;
4928 #ifdef HAS_ENDSERVENT
4929     PerlSock_endservent();
4930     EXTEND(SP,1);
4931     RETPUSHYES;
4932 #else
4933     DIE(aTHX_ PL_no_sock_func, "endservent");
4934 #endif
4935 }
4936
4937 PP(pp_gpwnam)
4938 {
4939 #ifdef HAS_PASSWD
4940     return pp_gpwent();
4941 #else
4942     DIE(aTHX_ PL_no_func, "getpwnam");
4943 #endif
4944 }
4945
4946 PP(pp_gpwuid)
4947 {
4948 #ifdef HAS_PASSWD
4949     return pp_gpwent();
4950 #else
4951     DIE(aTHX_ PL_no_func, "getpwuid");
4952 #endif
4953 }
4954
4955 PP(pp_gpwent)
4956 {
4957     djSP;
4958 #ifdef HAS_PASSWD
4959     I32 which = PL_op->op_type;
4960     register SV *sv;
4961     STRLEN n_a;
4962     struct passwd *pwent  = NULL;
4963     /*
4964      * We currently support only the SysV getsp* shadow password interface.
4965      * The interface is declared in <shadow.h> and often one needs to link
4966      * with -lsecurity or some such.
4967      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
4968      * (and SCO?)
4969      *
4970      * AIX getpwnam() is clever enough to return the encrypted password
4971      * only if the caller (euid?) is root.
4972      *
4973      * There are at least two other shadow password APIs.  Many platforms
4974      * seem to contain more than one interface for accessing the shadow
4975      * password databases, possibly for compatibility reasons.
4976      * The getsp*() is by far he simplest one, the other two interfaces
4977      * are much more complicated, but also very similar to each other.
4978      *
4979      * <sys/types.h>
4980      * <sys/security.h>
4981      * <prot.h>
4982      * struct pr_passwd *getprpw*();
4983      * The password is in
4984      * char getprpw*(...).ufld.fd_encrypt[]
4985      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
4986      *
4987      * <sys/types.h>
4988      * <sys/security.h>
4989      * <prot.h>
4990      * struct es_passwd *getespw*();
4991      * The password is in
4992      * char *(getespw*(...).ufld.fd_encrypt)
4993      * Mention HAS_GETESPWNAM here so that Configure probes for it.
4994      *
4995      * Mention I_PROT here so that Configure probes for it.
4996      *
4997      * In HP-UX for getprpw*() the manual page claims that one should include
4998      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
4999      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5000      * and pp_sys.c already includes <shadow.h> if there is such.
5001      *
5002      * Note that <sys/security.h> is already probed for, but currently
5003      * it is only included in special cases.
5004      *
5005      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5006      * be preferred interface, even though also the getprpw*() interface
5007      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5008      * One also needs to call set_auth_parameters() in main() before
5009      * doing anything else, whether one is using getespw*() or getprpw*().
5010      *
5011      * Note that accessing the shadow databases can be magnitudes
5012      * slower than accessing the standard databases.
5013      *
5014      * --jhi
5015      */
5016
5017     switch (which) {
5018     case OP_GPWNAM:
5019         pwent  = getpwnam(POPpx);
5020         break;
5021     case OP_GPWUID:
5022         pwent = getpwuid((Uid_t)POPi);
5023         break;
5024     case OP_GPWENT:
5025 #   ifdef HAS_GETPWENT
5026         pwent  = getpwent();
5027 #   else
5028         DIE(aTHX_ PL_no_func, "getpwent");
5029 #   endif
5030         break;
5031     }
5032
5033     EXTEND(SP, 10);
5034     if (GIMME != G_ARRAY) {
5035         PUSHs(sv = sv_newmortal());
5036         if (pwent) {
5037             if (which == OP_GPWNAM)
5038 #   if Uid_t_sign <= 0
5039                 sv_setiv(sv, (IV)pwent->pw_uid);
5040 #   else
5041                 sv_setuv(sv, (UV)pwent->pw_uid);
5042 #   endif
5043             else
5044                 sv_setpv(sv, pwent->pw_name);
5045         }
5046         RETURN;
5047     }
5048
5049     if (pwent) {
5050         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5051         sv_setpv(sv, pwent->pw_name);
5052
5053         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5054         SvPOK_off(sv);
5055         /* If we have getspnam(), we try to dig up the shadow
5056          * password.  If we are underprivileged, the shadow
5057          * interface will set the errno to EACCES or similar,
5058          * and return a null pointer.  If this happens, we will
5059          * use the dummy password (usually "*" or "x") from the
5060          * standard password database.
5061          *
5062          * In theory we could skip the shadow call completely
5063          * if euid != 0 but in practice we cannot know which
5064          * security measures are guarding the shadow databases
5065          * on a random platform.
5066          *
5067          * Resist the urge to use additional shadow interfaces.
5068          * Divert the urge to writing an extension instead.
5069          *
5070          * --jhi */
5071 #   ifdef HAS_GETSPNAM
5072         {
5073             struct spwd *spwent;
5074             int saverrno; /* Save and restore errno so that
5075                            * underprivileged attempts seem
5076                            * to have never made the unsccessful
5077                            * attempt to retrieve the shadow password. */
5078
5079             saverrno = errno;
5080             spwent = getspnam(pwent->pw_name);
5081             errno = saverrno;
5082             if (spwent && spwent->sp_pwdp)
5083                 sv_setpv(sv, spwent->sp_pwdp);
5084         }
5085 #   endif
5086 #   ifdef PWPASSWD
5087         if (!SvPOK(sv)) /* Use the standard password, then. */
5088             sv_setpv(sv, pwent->pw_passwd);
5089 #   endif
5090
5091 #   ifndef INCOMPLETE_TAINTS
5092         /* passwd is tainted because user himself can diddle with it.
5093          * admittedly not much and in a very limited way, but nevertheless. */
5094         SvTAINTED_on(sv);
5095 #   endif
5096
5097         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5098 #   if Uid_t_sign <= 0
5099         sv_setiv(sv, (IV)pwent->pw_uid);
5100 #   else
5101         sv_setuv(sv, (UV)pwent->pw_uid);
5102 #   endif
5103
5104         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5105 #   if Uid_t_sign <= 0
5106         sv_setiv(sv, (IV)pwent->pw_gid);
5107 #   else
5108         sv_setuv(sv, (UV)pwent->pw_gid);
5109 #   endif
5110         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5111          * because of the poor interface of the Perl getpw*(),
5112          * not because there's some standard/convention saying so.
5113          * A better interface would have been to return a hash,
5114          * but we are accursed by our history, alas. --jhi.  */
5115         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5116 #   ifdef PWCHANGE
5117         sv_setiv(sv, (IV)pwent->pw_change);
5118 #   else
5119 #       ifdef PWQUOTA
5120         sv_setiv(sv, (IV)pwent->pw_quota);
5121 #       else
5122 #           ifdef PWAGE
5123         sv_setpv(sv, pwent->pw_age);
5124 #           endif
5125 #       endif
5126 #   endif
5127
5128         /* pw_class and pw_comment are mutually exclusive--.
5129          * see the above note for pw_change, pw_quota, and pw_age. */
5130         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5131 #   ifdef PWCLASS
5132         sv_setpv(sv, pwent->pw_class);
5133 #   else
5134 #       ifdef PWCOMMENT
5135         sv_setpv(sv, pwent->pw_comment);
5136 #       endif
5137 #   endif
5138
5139         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5140 #   ifdef PWGECOS
5141         sv_setpv(sv, pwent->pw_gecos);
5142 #   endif
5143 #   ifndef INCOMPLETE_TAINTS
5144         /* pw_gecos is tainted because user himself can diddle with it. */
5145         SvTAINTED_on(sv);
5146 #   endif
5147
5148         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5149         sv_setpv(sv, pwent->pw_dir);
5150
5151         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5152         sv_setpv(sv, pwent->pw_shell);
5153 #   ifndef INCOMPLETE_TAINTS
5154         /* pw_shell is tainted because user himself can diddle with it. */
5155         SvTAINTED_on(sv);
5156 #   endif
5157
5158 #   ifdef PWEXPIRE
5159         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5160         sv_setiv(sv, (IV)pwent->pw_expire);
5161 #   endif
5162     }
5163     RETURN;
5164 #else
5165     DIE(aTHX_ PL_no_func, "getpwent");
5166 #endif
5167 }
5168
5169 PP(pp_spwent)
5170 {
5171     djSP;
5172 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5173     setpwent();
5174     RETPUSHYES;
5175 #else
5176     DIE(aTHX_ PL_no_func, "setpwent");
5177 #endif
5178 }
5179
5180 PP(pp_epwent)
5181 {
5182     djSP;
5183 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5184     endpwent();
5185     RETPUSHYES;
5186 #else
5187     DIE(aTHX_ PL_no_func, "endpwent");
5188 #endif
5189 }
5190
5191 PP(pp_ggrnam)
5192 {
5193 #ifdef HAS_GROUP
5194     return pp_ggrent();
5195 #else
5196     DIE(aTHX_ PL_no_func, "getgrnam");
5197 #endif
5198 }
5199
5200 PP(pp_ggrgid)
5201 {
5202 #ifdef HAS_GROUP
5203     return pp_ggrent();
5204 #else
5205     DIE(aTHX_ PL_no_func, "getgrgid");
5206 #endif
5207 }
5208
5209 PP(pp_ggrent)
5210 {
5211     djSP;
5212 #ifdef HAS_GROUP
5213     I32 which = PL_op->op_type;
5214     register char **elem;
5215     register SV *sv;
5216     struct group *grent;
5217     STRLEN n_a;
5218
5219     if (which == OP_GGRNAM)
5220         grent = (struct group *)getgrnam(POPpx);
5221     else if (which == OP_GGRGID)
5222         grent = (struct group *)getgrgid(POPi);
5223     else
5224 #ifdef HAS_GETGRENT
5225         grent = (struct group *)getgrent();
5226 #else
5227         DIE(aTHX_ PL_no_func, "getgrent");
5228 #endif
5229
5230     EXTEND(SP, 4);
5231     if (GIMME != G_ARRAY) {
5232         PUSHs(sv = sv_newmortal());
5233         if (grent) {
5234             if (which == OP_GGRNAM)
5235                 sv_setiv(sv, (IV)grent->gr_gid);
5236             else
5237                 sv_setpv(sv, grent->gr_name);
5238         }
5239         RETURN;
5240     }
5241
5242     if (grent) {
5243         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5244         sv_setpv(sv, grent->gr_name);
5245
5246         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5247 #ifdef GRPASSWD
5248         sv_setpv(sv, grent->gr_passwd);
5249 #endif
5250
5251         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5252         sv_setiv(sv, (IV)grent->gr_gid);
5253
5254         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5255         for (elem = grent->gr_mem; elem && *elem; elem++) {
5256             sv_catpv(sv, *elem);
5257             if (elem[1])
5258                 sv_catpvn(sv, " ", 1);
5259         }
5260     }
5261
5262     RETURN;
5263 #else
5264     DIE(aTHX_ PL_no_func, "getgrent");
5265 #endif
5266 }
5267
5268 PP(pp_sgrent)
5269 {
5270     djSP;
5271 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5272     setgrent();
5273     RETPUSHYES;
5274 #else
5275     DIE(aTHX_ PL_no_func, "setgrent");
5276 #endif
5277 }
5278
5279 PP(pp_egrent)
5280 {
5281     djSP;
5282 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5283     endgrent();
5284     RETPUSHYES;
5285 #else
5286     DIE(aTHX_ PL_no_func, "endgrent");
5287 #endif
5288 }
5289
5290 PP(pp_getlogin)
5291 {
5292     djSP; dTARGET;
5293 #ifdef HAS_GETLOGIN
5294     char *tmps;
5295     EXTEND(SP, 1);
5296     if (!(tmps = PerlProc_getlogin()))
5297         RETPUSHUNDEF;
5298     PUSHp(tmps, strlen(tmps));
5299     RETURN;
5300 #else
5301     DIE(aTHX_ PL_no_func, "getlogin");
5302 #endif
5303 }
5304
5305 /* Miscellaneous. */
5306
5307 PP(pp_syscall)
5308 {
5309 #ifdef HAS_SYSCALL
5310     djSP; dMARK; dORIGMARK; dTARGET;
5311     register I32 items = SP - MARK;
5312     unsigned long a[20];
5313     register I32 i = 0;
5314     I32 retval = -1;
5315     STRLEN n_a;
5316
5317     if (PL_tainting) {
5318         while (++MARK <= SP) {
5319             if (SvTAINTED(*MARK)) {
5320                 TAINT;
5321                 break;
5322             }
5323         }
5324         MARK = ORIGMARK;
5325         TAINT_PROPER("syscall");
5326     }
5327
5328     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5329      * or where sizeof(long) != sizeof(char*).  But such machines will
5330      * not likely have syscall implemented either, so who cares?
5331      */
5332     while (++MARK <= SP) {
5333         if (SvNIOK(*MARK) || !i)
5334             a[i++] = SvIV(*MARK);
5335         else if (*MARK == &PL_sv_undef)
5336             a[i++] = 0;
5337         else
5338             a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
5339         if (i > 15)
5340             break;
5341     }
5342     switch (items) {
5343     default:
5344         DIE(aTHX_ "Too many args to syscall");
5345     case 0:
5346         DIE(aTHX_ "Too few args to syscall");
5347     case 1:
5348         retval = syscall(a[0]);
5349         break;
5350     case 2:
5351         retval = syscall(a[0],a[1]);
5352         break;
5353     case 3:
5354         retval = syscall(a[0],a[1],a[2]);
5355         break;
5356     case 4:
5357         retval = syscall(a[0],a[1],a[2],a[3]);
5358         break;
5359     case 5:
5360         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5361         break;
5362     case 6:
5363         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5364         break;
5365     case 7:
5366         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5367         break;
5368     case 8:
5369         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5370         break;
5371 #ifdef atarist
5372     case 9:
5373         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5374         break;
5375     case 10:
5376         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5377         break;
5378     case 11:
5379         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5380           a[10]);
5381         break;
5382     case 12:
5383         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5384           a[10],a[11]);
5385         break;
5386     case 13:
5387         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5388           a[10],a[11],a[12]);
5389         break;
5390     case 14:
5391         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5392           a[10],a[11],a[12],a[13]);
5393         break;
5394 #endif /* atarist */
5395     }
5396     SP = ORIGMARK;
5397     PUSHi(retval);
5398     RETURN;
5399 #else
5400     DIE(aTHX_ PL_no_func, "syscall");
5401 #endif
5402 }
5403
5404 #ifdef FCNTL_EMULATE_FLOCK
5405
5406 /*  XXX Emulate flock() with fcntl().
5407     What's really needed is a good file locking module.
5408 */
5409
5410 static int
5411 fcntl_emulate_flock(int fd, int operation)
5412 {
5413     struct flock flock;
5414
5415     switch (operation & ~LOCK_NB) {
5416     case LOCK_SH:
5417         flock.l_type = F_RDLCK;
5418         break;
5419     case LOCK_EX:
5420         flock.l_type = F_WRLCK;
5421         break;
5422     case LOCK_UN:
5423         flock.l_type = F_UNLCK;
5424         break;
5425     default:
5426         errno = EINVAL;
5427         return -1;
5428     }
5429     flock.l_whence = SEEK_SET;
5430     flock.l_start = flock.l_len = (Off_t)0;
5431
5432     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5433 }
5434
5435 #endif /* FCNTL_EMULATE_FLOCK */
5436
5437 #ifdef LOCKF_EMULATE_FLOCK
5438
5439 /*  XXX Emulate flock() with lockf().  This is just to increase
5440     portability of scripts.  The calls are not completely
5441     interchangeable.  What's really needed is a good file
5442     locking module.
5443 */
5444
5445 /*  The lockf() constants might have been defined in <unistd.h>.
5446     Unfortunately, <unistd.h> causes troubles on some mixed
5447     (BSD/POSIX) systems, such as SunOS 4.1.3.
5448
5449    Further, the lockf() constants aren't POSIX, so they might not be
5450    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5451    just stick in the SVID values and be done with it.  Sigh.
5452 */
5453
5454 # ifndef F_ULOCK
5455 #  define F_ULOCK       0       /* Unlock a previously locked region */
5456 # endif
5457 # ifndef F_LOCK
5458 #  define F_LOCK        1       /* Lock a region for exclusive use */
5459 # endif
5460 # ifndef F_TLOCK
5461 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5462 # endif
5463 # ifndef F_TEST
5464 #  define F_TEST        3       /* Test a region for other processes locks */
5465 # endif
5466
5467 static int
5468 lockf_emulate_flock(int fd, int operation)
5469 {
5470     int i;
5471     int save_errno;
5472     Off_t pos;
5473
5474     /* flock locks entire file so for lockf we need to do the same      */
5475     save_errno = errno;
5476     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5477     if (pos > 0)        /* is seekable and needs to be repositioned     */
5478         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5479             pos = -1;   /* seek failed, so don't seek back afterwards   */
5480     errno = save_errno;
5481
5482     switch (operation) {
5483
5484         /* LOCK_SH - get a shared lock */
5485         case LOCK_SH:
5486         /* LOCK_EX - get an exclusive lock */
5487         case LOCK_EX:
5488             i = lockf (fd, F_LOCK, 0);
5489             break;
5490
5491         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5492         case LOCK_SH|LOCK_NB:
5493         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5494         case LOCK_EX|LOCK_NB:
5495             i = lockf (fd, F_TLOCK, 0);
5496             if (i == -1)
5497                 if ((errno == EAGAIN) || (errno == EACCES))
5498                     errno = EWOULDBLOCK;
5499             break;
5500
5501         /* LOCK_UN - unlock (non-blocking is a no-op) */
5502         case LOCK_UN:
5503         case LOCK_UN|LOCK_NB:
5504             i = lockf (fd, F_ULOCK, 0);
5505             break;
5506
5507         /* Default - can't decipher operation */
5508         default:
5509             i = -1;
5510             errno = EINVAL;
5511             break;
5512     }
5513
5514     if (pos > 0)      /* need to restore position of the handle */
5515         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5516
5517     return (i);
5518 }
5519
5520 #endif /* LOCKF_EMULATE_FLOCK */