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