pp_sys.c

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