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