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