pp_sys.c

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