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