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