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