pp_sys.c

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