pp_sys.c

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