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