pp_sys.c

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