pp_sys.c

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