pp_sys.c

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