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