pp_sys.c

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