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