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_evil_fh(gv, io, PL_op->op_type);
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_evil_fh(gv, io, PL_op->op_type);
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             report_evil_fh(gv, io, PL_op->op_type);
1635     }
1636     else if (PL_op->op_type == OP_SYSWRITE) {
1637         if (MARK < SP) {
1638             offset = SvIVx(*++MARK);
1639             if (offset < 0) {
1640                 if (-offset > blen)
1641                     DIE(aTHX_ "Offset outside string");
1642                 offset += blen;
1643             } else if (offset >= blen && blen > 0)
1644                 DIE(aTHX_ "Offset outside string");
1645         } else
1646             offset = 0;
1647         if (length > blen - offset)
1648             length = blen - offset;
1649 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1650         if (IoTYPE(io) == 's') {
1651             retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1652                                    buffer+offset, length, 0);
1653         }
1654         else
1655 #endif
1656         {
1657             /* See the note at doio.c:do_print about filesize limits. --jhi */
1658             retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1659                                    buffer+offset, length);
1660         }
1661     }
1662 #ifdef HAS_SOCKET
1663     else if (SP > MARK) {
1664         char *sockbuf;
1665         STRLEN mlen;
1666         sockbuf = SvPVx(*++MARK, mlen);
1667         retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1668                                  length, (struct sockaddr *)sockbuf, mlen);
1669     }
1670     else
1671         retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
1672
1673 #else
1674     else
1675         DIE(aTHX_ PL_no_sock_func, "send");
1676 #endif
1677     if (retval < 0)
1678         goto say_undef;
1679     SP = ORIGMARK;
1680 #if Size_t_size > IVSIZE
1681     PUSHn(retval);
1682 #else
1683     PUSHi(retval);
1684 #endif
1685     RETURN;
1686
1687   say_undef:
1688     SP = ORIGMARK;
1689     RETPUSHUNDEF;
1690 }
1691
1692 PP(pp_recv)
1693 {
1694     return pp_sysread();
1695 }
1696
1697 PP(pp_eof)
1698 {
1699     djSP;
1700     GV *gv;
1701     MAGIC *mg;
1702
1703     if (MAXARG == 0) {
1704         if (PL_op->op_flags & OPf_SPECIAL) {    /* eof() */
1705             IO *io;
1706             gv = PL_last_in_gv = PL_argvgv;
1707             io = GvIO(gv);
1708             if (io && !IoIFP(io)) {
1709                 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
1710                     IoLINES(io) = 0;
1711                     IoFLAGS(io) &= ~IOf_START;
1712                     do_open(gv, "-", 1, FALSE, O_RDONLY, 0, Nullfp);
1713                     sv_setpvn(GvSV(gv), "-", 1);
1714                     SvSETMAGIC(GvSV(gv));
1715                 }
1716                 else if (!nextargv(gv))
1717                     RETPUSHYES;
1718             }
1719         }
1720         else
1721             gv = PL_last_in_gv;                 /* eof */
1722     }
1723     else
1724         gv = PL_last_in_gv = (GV*)POPs;         /* eof(FH) */
1725
1726     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1727         PUSHMARK(SP);
1728         XPUSHs(SvTIED_obj((SV*)gv, mg));
1729         PUTBACK;
1730         ENTER;
1731         call_method("EOF", G_SCALAR);
1732         LEAVE;
1733         SPAGAIN;
1734         RETURN;
1735     }
1736
1737     PUSHs(boolSV(!gv || do_eof(gv)));
1738     RETURN;
1739 }
1740
1741 PP(pp_tell)
1742 {
1743     djSP; dTARGET;
1744     GV *gv;
1745     MAGIC *mg;
1746
1747     if (MAXARG == 0)
1748         gv = PL_last_in_gv;
1749     else
1750         gv = PL_last_in_gv = (GV*)POPs;
1751
1752     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1753         PUSHMARK(SP);
1754         XPUSHs(SvTIED_obj((SV*)gv, mg));
1755         PUTBACK;
1756         ENTER;
1757         call_method("TELL", G_SCALAR);
1758         LEAVE;
1759         SPAGAIN;
1760         RETURN;
1761     }
1762
1763 #if LSEEKSIZE > IVSIZE
1764     PUSHn( do_tell(gv) );
1765 #else
1766     PUSHi( do_tell(gv) );
1767 #endif
1768     RETURN;
1769 }
1770
1771 PP(pp_seek)
1772 {
1773     return pp_sysseek();
1774 }
1775
1776 PP(pp_sysseek)
1777 {
1778     djSP;
1779     GV *gv;
1780     int whence = POPi;
1781 #if LSEEKSIZE > IVSIZE
1782     Off_t offset = (Off_t)SvNVx(POPs);
1783 #else
1784     Off_t offset = (Off_t)SvIVx(POPs);
1785 #endif
1786     MAGIC *mg;
1787
1788     gv = PL_last_in_gv = (GV*)POPs;
1789
1790     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1791         PUSHMARK(SP);
1792         XPUSHs(SvTIED_obj((SV*)gv, mg));
1793 #if LSEEKSIZE > IVSIZE
1794         XPUSHs(sv_2mortal(newSVnv((NV) offset)));
1795 #else
1796         XPUSHs(sv_2mortal(newSViv(offset)));
1797 #endif
1798         XPUSHs(sv_2mortal(newSViv(whence)));
1799         PUTBACK;
1800         ENTER;
1801         call_method("SEEK", G_SCALAR);
1802         LEAVE;
1803         SPAGAIN;
1804         RETURN;
1805     }
1806
1807     if (PL_op->op_type == OP_SEEK)
1808         PUSHs(boolSV(do_seek(gv, offset, whence)));
1809     else {
1810         Off_t sought = do_sysseek(gv, offset, whence);
1811         if (sought < 0)
1812             PUSHs(&PL_sv_undef);
1813         else {
1814             SV* sv = sought ?
1815 #if LSEEKSIZE > IVSIZE
1816                 newSVnv((NV)sought)
1817 #else
1818                 newSViv(sought)
1819 #endif
1820                 : newSVpvn(zero_but_true, ZBTLEN);
1821             PUSHs(sv_2mortal(sv));
1822         }
1823     }
1824     RETURN;
1825 }
1826
1827 PP(pp_truncate)
1828 {
1829     djSP;
1830     /* There seems to be no consensus on the length type of truncate()
1831      * and ftruncate(), both off_t and size_t have supporters. In
1832      * general one would think that when using large files, off_t is
1833      * at least as wide as size_t, so using an off_t should be okay. */
1834     /* XXX Configure probe for the length type of *truncate() needed XXX */
1835     Off_t len;
1836     int result = 1;
1837     GV *tmpgv;
1838     STRLEN n_a;
1839
1840 #if Size_t_size > IVSIZE
1841     len = (Off_t)POPn;
1842 #else
1843     len = (Off_t)POPi;
1844 #endif
1845     /* Checking for length < 0 is problematic as the type might or
1846      * might not be signed: if it is not, clever compilers will moan. */
1847     /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
1848     SETERRNO(0,0);
1849 #if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
1850     if (PL_op->op_flags & OPf_SPECIAL) {
1851         tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
1852     do_ftruncate:
1853         TAINT_PROPER("truncate");
1854         if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)))
1855             result = 0;
1856         else {
1857             PerlIO_flush(IoIFP(GvIOp(tmpgv)));
1858 #ifdef HAS_TRUNCATE
1859             if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
1860 #else
1861             if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
1862 #endif
1863                 result = 0;
1864         }
1865     }
1866     else {
1867         SV *sv = POPs;
1868         char *name;
1869         STRLEN n_a;
1870
1871         if (SvTYPE(sv) == SVt_PVGV) {
1872             tmpgv = (GV*)sv;            /* *main::FRED for example */
1873             goto do_ftruncate;
1874         }
1875         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1876             tmpgv = (GV*) SvRV(sv);     /* \*main::FRED for example */
1877             goto do_ftruncate;
1878         }
1879
1880         name = SvPV(sv, n_a);
1881         TAINT_PROPER("truncate");
1882 #ifdef HAS_TRUNCATE
1883         if (truncate(name, len) < 0)
1884             result = 0;
1885 #else
1886         {
1887             int tmpfd;
1888             if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
1889                 result = 0;
1890             else {
1891                 if (my_chsize(tmpfd, len) < 0)
1892                     result = 0;
1893                 PerlLIO_close(tmpfd);
1894             }
1895         }
1896 #endif
1897     }
1898
1899     if (result)
1900         RETPUSHYES;
1901     if (!errno)
1902         SETERRNO(EBADF,RMS$_IFI);
1903     RETPUSHUNDEF;
1904 #else
1905     DIE(aTHX_ "truncate not implemented");
1906 #endif
1907 }
1908
1909 PP(pp_fcntl)
1910 {
1911     return pp_ioctl();
1912 }
1913
1914 PP(pp_ioctl)
1915 {
1916     djSP; dTARGET;
1917     SV *argsv = POPs;
1918     unsigned int func = U_I(POPn);
1919     int optype = PL_op->op_type;
1920     char *s;
1921     IV retval;
1922     GV *gv = (GV*)POPs;
1923     IO *io = GvIOn(gv);
1924
1925     if (!io || !argsv || !IoIFP(io)) {
1926         SETERRNO(EBADF,RMS$_IFI);       /* well, sort of... */
1927         RETPUSHUNDEF;
1928     }
1929
1930     if (SvPOK(argsv) || !SvNIOK(argsv)) {
1931         STRLEN len;
1932         STRLEN need;
1933         s = SvPV_force(argsv, len);
1934         need = IOCPARM_LEN(func);
1935         if (len < need) {
1936             s = Sv_Grow(argsv, need + 1);
1937             SvCUR_set(argsv, need);
1938         }
1939
1940         s[SvCUR(argsv)] = 17;   /* a little sanity check here */
1941     }
1942     else {
1943         retval = SvIV(argsv);
1944         s = INT2PTR(char*,retval);              /* ouch */
1945     }
1946
1947     TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
1948
1949     if (optype == OP_IOCTL)
1950 #ifdef HAS_IOCTL
1951         retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
1952 #else
1953         DIE(aTHX_ "ioctl is not implemented");
1954 #endif
1955     else
1956 #ifdef HAS_FCNTL
1957 #if defined(OS2) && defined(__EMX__)
1958         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
1959 #else
1960         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
1961 #endif
1962 #else
1963         DIE(aTHX_ "fcntl is not implemented");
1964 #endif
1965
1966     if (SvPOK(argsv)) {
1967         if (s[SvCUR(argsv)] != 17)
1968             DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
1969                 PL_op_name[optype]);
1970         s[SvCUR(argsv)] = 0;            /* put our null back */
1971         SvSETMAGIC(argsv);              /* Assume it has changed */
1972     }
1973
1974     if (retval == -1)
1975         RETPUSHUNDEF;
1976     if (retval != 0) {
1977         PUSHi(retval);
1978     }
1979     else {
1980         PUSHp(zero_but_true, ZBTLEN);
1981     }
1982     RETURN;
1983 }
1984
1985 PP(pp_flock)
1986 {
1987     djSP; dTARGET;
1988     I32 value;
1989     int argtype;
1990     GV *gv;
1991     IO *io = NULL;
1992     PerlIO *fp;
1993
1994 #ifdef FLOCK
1995     argtype = POPi;
1996     if (MAXARG == 0)
1997         gv = PL_last_in_gv;
1998     else
1999         gv = (GV*)POPs;
2000     if (gv && (io = GvIO(gv)))
2001         fp = IoIFP(io);
2002     else {
2003         fp = Nullfp;
2004         io = NULL;
2005     }
2006     if (fp) {
2007         (void)PerlIO_flush(fp);
2008         value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2009     }
2010     else {
2011         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2012             report_evil_fh(gv, io, PL_op->op_type);
2013         value = 0;
2014         SETERRNO(EBADF,RMS$_IFI);
2015     }
2016     PUSHi(value);
2017     RETURN;
2018 #else
2019     DIE(aTHX_ PL_no_func, "flock()");
2020 #endif
2021 }
2022
2023 /* Sockets. */
2024
2025 PP(pp_socket)
2026 {
2027     djSP;
2028 #ifdef HAS_SOCKET
2029     GV *gv;
2030     register IO *io;
2031     int protocol = POPi;
2032     int type = POPi;
2033     int domain = POPi;
2034     int fd;
2035
2036     gv = (GV*)POPs;
2037
2038     if (!gv) {
2039         SETERRNO(EBADF,LIB$_INVARG);
2040         RETPUSHUNDEF;
2041     }
2042
2043     io = GvIOn(gv);
2044     if (IoIFP(io))
2045         do_close(gv, FALSE);
2046
2047     TAINT_PROPER("socket");
2048     fd = PerlSock_socket(domain, type, protocol);
2049     if (fd < 0)
2050         RETPUSHUNDEF;
2051     IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
2052     IoOFP(io) = PerlIO_fdopen(fd, "w");
2053     IoTYPE(io) = 's';
2054     if (!IoIFP(io) || !IoOFP(io)) {
2055         if (IoIFP(io)) PerlIO_close(IoIFP(io));
2056         if (IoOFP(io)) PerlIO_close(IoOFP(io));
2057         if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2058         RETPUSHUNDEF;
2059     }
2060 #if defined(HAS_FCNTL) && defined(F_SETFD)
2061     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2062 #endif
2063
2064     RETPUSHYES;
2065 #else
2066     DIE(aTHX_ PL_no_sock_func, "socket");
2067 #endif
2068 }
2069
2070 PP(pp_sockpair)
2071 {
2072     djSP;
2073 #ifdef HAS_SOCKETPAIR
2074     GV *gv1;
2075     GV *gv2;
2076     register IO *io1;
2077     register IO *io2;
2078     int protocol = POPi;
2079     int type = POPi;
2080     int domain = POPi;
2081     int fd[2];
2082
2083     gv2 = (GV*)POPs;
2084     gv1 = (GV*)POPs;
2085     if (!gv1 || !gv2)
2086         RETPUSHUNDEF;
2087
2088     io1 = GvIOn(gv1);
2089     io2 = GvIOn(gv2);
2090     if (IoIFP(io1))
2091         do_close(gv1, FALSE);
2092     if (IoIFP(io2))
2093         do_close(gv2, FALSE);
2094
2095     TAINT_PROPER("socketpair");
2096     if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2097         RETPUSHUNDEF;
2098     IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
2099     IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
2100     IoTYPE(io1) = 's';
2101     IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
2102     IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
2103     IoTYPE(io2) = 's';
2104     if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2105         if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2106         if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2107         if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2108         if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2109         if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2110         if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2111         RETPUSHUNDEF;
2112     }
2113 #if defined(HAS_FCNTL) && defined(F_SETFD)
2114     fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);   /* ensure close-on-exec */
2115     fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);   /* ensure close-on-exec */
2116 #endif
2117
2118     RETPUSHYES;
2119 #else
2120     DIE(aTHX_ PL_no_sock_func, "socketpair");
2121 #endif
2122 }
2123
2124 PP(pp_bind)
2125 {
2126     djSP;
2127 #ifdef HAS_SOCKET
2128 #ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
2129     extern GETPRIVMODE();
2130     extern GETUSERMODE();
2131 #endif
2132     SV *addrsv = POPs;
2133     char *addr;
2134     GV *gv = (GV*)POPs;
2135     register IO *io = GvIOn(gv);
2136     STRLEN len;
2137     int bind_ok = 0;
2138 #ifdef MPE
2139     int mpeprivmode = 0;
2140 #endif
2141
2142     if (!io || !IoIFP(io))
2143         goto nuts;
2144
2145     addr = SvPV(addrsv, len);
2146     TAINT_PROPER("bind");
2147 #ifdef MPE /* Deal with MPE bind() peculiarities */
2148     if (((struct sockaddr *)addr)->sa_family == AF_INET) {
2149         /* The address *MUST* stupidly be zero. */
2150         ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
2151         /* PRIV mode is required to bind() to ports < 1024. */
2152         if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
2153             ((struct sockaddr_in *)addr)->sin_port > 0) {
2154             GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
2155             mpeprivmode = 1;
2156         }
2157     }
2158 #endif /* MPE */
2159     if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
2160                       (struct sockaddr *)addr, len) >= 0)
2161         bind_ok = 1;
2162
2163 #ifdef MPE /* Switch back to USER mode */
2164     if (mpeprivmode)
2165         GETUSERMODE();
2166 #endif /* MPE */
2167
2168     if (bind_ok)
2169         RETPUSHYES;
2170     else
2171         RETPUSHUNDEF;
2172
2173 nuts:
2174     if (ckWARN(WARN_CLOSED))
2175         report_evil_fh(gv, io, PL_op->op_type);
2176     SETERRNO(EBADF,SS$_IVCHAN);
2177     RETPUSHUNDEF;
2178 #else
2179     DIE(aTHX_ PL_no_sock_func, "bind");
2180 #endif
2181 }
2182
2183 PP(pp_connect)
2184 {
2185     djSP;
2186 #ifdef HAS_SOCKET
2187     SV *addrsv = POPs;
2188     char *addr;
2189     GV *gv = (GV*)POPs;
2190     register IO *io = GvIOn(gv);
2191     STRLEN len;
2192
2193     if (!io || !IoIFP(io))
2194         goto nuts;
2195
2196     addr = SvPV(addrsv, len);
2197     TAINT_PROPER("connect");
2198     if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2199         RETPUSHYES;
2200     else
2201         RETPUSHUNDEF;
2202
2203 nuts:
2204     if (ckWARN(WARN_CLOSED))
2205         report_evil_fh(gv, io, PL_op->op_type);
2206     SETERRNO(EBADF,SS$_IVCHAN);
2207     RETPUSHUNDEF;
2208 #else
2209     DIE(aTHX_ PL_no_sock_func, "connect");
2210 #endif
2211 }
2212
2213 PP(pp_listen)
2214 {
2215     djSP;
2216 #ifdef HAS_SOCKET
2217     int backlog = POPi;
2218     GV *gv = (GV*)POPs;
2219     register IO *io = GvIOn(gv);
2220
2221     if (!io || !IoIFP(io))
2222         goto nuts;
2223
2224     if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2225         RETPUSHYES;
2226     else
2227         RETPUSHUNDEF;
2228
2229 nuts:
2230     if (ckWARN(WARN_CLOSED))
2231         report_evil_fh(gv, io, PL_op->op_type);
2232     SETERRNO(EBADF,SS$_IVCHAN);
2233     RETPUSHUNDEF;
2234 #else
2235     DIE(aTHX_ PL_no_sock_func, "listen");
2236 #endif
2237 }
2238
2239 PP(pp_accept)
2240 {
2241     djSP; dTARGET;
2242 #ifdef HAS_SOCKET
2243     GV *ngv;
2244     GV *ggv;
2245     register IO *nstio;
2246     register IO *gstio;
2247     struct sockaddr saddr;      /* use a struct to avoid alignment problems */
2248     Sock_size_t len = sizeof saddr;
2249     int fd;
2250
2251     ggv = (GV*)POPs;
2252     ngv = (GV*)POPs;
2253
2254     if (!ngv)
2255         goto badexit;
2256     if (!ggv)
2257         goto nuts;
2258
2259     gstio = GvIO(ggv);
2260     if (!gstio || !IoIFP(gstio))
2261         goto nuts;
2262
2263     nstio = GvIOn(ngv);
2264     if (IoIFP(nstio))
2265         do_close(ngv, FALSE);
2266
2267     fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
2268     if (fd < 0)
2269         goto badexit;
2270     IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2271     IoOFP(nstio) = PerlIO_fdopen(fd, "w");
2272     IoTYPE(nstio) = 's';
2273     if (!IoIFP(nstio) || !IoOFP(nstio)) {
2274         if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2275         if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2276         if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2277         goto badexit;
2278     }
2279 #if defined(HAS_FCNTL) && defined(F_SETFD)
2280     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2281 #endif
2282
2283     PUSHp((char *)&saddr, len);
2284     RETURN;
2285
2286 nuts:
2287     if (ckWARN(WARN_CLOSED))
2288         report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2289     SETERRNO(EBADF,SS$_IVCHAN);
2290
2291 badexit:
2292     RETPUSHUNDEF;
2293
2294 #else
2295     DIE(aTHX_ PL_no_sock_func, "accept");
2296 #endif
2297 }
2298
2299 PP(pp_shutdown)
2300 {
2301     djSP; dTARGET;
2302 #ifdef HAS_SOCKET
2303     int how = POPi;
2304     GV *gv = (GV*)POPs;
2305     register IO *io = GvIOn(gv);
2306
2307     if (!io || !IoIFP(io))
2308         goto nuts;
2309
2310     PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2311     RETURN;
2312
2313 nuts:
2314     if (ckWARN(WARN_CLOSED))
2315         report_evil_fh(gv, io, PL_op->op_type);
2316     SETERRNO(EBADF,SS$_IVCHAN);
2317     RETPUSHUNDEF;
2318 #else
2319     DIE(aTHX_ PL_no_sock_func, "shutdown");
2320 #endif
2321 }
2322
2323 PP(pp_gsockopt)
2324 {
2325 #ifdef HAS_SOCKET
2326     return pp_ssockopt();
2327 #else
2328     DIE(aTHX_ PL_no_sock_func, "getsockopt");
2329 #endif
2330 }
2331
2332 PP(pp_ssockopt)
2333 {
2334     djSP;
2335 #ifdef HAS_SOCKET
2336     int optype = PL_op->op_type;
2337     SV *sv;
2338     int fd;
2339     unsigned int optname;
2340     unsigned int lvl;
2341     GV *gv;
2342     register IO *io;
2343     Sock_size_t len;
2344
2345     if (optype == OP_GSOCKOPT)
2346         sv = sv_2mortal(NEWSV(22, 257));
2347     else
2348         sv = POPs;
2349     optname = (unsigned int) POPi;
2350     lvl = (unsigned int) POPi;
2351
2352     gv = (GV*)POPs;
2353     io = GvIOn(gv);
2354     if (!io || !IoIFP(io))
2355         goto nuts;
2356
2357     fd = PerlIO_fileno(IoIFP(io));
2358     switch (optype) {
2359     case OP_GSOCKOPT:
2360         SvGROW(sv, 257);
2361         (void)SvPOK_only(sv);
2362         SvCUR_set(sv,256);
2363         *SvEND(sv) ='\0';
2364         len = SvCUR(sv);
2365         if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2366             goto nuts2;
2367         SvCUR_set(sv, len);
2368         *SvEND(sv) ='\0';
2369         PUSHs(sv);
2370         break;
2371     case OP_SSOCKOPT: {
2372             char *buf;
2373             int aint;
2374             if (SvPOKp(sv)) {
2375                 STRLEN l;
2376                 buf = SvPV(sv, l);
2377                 len = l;
2378             }
2379             else {
2380                 aint = (int)SvIV(sv);
2381                 buf = (char*)&aint;
2382                 len = sizeof(int);
2383             }
2384             if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2385                 goto nuts2;
2386             PUSHs(&PL_sv_yes);
2387         }
2388         break;
2389     }
2390     RETURN;
2391
2392 nuts:
2393     if (ckWARN(WARN_CLOSED))
2394         report_evil_fh(gv, io, optype);
2395     SETERRNO(EBADF,SS$_IVCHAN);
2396 nuts2:
2397     RETPUSHUNDEF;
2398
2399 #else
2400     DIE(aTHX_ PL_no_sock_func, "setsockopt");
2401 #endif
2402 }
2403
2404 PP(pp_getsockname)
2405 {
2406 #ifdef HAS_SOCKET
2407     return pp_getpeername();
2408 #else
2409     DIE(aTHX_ PL_no_sock_func, "getsockname");
2410 #endif
2411 }
2412
2413 PP(pp_getpeername)
2414 {
2415     djSP;
2416 #ifdef HAS_SOCKET
2417     int optype = PL_op->op_type;
2418     SV *sv;
2419     int fd;
2420     GV *gv = (GV*)POPs;
2421     register IO *io = GvIOn(gv);
2422     Sock_size_t len;
2423
2424     if (!io || !IoIFP(io))
2425         goto nuts;
2426
2427     sv = sv_2mortal(NEWSV(22, 257));
2428     (void)SvPOK_only(sv);
2429     len = 256;
2430     SvCUR_set(sv, len);
2431     *SvEND(sv) ='\0';
2432     fd = PerlIO_fileno(IoIFP(io));
2433     switch (optype) {
2434     case OP_GETSOCKNAME:
2435         if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2436             goto nuts2;
2437         break;
2438     case OP_GETPEERNAME:
2439         if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2440             goto nuts2;
2441 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2442         {
2443             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";
2444             /* If the call succeeded, make sure we don't have a zeroed port/addr */
2445             if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2446                 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2447                         sizeof(u_short) + sizeof(struct in_addr))) {
2448                 goto nuts2;
2449             }
2450         }
2451 #endif
2452         break;
2453     }
2454 #ifdef BOGUS_GETNAME_RETURN
2455     /* Interactive Unix, getpeername() and getsockname()
2456       does not return valid namelen */
2457     if (len == BOGUS_GETNAME_RETURN)
2458         len = sizeof(struct sockaddr);
2459 #endif
2460     SvCUR_set(sv, len);
2461     *SvEND(sv) ='\0';
2462     PUSHs(sv);
2463     RETURN;
2464
2465 nuts:
2466     if (ckWARN(WARN_CLOSED))
2467         report_evil_fh(gv, io, optype);
2468     SETERRNO(EBADF,SS$_IVCHAN);
2469 nuts2:
2470     RETPUSHUNDEF;
2471
2472 #else
2473     DIE(aTHX_ PL_no_sock_func, "getpeername");
2474 #endif
2475 }
2476
2477 /* Stat calls. */
2478
2479 PP(pp_lstat)
2480 {
2481     return pp_stat();
2482 }
2483
2484 PP(pp_stat)
2485 {
2486     djSP;
2487     GV *tmpgv;
2488     I32 gimme;
2489     I32 max = 13;
2490     STRLEN n_a;
2491
2492     if (PL_op->op_flags & OPf_REF) {
2493         tmpgv = cGVOP_gv;
2494         if (PL_op->op_type == OP_LSTAT && ckWARN(WARN_IO))
2495             Perl_warner(aTHX_ WARN_IO,
2496                         "lstat() on filehandle %s", GvENAME(tmpgv));
2497       do_fstat:
2498         if (tmpgv != PL_defgv) {
2499             PL_laststype = OP_STAT;
2500             PL_statgv = tmpgv;
2501             sv_setpv(PL_statname, "");
2502             PL_laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
2503                 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &PL_statcache) : -1);
2504         }
2505         if (PL_laststatval < 0) {
2506             if (ckWARN(WARN_UNOPENED))
2507                 Perl_warner(aTHX_ WARN_UNOPENED, "%s() on unopened filehandle %s",
2508                             PL_op_desc[PL_op->op_type], GvENAME(tmpgv));
2509             max = 0;
2510         }
2511     }
2512     else {
2513         SV* sv = POPs;
2514         if (SvTYPE(sv) == SVt_PVGV) {
2515             tmpgv = (GV*)sv;
2516             goto do_fstat;
2517         }
2518         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2519             tmpgv = (GV*)SvRV(sv);
2520             goto do_fstat;
2521         }
2522         sv_setpv(PL_statname, SvPV(sv,n_a));
2523         PL_statgv = Nullgv;
2524 #ifdef HAS_LSTAT
2525         PL_laststype = PL_op->op_type;
2526         if (PL_op->op_type == OP_LSTAT)
2527             PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
2528         else
2529 #endif
2530             PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
2531         if (PL_laststatval < 0) {
2532             if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
2533                 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
2534             max = 0;
2535         }
2536     }
2537
2538     gimme = GIMME_V;
2539     if (gimme != G_ARRAY) {
2540         if (gimme != G_VOID)
2541             XPUSHs(boolSV(max));
2542         RETURN;
2543     }
2544     if (max) {
2545         EXTEND(SP, max);
2546         EXTEND_MORTAL(max);
2547         PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2548         PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2549         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2550         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
2551 #if Uid_t_size > IVSIZE
2552         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2553 #else
2554 #   if Uid_t_sign <= 0
2555         PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2556 #   else
2557         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2558 #   endif
2559 #endif
2560 #if Gid_t_size > IVSIZE
2561         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2562 #else
2563 #   if Gid_t_sign <= 0
2564         PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2565 #   else
2566         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2567 #   endif
2568 #endif
2569 #ifdef USE_STAT_RDEV
2570         PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2571 #else
2572         PUSHs(sv_2mortal(newSVpvn("", 0)));
2573 #endif
2574 #if Off_t_size > IVSIZE
2575         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size)));
2576 #else
2577         PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2578 #endif
2579 #ifdef BIG_TIME
2580         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2581         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2582         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2583 #else
2584         PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2585         PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2586         PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
2587 #endif
2588 #ifdef USE_STAT_BLOCKS
2589         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2590         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
2591 #else
2592         PUSHs(sv_2mortal(newSVpvn("", 0)));
2593         PUSHs(sv_2mortal(newSVpvn("", 0)));
2594 #endif
2595     }
2596     RETURN;
2597 }
2598
2599 PP(pp_ftrread)
2600 {
2601     I32 result;
2602     djSP;
2603 #if defined(HAS_ACCESS) && defined(R_OK)
2604     STRLEN n_a;
2605     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2606         result = access(TOPpx, R_OK);
2607         if (result == 0)
2608             RETPUSHYES;
2609         if (result < 0)
2610             RETPUSHUNDEF;
2611         RETPUSHNO;
2612     }
2613     else
2614         result = my_stat();
2615 #else
2616     result = my_stat();
2617 #endif
2618     SPAGAIN;
2619     if (result < 0)
2620         RETPUSHUNDEF;
2621     if (cando(S_IRUSR, 0, &PL_statcache))
2622         RETPUSHYES;
2623     RETPUSHNO;
2624 }
2625
2626 PP(pp_ftrwrite)
2627 {
2628     I32 result;
2629     djSP;
2630 #if defined(HAS_ACCESS) && defined(W_OK)
2631     STRLEN n_a;
2632     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2633         result = access(TOPpx, W_OK);
2634         if (result == 0)
2635             RETPUSHYES;
2636         if (result < 0)
2637             RETPUSHUNDEF;
2638         RETPUSHNO;
2639     }
2640     else
2641         result = my_stat();
2642 #else
2643     result = my_stat();
2644 #endif
2645     SPAGAIN;
2646     if (result < 0)
2647         RETPUSHUNDEF;
2648     if (cando(S_IWUSR, 0, &PL_statcache))
2649         RETPUSHYES;
2650     RETPUSHNO;
2651 }
2652
2653 PP(pp_ftrexec)
2654 {
2655     I32 result;
2656     djSP;
2657 #if defined(HAS_ACCESS) && defined(X_OK)
2658     STRLEN n_a;
2659     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2660         result = access(TOPpx, X_OK);
2661         if (result == 0)
2662             RETPUSHYES;
2663         if (result < 0)
2664             RETPUSHUNDEF;
2665         RETPUSHNO;
2666     }
2667     else
2668         result = my_stat();
2669 #else
2670     result = my_stat();
2671 #endif
2672     SPAGAIN;
2673     if (result < 0)
2674         RETPUSHUNDEF;
2675     if (cando(S_IXUSR, 0, &PL_statcache))
2676         RETPUSHYES;
2677     RETPUSHNO;
2678 }
2679
2680 PP(pp_fteread)
2681 {
2682     I32 result;
2683     djSP;
2684 #ifdef PERL_EFF_ACCESS_R_OK
2685     STRLEN n_a;
2686     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2687         result = PERL_EFF_ACCESS_R_OK(TOPpx);
2688         if (result == 0)
2689             RETPUSHYES;
2690         if (result < 0)
2691             RETPUSHUNDEF;
2692         RETPUSHNO;
2693     }
2694     else
2695         result = my_stat();
2696 #else
2697     result = my_stat();
2698 #endif
2699     SPAGAIN;
2700     if (result < 0)
2701         RETPUSHUNDEF;
2702     if (cando(S_IRUSR, 1, &PL_statcache))
2703         RETPUSHYES;
2704     RETPUSHNO;
2705 }
2706
2707 PP(pp_ftewrite)
2708 {
2709     I32 result;
2710     djSP;
2711 #ifdef PERL_EFF_ACCESS_W_OK
2712     STRLEN n_a;
2713     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2714         result = PERL_EFF_ACCESS_W_OK(TOPpx);
2715         if (result == 0)
2716             RETPUSHYES;
2717         if (result < 0)
2718             RETPUSHUNDEF;
2719         RETPUSHNO;
2720     }
2721     else
2722         result = my_stat();
2723 #else
2724     result = my_stat();
2725 #endif
2726     SPAGAIN;
2727     if (result < 0)
2728         RETPUSHUNDEF;
2729     if (cando(S_IWUSR, 1, &PL_statcache))
2730         RETPUSHYES;
2731     RETPUSHNO;
2732 }
2733
2734 PP(pp_fteexec)
2735 {
2736     I32 result;
2737     djSP;
2738 #ifdef PERL_EFF_ACCESS_X_OK
2739     STRLEN n_a;
2740     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2741         result = PERL_EFF_ACCESS_X_OK(TOPpx);
2742         if (result == 0)
2743             RETPUSHYES;
2744         if (result < 0)
2745             RETPUSHUNDEF;
2746         RETPUSHNO;
2747     }
2748     else
2749         result = my_stat();
2750 #else
2751     result = my_stat();
2752 #endif
2753     SPAGAIN;
2754     if (result < 0)
2755         RETPUSHUNDEF;
2756     if (cando(S_IXUSR, 1, &PL_statcache))
2757         RETPUSHYES;
2758     RETPUSHNO;
2759 }
2760
2761 PP(pp_ftis)
2762 {
2763     I32 result = my_stat();
2764     djSP;
2765     if (result < 0)
2766         RETPUSHUNDEF;
2767     RETPUSHYES;
2768 }
2769
2770 PP(pp_fteowned)
2771 {
2772     return pp_ftrowned();
2773 }
2774
2775 PP(pp_ftrowned)
2776 {
2777     I32 result = my_stat();
2778     djSP;
2779     if (result < 0)
2780         RETPUSHUNDEF;
2781     if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
2782                                 PL_euid : PL_uid) )
2783         RETPUSHYES;
2784     RETPUSHNO;
2785 }
2786
2787 PP(pp_ftzero)
2788 {
2789     I32 result = my_stat();
2790     djSP;
2791     if (result < 0)
2792         RETPUSHUNDEF;
2793     if (PL_statcache.st_size == 0)
2794         RETPUSHYES;
2795     RETPUSHNO;
2796 }
2797
2798 PP(pp_ftsize)
2799 {
2800     I32 result = my_stat();
2801     djSP; dTARGET;
2802     if (result < 0)
2803         RETPUSHUNDEF;
2804 #if Off_t_size > IVSIZE
2805     PUSHn(PL_statcache.st_size);
2806 #else
2807     PUSHi(PL_statcache.st_size);
2808 #endif
2809     RETURN;
2810 }
2811
2812 PP(pp_ftmtime)
2813 {
2814     I32 result = my_stat();
2815     djSP; dTARGET;
2816     if (result < 0)
2817         RETPUSHUNDEF;
2818     PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
2819     RETURN;
2820 }
2821
2822 PP(pp_ftatime)
2823 {
2824     I32 result = my_stat();
2825     djSP; dTARGET;
2826     if (result < 0)
2827         RETPUSHUNDEF;
2828     PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
2829     RETURN;
2830 }
2831
2832 PP(pp_ftctime)
2833 {
2834     I32 result = my_stat();
2835     djSP; dTARGET;
2836     if (result < 0)
2837         RETPUSHUNDEF;
2838     PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
2839     RETURN;
2840 }
2841
2842 PP(pp_ftsock)
2843 {
2844     I32 result = my_stat();
2845     djSP;
2846     if (result < 0)
2847         RETPUSHUNDEF;
2848     if (S_ISSOCK(PL_statcache.st_mode))
2849         RETPUSHYES;
2850     RETPUSHNO;
2851 }
2852
2853 PP(pp_ftchr)
2854 {
2855     I32 result = my_stat();
2856     djSP;
2857     if (result < 0)
2858         RETPUSHUNDEF;
2859     if (S_ISCHR(PL_statcache.st_mode))
2860         RETPUSHYES;
2861     RETPUSHNO;
2862 }
2863
2864 PP(pp_ftblk)
2865 {
2866     I32 result = my_stat();
2867     djSP;
2868     if (result < 0)
2869         RETPUSHUNDEF;
2870     if (S_ISBLK(PL_statcache.st_mode))
2871         RETPUSHYES;
2872     RETPUSHNO;
2873 }
2874
2875 PP(pp_ftfile)
2876 {
2877     I32 result = my_stat();
2878     djSP;
2879     if (result < 0)
2880         RETPUSHUNDEF;
2881     if (S_ISREG(PL_statcache.st_mode))
2882         RETPUSHYES;
2883     RETPUSHNO;
2884 }
2885
2886 PP(pp_ftdir)
2887 {
2888     I32 result = my_stat();
2889     djSP;
2890     if (result < 0)
2891         RETPUSHUNDEF;
2892     if (S_ISDIR(PL_statcache.st_mode))
2893         RETPUSHYES;
2894     RETPUSHNO;
2895 }
2896
2897 PP(pp_ftpipe)
2898 {
2899     I32 result = my_stat();
2900     djSP;
2901     if (result < 0)
2902         RETPUSHUNDEF;
2903     if (S_ISFIFO(PL_statcache.st_mode))
2904         RETPUSHYES;
2905     RETPUSHNO;
2906 }
2907
2908 PP(pp_ftlink)
2909 {
2910     I32 result = my_lstat();
2911     djSP;
2912     if (result < 0)
2913         RETPUSHUNDEF;
2914     if (S_ISLNK(PL_statcache.st_mode))
2915         RETPUSHYES;
2916     RETPUSHNO;
2917 }
2918
2919 PP(pp_ftsuid)
2920 {
2921     djSP;
2922 #ifdef S_ISUID
2923     I32 result = my_stat();
2924     SPAGAIN;
2925     if (result < 0)
2926         RETPUSHUNDEF;
2927     if (PL_statcache.st_mode & S_ISUID)
2928         RETPUSHYES;
2929 #endif
2930     RETPUSHNO;
2931 }
2932
2933 PP(pp_ftsgid)
2934 {
2935     djSP;
2936 #ifdef S_ISGID
2937     I32 result = my_stat();
2938     SPAGAIN;
2939     if (result < 0)
2940         RETPUSHUNDEF;
2941     if (PL_statcache.st_mode & S_ISGID)
2942         RETPUSHYES;
2943 #endif
2944     RETPUSHNO;
2945 }
2946
2947 PP(pp_ftsvtx)
2948 {
2949     djSP;
2950 #ifdef S_ISVTX
2951     I32 result = my_stat();
2952     SPAGAIN;
2953     if (result < 0)
2954         RETPUSHUNDEF;
2955     if (PL_statcache.st_mode & S_ISVTX)
2956         RETPUSHYES;
2957 #endif
2958     RETPUSHNO;
2959 }
2960
2961 PP(pp_fttty)
2962 {
2963     djSP;
2964     int fd;
2965     GV *gv;
2966     char *tmps = Nullch;
2967     STRLEN n_a;
2968
2969     if (PL_op->op_flags & OPf_REF)
2970         gv = cGVOP_gv;
2971     else if (isGV(TOPs))
2972         gv = (GV*)POPs;
2973     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2974         gv = (GV*)SvRV(POPs);
2975     else
2976         gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
2977
2978     if (GvIO(gv) && IoIFP(GvIOp(gv)))
2979         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
2980     else if (tmps && isDIGIT(*tmps))
2981         fd = atoi(tmps);
2982     else
2983         RETPUSHUNDEF;
2984     if (PerlLIO_isatty(fd))
2985         RETPUSHYES;
2986     RETPUSHNO;
2987 }
2988
2989 #if defined(atarist) /* this will work with atariST. Configure will
2990                         make guesses for other systems. */
2991 # define FILE_base(f) ((f)->_base)
2992 # define FILE_ptr(f) ((f)->_ptr)
2993 # define FILE_cnt(f) ((f)->_cnt)
2994 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
2995 #endif
2996
2997 PP(pp_fttext)
2998 {
2999     djSP;
3000     I32 i;
3001     I32 len;
3002     I32 odd = 0;
3003     STDCHAR tbuf[512];
3004     register STDCHAR *s;
3005     register IO *io;
3006     register SV *sv;
3007     GV *gv;
3008     STRLEN n_a;
3009     PerlIO *fp;
3010
3011     if (PL_op->op_flags & OPf_REF)
3012         gv = cGVOP_gv;
3013     else if (isGV(TOPs))
3014         gv = (GV*)POPs;
3015     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3016         gv = (GV*)SvRV(POPs);
3017     else
3018         gv = Nullgv;
3019
3020     if (gv) {
3021         EXTEND(SP, 1);
3022         if (gv == PL_defgv) {
3023             if (PL_statgv)
3024                 io = GvIO(PL_statgv);
3025             else {
3026                 sv = PL_statname;
3027                 goto really_filename;
3028             }
3029         }
3030         else {
3031             PL_statgv = gv;
3032             PL_laststatval = -1;
3033             sv_setpv(PL_statname, "");
3034             io = GvIO(PL_statgv);
3035         }
3036         if (io && IoIFP(io)) {
3037             if (! PerlIO_has_base(IoIFP(io)))
3038                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3039             PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3040             if (PL_laststatval < 0)
3041                 RETPUSHUNDEF;
3042             if (S_ISDIR(PL_statcache.st_mode))  /* handle NFS glitch */
3043                 if (PL_op->op_type == OP_FTTEXT)
3044                     RETPUSHNO;
3045                 else
3046                     RETPUSHYES;
3047             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3048                 i = PerlIO_getc(IoIFP(io));
3049                 if (i != EOF)
3050                     (void)PerlIO_ungetc(IoIFP(io),i);
3051             }
3052             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3053                 RETPUSHYES;
3054             len = PerlIO_get_bufsiz(IoIFP(io));
3055             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3056             /* sfio can have large buffers - limit to 512 */
3057             if (len > 512)
3058                 len = 512;
3059         }
3060         else {
3061             if (ckWARN(WARN_UNOPENED)) {
3062                 gv = cGVOP_gv;
3063                 Perl_warner(aTHX_ WARN_UNOPENED, "%s on unopened filehandle %s",
3064                             PL_op_desc[PL_op->op_type], GvENAME(gv));
3065             }
3066             SETERRNO(EBADF,RMS$_IFI);
3067             RETPUSHUNDEF;
3068         }
3069     }
3070     else {
3071         sv = POPs;
3072       really_filename:
3073         PL_statgv = Nullgv;
3074         PL_laststatval = -1;
3075         sv_setpv(PL_statname, SvPV(sv, n_a));
3076         if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
3077             if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
3078                 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
3079             RETPUSHUNDEF;
3080         }
3081         PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3082         if (PL_laststatval < 0) {
3083             (void)PerlIO_close(fp);
3084             RETPUSHUNDEF;
3085         }
3086         do_binmode(fp, '<', O_BINARY);
3087         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3088         (void)PerlIO_close(fp);
3089         if (len <= 0) {
3090             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3091                 RETPUSHNO;              /* special case NFS directories */
3092             RETPUSHYES;         /* null file is anything */
3093         }
3094         s = tbuf;
3095     }
3096
3097     /* now scan s to look for textiness */
3098     /*   XXX ASCII dependent code */
3099
3100 #if defined(DOSISH) || defined(USEMYBINMODE)
3101     /* ignore trailing ^Z on short files */
3102     if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3103         --len;
3104 #endif
3105
3106     for (i = 0; i < len; i++, s++) {
3107         if (!*s) {                      /* null never allowed in text */
3108             odd += len;
3109             break;
3110         }
3111 #ifdef EBCDIC
3112         else if (!(isPRINT(*s) || isSPACE(*s)))
3113             odd++;
3114 #else
3115         else if (*s & 128) {
3116 #ifdef USE_LOCALE
3117             if ((PL_op->op_private & OPpLOCALE) && isALPHA_LC(*s))
3118                 continue;
3119 #endif
3120             /* utf8 characters don't count as odd */
3121             if (*s & 0x40) {
3122                 int ulen = UTF8SKIP(s);
3123                 if (ulen < len - i) {
3124                     int j;
3125                     for (j = 1; j < ulen; j++) {
3126                         if ((s[j] & 0xc0) != 0x80)
3127                             goto not_utf8;
3128                     }
3129                     --ulen;     /* loop does extra increment */
3130                     s += ulen;
3131                     i += ulen;
3132                     continue;
3133                 }
3134             }
3135           not_utf8:
3136             odd++;
3137         }
3138         else if (*s < 32 &&
3139           *s != '\n' && *s != '\r' && *s != '\b' &&
3140           *s != '\t' && *s != '\f' && *s != 27)
3141             odd++;
3142 #endif
3143     }
3144
3145     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3146         RETPUSHNO;
3147     else
3148         RETPUSHYES;
3149 }
3150
3151 PP(pp_ftbinary)
3152 {
3153     return pp_fttext();
3154 }
3155
3156 /* File calls. */
3157
3158 PP(pp_chdir)
3159 {
3160     djSP; dTARGET;
3161     char *tmps;
3162     SV **svp;
3163     STRLEN n_a;
3164
3165     if (MAXARG < 1)
3166         tmps = Nullch;
3167     else
3168         tmps = POPpx;
3169     if (!tmps || !*tmps) {
3170         svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
3171         if (svp)
3172             tmps = SvPV(*svp, n_a);
3173     }
3174     if (!tmps || !*tmps) {
3175         svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
3176         if (svp)
3177             tmps = SvPV(*svp, n_a);
3178     }
3179 #ifdef VMS
3180     if (!tmps || !*tmps) {
3181        svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
3182        if (svp)
3183            tmps = SvPV(*svp, n_a);
3184     }
3185 #endif
3186     TAINT_PROPER("chdir");
3187     PUSHi( PerlDir_chdir(tmps) >= 0 );
3188 #ifdef VMS
3189     /* Clear the DEFAULT element of ENV so we'll get the new value
3190      * in the future. */
3191     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3192 #endif
3193     RETURN;
3194 }
3195
3196 PP(pp_chown)
3197 {
3198     djSP; dMARK; dTARGET;
3199     I32 value;
3200 #ifdef HAS_CHOWN
3201     value = (I32)apply(PL_op->op_type, MARK, SP);
3202     SP = MARK;
3203     PUSHi(value);
3204     RETURN;
3205 #else
3206     DIE(aTHX_ PL_no_func, "Unsupported function chown");
3207 #endif
3208 }
3209
3210 PP(pp_chroot)
3211 {
3212     djSP; dTARGET;
3213     char *tmps;
3214 #ifdef HAS_CHROOT
3215     STRLEN n_a;
3216     tmps = POPpx;
3217     TAINT_PROPER("chroot");
3218     PUSHi( chroot(tmps) >= 0 );
3219     RETURN;
3220 #else
3221     DIE(aTHX_ PL_no_func, "chroot");
3222 #endif
3223 }
3224
3225 PP(pp_unlink)
3226 {
3227     djSP; dMARK; dTARGET;
3228     I32 value;
3229     value = (I32)apply(PL_op->op_type, MARK, SP);
3230     SP = MARK;
3231     PUSHi(value);
3232     RETURN;
3233 }
3234
3235 PP(pp_chmod)
3236 {
3237     djSP; dMARK; dTARGET;
3238     I32 value;
3239     value = (I32)apply(PL_op->op_type, MARK, SP);
3240     SP = MARK;
3241     PUSHi(value);
3242     RETURN;
3243 }
3244
3245 PP(pp_utime)
3246 {
3247     djSP; dMARK; dTARGET;
3248     I32 value;
3249     value = (I32)apply(PL_op->op_type, MARK, SP);
3250     SP = MARK;
3251     PUSHi(value);
3252     RETURN;
3253 }
3254
3255 PP(pp_rename)
3256 {
3257     djSP; dTARGET;
3258     int anum;
3259     STRLEN n_a;
3260
3261     char *tmps2 = POPpx;
3262     char *tmps = SvPV(TOPs, n_a);
3263     TAINT_PROPER("rename");
3264 #ifdef HAS_RENAME
3265     anum = PerlLIO_rename(tmps, tmps2);
3266 #else
3267     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3268         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3269             anum = 1;
3270         else {
3271             if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3272                 (void)UNLINK(tmps2);
3273             if (!(anum = link(tmps, tmps2)))
3274                 anum = UNLINK(tmps);
3275         }
3276     }
3277 #endif
3278     SETi( anum >= 0 );
3279     RETURN;
3280 }
3281
3282 PP(pp_link)
3283 {
3284     djSP; dTARGET;
3285 #ifdef HAS_LINK
3286     STRLEN n_a;
3287     char *tmps2 = POPpx;
3288     char *tmps = SvPV(TOPs, n_a);
3289     TAINT_PROPER("link");
3290     SETi( PerlLIO_link(tmps, tmps2) >= 0 );
3291 #else
3292     DIE(aTHX_ PL_no_func, "Unsupported function link");
3293 #endif
3294     RETURN;
3295 }
3296
3297 PP(pp_symlink)
3298 {
3299     djSP; dTARGET;
3300 #ifdef HAS_SYMLINK
3301     STRLEN n_a;
3302     char *tmps2 = POPpx;
3303     char *tmps = SvPV(TOPs, n_a);
3304     TAINT_PROPER("symlink");
3305     SETi( symlink(tmps, tmps2) >= 0 );
3306     RETURN;
3307 #else
3308     DIE(aTHX_ PL_no_func, "symlink");
3309 #endif
3310 }
3311
3312 PP(pp_readlink)
3313 {
3314     djSP; dTARGET;
3315 #ifdef HAS_SYMLINK
3316     char *tmps;
3317     char buf[MAXPATHLEN];
3318     int len;
3319     STRLEN n_a;
3320
3321 #ifndef INCOMPLETE_TAINTS
3322     TAINT;
3323 #endif
3324     tmps = POPpx;
3325     len = readlink(tmps, buf, sizeof buf);
3326     EXTEND(SP, 1);
3327     if (len < 0)
3328         RETPUSHUNDEF;
3329     PUSHp(buf, len);
3330     RETURN;
3331 #else
3332     EXTEND(SP, 1);
3333     RETSETUNDEF;                /* just pretend it's a normal file */
3334 #endif
3335 }
3336
3337 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3338 STATIC int
3339 S_dooneliner(pTHX_ char *cmd, char *filename)
3340 {
3341     char *save_filename = filename;
3342     char *cmdline;
3343     char *s;
3344     PerlIO *myfp;
3345     int anum = 1;
3346
3347     New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3348     strcpy(cmdline, cmd);
3349     strcat(cmdline, " ");
3350     for (s = cmdline + strlen(cmdline); *filename; ) {
3351         *s++ = '\\';
3352         *s++ = *filename++;
3353     }
3354     strcpy(s, " 2>&1");
3355     myfp = PerlProc_popen(cmdline, "r");
3356     Safefree(cmdline);
3357
3358     if (myfp) {
3359         SV *tmpsv = sv_newmortal();
3360         /* Need to save/restore 'PL_rs' ?? */
3361         s = sv_gets(tmpsv, myfp, 0);
3362         (void)PerlProc_pclose(myfp);
3363         if (s != Nullch) {
3364             int e;
3365             for (e = 1;
3366 #ifdef HAS_SYS_ERRLIST
3367                  e <= sys_nerr
3368 #endif
3369                  ; e++)
3370             {
3371                 /* you don't see this */
3372                 char *errmsg =
3373 #ifdef HAS_SYS_ERRLIST
3374                     sys_errlist[e]
3375 #else
3376                     strerror(e)
3377 #endif
3378                     ;
3379                 if (!errmsg)
3380                     break;
3381                 if (instr(s, errmsg)) {
3382                     SETERRNO(e,0);
3383                     return 0;
3384                 }
3385             }
3386             SETERRNO(0,0);
3387 #ifndef EACCES
3388 #define EACCES EPERM
3389 #endif
3390             if (instr(s, "cannot make"))
3391                 SETERRNO(EEXIST,RMS$_FEX);
3392             else if (instr(s, "existing file"))
3393                 SETERRNO(EEXIST,RMS$_FEX);
3394             else if (instr(s, "ile exists"))
3395                 SETERRNO(EEXIST,RMS$_FEX);
3396             else if (instr(s, "non-exist"))
3397                 SETERRNO(ENOENT,RMS$_FNF);
3398             else if (instr(s, "does not exist"))
3399                 SETERRNO(ENOENT,RMS$_FNF);
3400             else if (instr(s, "not empty"))
3401                 SETERRNO(EBUSY,SS$_DEVOFFLINE);
3402             else if (instr(s, "cannot access"))
3403                 SETERRNO(EACCES,RMS$_PRV);
3404             else
3405                 SETERRNO(EPERM,RMS$_PRV);
3406             return 0;
3407         }
3408         else {  /* some mkdirs return no failure indication */
3409             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3410             if (PL_op->op_type == OP_RMDIR)
3411                 anum = !anum;
3412             if (anum)
3413                 SETERRNO(0,0);
3414             else
3415                 SETERRNO(EACCES,RMS$_PRV);      /* a guess */
3416         }
3417         return anum;
3418     }
3419     else
3420         return 0;
3421 }
3422 #endif
3423
3424 PP(pp_mkdir)
3425 {
3426     djSP; dTARGET;
3427     int mode;
3428 #ifndef HAS_MKDIR
3429     int oldumask;
3430 #endif
3431     STRLEN n_a;
3432     char *tmps;
3433
3434     if (MAXARG > 1)
3435         mode = POPi;
3436     else
3437         mode = 0777;
3438
3439     tmps = SvPV(TOPs, n_a);
3440
3441     TAINT_PROPER("mkdir");
3442 #ifdef HAS_MKDIR
3443     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3444 #else
3445     SETi( dooneliner("mkdir", tmps) );
3446     oldumask = PerlLIO_umask(0);
3447     PerlLIO_umask(oldumask);
3448     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3449 #endif
3450     RETURN;
3451 }
3452
3453 PP(pp_rmdir)
3454 {
3455     djSP; dTARGET;
3456     char *tmps;
3457     STRLEN n_a;
3458
3459     tmps = POPpx;
3460     TAINT_PROPER("rmdir");
3461 #ifdef HAS_RMDIR
3462     XPUSHi( PerlDir_rmdir(tmps) >= 0 );
3463 #else
3464     XPUSHi( dooneliner("rmdir", tmps) );
3465 #endif
3466     RETURN;
3467 }
3468
3469 /* Directory calls. */
3470
3471 PP(pp_open_dir)
3472 {
3473     djSP;
3474 #if defined(Direntry_t) && defined(HAS_READDIR)
3475     STRLEN n_a;
3476     char *dirname = POPpx;
3477     GV *gv = (GV*)POPs;
3478     register IO *io = GvIOn(gv);
3479
3480     if (!io)
3481         goto nope;
3482
3483     if (IoDIRP(io))
3484         PerlDir_close(IoDIRP(io));
3485     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3486         goto nope;
3487
3488     RETPUSHYES;
3489 nope:
3490     if (!errno)
3491         SETERRNO(EBADF,RMS$_DIR);
3492     RETPUSHUNDEF;
3493 #else
3494     DIE(aTHX_ PL_no_dir_func, "opendir");
3495 #endif
3496 }
3497
3498 PP(pp_readdir)
3499 {
3500     djSP;
3501 #if defined(Direntry_t) && defined(HAS_READDIR)
3502 #ifndef I_DIRENT
3503     Direntry_t *readdir (DIR *);
3504 #endif
3505     register Direntry_t *dp;
3506     GV *gv = (GV*)POPs;
3507     register IO *io = GvIOn(gv);
3508     SV *sv;
3509
3510     if (!io || !IoDIRP(io))
3511         goto nope;
3512
3513     if (GIMME == G_ARRAY) {
3514         /*SUPPRESS 560*/
3515         while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
3516 #ifdef DIRNAMLEN
3517             sv = newSVpvn(dp->d_name, dp->d_namlen);
3518 #else
3519             sv = newSVpv(dp->d_name, 0);
3520 #endif
3521 #ifndef INCOMPLETE_TAINTS
3522             if (!(IoFLAGS(io) & IOf_UNTAINT))
3523                 SvTAINTED_on(sv);
3524 #endif
3525             XPUSHs(sv_2mortal(sv));
3526         }
3527     }
3528     else {
3529         if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
3530             goto nope;
3531 #ifdef DIRNAMLEN
3532         sv = newSVpvn(dp->d_name, dp->d_namlen);
3533 #else
3534         sv = newSVpv(dp->d_name, 0);
3535 #endif
3536 #ifndef INCOMPLETE_TAINTS
3537         if (!(IoFLAGS(io) & IOf_UNTAINT))
3538             SvTAINTED_on(sv);
3539 #endif
3540         XPUSHs(sv_2mortal(sv));
3541     }
3542     RETURN;
3543
3544 nope:
3545     if (!errno)
3546         SETERRNO(EBADF,RMS$_ISI);
3547     if (GIMME == G_ARRAY)
3548         RETURN;
3549     else
3550         RETPUSHUNDEF;
3551 #else
3552     DIE(aTHX_ PL_no_dir_func, "readdir");
3553 #endif
3554 }
3555
3556 PP(pp_telldir)
3557 {
3558     djSP; dTARGET;
3559 #if defined(HAS_TELLDIR) || defined(telldir)
3560  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3561  /* XXX netbsd still seemed to.
3562     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3563     --JHI 1999-Feb-02 */
3564 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3565     long telldir (DIR *);
3566 # endif
3567     GV *gv = (GV*)POPs;
3568     register IO *io = GvIOn(gv);
3569
3570     if (!io || !IoDIRP(io))
3571         goto nope;
3572
3573     PUSHi( PerlDir_tell(IoDIRP(io)) );
3574     RETURN;
3575 nope:
3576     if (!errno)
3577         SETERRNO(EBADF,RMS$_ISI);
3578     RETPUSHUNDEF;
3579 #else
3580     DIE(aTHX_ PL_no_dir_func, "telldir");
3581 #endif
3582 }
3583
3584 PP(pp_seekdir)
3585 {
3586     djSP;
3587 #if defined(HAS_SEEKDIR) || defined(seekdir)
3588     long along = POPl;
3589     GV *gv = (GV*)POPs;
3590     register IO *io = GvIOn(gv);
3591
3592     if (!io || !IoDIRP(io))
3593         goto nope;
3594
3595     (void)PerlDir_seek(IoDIRP(io), along);
3596
3597     RETPUSHYES;
3598 nope:
3599     if (!errno)
3600         SETERRNO(EBADF,RMS$_ISI);
3601     RETPUSHUNDEF;
3602 #else
3603     DIE(aTHX_ PL_no_dir_func, "seekdir");
3604 #endif
3605 }
3606
3607 PP(pp_rewinddir)
3608 {
3609     djSP;
3610 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3611     GV *gv = (GV*)POPs;
3612     register IO *io = GvIOn(gv);
3613
3614     if (!io || !IoDIRP(io))
3615         goto nope;
3616
3617     (void)PerlDir_rewind(IoDIRP(io));
3618     RETPUSHYES;
3619 nope:
3620     if (!errno)
3621         SETERRNO(EBADF,RMS$_ISI);
3622     RETPUSHUNDEF;
3623 #else
3624     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3625 #endif
3626 }
3627
3628 PP(pp_closedir)
3629 {
3630     djSP;
3631 #if defined(Direntry_t) && defined(HAS_READDIR)
3632     GV *gv = (GV*)POPs;
3633     register IO *io = GvIOn(gv);
3634
3635     if (!io || !IoDIRP(io))
3636         goto nope;
3637
3638 #ifdef VOID_CLOSEDIR
3639     PerlDir_close(IoDIRP(io));
3640 #else
3641     if (PerlDir_close(IoDIRP(io)) < 0) {
3642         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3643         goto nope;
3644     }
3645 #endif
3646     IoDIRP(io) = 0;
3647
3648     RETPUSHYES;
3649 nope:
3650     if (!errno)
3651         SETERRNO(EBADF,RMS$_IFI);
3652     RETPUSHUNDEF;
3653 #else
3654     DIE(aTHX_ PL_no_dir_func, "closedir");
3655 #endif
3656 }
3657
3658 /* Process control. */
3659
3660 PP(pp_fork)
3661 {
3662 #ifdef HAS_FORK
3663     djSP; dTARGET;
3664     Pid_t childpid;
3665     GV *tmpgv;
3666
3667     EXTEND(SP, 1);
3668     PERL_FLUSHALL_FOR_CHILD;
3669     childpid = fork();
3670     if (childpid < 0)
3671         RETSETUNDEF;
3672     if (!childpid) {
3673         /*SUPPRESS 560*/
3674         if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
3675             sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3676         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3677     }
3678     PUSHi(childpid);
3679     RETURN;
3680 #else
3681 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3682     djSP; dTARGET;
3683     Pid_t childpid;
3684
3685     EXTEND(SP, 1);
3686     PERL_FLUSHALL_FOR_CHILD;
3687     childpid = PerlProc_fork();
3688     if (childpid == -1)
3689         RETSETUNDEF;
3690     PUSHi(childpid);
3691     RETURN;
3692 #  else
3693     DIE(aTHX_ PL_no_func, "Unsupported function fork");
3694 #  endif
3695 #endif
3696 }
3697
3698 PP(pp_wait)
3699 {
3700 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3701     djSP; dTARGET;
3702     Pid_t childpid;
3703     int argflags;
3704
3705     childpid = wait4pid(-1, &argflags, 0);
3706     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3707     XPUSHi(childpid);
3708     RETURN;
3709 #else
3710     DIE(aTHX_ PL_no_func, "Unsupported function wait");
3711 #endif
3712 }
3713
3714 PP(pp_waitpid)
3715 {
3716 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3717     djSP; dTARGET;
3718     Pid_t childpid;
3719     int optype;
3720     int argflags;
3721
3722     optype = POPi;
3723     childpid = TOPi;
3724     childpid = wait4pid(childpid, &argflags, optype);
3725     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3726     SETi(childpid);
3727     RETURN;
3728 #else
3729     DIE(aTHX_ PL_no_func, "Unsupported function waitpid");
3730 #endif
3731 }
3732
3733 PP(pp_system)
3734 {
3735     djSP; dMARK; dORIGMARK; dTARGET;
3736     I32 value;
3737     Pid_t childpid;
3738     int result;
3739     int status;
3740     Sigsave_t ihand,qhand;     /* place to save signals during system() */
3741     STRLEN n_a;
3742     I32 did_pipes = 0;
3743     int pp[2];
3744
3745     if (SP - MARK == 1) {
3746         if (PL_tainting) {
3747             char *junk = SvPV(TOPs, n_a);
3748             TAINT_ENV();
3749             TAINT_PROPER("system");
3750         }
3751     }
3752     PERL_FLUSHALL_FOR_CHILD;
3753 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) && !defined(__CYGWIN__) || defined(PERL_MICRO)
3754     if (PerlProc_pipe(pp) >= 0)
3755         did_pipes = 1;
3756     while ((childpid = vfork()) == -1) {
3757         if (errno != EAGAIN) {
3758             value = -1;
3759             SP = ORIGMARK;
3760             PUSHi(value);
3761             if (did_pipes) {
3762                 PerlLIO_close(pp[0]);
3763                 PerlLIO_close(pp[1]);
3764             }
3765             RETURN;
3766         }
3767         sleep(5);
3768     }
3769     if (childpid > 0) {
3770         if (did_pipes)
3771             PerlLIO_close(pp[1]);
3772 #ifndef PERL_MICRO
3773         rsignal_save(SIGINT, SIG_IGN, &ihand);
3774         rsignal_save(SIGQUIT, SIG_IGN, &qhand);
3775 #endif
3776         do {
3777             result = wait4pid(childpid, &status, 0);
3778         } while (result == -1 && errno == EINTR);
3779 #ifndef PERL_MICRO
3780         (void)rsignal_restore(SIGINT, &ihand);
3781         (void)rsignal_restore(SIGQUIT, &qhand);
3782 #endif
3783         STATUS_NATIVE_SET(result == -1 ? -1 : status);
3784         do_execfree();  /* free any memory child malloced on vfork */
3785         SP = ORIGMARK;
3786         if (did_pipes) {
3787             int errkid;
3788             int n = 0, n1;
3789
3790             while (n < sizeof(int)) {
3791                 n1 = PerlLIO_read(pp[0],
3792                                   (void*)(((char*)&errkid)+n),
3793                                   (sizeof(int)) - n);
3794                 if (n1 <= 0)
3795                     break;
3796                 n += n1;
3797             }
3798             PerlLIO_close(pp[0]);
3799             if (n) {                    /* Error */
3800                 if (n != sizeof(int))
3801                     DIE(aTHX_ "panic: kid popen errno read");
3802                 errno = errkid;         /* Propagate errno from kid */
3803                 STATUS_CURRENT = -1;
3804             }
3805         }
3806         PUSHi(STATUS_CURRENT);
3807         RETURN;
3808     }
3809     if (did_pipes) {
3810         PerlLIO_close(pp[0]);
3811 #if defined(HAS_FCNTL) && defined(F_SETFD)
3812         fcntl(pp[1], F_SETFD, FD_CLOEXEC);
3813 #endif
3814     }
3815     if (PL_op->op_flags & OPf_STACKED) {
3816         SV *really = *++MARK;
3817         value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
3818     }
3819     else if (SP - MARK != 1)
3820         value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
3821     else {
3822         value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
3823     }
3824     PerlProc__exit(-1);
3825 #else /* ! FORK or VMS or OS/2 */
3826     if (PL_op->op_flags & OPf_STACKED) {
3827         SV *really = *++MARK;
3828         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
3829     }
3830     else if (SP - MARK != 1)
3831         value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
3832     else {
3833         value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
3834     }
3835     STATUS_NATIVE_SET(value);
3836     do_execfree();
3837     SP = ORIGMARK;
3838     PUSHi(STATUS_CURRENT);
3839 #endif /* !FORK or VMS */
3840     RETURN;
3841 }
3842
3843 PP(pp_exec)
3844 {
3845     djSP; dMARK; dORIGMARK; dTARGET;
3846     I32 value;
3847     STRLEN n_a;
3848
3849     PERL_FLUSHALL_FOR_CHILD;
3850     if (PL_op->op_flags & OPf_STACKED) {
3851         SV *really = *++MARK;
3852         value = (I32)do_aexec(really, MARK, SP);
3853     }
3854     else if (SP - MARK != 1)
3855 #ifdef VMS
3856         value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3857 #else
3858 #  ifdef __OPEN_VM
3859         {
3860            (void ) do_aspawn(Nullsv, MARK, SP);
3861            value = 0;
3862         }
3863 #  else
3864         value = (I32)do_aexec(Nullsv, MARK, SP);
3865 #  endif
3866 #endif
3867     else {
3868         if (PL_tainting) {
3869             char *junk = SvPV(*SP, n_a);
3870             TAINT_ENV();
3871             TAINT_PROPER("exec");
3872         }
3873 #ifdef VMS
3874         value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
3875 #else
3876 #  ifdef __OPEN_VM
3877         (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
3878         value = 0;
3879 #  else
3880         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
3881 #  endif
3882 #endif
3883     }
3884
3885 #if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3886     if (value >= 0)
3887         my_exit(value);
3888 #endif
3889
3890     SP = ORIGMARK;
3891     PUSHi(value);
3892     RETURN;
3893 }
3894
3895 PP(pp_kill)
3896 {
3897     djSP; dMARK; dTARGET;
3898     I32 value;
3899 #ifdef HAS_KILL
3900     value = (I32)apply(PL_op->op_type, MARK, SP);
3901     SP = MARK;
3902     PUSHi(value);
3903     RETURN;
3904 #else
3905     DIE(aTHX_ PL_no_func, "Unsupported function kill");
3906 #endif
3907 }
3908
3909 PP(pp_getppid)
3910 {
3911 #ifdef HAS_GETPPID
3912     djSP; dTARGET;
3913     XPUSHi( getppid() );
3914     RETURN;
3915 #else
3916     DIE(aTHX_ PL_no_func, "getppid");
3917 #endif
3918 }
3919
3920 PP(pp_getpgrp)
3921 {
3922 #ifdef HAS_GETPGRP
3923     djSP; dTARGET;
3924     Pid_t pid;
3925     Pid_t pgrp;
3926
3927     if (MAXARG < 1)
3928         pid = 0;
3929     else
3930         pid = SvIVx(POPs);
3931 #ifdef BSD_GETPGRP
3932     pgrp = (I32)BSD_GETPGRP(pid);
3933 #else
3934     if (pid != 0 && pid != PerlProc_getpid())
3935         DIE(aTHX_ "POSIX getpgrp can't take an argument");
3936     pgrp = getpgrp();
3937 #endif
3938     XPUSHi(pgrp);
3939     RETURN;
3940 #else
3941     DIE(aTHX_ PL_no_func, "getpgrp()");
3942 #endif
3943 }
3944
3945 PP(pp_setpgrp)
3946 {
3947 #ifdef HAS_SETPGRP
3948     djSP; dTARGET;
3949     Pid_t pgrp;
3950     Pid_t pid;
3951     if (MAXARG < 2) {
3952         pgrp = 0;
3953         pid = 0;
3954     }
3955     else {
3956         pgrp = POPi;
3957         pid = TOPi;
3958     }
3959
3960     TAINT_PROPER("setpgrp");
3961 #ifdef BSD_SETPGRP
3962     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
3963 #else
3964     if ((pgrp != 0 && pgrp != PerlProc_getpid())
3965         || (pid != 0 && pid != PerlProc_getpid()))
3966     {
3967         DIE(aTHX_ "setpgrp can't take arguments");
3968     }
3969     SETi( setpgrp() >= 0 );
3970 #endif /* USE_BSDPGRP */
3971     RETURN;
3972 #else
3973     DIE(aTHX_ PL_no_func, "setpgrp()");
3974 #endif
3975 }
3976
3977 PP(pp_getpriority)
3978 {
3979     djSP; dTARGET;
3980     int which;
3981     int who;
3982 #ifdef HAS_GETPRIORITY
3983     who = POPi;
3984     which = TOPi;
3985     SETi( getpriority(which, who) );
3986     RETURN;
3987 #else
3988     DIE(aTHX_ PL_no_func, "getpriority()");
3989 #endif
3990 }
3991
3992 PP(pp_setpriority)
3993 {
3994     djSP; dTARGET;
3995     int which;
3996     int who;
3997     int niceval;
3998 #ifdef HAS_SETPRIORITY
3999     niceval = POPi;
4000     who = POPi;
4001     which = TOPi;
4002     TAINT_PROPER("setpriority");
4003     SETi( setpriority(which, who, niceval) >= 0 );
4004     RETURN;
4005 #else
4006     DIE(aTHX_ PL_no_func, "setpriority()");
4007 #endif
4008 }
4009
4010 /* Time calls. */
4011
4012 PP(pp_time)
4013 {
4014     djSP; dTARGET;
4015 #ifdef BIG_TIME
4016     XPUSHn( time(Null(Time_t*)) );
4017 #else
4018     XPUSHi( time(Null(Time_t*)) );
4019 #endif
4020     RETURN;
4021 }
4022
4023 /* XXX The POSIX name is CLK_TCK; it is to be preferred
4024    to HZ.  Probably.  For now, assume that if the system
4025    defines HZ, it does so correctly.  (Will this break
4026    on VMS?)
4027    Probably we ought to use _sysconf(_SC_CLK_TCK), if
4028    it's supported.    --AD  9/96.
4029 */
4030
4031 #ifndef HZ
4032 #  ifdef CLK_TCK
4033 #    define HZ CLK_TCK
4034 #  else
4035 #    define HZ 60
4036 #  endif
4037 #endif
4038
4039 PP(pp_tms)
4040 {
4041     djSP;
4042
4043 #ifndef HAS_TIMES
4044     DIE(aTHX_ "times not implemented");
4045 #else
4046     EXTEND(SP, 4);
4047
4048 #ifndef VMS
4049     (void)PerlProc_times(&PL_timesbuf);
4050 #else
4051     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4052                                                    /* struct tms, though same data   */
4053                                                    /* is returned.                   */
4054 #endif
4055
4056     PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
4057     if (GIMME == G_ARRAY) {
4058         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4059         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4060         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
4061     }
4062     RETURN;
4063 #endif /* HAS_TIMES */
4064 }
4065
4066 PP(pp_localtime)
4067 {
4068     return pp_gmtime();
4069 }
4070
4071 PP(pp_gmtime)
4072 {
4073     djSP;
4074     Time_t when;
4075     struct tm *tmbuf;
4076     static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4077     static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4078                               "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4079
4080     if (MAXARG < 1)
4081         (void)time(&when);
4082     else
4083 #ifdef BIG_TIME
4084         when = (Time_t)SvNVx(POPs);
4085 #else
4086         when = (Time_t)SvIVx(POPs);
4087 #endif
4088
4089     if (PL_op->op_type == OP_LOCALTIME)
4090         tmbuf = localtime(&when);
4091     else
4092         tmbuf = gmtime(&when);
4093
4094     EXTEND(SP, 9);
4095     EXTEND_MORTAL(9);
4096     if (GIMME != G_ARRAY) {
4097         SV *tsv;
4098         if (!tmbuf)
4099             RETPUSHUNDEF;
4100         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4101                             dayname[tmbuf->tm_wday],
4102                             monname[tmbuf->tm_mon],
4103                             tmbuf->tm_mday,
4104                             tmbuf->tm_hour,
4105                             tmbuf->tm_min,
4106                             tmbuf->tm_sec,
4107                             tmbuf->tm_year + 1900);
4108         PUSHs(sv_2mortal(tsv));
4109     }
4110     else if (tmbuf) {
4111         PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4112         PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4113         PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4114         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4115         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4116         PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4117         PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4118         PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4119         PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4120     }
4121     RETURN;
4122 }
4123
4124 PP(pp_alarm)
4125 {
4126     djSP; dTARGET;
4127     int anum;
4128 #ifdef HAS_ALARM
4129     anum = POPi;
4130     anum = alarm((unsigned int)anum);
4131     EXTEND(SP, 1);
4132     if (anum < 0)
4133         RETPUSHUNDEF;
4134     PUSHi(anum);
4135     RETURN;
4136 #else
4137     DIE(aTHX_ PL_no_func, "Unsupported function alarm");
4138 #endif
4139 }
4140
4141 PP(pp_sleep)
4142 {
4143     djSP; dTARGET;
4144     I32 duration;
4145     Time_t lasttime;
4146     Time_t when;
4147
4148     (void)time(&lasttime);
4149     if (MAXARG < 1)
4150         PerlProc_pause();
4151     else {
4152         duration = POPi;
4153         PerlProc_sleep((unsigned int)duration);
4154     }
4155     (void)time(&when);
4156     XPUSHi(when - lasttime);
4157     RETURN;
4158 }
4159
4160 /* Shared memory. */
4161
4162 PP(pp_shmget)
4163 {
4164     return pp_semget();
4165 }
4166
4167 PP(pp_shmctl)
4168 {
4169     return pp_semctl();
4170 }
4171
4172 PP(pp_shmread)
4173 {
4174     return pp_shmwrite();
4175 }
4176
4177 PP(pp_shmwrite)
4178 {
4179 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4180     djSP; dMARK; dTARGET;
4181     I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
4182     SP = MARK;
4183     PUSHi(value);
4184     RETURN;
4185 #else
4186     return pp_semget();
4187 #endif
4188 }
4189
4190 /* Message passing. */
4191
4192 PP(pp_msgget)
4193 {
4194     return pp_semget();
4195 }
4196
4197 PP(pp_msgctl)
4198 {
4199     return pp_semctl();
4200 }
4201
4202 PP(pp_msgsnd)
4203 {
4204 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4205     djSP; dMARK; dTARGET;
4206     I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4207     SP = MARK;
4208     PUSHi(value);
4209     RETURN;
4210 #else
4211     return pp_semget();
4212 #endif
4213 }
4214
4215 PP(pp_msgrcv)
4216 {
4217 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4218     djSP; dMARK; dTARGET;
4219     I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4220     SP = MARK;
4221     PUSHi(value);
4222     RETURN;
4223 #else
4224     return pp_semget();
4225 #endif
4226 }
4227
4228 /* Semaphores. */
4229
4230 PP(pp_semget)
4231 {
4232 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4233     djSP; dMARK; dTARGET;
4234     int anum = do_ipcget(PL_op->op_type, MARK, SP);
4235     SP = MARK;
4236     if (anum == -1)
4237         RETPUSHUNDEF;
4238     PUSHi(anum);
4239     RETURN;
4240 #else
4241     DIE(aTHX_ "System V IPC is not implemented on this machine");
4242 #endif
4243 }
4244
4245 PP(pp_semctl)
4246 {
4247 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4248     djSP; dMARK; dTARGET;
4249     int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4250     SP = MARK;
4251     if (anum == -1)
4252         RETSETUNDEF;
4253     if (anum != 0) {
4254         PUSHi(anum);
4255     }
4256     else {
4257         PUSHp(zero_but_true, ZBTLEN);
4258     }
4259     RETURN;
4260 #else
4261     return pp_semget();
4262 #endif
4263 }
4264
4265 PP(pp_semop)
4266 {
4267 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4268     djSP; dMARK; dTARGET;
4269     I32 value = (I32)(do_semop(MARK, SP) >= 0);
4270     SP = MARK;
4271     PUSHi(value);
4272     RETURN;
4273 #else
4274     return pp_semget();
4275 #endif
4276 }
4277
4278 /* Get system info. */
4279
4280 PP(pp_ghbyname)
4281 {
4282 #ifdef HAS_GETHOSTBYNAME
4283     return pp_ghostent();
4284 #else
4285     DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4286 #endif
4287 }
4288
4289 PP(pp_ghbyaddr)
4290 {
4291 #ifdef HAS_GETHOSTBYADDR
4292     return pp_ghostent();
4293 #else
4294     DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4295 #endif
4296 }
4297
4298 PP(pp_ghostent)
4299 {
4300     djSP;
4301 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4302     I32 which = PL_op->op_type;
4303     register char **elem;
4304     register SV *sv;
4305 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4306     struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4307     struct hostent *PerlSock_gethostbyname(Netdb_name_t);
4308     struct hostent *PerlSock_gethostent(void);
4309 #endif
4310     struct hostent *hent;
4311     unsigned long len;
4312     STRLEN n_a;
4313
4314     EXTEND(SP, 10);
4315     if (which == OP_GHBYNAME)
4316 #ifdef HAS_GETHOSTBYNAME
4317         hent = PerlSock_gethostbyname(POPpx);
4318 #else
4319         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4320 #endif
4321     else if (which == OP_GHBYADDR) {
4322 #ifdef HAS_GETHOSTBYADDR
4323         int addrtype = POPi;
4324         SV *addrsv = POPs;
4325         STRLEN addrlen;
4326         Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen);
4327
4328         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4329 #else
4330         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4331 #endif
4332     }
4333     else
4334 #ifdef HAS_GETHOSTENT
4335         hent = PerlSock_gethostent();
4336 #else
4337         DIE(aTHX_ PL_no_sock_func, "gethostent");
4338 #endif
4339
4340 #ifdef HOST_NOT_FOUND
4341     if (!hent)
4342         STATUS_NATIVE_SET(h_errno);
4343 #endif
4344
4345     if (GIMME != G_ARRAY) {
4346         PUSHs(sv = sv_newmortal());
4347         if (hent) {
4348             if (which == OP_GHBYNAME) {
4349                 if (hent->h_addr)
4350                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4351             }
4352             else
4353                 sv_setpv(sv, (char*)hent->h_name);
4354         }
4355         RETURN;
4356     }
4357
4358     if (hent) {
4359         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4360         sv_setpv(sv, (char*)hent->h_name);
4361         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4362         for (elem = hent->h_aliases; elem && *elem; elem++) {
4363             sv_catpv(sv, *elem);
4364             if (elem[1])
4365                 sv_catpvn(sv, " ", 1);
4366         }
4367         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4368         sv_setiv(sv, (IV)hent->h_addrtype);
4369         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4370         len = hent->h_length;
4371         sv_setiv(sv, (IV)len);
4372 #ifdef h_addr
4373         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4374             XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
4375             sv_setpvn(sv, *elem, len);
4376         }
4377 #else
4378         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4379         if (hent->h_addr)
4380             sv_setpvn(sv, hent->h_addr, len);
4381 #endif /* h_addr */
4382     }
4383     RETURN;
4384 #else
4385     DIE(aTHX_ PL_no_sock_func, "gethostent");
4386 #endif
4387 }
4388
4389 PP(pp_gnbyname)
4390 {
4391 #ifdef HAS_GETNETBYNAME
4392     return pp_gnetent();
4393 #else
4394     DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4395 #endif
4396 }
4397
4398 PP(pp_gnbyaddr)
4399 {
4400 #ifdef HAS_GETNETBYADDR
4401     return pp_gnetent();
4402 #else
4403     DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4404 #endif
4405 }
4406
4407 PP(pp_gnetent)
4408 {
4409     djSP;
4410 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4411     I32 which = PL_op->op_type;
4412     register char **elem;
4413     register SV *sv;
4414 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4415     struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4416     struct netent *PerlSock_getnetbyname(Netdb_name_t);
4417     struct netent *PerlSock_getnetent(void);
4418 #endif
4419     struct netent *nent;
4420     STRLEN n_a;
4421
4422     if (which == OP_GNBYNAME)
4423 #ifdef HAS_GETNETBYNAME
4424         nent = PerlSock_getnetbyname(POPpx);
4425 #else
4426         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4427 #endif
4428     else if (which == OP_GNBYADDR) {
4429 #ifdef HAS_GETNETBYADDR
4430         int addrtype = POPi;
4431         Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
4432         nent = PerlSock_getnetbyaddr(addr, addrtype);
4433 #else
4434         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4435 #endif
4436     }
4437     else
4438 #ifdef HAS_GETNETENT
4439         nent = PerlSock_getnetent();
4440 #else
4441         DIE(aTHX_ PL_no_sock_func, "getnetent");
4442 #endif
4443
4444     EXTEND(SP, 4);
4445     if (GIMME != G_ARRAY) {
4446         PUSHs(sv = sv_newmortal());
4447         if (nent) {
4448             if (which == OP_GNBYNAME)
4449                 sv_setiv(sv, (IV)nent->n_net);
4450             else
4451                 sv_setpv(sv, nent->n_name);
4452         }
4453         RETURN;
4454     }
4455
4456     if (nent) {
4457         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4458         sv_setpv(sv, nent->n_name);
4459         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4460         for (elem = nent->n_aliases; elem && *elem; elem++) {
4461             sv_catpv(sv, *elem);
4462             if (elem[1])
4463                 sv_catpvn(sv, " ", 1);
4464         }
4465         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4466         sv_setiv(sv, (IV)nent->n_addrtype);
4467         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4468         sv_setiv(sv, (IV)nent->n_net);
4469     }
4470
4471     RETURN;
4472 #else
4473     DIE(aTHX_ PL_no_sock_func, "getnetent");
4474 #endif
4475 }
4476
4477 PP(pp_gpbyname)
4478 {
4479 #ifdef HAS_GETPROTOBYNAME
4480     return pp_gprotoent();
4481 #else
4482     DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4483 #endif
4484 }
4485
4486 PP(pp_gpbynumber)
4487 {
4488 #ifdef HAS_GETPROTOBYNUMBER
4489     return pp_gprotoent();
4490 #else
4491     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4492 #endif
4493 }
4494
4495 PP(pp_gprotoent)
4496 {
4497     djSP;
4498 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4499     I32 which = PL_op->op_type;
4500     register char **elem;
4501     register SV *sv;
4502 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4503     struct protoent *PerlSock_getprotobyname(Netdb_name_t);
4504     struct protoent *PerlSock_getprotobynumber(int);
4505     struct protoent *PerlSock_getprotoent(void);
4506 #endif
4507     struct protoent *pent;
4508     STRLEN n_a;
4509
4510     if (which == OP_GPBYNAME)
4511 #ifdef HAS_GETPROTOBYNAME
4512         pent = PerlSock_getprotobyname(POPpx);
4513 #else
4514         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4515 #endif
4516     else if (which == OP_GPBYNUMBER)
4517 #ifdef HAS_GETPROTOBYNUMBER
4518         pent = PerlSock_getprotobynumber(POPi);
4519 #else
4520     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4521 #endif
4522     else
4523 #ifdef HAS_GETPROTOENT
4524         pent = PerlSock_getprotoent();
4525 #else
4526         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4527 #endif
4528
4529     EXTEND(SP, 3);
4530     if (GIMME != G_ARRAY) {
4531         PUSHs(sv = sv_newmortal());
4532         if (pent) {
4533             if (which == OP_GPBYNAME)
4534                 sv_setiv(sv, (IV)pent->p_proto);
4535             else
4536                 sv_setpv(sv, pent->p_name);
4537         }
4538         RETURN;
4539     }
4540
4541     if (pent) {
4542         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4543         sv_setpv(sv, pent->p_name);
4544         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4545         for (elem = pent->p_aliases; elem && *elem; elem++) {
4546             sv_catpv(sv, *elem);
4547             if (elem[1])
4548                 sv_catpvn(sv, " ", 1);
4549         }
4550         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4551         sv_setiv(sv, (IV)pent->p_proto);
4552     }
4553
4554     RETURN;
4555 #else
4556     DIE(aTHX_ PL_no_sock_func, "getprotoent");
4557 #endif
4558 }
4559
4560 PP(pp_gsbyname)
4561 {
4562 #ifdef HAS_GETSERVBYNAME
4563     return pp_gservent();
4564 #else
4565     DIE(aTHX_ PL_no_sock_func, "getservbyname");
4566 #endif
4567 }
4568
4569 PP(pp_gsbyport)
4570 {
4571 #ifdef HAS_GETSERVBYPORT
4572     return pp_gservent();
4573 #else
4574     DIE(aTHX_ PL_no_sock_func, "getservbyport");
4575 #endif
4576 }
4577
4578 PP(pp_gservent)
4579 {
4580     djSP;
4581 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4582     I32 which = PL_op->op_type;
4583     register char **elem;
4584     register SV *sv;
4585 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4586     struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4587     struct servent *PerlSock_getservbyport(int, Netdb_name_t);
4588     struct servent *PerlSock_getservent(void);
4589 #endif
4590     struct servent *sent;
4591     STRLEN n_a;
4592
4593     if (which == OP_GSBYNAME) {
4594 #ifdef HAS_GETSERVBYNAME
4595         char *proto = POPpx;
4596         char *name = POPpx;
4597
4598         if (proto && !*proto)
4599             proto = Nullch;
4600
4601         sent = PerlSock_getservbyname(name, proto);
4602 #else
4603         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4604 #endif
4605     }
4606     else if (which == OP_GSBYPORT) {
4607 #ifdef HAS_GETSERVBYPORT
4608         char *proto = POPpx;
4609         unsigned short port = POPu;
4610
4611 #ifdef HAS_HTONS
4612         port = PerlSock_htons(port);
4613 #endif
4614         sent = PerlSock_getservbyport(port, proto);
4615 #else
4616         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4617 #endif
4618     }
4619     else
4620 #ifdef HAS_GETSERVENT
4621         sent = PerlSock_getservent();
4622 #else
4623         DIE(aTHX_ PL_no_sock_func, "getservent");
4624 #endif
4625
4626     EXTEND(SP, 4);
4627     if (GIMME != G_ARRAY) {
4628         PUSHs(sv = sv_newmortal());
4629         if (sent) {
4630             if (which == OP_GSBYNAME) {
4631 #ifdef HAS_NTOHS
4632                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4633 #else
4634                 sv_setiv(sv, (IV)(sent->s_port));
4635 #endif
4636             }
4637             else
4638                 sv_setpv(sv, sent->s_name);
4639         }
4640         RETURN;
4641     }
4642
4643     if (sent) {
4644         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4645         sv_setpv(sv, sent->s_name);
4646         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4647         for (elem = sent->s_aliases; elem && *elem; elem++) {
4648             sv_catpv(sv, *elem);
4649             if (elem[1])
4650                 sv_catpvn(sv, " ", 1);
4651         }
4652         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4653 #ifdef HAS_NTOHS
4654         sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4655 #else
4656         sv_setiv(sv, (IV)(sent->s_port));
4657 #endif
4658         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4659         sv_setpv(sv, sent->s_proto);
4660     }
4661
4662     RETURN;
4663 #else
4664     DIE(aTHX_ PL_no_sock_func, "getservent");
4665 #endif
4666 }
4667
4668 PP(pp_shostent)
4669 {
4670     djSP;
4671 #ifdef HAS_SETHOSTENT
4672     PerlSock_sethostent(TOPi);
4673     RETSETYES;
4674 #else
4675     DIE(aTHX_ PL_no_sock_func, "sethostent");
4676 #endif
4677 }
4678
4679 PP(pp_snetent)
4680 {
4681     djSP;
4682 #ifdef HAS_SETNETENT
4683     PerlSock_setnetent(TOPi);
4684     RETSETYES;
4685 #else
4686     DIE(aTHX_ PL_no_sock_func, "setnetent");
4687 #endif
4688 }
4689
4690 PP(pp_sprotoent)
4691 {
4692     djSP;
4693 #ifdef HAS_SETPROTOENT
4694     PerlSock_setprotoent(TOPi);
4695     RETSETYES;
4696 #else
4697     DIE(aTHX_ PL_no_sock_func, "setprotoent");
4698 #endif
4699 }
4700
4701 PP(pp_sservent)
4702 {
4703     djSP;
4704 #ifdef HAS_SETSERVENT
4705     PerlSock_setservent(TOPi);
4706     RETSETYES;
4707 #else
4708     DIE(aTHX_ PL_no_sock_func, "setservent");
4709 #endif
4710 }
4711
4712 PP(pp_ehostent)
4713 {
4714     djSP;
4715 #ifdef HAS_ENDHOSTENT
4716     PerlSock_endhostent();
4717     EXTEND(SP,1);
4718     RETPUSHYES;
4719 #else
4720     DIE(aTHX_ PL_no_sock_func, "endhostent");
4721 #endif
4722 }
4723
4724 PP(pp_enetent)
4725 {
4726     djSP;
4727 #ifdef HAS_ENDNETENT
4728     PerlSock_endnetent();
4729     EXTEND(SP,1);
4730     RETPUSHYES;
4731 #else
4732     DIE(aTHX_ PL_no_sock_func, "endnetent");
4733 #endif
4734 }
4735
4736 PP(pp_eprotoent)
4737 {
4738     djSP;
4739 #ifdef HAS_ENDPROTOENT
4740     PerlSock_endprotoent();
4741     EXTEND(SP,1);
4742     RETPUSHYES;
4743 #else
4744     DIE(aTHX_ PL_no_sock_func, "endprotoent");
4745 #endif
4746 }
4747
4748 PP(pp_eservent)
4749 {
4750     djSP;
4751 #ifdef HAS_ENDSERVENT
4752     PerlSock_endservent();
4753     EXTEND(SP,1);
4754     RETPUSHYES;
4755 #else
4756     DIE(aTHX_ PL_no_sock_func, "endservent");
4757 #endif
4758 }
4759
4760 PP(pp_gpwnam)
4761 {
4762 #ifdef HAS_PASSWD
4763     return pp_gpwent();
4764 #else
4765     DIE(aTHX_ PL_no_func, "getpwnam");
4766 #endif
4767 }
4768
4769 PP(pp_gpwuid)
4770 {
4771 #ifdef HAS_PASSWD
4772     return pp_gpwent();
4773 #else
4774     DIE(aTHX_ PL_no_func, "getpwuid");
4775 #endif
4776 }
4777
4778 PP(pp_gpwent)
4779 {
4780     djSP;
4781 #ifdef HAS_PASSWD
4782     I32 which = PL_op->op_type;
4783     register SV *sv;
4784     STRLEN n_a;
4785     struct passwd *pwent  = NULL;
4786     /*
4787      * We currently support only the SysV getsp* shadow password interface.
4788      * The interface is declared in <shadow.h> and often one needs to link
4789      * with -lsecurity or some such.
4790      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
4791      * (and SCO?)
4792      *
4793      * AIX getpwnam() is clever enough to return the encrypted password
4794      * only if the caller (euid?) is root.
4795      *
4796      * There are at least two other shadow password APIs.  Many platforms
4797      * seem to contain more than one interface for accessing the shadow
4798      * password databases, possibly for compatibility reasons.
4799      * The getsp*() is by far he simplest one, the other two interfaces
4800      * are much more complicated, but also very similar to each other.
4801      *
4802      * <sys/types.h>
4803      * <sys/security.h>
4804      * <prot.h>
4805      * struct pr_passwd *getprpw*();
4806      * The password is in
4807      * char getprpw*(...).ufld.fd_encrypt[]
4808      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
4809      *
4810      * <sys/types.h>
4811      * <sys/security.h>
4812      * <prot.h>
4813      * struct es_passwd *getespw*();
4814      * The password is in
4815      * char *(getespw*(...).ufld.fd_encrypt)
4816      * Mention HAS_GETESPWNAM here so that Configure probes for it.
4817      *
4818      * Mention I_PROT here so that Configure probes for it.
4819      *
4820      * In HP-UX for getprpw*() the manual page claims that one should include
4821      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
4822      * if one includes <shadow.h> as that includes <hpsecurity.h>,
4823      * and pp_sys.c already includes <shadow.h> if there is such.
4824      *
4825      * Note that <sys/security.h> is already probed for, but currently
4826      * it is only included in special cases.
4827      *
4828      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
4829      * be preferred interface, even though also the getprpw*() interface
4830      * is available) one needs to link with -lsecurity -ldb -laud -lm.
4831      * One also needs to call set_auth_parameters() in main() before
4832      * doing anything else, whether one is using getespw*() or getprpw*().
4833      *
4834      * Note that accessing the shadow databases can be magnitudes
4835      * slower than accessing the standard databases.
4836      *
4837      * --jhi
4838      */
4839
4840     switch (which) {
4841     case OP_GPWNAM:
4842         pwent  = getpwnam(POPpx);
4843         break;
4844     case OP_GPWUID:
4845         pwent = getpwuid((Uid_t)POPi);
4846         break;
4847     case OP_GPWENT:
4848 #   ifdef HAS_GETPWENT
4849         pwent  = getpwent();
4850 #   else
4851         DIE(aTHX_ PL_no_func, "getpwent");
4852 #   endif
4853         break;
4854     }
4855
4856     EXTEND(SP, 10);
4857     if (GIMME != G_ARRAY) {
4858         PUSHs(sv = sv_newmortal());
4859         if (pwent) {
4860             if (which == OP_GPWNAM)
4861 #   if Uid_t_sign <= 0
4862                 sv_setiv(sv, (IV)pwent->pw_uid);
4863 #   else
4864                 sv_setuv(sv, (UV)pwent->pw_uid);
4865 #   endif
4866             else
4867                 sv_setpv(sv, pwent->pw_name);
4868         }
4869         RETURN;
4870     }
4871
4872     if (pwent) {
4873         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4874         sv_setpv(sv, pwent->pw_name);
4875
4876         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4877         SvPOK_off(sv);
4878         /* If we have getspnam(), we try to dig up the shadow
4879          * password.  If we are underprivileged, the shadow
4880          * interface will set the errno to EACCES or similar,
4881          * and return a null pointer.  If this happens, we will
4882          * use the dummy password (usually "*" or "x") from the
4883          * standard password database.
4884          *
4885          * In theory we could skip the shadow call completely
4886          * if euid != 0 but in practice we cannot know which
4887          * security measures are guarding the shadow databases
4888          * on a random platform.
4889          *
4890          * Resist the urge to use additional shadow interfaces.
4891          * Divert the urge to writing an extension instead.
4892          *
4893          * --jhi */
4894 #   ifdef HAS_GETSPNAM
4895         {
4896             struct spwd *spwent;
4897             int saverrno; /* Save and restore errno so that
4898                            * underprivileged attempts seem
4899                            * to have never made the unsccessful
4900                            * attempt to retrieve the shadow password. */
4901
4902             saverrno = errno;
4903             spwent = getspnam(pwent->pw_name);
4904             errno = saverrno;
4905             if (spwent && spwent->sp_pwdp)
4906                 sv_setpv(sv, spwent->sp_pwdp);
4907         }
4908 #   endif
4909         if (!SvPOK(sv)) /* Use the standard password, then. */
4910             sv_setpv(sv, pwent->pw_passwd);
4911
4912 #   ifndef INCOMPLETE_TAINTS
4913         /* passwd is tainted because user himself can diddle with it.
4914          * admittedly not much and in a very limited way, but nevertheless. */
4915         SvTAINTED_on(sv);
4916 #   endif
4917
4918         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4919 #   if Uid_t_sign <= 0
4920         sv_setiv(sv, (IV)pwent->pw_uid);
4921 #   else
4922         sv_setuv(sv, (UV)pwent->pw_uid);
4923 #   endif
4924
4925         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4926 #   if Uid_t_sign <= 0
4927         sv_setiv(sv, (IV)pwent->pw_gid);
4928 #   else
4929         sv_setuv(sv, (UV)pwent->pw_gid);
4930 #   endif
4931         /* pw_change, pw_quota, and pw_age are mutually exclusive--
4932          * because of the poor interface of the Perl getpw*(),
4933          * not because there's some standard/convention saying so.
4934          * A better interface would have been to return a hash,
4935          * but we are accursed by our history, alas. --jhi.  */
4936         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4937 #   ifdef PWCHANGE
4938         sv_setiv(sv, (IV)pwent->pw_change);
4939 #   else
4940 #       ifdef PWQUOTA
4941         sv_setiv(sv, (IV)pwent->pw_quota);
4942 #       else
4943 #           ifdef PWAGE
4944         sv_setpv(sv, pwent->pw_age);
4945 #           endif
4946 #       endif
4947 #   endif
4948
4949         /* pw_class and pw_comment are mutually exclusive--.
4950          * see the above note for pw_change, pw_quota, and pw_age. */
4951         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4952 #   ifdef PWCLASS
4953         sv_setpv(sv, pwent->pw_class);
4954 #   else
4955 #       ifdef PWCOMMENT
4956         sv_setpv(sv, pwent->pw_comment);
4957 #       endif
4958 #   endif
4959
4960         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4961 #   ifdef PWGECOS
4962         sv_setpv(sv, pwent->pw_gecos);
4963 #   endif
4964 #   ifndef INCOMPLETE_TAINTS
4965         /* pw_gecos is tainted because user himself can diddle with it. */
4966         SvTAINTED_on(sv);
4967 #   endif
4968
4969         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4970         sv_setpv(sv, pwent->pw_dir);
4971
4972         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4973         sv_setpv(sv, pwent->pw_shell);
4974 #   ifndef INCOMPLETE_TAINTS
4975         /* pw_shell is tainted because user himself can diddle with it. */
4976         SvTAINTED_on(sv);
4977 #   endif
4978
4979 #   ifdef PWEXPIRE
4980         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4981         sv_setiv(sv, (IV)pwent->pw_expire);
4982 #   endif
4983     }
4984     RETURN;
4985 #else
4986     DIE(aTHX_ PL_no_func, "getpwent");
4987 #endif
4988 }
4989
4990 PP(pp_spwent)
4991 {
4992     djSP;
4993 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
4994     setpwent();
4995     RETPUSHYES;
4996 #else
4997     DIE(aTHX_ PL_no_func, "setpwent");
4998 #endif
4999 }
5000
5001 PP(pp_epwent)
5002 {
5003     djSP;
5004 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5005     endpwent();
5006     RETPUSHYES;
5007 #else
5008     DIE(aTHX_ PL_no_func, "endpwent");
5009 #endif
5010 }
5011
5012 PP(pp_ggrnam)
5013 {
5014 #ifdef HAS_GROUP
5015     return pp_ggrent();
5016 #else
5017     DIE(aTHX_ PL_no_func, "getgrnam");
5018 #endif
5019 }
5020
5021 PP(pp_ggrgid)
5022 {
5023 #ifdef HAS_GROUP
5024     return pp_ggrent();
5025 #else
5026     DIE(aTHX_ PL_no_func, "getgrgid");
5027 #endif
5028 }
5029
5030 PP(pp_ggrent)
5031 {
5032     djSP;
5033 #ifdef HAS_GROUP
5034     I32 which = PL_op->op_type;
5035     register char **elem;
5036     register SV *sv;
5037     struct group *grent;
5038     STRLEN n_a;
5039
5040     if (which == OP_GGRNAM)
5041         grent = (struct group *)getgrnam(POPpx);
5042     else if (which == OP_GGRGID)
5043         grent = (struct group *)getgrgid(POPi);
5044     else
5045 #ifdef HAS_GETGRENT
5046         grent = (struct group *)getgrent();
5047 #else
5048         DIE(aTHX_ PL_no_func, "getgrent");
5049 #endif
5050
5051     EXTEND(SP, 4);
5052     if (GIMME != G_ARRAY) {
5053         PUSHs(sv = sv_newmortal());
5054         if (grent) {
5055             if (which == OP_GGRNAM)
5056                 sv_setiv(sv, (IV)grent->gr_gid);
5057             else
5058                 sv_setpv(sv, grent->gr_name);
5059         }
5060         RETURN;
5061     }
5062
5063     if (grent) {
5064         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5065         sv_setpv(sv, grent->gr_name);
5066
5067         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5068 #ifdef GRPASSWD
5069         sv_setpv(sv, grent->gr_passwd);
5070 #endif
5071
5072         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5073         sv_setiv(sv, (IV)grent->gr_gid);
5074
5075         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5076         for (elem = grent->gr_mem; elem && *elem; elem++) {
5077             sv_catpv(sv, *elem);
5078             if (elem[1])
5079                 sv_catpvn(sv, " ", 1);
5080         }
5081     }
5082
5083     RETURN;
5084 #else
5085     DIE(aTHX_ PL_no_func, "getgrent");
5086 #endif
5087 }
5088
5089 PP(pp_sgrent)
5090 {
5091     djSP;
5092 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5093     setgrent();
5094     RETPUSHYES;
5095 #else
5096     DIE(aTHX_ PL_no_func, "setgrent");
5097 #endif
5098 }
5099
5100 PP(pp_egrent)
5101 {
5102     djSP;
5103 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5104     endgrent();
5105     RETPUSHYES;
5106 #else
5107     DIE(aTHX_ PL_no_func, "endgrent");
5108 #endif
5109 }
5110
5111 PP(pp_getlogin)
5112 {
5113     djSP; dTARGET;
5114 #ifdef HAS_GETLOGIN
5115     char *tmps;
5116     EXTEND(SP, 1);
5117     if (!(tmps = PerlProc_getlogin()))
5118         RETPUSHUNDEF;
5119     PUSHp(tmps, strlen(tmps));
5120     RETURN;
5121 #else
5122     DIE(aTHX_ PL_no_func, "getlogin");
5123 #endif
5124 }
5125
5126 /* Miscellaneous. */
5127
5128 PP(pp_syscall)
5129 {
5130 #ifdef HAS_SYSCALL
5131     djSP; dMARK; dORIGMARK; dTARGET;
5132     register I32 items = SP - MARK;
5133     unsigned long a[20];
5134     register I32 i = 0;
5135     I32 retval = -1;
5136     STRLEN n_a;
5137
5138     if (PL_tainting) {
5139         while (++MARK <= SP) {
5140             if (SvTAINTED(*MARK)) {
5141                 TAINT;
5142                 break;
5143             }
5144         }
5145         MARK = ORIGMARK;
5146         TAINT_PROPER("syscall");
5147     }
5148
5149     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5150      * or where sizeof(long) != sizeof(char*).  But such machines will
5151      * not likely have syscall implemented either, so who cares?
5152      */
5153     while (++MARK <= SP) {
5154         if (SvNIOK(*MARK) || !i)
5155             a[i++] = SvIV(*MARK);
5156         else if (*MARK == &PL_sv_undef)
5157             a[i++] = 0;
5158         else
5159             a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
5160         if (i > 15)
5161             break;
5162     }
5163     switch (items) {
5164     default:
5165         DIE(aTHX_ "Too many args to syscall");
5166     case 0:
5167         DIE(aTHX_ "Too few args to syscall");
5168     case 1:
5169         retval = syscall(a[0]);
5170         break;
5171     case 2:
5172         retval = syscall(a[0],a[1]);
5173         break;
5174     case 3:
5175         retval = syscall(a[0],a[1],a[2]);
5176         break;
5177     case 4:
5178         retval = syscall(a[0],a[1],a[2],a[3]);
5179         break;
5180     case 5:
5181         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5182         break;
5183     case 6:
5184         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5185         break;
5186     case 7:
5187         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5188         break;
5189     case 8:
5190         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5191         break;
5192 #ifdef atarist
5193     case 9:
5194         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5195         break;
5196     case 10:
5197         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5198         break;
5199     case 11:
5200         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5201           a[10]);
5202         break;
5203     case 12:
5204         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5205           a[10],a[11]);
5206         break;
5207     case 13:
5208         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5209           a[10],a[11],a[12]);
5210         break;
5211     case 14:
5212         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5213           a[10],a[11],a[12],a[13]);
5214         break;
5215 #endif /* atarist */
5216     }
5217     SP = ORIGMARK;
5218     PUSHi(retval);
5219     RETURN;
5220 #else
5221     DIE(aTHX_ PL_no_func, "syscall");
5222 #endif
5223 }
5224
5225 #ifdef FCNTL_EMULATE_FLOCK
5226
5227 /*  XXX Emulate flock() with fcntl().
5228     What's really needed is a good file locking module.
5229 */
5230
5231 static int
5232 fcntl_emulate_flock(int fd, int operation)
5233 {
5234     struct flock flock;
5235
5236     switch (operation & ~LOCK_NB) {
5237     case LOCK_SH:
5238         flock.l_type = F_RDLCK;
5239         break;
5240     case LOCK_EX:
5241         flock.l_type = F_WRLCK;
5242         break;
5243     case LOCK_UN:
5244         flock.l_type = F_UNLCK;
5245         break;
5246     default:
5247         errno = EINVAL;
5248         return -1;
5249     }
5250     flock.l_whence = SEEK_SET;
5251     flock.l_start = flock.l_len = (Off_t)0;
5252
5253     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5254 }
5255
5256 #endif /* FCNTL_EMULATE_FLOCK */
5257
5258 #ifdef LOCKF_EMULATE_FLOCK
5259
5260 /*  XXX Emulate flock() with lockf().  This is just to increase
5261     portability of scripts.  The calls are not completely
5262     interchangeable.  What's really needed is a good file
5263     locking module.
5264 */
5265
5266 /*  The lockf() constants might have been defined in <unistd.h>.
5267     Unfortunately, <unistd.h> causes troubles on some mixed
5268     (BSD/POSIX) systems, such as SunOS 4.1.3.
5269
5270    Further, the lockf() constants aren't POSIX, so they might not be
5271    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5272    just stick in the SVID values and be done with it.  Sigh.
5273 */
5274
5275 # ifndef F_ULOCK
5276 #  define F_ULOCK       0       /* Unlock a previously locked region */
5277 # endif
5278 # ifndef F_LOCK
5279 #  define F_LOCK        1       /* Lock a region for exclusive use */
5280 # endif
5281 # ifndef F_TLOCK
5282 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5283 # endif
5284 # ifndef F_TEST
5285 #  define F_TEST        3       /* Test a region for other processes locks */
5286 # endif
5287
5288 static int
5289 lockf_emulate_flock(int fd, int operation)
5290 {
5291     int i;
5292     int save_errno;
5293     Off_t pos;
5294
5295     /* flock locks entire file so for lockf we need to do the same      */
5296     save_errno = errno;
5297     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5298     if (pos > 0)        /* is seekable and needs to be repositioned     */
5299         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5300             pos = -1;   /* seek failed, so don't seek back afterwards   */
5301     errno = save_errno;
5302
5303     switch (operation) {
5304
5305         /* LOCK_SH - get a shared lock */
5306         case LOCK_SH:
5307         /* LOCK_EX - get an exclusive lock */
5308         case LOCK_EX:
5309             i = lockf (fd, F_LOCK, 0);
5310             break;
5311
5312         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5313         case LOCK_SH|LOCK_NB:
5314         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5315         case LOCK_EX|LOCK_NB:
5316             i = lockf (fd, F_TLOCK, 0);
5317             if (i == -1)
5318                 if ((errno == EAGAIN) || (errno == EACCES))
5319                     errno = EWOULDBLOCK;
5320             break;
5321
5322         /* LOCK_UN - unlock (non-blocking is a no-op) */
5323         case LOCK_UN:
5324         case LOCK_UN|LOCK_NB:
5325             i = lockf (fd, F_ULOCK, 0);
5326             break;
5327
5328         /* Default - can't decipher operation */
5329         default:
5330             i = -1;
5331             errno = EINVAL;
5332             break;
5333     }
5334
5335     if (pos > 0)      /* need to restore position of the handle */
5336         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5337
5338     return (i);
5339 }
5340
5341 #endif /* LOCKF_EMULATE_FLOCK */