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) {
2561             if (PL_laststype != OP_LSTAT)
2562                 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2563             if (ckWARN(WARN_IO) && gv != PL_defgv)
2564                 Perl_warner(aTHX_ WARN_IO,
2565                         "lstat() on filehandle %s", GvENAME(gv));
2566                 /* Perl_my_lstat (-l) croak's on filehandle, why warn here? */
2567         }
2568
2569       do_fstat:
2570         if (gv != PL_defgv) {
2571             PL_laststype = OP_STAT;
2572             PL_statgv = gv;
2573             sv_setpv(PL_statname, "");
2574             PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv))
2575                 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
2576         }
2577         if (PL_laststatval < 0) {
2578             dTHR;
2579             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2580                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2581             max = 0;
2582         }
2583     }
2584     else {
2585         SV* sv = POPs;
2586         if (SvTYPE(sv) == SVt_PVGV) {
2587             gv = (GV*)sv;
2588             goto do_fstat;
2589         }
2590         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2591             gv = (GV*)SvRV(sv);
2592             goto do_fstat;
2593         }
2594         sv_setpv(PL_statname, SvPV(sv,n_a));
2595         PL_statgv = Nullgv;
2596 #ifdef HAS_LSTAT
2597         PL_laststype = PL_op->op_type;
2598         if (PL_op->op_type == OP_LSTAT)
2599             PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
2600         else
2601 #endif
2602             PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
2603         if (PL_laststatval < 0) {
2604             if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
2605                 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
2606             max = 0;
2607         }
2608     }
2609
2610     gimme = GIMME_V;
2611     if (gimme != G_ARRAY) {
2612         if (gimme != G_VOID)
2613             XPUSHs(boolSV(max));
2614         RETURN;
2615     }
2616     if (max) {
2617         EXTEND(SP, max);
2618         EXTEND_MORTAL(max);
2619         PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2620         PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2621         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2622         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
2623 #if Uid_t_size > IVSIZE
2624         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2625 #else
2626 #   if Uid_t_sign <= 0
2627         PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2628 #   else
2629         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2630 #   endif
2631 #endif
2632 #if Gid_t_size > IVSIZE
2633         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2634 #else
2635 #   if Gid_t_sign <= 0
2636         PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2637 #   else
2638         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2639 #   endif
2640 #endif
2641 #ifdef USE_STAT_RDEV
2642         PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2643 #else
2644         PUSHs(sv_2mortal(newSVpvn("", 0)));
2645 #endif
2646 #if Off_t_size > IVSIZE
2647         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size)));
2648 #else
2649         PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2650 #endif
2651 #ifdef BIG_TIME
2652         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2653         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2654         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2655 #else
2656         PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2657         PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2658         PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
2659 #endif
2660 #ifdef USE_STAT_BLOCKS
2661         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2662         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
2663 #else
2664         PUSHs(sv_2mortal(newSVpvn("", 0)));
2665         PUSHs(sv_2mortal(newSVpvn("", 0)));
2666 #endif
2667     }
2668     RETURN;
2669 }
2670
2671 PP(pp_ftrread)
2672 {
2673     I32 result;
2674     djSP;
2675 #if defined(HAS_ACCESS) && defined(R_OK)
2676     STRLEN n_a;
2677     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2678         result = access(TOPpx, R_OK);
2679         if (result == 0)
2680             RETPUSHYES;
2681         if (result < 0)
2682             RETPUSHUNDEF;
2683         RETPUSHNO;
2684     }
2685     else
2686         result = my_stat();
2687 #else
2688     result = my_stat();
2689 #endif
2690     SPAGAIN;
2691     if (result < 0)
2692         RETPUSHUNDEF;
2693     if (cando(S_IRUSR, 0, &PL_statcache))
2694         RETPUSHYES;
2695     RETPUSHNO;
2696 }
2697
2698 PP(pp_ftrwrite)
2699 {
2700     I32 result;
2701     djSP;
2702 #if defined(HAS_ACCESS) && defined(W_OK)
2703     STRLEN n_a;
2704     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2705         result = access(TOPpx, W_OK);
2706         if (result == 0)
2707             RETPUSHYES;
2708         if (result < 0)
2709             RETPUSHUNDEF;
2710         RETPUSHNO;
2711     }
2712     else
2713         result = my_stat();
2714 #else
2715     result = my_stat();
2716 #endif
2717     SPAGAIN;
2718     if (result < 0)
2719         RETPUSHUNDEF;
2720     if (cando(S_IWUSR, 0, &PL_statcache))
2721         RETPUSHYES;
2722     RETPUSHNO;
2723 }
2724
2725 PP(pp_ftrexec)
2726 {
2727     I32 result;
2728     djSP;
2729 #if defined(HAS_ACCESS) && defined(X_OK)
2730     STRLEN n_a;
2731     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2732         result = access(TOPpx, X_OK);
2733         if (result == 0)
2734             RETPUSHYES;
2735         if (result < 0)
2736             RETPUSHUNDEF;
2737         RETPUSHNO;
2738     }
2739     else
2740         result = my_stat();
2741 #else
2742     result = my_stat();
2743 #endif
2744     SPAGAIN;
2745     if (result < 0)
2746         RETPUSHUNDEF;
2747     if (cando(S_IXUSR, 0, &PL_statcache))
2748         RETPUSHYES;
2749     RETPUSHNO;
2750 }
2751
2752 PP(pp_fteread)
2753 {
2754     I32 result;
2755     djSP;
2756 #ifdef PERL_EFF_ACCESS_R_OK
2757     STRLEN n_a;
2758     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2759         result = PERL_EFF_ACCESS_R_OK(TOPpx);
2760         if (result == 0)
2761             RETPUSHYES;
2762         if (result < 0)
2763             RETPUSHUNDEF;
2764         RETPUSHNO;
2765     }
2766     else
2767         result = my_stat();
2768 #else
2769     result = my_stat();
2770 #endif
2771     SPAGAIN;
2772     if (result < 0)
2773         RETPUSHUNDEF;
2774     if (cando(S_IRUSR, 1, &PL_statcache))
2775         RETPUSHYES;
2776     RETPUSHNO;
2777 }
2778
2779 PP(pp_ftewrite)
2780 {
2781     I32 result;
2782     djSP;
2783 #ifdef PERL_EFF_ACCESS_W_OK
2784     STRLEN n_a;
2785     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2786         result = PERL_EFF_ACCESS_W_OK(TOPpx);
2787         if (result == 0)
2788             RETPUSHYES;
2789         if (result < 0)
2790             RETPUSHUNDEF;
2791         RETPUSHNO;
2792     }
2793     else
2794         result = my_stat();
2795 #else
2796     result = my_stat();
2797 #endif
2798     SPAGAIN;
2799     if (result < 0)
2800         RETPUSHUNDEF;
2801     if (cando(S_IWUSR, 1, &PL_statcache))
2802         RETPUSHYES;
2803     RETPUSHNO;
2804 }
2805
2806 PP(pp_fteexec)
2807 {
2808     I32 result;
2809     djSP;
2810 #ifdef PERL_EFF_ACCESS_X_OK
2811     STRLEN n_a;
2812     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2813         result = PERL_EFF_ACCESS_X_OK(TOPpx);
2814         if (result == 0)
2815             RETPUSHYES;
2816         if (result < 0)
2817             RETPUSHUNDEF;
2818         RETPUSHNO;
2819     }
2820     else
2821         result = my_stat();
2822 #else
2823     result = my_stat();
2824 #endif
2825     SPAGAIN;
2826     if (result < 0)
2827         RETPUSHUNDEF;
2828     if (cando(S_IXUSR, 1, &PL_statcache))
2829         RETPUSHYES;
2830     RETPUSHNO;
2831 }
2832
2833 PP(pp_ftis)
2834 {
2835     I32 result = my_stat();
2836     djSP;
2837     if (result < 0)
2838         RETPUSHUNDEF;
2839     RETPUSHYES;
2840 }
2841
2842 PP(pp_fteowned)
2843 {
2844     return pp_ftrowned();
2845 }
2846
2847 PP(pp_ftrowned)
2848 {
2849     I32 result = my_stat();
2850     djSP;
2851     if (result < 0)
2852         RETPUSHUNDEF;
2853     if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
2854                                 PL_euid : PL_uid) )
2855         RETPUSHYES;
2856     RETPUSHNO;
2857 }
2858
2859 PP(pp_ftzero)
2860 {
2861     I32 result = my_stat();
2862     djSP;
2863     if (result < 0)
2864         RETPUSHUNDEF;
2865     if (PL_statcache.st_size == 0)
2866         RETPUSHYES;
2867     RETPUSHNO;
2868 }
2869
2870 PP(pp_ftsize)
2871 {
2872     I32 result = my_stat();
2873     djSP; dTARGET;
2874     if (result < 0)
2875         RETPUSHUNDEF;
2876 #if Off_t_size > IVSIZE
2877     PUSHn(PL_statcache.st_size);
2878 #else
2879     PUSHi(PL_statcache.st_size);
2880 #endif
2881     RETURN;
2882 }
2883
2884 PP(pp_ftmtime)
2885 {
2886     I32 result = my_stat();
2887     djSP; dTARGET;
2888     if (result < 0)
2889         RETPUSHUNDEF;
2890     PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
2891     RETURN;
2892 }
2893
2894 PP(pp_ftatime)
2895 {
2896     I32 result = my_stat();
2897     djSP; dTARGET;
2898     if (result < 0)
2899         RETPUSHUNDEF;
2900     PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
2901     RETURN;
2902 }
2903
2904 PP(pp_ftctime)
2905 {
2906     I32 result = my_stat();
2907     djSP; dTARGET;
2908     if (result < 0)
2909         RETPUSHUNDEF;
2910     PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
2911     RETURN;
2912 }
2913
2914 PP(pp_ftsock)
2915 {
2916     I32 result = my_stat();
2917     djSP;
2918     if (result < 0)
2919         RETPUSHUNDEF;
2920     if (S_ISSOCK(PL_statcache.st_mode))
2921         RETPUSHYES;
2922     RETPUSHNO;
2923 }
2924
2925 PP(pp_ftchr)
2926 {
2927     I32 result = my_stat();
2928     djSP;
2929     if (result < 0)
2930         RETPUSHUNDEF;
2931     if (S_ISCHR(PL_statcache.st_mode))
2932         RETPUSHYES;
2933     RETPUSHNO;
2934 }
2935
2936 PP(pp_ftblk)
2937 {
2938     I32 result = my_stat();
2939     djSP;
2940     if (result < 0)
2941         RETPUSHUNDEF;
2942     if (S_ISBLK(PL_statcache.st_mode))
2943         RETPUSHYES;
2944     RETPUSHNO;
2945 }
2946
2947 PP(pp_ftfile)
2948 {
2949     I32 result = my_stat();
2950     djSP;
2951     if (result < 0)
2952         RETPUSHUNDEF;
2953     if (S_ISREG(PL_statcache.st_mode))
2954         RETPUSHYES;
2955     RETPUSHNO;
2956 }
2957
2958 PP(pp_ftdir)
2959 {
2960     I32 result = my_stat();
2961     djSP;
2962     if (result < 0)
2963         RETPUSHUNDEF;
2964     if (S_ISDIR(PL_statcache.st_mode))
2965         RETPUSHYES;
2966     RETPUSHNO;
2967 }
2968
2969 PP(pp_ftpipe)
2970 {
2971     I32 result = my_stat();
2972     djSP;
2973     if (result < 0)
2974         RETPUSHUNDEF;
2975     if (S_ISFIFO(PL_statcache.st_mode))
2976         RETPUSHYES;
2977     RETPUSHNO;
2978 }
2979
2980 PP(pp_ftlink)
2981 {
2982     I32 result = my_lstat();
2983     djSP;
2984     if (result < 0)
2985         RETPUSHUNDEF;
2986     if (S_ISLNK(PL_statcache.st_mode))
2987         RETPUSHYES;
2988     RETPUSHNO;
2989 }
2990
2991 PP(pp_ftsuid)
2992 {
2993     djSP;
2994 #ifdef S_ISUID
2995     I32 result = my_stat();
2996     SPAGAIN;
2997     if (result < 0)
2998         RETPUSHUNDEF;
2999     if (PL_statcache.st_mode & S_ISUID)
3000         RETPUSHYES;
3001 #endif
3002     RETPUSHNO;
3003 }
3004
3005 PP(pp_ftsgid)
3006 {
3007     djSP;
3008 #ifdef S_ISGID
3009     I32 result = my_stat();
3010     SPAGAIN;
3011     if (result < 0)
3012         RETPUSHUNDEF;
3013     if (PL_statcache.st_mode & S_ISGID)
3014         RETPUSHYES;
3015 #endif
3016     RETPUSHNO;
3017 }
3018
3019 PP(pp_ftsvtx)
3020 {
3021     djSP;
3022 #ifdef S_ISVTX
3023     I32 result = my_stat();
3024     SPAGAIN;
3025     if (result < 0)
3026         RETPUSHUNDEF;
3027     if (PL_statcache.st_mode & S_ISVTX)
3028         RETPUSHYES;
3029 #endif
3030     RETPUSHNO;
3031 }
3032
3033 PP(pp_fttty)
3034 {
3035     djSP;
3036     int fd;
3037     GV *gv;
3038     char *tmps = Nullch;
3039     STRLEN n_a;
3040
3041     if (PL_op->op_flags & OPf_REF)
3042         gv = cGVOP_gv;
3043     else if (isGV(TOPs))
3044         gv = (GV*)POPs;
3045     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3046         gv = (GV*)SvRV(POPs);
3047     else
3048         gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
3049
3050     if (GvIO(gv) && IoIFP(GvIOp(gv)))
3051         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3052     else if (tmps && isDIGIT(*tmps))
3053         fd = atoi(tmps);
3054     else
3055         RETPUSHUNDEF;
3056     if (PerlLIO_isatty(fd))
3057         RETPUSHYES;
3058     RETPUSHNO;
3059 }
3060
3061 #if defined(atarist) /* this will work with atariST. Configure will
3062                         make guesses for other systems. */
3063 # define FILE_base(f) ((f)->_base)
3064 # define FILE_ptr(f) ((f)->_ptr)
3065 # define FILE_cnt(f) ((f)->_cnt)
3066 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3067 #endif
3068
3069 PP(pp_fttext)
3070 {
3071     djSP;
3072     I32 i;
3073     I32 len;
3074     I32 odd = 0;
3075     STDCHAR tbuf[512];
3076     register STDCHAR *s;
3077     register IO *io;
3078     register SV *sv;
3079     GV *gv;
3080     STRLEN n_a;
3081     PerlIO *fp;
3082
3083     if (PL_op->op_flags & OPf_REF)
3084         gv = cGVOP_gv;
3085     else if (isGV(TOPs))
3086         gv = (GV*)POPs;
3087     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3088         gv = (GV*)SvRV(POPs);
3089     else
3090         gv = Nullgv;
3091
3092     if (gv) {
3093         EXTEND(SP, 1);
3094         if (gv == PL_defgv) {
3095             if (PL_statgv)
3096                 io = GvIO(PL_statgv);
3097             else {
3098                 sv = PL_statname;
3099                 goto really_filename;
3100             }
3101         }
3102         else {
3103             PL_statgv = gv;
3104             PL_laststatval = -1;
3105             sv_setpv(PL_statname, "");
3106             io = GvIO(PL_statgv);
3107         }
3108         if (io && IoIFP(io)) {
3109             if (! PerlIO_has_base(IoIFP(io)))
3110                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3111             PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3112             if (PL_laststatval < 0)
3113                 RETPUSHUNDEF;
3114             if (S_ISDIR(PL_statcache.st_mode))  /* handle NFS glitch */
3115                 if (PL_op->op_type == OP_FTTEXT)
3116                     RETPUSHNO;
3117                 else
3118                     RETPUSHYES;
3119             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3120                 i = PerlIO_getc(IoIFP(io));
3121                 if (i != EOF)
3122                     (void)PerlIO_ungetc(IoIFP(io),i);
3123             }
3124             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3125                 RETPUSHYES;
3126             len = PerlIO_get_bufsiz(IoIFP(io));
3127             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3128             /* sfio can have large buffers - limit to 512 */
3129             if (len > 512)
3130                 len = 512;
3131         }
3132         else {
3133             dTHR;
3134             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3135                 gv = cGVOP_gv;
3136                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3137             }
3138             SETERRNO(EBADF,RMS$_IFI);
3139             RETPUSHUNDEF;
3140         }
3141     }
3142     else {
3143         sv = POPs;
3144       really_filename:
3145         PL_statgv = Nullgv;
3146         PL_laststatval = -1;
3147         sv_setpv(PL_statname, SvPV(sv, n_a));
3148         if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
3149             if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
3150                 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
3151             RETPUSHUNDEF;
3152         }
3153         PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3154         if (PL_laststatval < 0) {
3155             (void)PerlIO_close(fp);
3156             RETPUSHUNDEF;
3157         }
3158         do_binmode(fp, '<', O_BINARY);
3159         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3160         (void)PerlIO_close(fp);
3161         if (len <= 0) {
3162             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3163                 RETPUSHNO;              /* special case NFS directories */
3164             RETPUSHYES;         /* null file is anything */
3165         }
3166         s = tbuf;
3167     }
3168
3169     /* now scan s to look for textiness */
3170     /*   XXX ASCII dependent code */
3171
3172 #if defined(DOSISH) || defined(USEMYBINMODE)
3173     /* ignore trailing ^Z on short files */
3174     if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3175         --len;
3176 #endif
3177
3178     for (i = 0; i < len; i++, s++) {
3179         if (!*s) {                      /* null never allowed in text */
3180             odd += len;
3181             break;
3182         }
3183 #ifdef EBCDIC
3184         else if (!(isPRINT(*s) || isSPACE(*s)))
3185             odd++;
3186 #else
3187         else if (*s & 128) {
3188 #ifdef USE_LOCALE
3189             if ((PL_op->op_private & OPpLOCALE) && isALPHA_LC(*s))
3190                 continue;
3191 #endif
3192             /* utf8 characters don't count as odd */
3193             if (*s & 0x40) {
3194                 int ulen = UTF8SKIP(s);
3195                 if (ulen < len - i) {
3196                     int j;
3197                     for (j = 1; j < ulen; j++) {
3198                         if ((s[j] & 0xc0) != 0x80)
3199                             goto not_utf8;
3200                     }
3201                     --ulen;     /* loop does extra increment */
3202                     s += ulen;
3203                     i += ulen;
3204                     continue;
3205                 }
3206             }
3207           not_utf8:
3208             odd++;
3209         }
3210         else if (*s < 32 &&
3211           *s != '\n' && *s != '\r' && *s != '\b' &&
3212           *s != '\t' && *s != '\f' && *s != 27)
3213             odd++;
3214 #endif
3215     }
3216
3217     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3218         RETPUSHNO;
3219     else
3220         RETPUSHYES;
3221 }
3222
3223 PP(pp_ftbinary)
3224 {
3225     return pp_fttext();
3226 }
3227
3228 /* File calls. */
3229
3230 PP(pp_chdir)
3231 {
3232     djSP; dTARGET;
3233     char *tmps;
3234     SV **svp;
3235     STRLEN n_a;
3236
3237     if (MAXARG < 1)
3238         tmps = Nullch;
3239     else
3240         tmps = POPpx;
3241     if (!tmps || !*tmps) {
3242         svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
3243         if (svp)
3244             tmps = SvPV(*svp, n_a);
3245     }
3246     if (!tmps || !*tmps) {
3247         svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
3248         if (svp)
3249             tmps = SvPV(*svp, n_a);
3250     }
3251 #ifdef VMS
3252     if (!tmps || !*tmps) {
3253        svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
3254        if (svp)
3255            tmps = SvPV(*svp, n_a);
3256     }
3257 #endif
3258     TAINT_PROPER("chdir");
3259     PUSHi( PerlDir_chdir(tmps) >= 0 );
3260 #ifdef VMS
3261     /* Clear the DEFAULT element of ENV so we'll get the new value
3262      * in the future. */
3263     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3264 #endif
3265     RETURN;
3266 }
3267
3268 PP(pp_chown)
3269 {
3270     djSP; dMARK; dTARGET;
3271     I32 value;
3272 #ifdef HAS_CHOWN
3273     value = (I32)apply(PL_op->op_type, MARK, SP);
3274     SP = MARK;
3275     PUSHi(value);
3276     RETURN;
3277 #else
3278     DIE(aTHX_ PL_no_func, "Unsupported function chown");
3279 #endif
3280 }
3281
3282 PP(pp_chroot)
3283 {
3284     djSP; dTARGET;
3285     char *tmps;
3286 #ifdef HAS_CHROOT
3287     STRLEN n_a;
3288     tmps = POPpx;
3289     TAINT_PROPER("chroot");
3290     PUSHi( chroot(tmps) >= 0 );
3291     RETURN;
3292 #else
3293     DIE(aTHX_ PL_no_func, "chroot");
3294 #endif
3295 }
3296
3297 PP(pp_unlink)
3298 {
3299     djSP; dMARK; dTARGET;
3300     I32 value;
3301     value = (I32)apply(PL_op->op_type, MARK, SP);
3302     SP = MARK;
3303     PUSHi(value);
3304     RETURN;
3305 }
3306
3307 PP(pp_chmod)
3308 {
3309     djSP; dMARK; dTARGET;
3310     I32 value;
3311     value = (I32)apply(PL_op->op_type, MARK, SP);
3312     SP = MARK;
3313     PUSHi(value);
3314     RETURN;
3315 }
3316
3317 PP(pp_utime)
3318 {
3319     djSP; dMARK; dTARGET;
3320     I32 value;
3321     value = (I32)apply(PL_op->op_type, MARK, SP);
3322     SP = MARK;
3323     PUSHi(value);
3324     RETURN;
3325 }
3326
3327 PP(pp_rename)
3328 {
3329     djSP; dTARGET;
3330     int anum;
3331     STRLEN n_a;
3332
3333     char *tmps2 = POPpx;
3334     char *tmps = SvPV(TOPs, n_a);
3335     TAINT_PROPER("rename");
3336 #ifdef HAS_RENAME
3337     anum = PerlLIO_rename(tmps, tmps2);
3338 #else
3339     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3340         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3341             anum = 1;
3342         else {
3343             if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3344                 (void)UNLINK(tmps2);
3345             if (!(anum = link(tmps, tmps2)))
3346                 anum = UNLINK(tmps);
3347         }
3348     }
3349 #endif
3350     SETi( anum >= 0 );
3351     RETURN;
3352 }
3353
3354 PP(pp_link)
3355 {
3356     djSP; dTARGET;
3357 #ifdef HAS_LINK
3358     STRLEN n_a;
3359     char *tmps2 = POPpx;
3360     char *tmps = SvPV(TOPs, n_a);
3361     TAINT_PROPER("link");
3362     SETi( PerlLIO_link(tmps, tmps2) >= 0 );
3363 #else
3364     DIE(aTHX_ PL_no_func, "Unsupported function link");
3365 #endif
3366     RETURN;
3367 }
3368
3369 PP(pp_symlink)
3370 {
3371     djSP; dTARGET;
3372 #ifdef HAS_SYMLINK
3373     STRLEN n_a;
3374     char *tmps2 = POPpx;
3375     char *tmps = SvPV(TOPs, n_a);
3376     TAINT_PROPER("symlink");
3377     SETi( symlink(tmps, tmps2) >= 0 );
3378     RETURN;
3379 #else
3380     DIE(aTHX_ PL_no_func, "symlink");
3381 #endif
3382 }
3383
3384 PP(pp_readlink)
3385 {
3386     djSP; dTARGET;
3387 #ifdef HAS_SYMLINK
3388     char *tmps;
3389     char buf[MAXPATHLEN];
3390     int len;
3391     STRLEN n_a;
3392
3393 #ifndef INCOMPLETE_TAINTS
3394     TAINT;
3395 #endif
3396     tmps = POPpx;
3397     len = readlink(tmps, buf, sizeof buf);
3398     EXTEND(SP, 1);
3399     if (len < 0)
3400         RETPUSHUNDEF;
3401     PUSHp(buf, len);
3402     RETURN;
3403 #else
3404     EXTEND(SP, 1);
3405     RETSETUNDEF;                /* just pretend it's a normal file */
3406 #endif
3407 }
3408
3409 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3410 STATIC int
3411 S_dooneliner(pTHX_ char *cmd, char *filename)
3412 {
3413     char *save_filename = filename;
3414     char *cmdline;
3415     char *s;
3416     PerlIO *myfp;
3417     int anum = 1;
3418
3419     New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3420     strcpy(cmdline, cmd);
3421     strcat(cmdline, " ");
3422     for (s = cmdline + strlen(cmdline); *filename; ) {
3423         *s++ = '\\';
3424         *s++ = *filename++;
3425     }
3426     strcpy(s, " 2>&1");
3427     myfp = PerlProc_popen(cmdline, "r");
3428     Safefree(cmdline);
3429
3430     if (myfp) {
3431         SV *tmpsv = sv_newmortal();
3432         /* Need to save/restore 'PL_rs' ?? */
3433         s = sv_gets(tmpsv, myfp, 0);
3434         (void)PerlProc_pclose(myfp);
3435         if (s != Nullch) {
3436             int e;
3437             for (e = 1;
3438 #ifdef HAS_SYS_ERRLIST
3439                  e <= sys_nerr
3440 #endif
3441                  ; e++)
3442             {
3443                 /* you don't see this */
3444                 char *errmsg =
3445 #ifdef HAS_SYS_ERRLIST
3446                     sys_errlist[e]
3447 #else
3448                     strerror(e)
3449 #endif
3450                     ;
3451                 if (!errmsg)
3452                     break;
3453                 if (instr(s, errmsg)) {
3454                     SETERRNO(e,0);
3455                     return 0;
3456                 }
3457             }
3458             SETERRNO(0,0);
3459 #ifndef EACCES
3460 #define EACCES EPERM
3461 #endif
3462             if (instr(s, "cannot make"))
3463                 SETERRNO(EEXIST,RMS$_FEX);
3464             else if (instr(s, "existing file"))
3465                 SETERRNO(EEXIST,RMS$_FEX);
3466             else if (instr(s, "ile exists"))
3467                 SETERRNO(EEXIST,RMS$_FEX);
3468             else if (instr(s, "non-exist"))
3469                 SETERRNO(ENOENT,RMS$_FNF);
3470             else if (instr(s, "does not exist"))
3471                 SETERRNO(ENOENT,RMS$_FNF);
3472             else if (instr(s, "not empty"))
3473                 SETERRNO(EBUSY,SS$_DEVOFFLINE);
3474             else if (instr(s, "cannot access"))
3475                 SETERRNO(EACCES,RMS$_PRV);
3476             else
3477                 SETERRNO(EPERM,RMS$_PRV);
3478             return 0;
3479         }
3480         else {  /* some mkdirs return no failure indication */
3481             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3482             if (PL_op->op_type == OP_RMDIR)
3483                 anum = !anum;
3484             if (anum)
3485                 SETERRNO(0,0);
3486             else
3487                 SETERRNO(EACCES,RMS$_PRV);      /* a guess */
3488         }
3489         return anum;
3490     }
3491     else
3492         return 0;
3493 }
3494 #endif
3495
3496 PP(pp_mkdir)
3497 {
3498     djSP; dTARGET;
3499     int mode;
3500 #ifndef HAS_MKDIR
3501     int oldumask;
3502 #endif
3503     STRLEN n_a;
3504     char *tmps;
3505
3506     if (MAXARG > 1)
3507         mode = POPi;
3508     else
3509         mode = 0777;
3510
3511     tmps = SvPV(TOPs, n_a);
3512
3513     TAINT_PROPER("mkdir");
3514 #ifdef HAS_MKDIR
3515     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3516 #else
3517     SETi( dooneliner("mkdir", tmps) );
3518     oldumask = PerlLIO_umask(0);
3519     PerlLIO_umask(oldumask);
3520     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3521 #endif
3522     RETURN;
3523 }
3524
3525 PP(pp_rmdir)
3526 {
3527     djSP; dTARGET;
3528     char *tmps;
3529     STRLEN n_a;
3530
3531     tmps = POPpx;
3532     TAINT_PROPER("rmdir");
3533 #ifdef HAS_RMDIR
3534     XPUSHi( PerlDir_rmdir(tmps) >= 0 );
3535 #else
3536     XPUSHi( dooneliner("rmdir", tmps) );
3537 #endif
3538     RETURN;
3539 }
3540
3541 /* Directory calls. */
3542
3543 PP(pp_open_dir)
3544 {
3545     djSP;
3546 #if defined(Direntry_t) && defined(HAS_READDIR)
3547     STRLEN n_a;
3548     char *dirname = POPpx;
3549     GV *gv = (GV*)POPs;
3550     register IO *io = GvIOn(gv);
3551
3552     if (!io)
3553         goto nope;
3554
3555     if (IoDIRP(io))
3556         PerlDir_close(IoDIRP(io));
3557     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3558         goto nope;
3559
3560     RETPUSHYES;
3561 nope:
3562     if (!errno)
3563         SETERRNO(EBADF,RMS$_DIR);
3564     RETPUSHUNDEF;
3565 #else
3566     DIE(aTHX_ PL_no_dir_func, "opendir");
3567 #endif
3568 }
3569
3570 PP(pp_readdir)
3571 {
3572     djSP;
3573 #if defined(Direntry_t) && defined(HAS_READDIR)
3574 #ifndef I_DIRENT
3575     Direntry_t *readdir (DIR *);
3576 #endif
3577     register Direntry_t *dp;
3578     GV *gv = (GV*)POPs;
3579     register IO *io = GvIOn(gv);
3580     SV *sv;
3581
3582     if (!io || !IoDIRP(io))
3583         goto nope;
3584
3585     if (GIMME == G_ARRAY) {
3586         /*SUPPRESS 560*/
3587         while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
3588 #ifdef DIRNAMLEN
3589             sv = newSVpvn(dp->d_name, dp->d_namlen);
3590 #else
3591             sv = newSVpv(dp->d_name, 0);
3592 #endif
3593 #ifndef INCOMPLETE_TAINTS
3594             if (!(IoFLAGS(io) & IOf_UNTAINT))
3595                 SvTAINTED_on(sv);
3596 #endif
3597             XPUSHs(sv_2mortal(sv));
3598         }
3599     }
3600     else {
3601         if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
3602             goto nope;
3603 #ifdef DIRNAMLEN
3604         sv = newSVpvn(dp->d_name, dp->d_namlen);
3605 #else
3606         sv = newSVpv(dp->d_name, 0);
3607 #endif
3608 #ifndef INCOMPLETE_TAINTS
3609         if (!(IoFLAGS(io) & IOf_UNTAINT))
3610             SvTAINTED_on(sv);
3611 #endif
3612         XPUSHs(sv_2mortal(sv));
3613     }
3614     RETURN;
3615
3616 nope:
3617     if (!errno)
3618         SETERRNO(EBADF,RMS$_ISI);
3619     if (GIMME == G_ARRAY)
3620         RETURN;
3621     else
3622         RETPUSHUNDEF;
3623 #else
3624     DIE(aTHX_ PL_no_dir_func, "readdir");
3625 #endif
3626 }
3627
3628 PP(pp_telldir)
3629 {
3630     djSP; dTARGET;
3631 #if defined(HAS_TELLDIR) || defined(telldir)
3632  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3633  /* XXX netbsd still seemed to.
3634     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3635     --JHI 1999-Feb-02 */
3636 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3637     long telldir (DIR *);
3638 # endif
3639     GV *gv = (GV*)POPs;
3640     register IO *io = GvIOn(gv);
3641
3642     if (!io || !IoDIRP(io))
3643         goto nope;
3644
3645     PUSHi( PerlDir_tell(IoDIRP(io)) );
3646     RETURN;
3647 nope:
3648     if (!errno)
3649         SETERRNO(EBADF,RMS$_ISI);
3650     RETPUSHUNDEF;
3651 #else
3652     DIE(aTHX_ PL_no_dir_func, "telldir");
3653 #endif
3654 }
3655
3656 PP(pp_seekdir)
3657 {
3658     djSP;
3659 #if defined(HAS_SEEKDIR) || defined(seekdir)
3660     long along = POPl;
3661     GV *gv = (GV*)POPs;
3662     register IO *io = GvIOn(gv);
3663
3664     if (!io || !IoDIRP(io))
3665         goto nope;
3666
3667     (void)PerlDir_seek(IoDIRP(io), along);
3668
3669     RETPUSHYES;
3670 nope:
3671     if (!errno)
3672         SETERRNO(EBADF,RMS$_ISI);
3673     RETPUSHUNDEF;
3674 #else
3675     DIE(aTHX_ PL_no_dir_func, "seekdir");
3676 #endif
3677 }
3678
3679 PP(pp_rewinddir)
3680 {
3681     djSP;
3682 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3683     GV *gv = (GV*)POPs;
3684     register IO *io = GvIOn(gv);
3685
3686     if (!io || !IoDIRP(io))
3687         goto nope;
3688
3689     (void)PerlDir_rewind(IoDIRP(io));
3690     RETPUSHYES;
3691 nope:
3692     if (!errno)
3693         SETERRNO(EBADF,RMS$_ISI);
3694     RETPUSHUNDEF;
3695 #else
3696     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3697 #endif
3698 }
3699
3700 PP(pp_closedir)
3701 {
3702     djSP;
3703 #if defined(Direntry_t) && defined(HAS_READDIR)
3704     GV *gv = (GV*)POPs;
3705     register IO *io = GvIOn(gv);
3706
3707     if (!io || !IoDIRP(io))
3708         goto nope;
3709
3710 #ifdef VOID_CLOSEDIR
3711     PerlDir_close(IoDIRP(io));
3712 #else
3713     if (PerlDir_close(IoDIRP(io)) < 0) {
3714         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3715         goto nope;
3716     }
3717 #endif
3718     IoDIRP(io) = 0;
3719
3720     RETPUSHYES;
3721 nope:
3722     if (!errno)
3723         SETERRNO(EBADF,RMS$_IFI);
3724     RETPUSHUNDEF;
3725 #else
3726     DIE(aTHX_ PL_no_dir_func, "closedir");
3727 #endif
3728 }
3729
3730 /* Process control. */
3731
3732 PP(pp_fork)
3733 {
3734 #ifdef HAS_FORK
3735     djSP; dTARGET;
3736     Pid_t childpid;
3737     GV *tmpgv;
3738
3739     EXTEND(SP, 1);
3740     PERL_FLUSHALL_FOR_CHILD;
3741     childpid = fork();
3742     if (childpid < 0)
3743         RETSETUNDEF;
3744     if (!childpid) {
3745         /*SUPPRESS 560*/
3746         if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
3747             sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3748         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3749     }
3750     PUSHi(childpid);
3751     RETURN;
3752 #else
3753 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3754     djSP; dTARGET;
3755     Pid_t childpid;
3756
3757     EXTEND(SP, 1);
3758     PERL_FLUSHALL_FOR_CHILD;
3759     childpid = PerlProc_fork();
3760     if (childpid == -1)
3761         RETSETUNDEF;
3762     PUSHi(childpid);
3763     RETURN;
3764 #  else
3765     DIE(aTHX_ PL_no_func, "Unsupported function fork");
3766 #  endif
3767 #endif
3768 }
3769
3770 PP(pp_wait)
3771 {
3772 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3773     djSP; dTARGET;
3774     Pid_t childpid;
3775     int argflags;
3776
3777     childpid = wait4pid(-1, &argflags, 0);
3778 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3779     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3780     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3781 #  else
3782     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3783 #  endif
3784     XPUSHi(childpid);
3785     RETURN;
3786 #else
3787     DIE(aTHX_ PL_no_func, "Unsupported function wait");
3788 #endif
3789 }
3790
3791 PP(pp_waitpid)
3792 {
3793 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3794     djSP; dTARGET;
3795     Pid_t childpid;
3796     int optype;
3797     int argflags;
3798
3799     optype = POPi;
3800     childpid = TOPi;
3801     childpid = wait4pid(childpid, &argflags, optype);
3802 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3803     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3804     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3805 #  else
3806     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3807 #  endif
3808     SETi(childpid);
3809     RETURN;
3810 #else
3811     DIE(aTHX_ PL_no_func, "Unsupported function waitpid");
3812 #endif
3813 }
3814
3815 PP(pp_system)
3816 {
3817     djSP; dMARK; dORIGMARK; dTARGET;
3818     I32 value;
3819     Pid_t childpid;
3820     int result;
3821     int status;
3822     Sigsave_t ihand,qhand;     /* place to save signals during system() */
3823     STRLEN n_a;
3824     I32 did_pipes = 0;
3825     int pp[2];
3826
3827     if (SP - MARK == 1) {
3828         if (PL_tainting) {
3829             char *junk = SvPV(TOPs, n_a);
3830             TAINT_ENV();
3831             TAINT_PROPER("system");
3832         }
3833     }
3834     PERL_FLUSHALL_FOR_CHILD;
3835 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) && !defined(__CYGWIN__) || defined(PERL_MICRO)
3836     if (PerlProc_pipe(pp) >= 0)
3837         did_pipes = 1;
3838     while ((childpid = vfork()) == -1) {
3839         if (errno != EAGAIN) {
3840             value = -1;
3841             SP = ORIGMARK;
3842             PUSHi(value);
3843             if (did_pipes) {
3844                 PerlLIO_close(pp[0]);
3845                 PerlLIO_close(pp[1]);
3846             }
3847             RETURN;
3848         }
3849         sleep(5);
3850     }
3851     if (childpid > 0) {
3852         if (did_pipes)
3853             PerlLIO_close(pp[1]);
3854 #ifndef PERL_MICRO
3855         rsignal_save(SIGINT, SIG_IGN, &ihand);
3856         rsignal_save(SIGQUIT, SIG_IGN, &qhand);
3857 #endif
3858         do {
3859             result = wait4pid(childpid, &status, 0);
3860         } while (result == -1 && errno == EINTR);
3861 #ifndef PERL_MICRO
3862         (void)rsignal_restore(SIGINT, &ihand);
3863         (void)rsignal_restore(SIGQUIT, &qhand);
3864 #endif
3865         STATUS_NATIVE_SET(result == -1 ? -1 : status);
3866         do_execfree();  /* free any memory child malloced on vfork */
3867         SP = ORIGMARK;
3868         if (did_pipes) {
3869             int errkid;
3870             int n = 0, n1;
3871
3872             while (n < sizeof(int)) {
3873                 n1 = PerlLIO_read(pp[0],
3874                                   (void*)(((char*)&errkid)+n),
3875                                   (sizeof(int)) - n);
3876                 if (n1 <= 0)
3877                     break;
3878                 n += n1;
3879             }
3880             PerlLIO_close(pp[0]);
3881             if (n) {                    /* Error */
3882                 if (n != sizeof(int))
3883                     DIE(aTHX_ "panic: kid popen errno read");
3884                 errno = errkid;         /* Propagate errno from kid */
3885                 STATUS_CURRENT = -1;
3886             }
3887         }
3888         PUSHi(STATUS_CURRENT);
3889         RETURN;
3890     }
3891     if (did_pipes) {
3892         PerlLIO_close(pp[0]);
3893 #if defined(HAS_FCNTL) && defined(F_SETFD)
3894         fcntl(pp[1], F_SETFD, FD_CLOEXEC);
3895 #endif
3896     }
3897     if (PL_op->op_flags & OPf_STACKED) {
3898         SV *really = *++MARK;
3899         value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
3900     }
3901     else if (SP - MARK != 1)
3902         value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
3903     else {
3904         value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
3905     }
3906     PerlProc__exit(-1);
3907 #else /* ! FORK or VMS or OS/2 */
3908     PL_statusvalue = 0;
3909     result = 0;
3910     if (PL_op->op_flags & OPf_STACKED) {
3911         SV *really = *++MARK;
3912         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
3913     }
3914     else if (SP - MARK != 1)
3915         value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
3916     else {
3917         value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
3918     }
3919     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
3920         result = 1;
3921     STATUS_NATIVE_SET(value);
3922     do_execfree();
3923     SP = ORIGMARK;
3924     PUSHi(result ? value : STATUS_CURRENT);
3925 #endif /* !FORK or VMS */
3926     RETURN;
3927 }
3928
3929 PP(pp_exec)
3930 {
3931     djSP; dMARK; dORIGMARK; dTARGET;
3932     I32 value;
3933     STRLEN n_a;
3934
3935     PERL_FLUSHALL_FOR_CHILD;
3936     if (PL_op->op_flags & OPf_STACKED) {
3937         SV *really = *++MARK;
3938         value = (I32)do_aexec(really, MARK, SP);
3939     }
3940     else if (SP - MARK != 1)
3941 #ifdef VMS
3942         value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3943 #else
3944 #  ifdef __OPEN_VM
3945         {
3946            (void ) do_aspawn(Nullsv, MARK, SP);
3947            value = 0;
3948         }
3949 #  else
3950         value = (I32)do_aexec(Nullsv, MARK, SP);
3951 #  endif
3952 #endif
3953     else {
3954         if (PL_tainting) {
3955             char *junk = SvPV(*SP, n_a);
3956             TAINT_ENV();
3957             TAINT_PROPER("exec");
3958         }
3959 #ifdef VMS
3960         value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
3961 #else
3962 #  ifdef __OPEN_VM
3963         (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
3964         value = 0;
3965 #  else
3966         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
3967 #  endif
3968 #endif
3969     }
3970
3971 #if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3972     if (value >= 0)
3973         my_exit(value);
3974 #endif
3975
3976     SP = ORIGMARK;
3977     PUSHi(value);
3978     RETURN;
3979 }
3980
3981 PP(pp_kill)
3982 {
3983     djSP; dMARK; dTARGET;
3984     I32 value;
3985 #ifdef HAS_KILL
3986     value = (I32)apply(PL_op->op_type, MARK, SP);
3987     SP = MARK;
3988     PUSHi(value);
3989     RETURN;
3990 #else
3991     DIE(aTHX_ PL_no_func, "Unsupported function kill");
3992 #endif
3993 }
3994
3995 PP(pp_getppid)
3996 {
3997 #ifdef HAS_GETPPID
3998     djSP; dTARGET;
3999     XPUSHi( getppid() );
4000     RETURN;
4001 #else
4002     DIE(aTHX_ PL_no_func, "getppid");
4003 #endif
4004 }
4005
4006 PP(pp_getpgrp)
4007 {
4008 #ifdef HAS_GETPGRP
4009     djSP; dTARGET;
4010     Pid_t pid;
4011     Pid_t pgrp;
4012
4013     if (MAXARG < 1)
4014         pid = 0;
4015     else
4016         pid = SvIVx(POPs);
4017 #ifdef BSD_GETPGRP
4018     pgrp = (I32)BSD_GETPGRP(pid);
4019 #else
4020     if (pid != 0 && pid != PerlProc_getpid())
4021         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4022     pgrp = getpgrp();
4023 #endif
4024     XPUSHi(pgrp);
4025     RETURN;
4026 #else
4027     DIE(aTHX_ PL_no_func, "getpgrp()");
4028 #endif
4029 }
4030
4031 PP(pp_setpgrp)
4032 {
4033 #ifdef HAS_SETPGRP
4034     djSP; dTARGET;
4035     Pid_t pgrp;
4036     Pid_t pid;
4037     if (MAXARG < 2) {
4038         pgrp = 0;
4039         pid = 0;
4040     }
4041     else {
4042         pgrp = POPi;
4043         pid = TOPi;
4044     }
4045
4046     TAINT_PROPER("setpgrp");
4047 #ifdef BSD_SETPGRP
4048     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4049 #else
4050     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4051         || (pid != 0 && pid != PerlProc_getpid()))
4052     {
4053         DIE(aTHX_ "setpgrp can't take arguments");
4054     }
4055     SETi( setpgrp() >= 0 );
4056 #endif /* USE_BSDPGRP */
4057     RETURN;
4058 #else
4059     DIE(aTHX_ PL_no_func, "setpgrp()");
4060 #endif
4061 }
4062
4063 PP(pp_getpriority)
4064 {
4065     djSP; dTARGET;
4066     int which;
4067     int who;
4068 #ifdef HAS_GETPRIORITY
4069     who = POPi;
4070     which = TOPi;
4071     SETi( getpriority(which, who) );
4072     RETURN;
4073 #else
4074     DIE(aTHX_ PL_no_func, "getpriority()");
4075 #endif
4076 }
4077
4078 PP(pp_setpriority)
4079 {
4080     djSP; dTARGET;
4081     int which;
4082     int who;
4083     int niceval;
4084 #ifdef HAS_SETPRIORITY
4085     niceval = POPi;
4086     who = POPi;
4087     which = TOPi;
4088     TAINT_PROPER("setpriority");
4089     SETi( setpriority(which, who, niceval) >= 0 );
4090     RETURN;
4091 #else
4092     DIE(aTHX_ PL_no_func, "setpriority()");
4093 #endif
4094 }
4095
4096 /* Time calls. */
4097
4098 PP(pp_time)
4099 {
4100     djSP; dTARGET;
4101 #ifdef BIG_TIME
4102     XPUSHn( time(Null(Time_t*)) );
4103 #else
4104     XPUSHi( time(Null(Time_t*)) );
4105 #endif
4106     RETURN;
4107 }
4108
4109 /* XXX The POSIX name is CLK_TCK; it is to be preferred
4110    to HZ.  Probably.  For now, assume that if the system
4111    defines HZ, it does so correctly.  (Will this break
4112    on VMS?)
4113    Probably we ought to use _sysconf(_SC_CLK_TCK), if
4114    it's supported.    --AD  9/96.
4115 */
4116
4117 #ifndef HZ
4118 #  ifdef CLK_TCK
4119 #    define HZ CLK_TCK
4120 #  else
4121 #    define HZ 60
4122 #  endif
4123 #endif
4124
4125 PP(pp_tms)
4126 {
4127     djSP;
4128
4129 #ifndef HAS_TIMES
4130     DIE(aTHX_ "times not implemented");
4131 #else
4132     EXTEND(SP, 4);
4133
4134 #ifndef VMS
4135     (void)PerlProc_times(&PL_timesbuf);
4136 #else
4137     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4138                                                    /* struct tms, though same data   */
4139                                                    /* is returned.                   */
4140 #endif
4141
4142     PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
4143     if (GIMME == G_ARRAY) {
4144         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4145         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4146         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
4147     }
4148     RETURN;
4149 #endif /* HAS_TIMES */
4150 }
4151
4152 PP(pp_localtime)
4153 {
4154     return pp_gmtime();
4155 }
4156
4157 PP(pp_gmtime)
4158 {
4159     djSP;
4160     Time_t when;
4161     struct tm *tmbuf;
4162     static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4163     static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4164                               "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4165
4166     if (MAXARG < 1)
4167         (void)time(&when);
4168     else
4169 #ifdef BIG_TIME
4170         when = (Time_t)SvNVx(POPs);
4171 #else
4172         when = (Time_t)SvIVx(POPs);
4173 #endif
4174
4175     if (PL_op->op_type == OP_LOCALTIME)
4176         tmbuf = localtime(&when);
4177     else
4178         tmbuf = gmtime(&when);
4179
4180     EXTEND(SP, 9);
4181     EXTEND_MORTAL(9);
4182     if (GIMME != G_ARRAY) {
4183         SV *tsv;
4184         if (!tmbuf)
4185             RETPUSHUNDEF;
4186         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4187                             dayname[tmbuf->tm_wday],
4188                             monname[tmbuf->tm_mon],
4189                             tmbuf->tm_mday,
4190                             tmbuf->tm_hour,
4191                             tmbuf->tm_min,
4192                             tmbuf->tm_sec,
4193                             tmbuf->tm_year + 1900);
4194         PUSHs(sv_2mortal(tsv));
4195     }
4196     else if (tmbuf) {
4197         PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4198         PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4199         PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4200         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4201         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4202         PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4203         PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4204         PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4205         PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4206     }
4207     RETURN;
4208 }
4209
4210 PP(pp_alarm)
4211 {
4212     djSP; dTARGET;
4213     int anum;
4214 #ifdef HAS_ALARM
4215     anum = POPi;
4216     anum = alarm((unsigned int)anum);
4217     EXTEND(SP, 1);
4218     if (anum < 0)
4219         RETPUSHUNDEF;
4220     PUSHi(anum);
4221     RETURN;
4222 #else
4223     DIE(aTHX_ PL_no_func, "Unsupported function alarm");
4224 #endif
4225 }
4226
4227 PP(pp_sleep)
4228 {
4229     djSP; dTARGET;
4230     I32 duration;
4231     Time_t lasttime;
4232     Time_t when;
4233
4234     (void)time(&lasttime);
4235     if (MAXARG < 1)
4236         PerlProc_pause();
4237     else {
4238         duration = POPi;
4239         PerlProc_sleep((unsigned int)duration);
4240     }
4241     (void)time(&when);
4242     XPUSHi(when - lasttime);
4243     RETURN;
4244 }
4245
4246 /* Shared memory. */
4247
4248 PP(pp_shmget)
4249 {
4250     return pp_semget();
4251 }
4252
4253 PP(pp_shmctl)
4254 {
4255     return pp_semctl();
4256 }
4257
4258 PP(pp_shmread)
4259 {
4260     return pp_shmwrite();
4261 }
4262
4263 PP(pp_shmwrite)
4264 {
4265 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4266     djSP; dMARK; dTARGET;
4267     I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
4268     SP = MARK;
4269     PUSHi(value);
4270     RETURN;
4271 #else
4272     return pp_semget();
4273 #endif
4274 }
4275
4276 /* Message passing. */
4277
4278 PP(pp_msgget)
4279 {
4280     return pp_semget();
4281 }
4282
4283 PP(pp_msgctl)
4284 {
4285     return pp_semctl();
4286 }
4287
4288 PP(pp_msgsnd)
4289 {
4290 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4291     djSP; dMARK; dTARGET;
4292     I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4293     SP = MARK;
4294     PUSHi(value);
4295     RETURN;
4296 #else
4297     return pp_semget();
4298 #endif
4299 }
4300
4301 PP(pp_msgrcv)
4302 {
4303 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4304     djSP; dMARK; dTARGET;
4305     I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4306     SP = MARK;
4307     PUSHi(value);
4308     RETURN;
4309 #else
4310     return pp_semget();
4311 #endif
4312 }
4313
4314 /* Semaphores. */
4315
4316 PP(pp_semget)
4317 {
4318 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4319     djSP; dMARK; dTARGET;
4320     int anum = do_ipcget(PL_op->op_type, MARK, SP);
4321     SP = MARK;
4322     if (anum == -1)
4323         RETPUSHUNDEF;
4324     PUSHi(anum);
4325     RETURN;
4326 #else
4327     DIE(aTHX_ "System V IPC is not implemented on this machine");
4328 #endif
4329 }
4330
4331 PP(pp_semctl)
4332 {
4333 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4334     djSP; dMARK; dTARGET;
4335     int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4336     SP = MARK;
4337     if (anum == -1)
4338         RETSETUNDEF;
4339     if (anum != 0) {
4340         PUSHi(anum);
4341     }
4342     else {
4343         PUSHp(zero_but_true, ZBTLEN);
4344     }
4345     RETURN;
4346 #else
4347     return pp_semget();
4348 #endif
4349 }
4350
4351 PP(pp_semop)
4352 {
4353 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4354     djSP; dMARK; dTARGET;
4355     I32 value = (I32)(do_semop(MARK, SP) >= 0);
4356     SP = MARK;
4357     PUSHi(value);
4358     RETURN;
4359 #else
4360     return pp_semget();
4361 #endif
4362 }
4363
4364 /* Get system info. */
4365
4366 PP(pp_ghbyname)
4367 {
4368 #ifdef HAS_GETHOSTBYNAME
4369     return pp_ghostent();
4370 #else
4371     DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4372 #endif
4373 }
4374
4375 PP(pp_ghbyaddr)
4376 {
4377 #ifdef HAS_GETHOSTBYADDR
4378     return pp_ghostent();
4379 #else
4380     DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4381 #endif
4382 }
4383
4384 PP(pp_ghostent)
4385 {
4386     djSP;
4387 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4388     I32 which = PL_op->op_type;
4389     register char **elem;
4390     register SV *sv;
4391 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4392     struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4393     struct hostent *PerlSock_gethostbyname(Netdb_name_t);
4394     struct hostent *PerlSock_gethostent(void);
4395 #endif
4396     struct hostent *hent;
4397     unsigned long len;
4398     STRLEN n_a;
4399
4400     EXTEND(SP, 10);
4401     if (which == OP_GHBYNAME)
4402 #ifdef HAS_GETHOSTBYNAME
4403         hent = PerlSock_gethostbyname(POPpx);
4404 #else
4405         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4406 #endif
4407     else if (which == OP_GHBYADDR) {
4408 #ifdef HAS_GETHOSTBYADDR
4409         int addrtype = POPi;
4410         SV *addrsv = POPs;
4411         STRLEN addrlen;
4412         Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen);
4413
4414         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4415 #else
4416         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4417 #endif
4418     }
4419     else
4420 #ifdef HAS_GETHOSTENT
4421         hent = PerlSock_gethostent();
4422 #else
4423         DIE(aTHX_ PL_no_sock_func, "gethostent");
4424 #endif
4425
4426 #ifdef HOST_NOT_FOUND
4427     if (!hent)
4428         STATUS_NATIVE_SET(h_errno);
4429 #endif
4430
4431     if (GIMME != G_ARRAY) {
4432         PUSHs(sv = sv_newmortal());
4433         if (hent) {
4434             if (which == OP_GHBYNAME) {
4435                 if (hent->h_addr)
4436                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4437             }
4438             else
4439                 sv_setpv(sv, (char*)hent->h_name);
4440         }
4441         RETURN;
4442     }
4443
4444     if (hent) {
4445         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4446         sv_setpv(sv, (char*)hent->h_name);
4447         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4448         for (elem = hent->h_aliases; elem && *elem; elem++) {
4449             sv_catpv(sv, *elem);
4450             if (elem[1])
4451                 sv_catpvn(sv, " ", 1);
4452         }
4453         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4454         sv_setiv(sv, (IV)hent->h_addrtype);
4455         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4456         len = hent->h_length;
4457         sv_setiv(sv, (IV)len);
4458 #ifdef h_addr
4459         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4460             XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
4461             sv_setpvn(sv, *elem, len);
4462         }
4463 #else
4464         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4465         if (hent->h_addr)
4466             sv_setpvn(sv, hent->h_addr, len);
4467 #endif /* h_addr */
4468     }
4469     RETURN;
4470 #else
4471     DIE(aTHX_ PL_no_sock_func, "gethostent");
4472 #endif
4473 }
4474
4475 PP(pp_gnbyname)
4476 {
4477 #ifdef HAS_GETNETBYNAME
4478     return pp_gnetent();
4479 #else
4480     DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4481 #endif
4482 }
4483
4484 PP(pp_gnbyaddr)
4485 {
4486 #ifdef HAS_GETNETBYADDR
4487     return pp_gnetent();
4488 #else
4489     DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4490 #endif
4491 }
4492
4493 PP(pp_gnetent)
4494 {
4495     djSP;
4496 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4497     I32 which = PL_op->op_type;
4498     register char **elem;
4499     register SV *sv;
4500 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4501     struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4502     struct netent *PerlSock_getnetbyname(Netdb_name_t);
4503     struct netent *PerlSock_getnetent(void);
4504 #endif
4505     struct netent *nent;
4506     STRLEN n_a;
4507
4508     if (which == OP_GNBYNAME)
4509 #ifdef HAS_GETNETBYNAME
4510         nent = PerlSock_getnetbyname(POPpx);
4511 #else
4512         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4513 #endif
4514     else if (which == OP_GNBYADDR) {
4515 #ifdef HAS_GETNETBYADDR
4516         int addrtype = POPi;
4517         Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
4518         nent = PerlSock_getnetbyaddr(addr, addrtype);
4519 #else
4520         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4521 #endif
4522     }
4523     else
4524 #ifdef HAS_GETNETENT
4525         nent = PerlSock_getnetent();
4526 #else
4527         DIE(aTHX_ PL_no_sock_func, "getnetent");
4528 #endif
4529
4530     EXTEND(SP, 4);
4531     if (GIMME != G_ARRAY) {
4532         PUSHs(sv = sv_newmortal());
4533         if (nent) {
4534             if (which == OP_GNBYNAME)
4535                 sv_setiv(sv, (IV)nent->n_net);
4536             else
4537                 sv_setpv(sv, nent->n_name);
4538         }
4539         RETURN;
4540     }
4541
4542     if (nent) {
4543         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4544         sv_setpv(sv, nent->n_name);
4545         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4546         for (elem = nent->n_aliases; elem && *elem; elem++) {
4547             sv_catpv(sv, *elem);
4548             if (elem[1])
4549                 sv_catpvn(sv, " ", 1);
4550         }
4551         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4552         sv_setiv(sv, (IV)nent->n_addrtype);
4553         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4554         sv_setiv(sv, (IV)nent->n_net);
4555     }
4556
4557     RETURN;
4558 #else
4559     DIE(aTHX_ PL_no_sock_func, "getnetent");
4560 #endif
4561 }
4562
4563 PP(pp_gpbyname)
4564 {
4565 #ifdef HAS_GETPROTOBYNAME
4566     return pp_gprotoent();
4567 #else
4568     DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4569 #endif
4570 }
4571
4572 PP(pp_gpbynumber)
4573 {
4574 #ifdef HAS_GETPROTOBYNUMBER
4575     return pp_gprotoent();
4576 #else
4577     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4578 #endif
4579 }
4580
4581 PP(pp_gprotoent)
4582 {
4583     djSP;
4584 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4585     I32 which = PL_op->op_type;
4586     register char **elem;
4587     register SV *sv;
4588 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4589     struct protoent *PerlSock_getprotobyname(Netdb_name_t);
4590     struct protoent *PerlSock_getprotobynumber(int);
4591     struct protoent *PerlSock_getprotoent(void);
4592 #endif
4593     struct protoent *pent;
4594     STRLEN n_a;
4595
4596     if (which == OP_GPBYNAME)
4597 #ifdef HAS_GETPROTOBYNAME
4598         pent = PerlSock_getprotobyname(POPpx);
4599 #else
4600         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4601 #endif
4602     else if (which == OP_GPBYNUMBER)
4603 #ifdef HAS_GETPROTOBYNUMBER
4604         pent = PerlSock_getprotobynumber(POPi);
4605 #else
4606     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4607 #endif
4608     else
4609 #ifdef HAS_GETPROTOENT
4610         pent = PerlSock_getprotoent();
4611 #else
4612         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4613 #endif
4614
4615     EXTEND(SP, 3);
4616     if (GIMME != G_ARRAY) {
4617         PUSHs(sv = sv_newmortal());
4618         if (pent) {
4619             if (which == OP_GPBYNAME)
4620                 sv_setiv(sv, (IV)pent->p_proto);
4621             else
4622                 sv_setpv(sv, pent->p_name);
4623         }
4624         RETURN;
4625     }
4626
4627     if (pent) {
4628         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4629         sv_setpv(sv, pent->p_name);
4630         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4631         for (elem = pent->p_aliases; elem && *elem; elem++) {
4632             sv_catpv(sv, *elem);
4633             if (elem[1])
4634                 sv_catpvn(sv, " ", 1);
4635         }
4636         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4637         sv_setiv(sv, (IV)pent->p_proto);
4638     }
4639
4640     RETURN;
4641 #else
4642     DIE(aTHX_ PL_no_sock_func, "getprotoent");
4643 #endif
4644 }
4645
4646 PP(pp_gsbyname)
4647 {
4648 #ifdef HAS_GETSERVBYNAME
4649     return pp_gservent();
4650 #else
4651     DIE(aTHX_ PL_no_sock_func, "getservbyname");
4652 #endif
4653 }
4654
4655 PP(pp_gsbyport)
4656 {
4657 #ifdef HAS_GETSERVBYPORT
4658     return pp_gservent();
4659 #else
4660     DIE(aTHX_ PL_no_sock_func, "getservbyport");
4661 #endif
4662 }
4663
4664 PP(pp_gservent)
4665 {
4666     djSP;
4667 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4668     I32 which = PL_op->op_type;
4669     register char **elem;
4670     register SV *sv;
4671 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4672     struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4673     struct servent *PerlSock_getservbyport(int, Netdb_name_t);
4674     struct servent *PerlSock_getservent(void);
4675 #endif
4676     struct servent *sent;
4677     STRLEN n_a;
4678
4679     if (which == OP_GSBYNAME) {
4680 #ifdef HAS_GETSERVBYNAME
4681         char *proto = POPpx;
4682         char *name = POPpx;
4683
4684         if (proto && !*proto)
4685             proto = Nullch;
4686
4687         sent = PerlSock_getservbyname(name, proto);
4688 #else
4689         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4690 #endif
4691     }
4692     else if (which == OP_GSBYPORT) {
4693 #ifdef HAS_GETSERVBYPORT
4694         char *proto = POPpx;
4695         unsigned short port = POPu;
4696
4697 #ifdef HAS_HTONS
4698         port = PerlSock_htons(port);
4699 #endif
4700         sent = PerlSock_getservbyport(port, proto);
4701 #else
4702         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4703 #endif
4704     }
4705     else
4706 #ifdef HAS_GETSERVENT
4707         sent = PerlSock_getservent();
4708 #else
4709         DIE(aTHX_ PL_no_sock_func, "getservent");
4710 #endif
4711
4712     EXTEND(SP, 4);
4713     if (GIMME != G_ARRAY) {
4714         PUSHs(sv = sv_newmortal());
4715         if (sent) {
4716             if (which == OP_GSBYNAME) {
4717 #ifdef HAS_NTOHS
4718                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4719 #else
4720                 sv_setiv(sv, (IV)(sent->s_port));
4721 #endif
4722             }
4723             else
4724                 sv_setpv(sv, sent->s_name);
4725         }
4726         RETURN;
4727     }
4728
4729     if (sent) {
4730         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4731         sv_setpv(sv, sent->s_name);
4732         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4733         for (elem = sent->s_aliases; elem && *elem; elem++) {
4734             sv_catpv(sv, *elem);
4735             if (elem[1])
4736                 sv_catpvn(sv, " ", 1);
4737         }
4738         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4739 #ifdef HAS_NTOHS
4740         sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4741 #else
4742         sv_setiv(sv, (IV)(sent->s_port));
4743 #endif
4744         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4745         sv_setpv(sv, sent->s_proto);
4746     }
4747
4748     RETURN;
4749 #else
4750     DIE(aTHX_ PL_no_sock_func, "getservent");
4751 #endif
4752 }
4753
4754 PP(pp_shostent)
4755 {
4756     djSP;
4757 #ifdef HAS_SETHOSTENT
4758     PerlSock_sethostent(TOPi);
4759     RETSETYES;
4760 #else
4761     DIE(aTHX_ PL_no_sock_func, "sethostent");
4762 #endif
4763 }
4764
4765 PP(pp_snetent)
4766 {
4767     djSP;
4768 #ifdef HAS_SETNETENT
4769     PerlSock_setnetent(TOPi);
4770     RETSETYES;
4771 #else
4772     DIE(aTHX_ PL_no_sock_func, "setnetent");
4773 #endif
4774 }
4775
4776 PP(pp_sprotoent)
4777 {
4778     djSP;
4779 #ifdef HAS_SETPROTOENT
4780     PerlSock_setprotoent(TOPi);
4781     RETSETYES;
4782 #else
4783     DIE(aTHX_ PL_no_sock_func, "setprotoent");
4784 #endif
4785 }
4786
4787 PP(pp_sservent)
4788 {
4789     djSP;
4790 #ifdef HAS_SETSERVENT
4791     PerlSock_setservent(TOPi);
4792     RETSETYES;
4793 #else
4794     DIE(aTHX_ PL_no_sock_func, "setservent");
4795 #endif
4796 }
4797
4798 PP(pp_ehostent)
4799 {
4800     djSP;
4801 #ifdef HAS_ENDHOSTENT
4802     PerlSock_endhostent();
4803     EXTEND(SP,1);
4804     RETPUSHYES;
4805 #else
4806     DIE(aTHX_ PL_no_sock_func, "endhostent");
4807 #endif
4808 }
4809
4810 PP(pp_enetent)
4811 {
4812     djSP;
4813 #ifdef HAS_ENDNETENT
4814     PerlSock_endnetent();
4815     EXTEND(SP,1);
4816     RETPUSHYES;
4817 #else
4818     DIE(aTHX_ PL_no_sock_func, "endnetent");
4819 #endif
4820 }
4821
4822 PP(pp_eprotoent)
4823 {
4824     djSP;
4825 #ifdef HAS_ENDPROTOENT
4826     PerlSock_endprotoent();
4827     EXTEND(SP,1);
4828     RETPUSHYES;
4829 #else
4830     DIE(aTHX_ PL_no_sock_func, "endprotoent");
4831 #endif
4832 }
4833
4834 PP(pp_eservent)
4835 {
4836     djSP;
4837 #ifdef HAS_ENDSERVENT
4838     PerlSock_endservent();
4839     EXTEND(SP,1);
4840     RETPUSHYES;
4841 #else
4842     DIE(aTHX_ PL_no_sock_func, "endservent");
4843 #endif
4844 }
4845
4846 PP(pp_gpwnam)
4847 {
4848 #ifdef HAS_PASSWD
4849     return pp_gpwent();
4850 #else
4851     DIE(aTHX_ PL_no_func, "getpwnam");
4852 #endif
4853 }
4854
4855 PP(pp_gpwuid)
4856 {
4857 #ifdef HAS_PASSWD
4858     return pp_gpwent();
4859 #else
4860     DIE(aTHX_ PL_no_func, "getpwuid");
4861 #endif
4862 }
4863
4864 PP(pp_gpwent)
4865 {
4866     djSP;
4867 #ifdef HAS_PASSWD
4868     I32 which = PL_op->op_type;
4869     register SV *sv;
4870     STRLEN n_a;
4871     struct passwd *pwent  = NULL;
4872     /*
4873      * We currently support only the SysV getsp* shadow password interface.
4874      * The interface is declared in <shadow.h> and often one needs to link
4875      * with -lsecurity or some such.
4876      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
4877      * (and SCO?)
4878      *
4879      * AIX getpwnam() is clever enough to return the encrypted password
4880      * only if the caller (euid?) is root.
4881      *
4882      * There are at least two other shadow password APIs.  Many platforms
4883      * seem to contain more than one interface for accessing the shadow
4884      * password databases, possibly for compatibility reasons.
4885      * The getsp*() is by far he simplest one, the other two interfaces
4886      * are much more complicated, but also very similar to each other.
4887      *
4888      * <sys/types.h>
4889      * <sys/security.h>
4890      * <prot.h>
4891      * struct pr_passwd *getprpw*();
4892      * The password is in
4893      * char getprpw*(...).ufld.fd_encrypt[]
4894      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
4895      *
4896      * <sys/types.h>
4897      * <sys/security.h>
4898      * <prot.h>
4899      * struct es_passwd *getespw*();
4900      * The password is in
4901      * char *(getespw*(...).ufld.fd_encrypt)
4902      * Mention HAS_GETESPWNAM here so that Configure probes for it.
4903      *
4904      * Mention I_PROT here so that Configure probes for it.
4905      *
4906      * In HP-UX for getprpw*() the manual page claims that one should include
4907      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
4908      * if one includes <shadow.h> as that includes <hpsecurity.h>,
4909      * and pp_sys.c already includes <shadow.h> if there is such.
4910      *
4911      * Note that <sys/security.h> is already probed for, but currently
4912      * it is only included in special cases.
4913      *
4914      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
4915      * be preferred interface, even though also the getprpw*() interface
4916      * is available) one needs to link with -lsecurity -ldb -laud -lm.
4917      * One also needs to call set_auth_parameters() in main() before
4918      * doing anything else, whether one is using getespw*() or getprpw*().
4919      *
4920      * Note that accessing the shadow databases can be magnitudes
4921      * slower than accessing the standard databases.
4922      *
4923      * --jhi
4924      */
4925
4926     switch (which) {
4927     case OP_GPWNAM:
4928         pwent  = getpwnam(POPpx);
4929         break;
4930     case OP_GPWUID:
4931         pwent = getpwuid((Uid_t)POPi);
4932         break;
4933     case OP_GPWENT:
4934 #   ifdef HAS_GETPWENT
4935         pwent  = getpwent();
4936 #   else
4937         DIE(aTHX_ PL_no_func, "getpwent");
4938 #   endif
4939         break;
4940     }
4941
4942     EXTEND(SP, 10);
4943     if (GIMME != G_ARRAY) {
4944         PUSHs(sv = sv_newmortal());
4945         if (pwent) {
4946             if (which == OP_GPWNAM)
4947 #   if Uid_t_sign <= 0
4948                 sv_setiv(sv, (IV)pwent->pw_uid);
4949 #   else
4950                 sv_setuv(sv, (UV)pwent->pw_uid);
4951 #   endif
4952             else
4953                 sv_setpv(sv, pwent->pw_name);
4954         }
4955         RETURN;
4956     }
4957
4958     if (pwent) {
4959         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4960         sv_setpv(sv, pwent->pw_name);
4961
4962         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4963         SvPOK_off(sv);
4964         /* If we have getspnam(), we try to dig up the shadow
4965          * password.  If we are underprivileged, the shadow
4966          * interface will set the errno to EACCES or similar,
4967          * and return a null pointer.  If this happens, we will
4968          * use the dummy password (usually "*" or "x") from the
4969          * standard password database.
4970          *
4971          * In theory we could skip the shadow call completely
4972          * if euid != 0 but in practice we cannot know which
4973          * security measures are guarding the shadow databases
4974          * on a random platform.
4975          *
4976          * Resist the urge to use additional shadow interfaces.
4977          * Divert the urge to writing an extension instead.
4978          *
4979          * --jhi */
4980 #   ifdef HAS_GETSPNAM
4981         {
4982             struct spwd *spwent;
4983             int saverrno; /* Save and restore errno so that
4984                            * underprivileged attempts seem
4985                            * to have never made the unsccessful
4986                            * attempt to retrieve the shadow password. */
4987
4988             saverrno = errno;
4989             spwent = getspnam(pwent->pw_name);
4990             errno = saverrno;
4991             if (spwent && spwent->sp_pwdp)
4992                 sv_setpv(sv, spwent->sp_pwdp);
4993         }
4994 #   endif
4995 #   ifdef PWPASSWD
4996         if (!SvPOK(sv)) /* Use the standard password, then. */
4997             sv_setpv(sv, pwent->pw_passwd);
4998 #   endif
4999
5000 #   ifndef INCOMPLETE_TAINTS
5001         /* passwd is tainted because user himself can diddle with it.
5002          * admittedly not much and in a very limited way, but nevertheless. */
5003         SvTAINTED_on(sv);
5004 #   endif
5005
5006         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5007 #   if Uid_t_sign <= 0
5008         sv_setiv(sv, (IV)pwent->pw_uid);
5009 #   else
5010         sv_setuv(sv, (UV)pwent->pw_uid);
5011 #   endif
5012
5013         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5014 #   if Uid_t_sign <= 0
5015         sv_setiv(sv, (IV)pwent->pw_gid);
5016 #   else
5017         sv_setuv(sv, (UV)pwent->pw_gid);
5018 #   endif
5019         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5020          * because of the poor interface of the Perl getpw*(),
5021          * not because there's some standard/convention saying so.
5022          * A better interface would have been to return a hash,
5023          * but we are accursed by our history, alas. --jhi.  */
5024         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5025 #   ifdef PWCHANGE
5026         sv_setiv(sv, (IV)pwent->pw_change);
5027 #   else
5028 #       ifdef PWQUOTA
5029         sv_setiv(sv, (IV)pwent->pw_quota);
5030 #       else
5031 #           ifdef PWAGE
5032         sv_setpv(sv, pwent->pw_age);
5033 #           endif
5034 #       endif
5035 #   endif
5036
5037         /* pw_class and pw_comment are mutually exclusive--.
5038          * see the above note for pw_change, pw_quota, and pw_age. */
5039         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5040 #   ifdef PWCLASS
5041         sv_setpv(sv, pwent->pw_class);
5042 #   else
5043 #       ifdef PWCOMMENT
5044         sv_setpv(sv, pwent->pw_comment);
5045 #       endif
5046 #   endif
5047
5048         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5049 #   ifdef PWGECOS
5050         sv_setpv(sv, pwent->pw_gecos);
5051 #   endif
5052 #   ifndef INCOMPLETE_TAINTS
5053         /* pw_gecos is tainted because user himself can diddle with it. */
5054         SvTAINTED_on(sv);
5055 #   endif
5056
5057         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5058         sv_setpv(sv, pwent->pw_dir);
5059
5060         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5061         sv_setpv(sv, pwent->pw_shell);
5062 #   ifndef INCOMPLETE_TAINTS
5063         /* pw_shell is tainted because user himself can diddle with it. */
5064         SvTAINTED_on(sv);
5065 #   endif
5066
5067 #   ifdef PWEXPIRE
5068         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5069         sv_setiv(sv, (IV)pwent->pw_expire);
5070 #   endif
5071     }
5072     RETURN;
5073 #else
5074     DIE(aTHX_ PL_no_func, "getpwent");
5075 #endif
5076 }
5077
5078 PP(pp_spwent)
5079 {
5080     djSP;
5081 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5082     setpwent();
5083     RETPUSHYES;
5084 #else
5085     DIE(aTHX_ PL_no_func, "setpwent");
5086 #endif
5087 }
5088
5089 PP(pp_epwent)
5090 {
5091     djSP;
5092 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5093     endpwent();
5094     RETPUSHYES;
5095 #else
5096     DIE(aTHX_ PL_no_func, "endpwent");
5097 #endif
5098 }
5099
5100 PP(pp_ggrnam)
5101 {
5102 #ifdef HAS_GROUP
5103     return pp_ggrent();
5104 #else
5105     DIE(aTHX_ PL_no_func, "getgrnam");
5106 #endif
5107 }
5108
5109 PP(pp_ggrgid)
5110 {
5111 #ifdef HAS_GROUP
5112     return pp_ggrent();
5113 #else
5114     DIE(aTHX_ PL_no_func, "getgrgid");
5115 #endif
5116 }
5117
5118 PP(pp_ggrent)
5119 {
5120     djSP;
5121 #ifdef HAS_GROUP
5122     I32 which = PL_op->op_type;
5123     register char **elem;
5124     register SV *sv;
5125     struct group *grent;
5126     STRLEN n_a;
5127
5128     if (which == OP_GGRNAM)
5129         grent = (struct group *)getgrnam(POPpx);
5130     else if (which == OP_GGRGID)
5131         grent = (struct group *)getgrgid(POPi);
5132     else
5133 #ifdef HAS_GETGRENT
5134         grent = (struct group *)getgrent();
5135 #else
5136         DIE(aTHX_ PL_no_func, "getgrent");
5137 #endif
5138
5139     EXTEND(SP, 4);
5140     if (GIMME != G_ARRAY) {
5141         PUSHs(sv = sv_newmortal());
5142         if (grent) {
5143             if (which == OP_GGRNAM)
5144                 sv_setiv(sv, (IV)grent->gr_gid);
5145             else
5146                 sv_setpv(sv, grent->gr_name);
5147         }
5148         RETURN;
5149     }
5150
5151     if (grent) {
5152         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5153         sv_setpv(sv, grent->gr_name);
5154
5155         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5156 #ifdef GRPASSWD
5157         sv_setpv(sv, grent->gr_passwd);
5158 #endif
5159
5160         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5161         sv_setiv(sv, (IV)grent->gr_gid);
5162
5163         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5164         for (elem = grent->gr_mem; elem && *elem; elem++) {
5165             sv_catpv(sv, *elem);
5166             if (elem[1])
5167                 sv_catpvn(sv, " ", 1);
5168         }
5169     }
5170
5171     RETURN;
5172 #else
5173     DIE(aTHX_ PL_no_func, "getgrent");
5174 #endif
5175 }
5176
5177 PP(pp_sgrent)
5178 {
5179     djSP;
5180 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5181     setgrent();
5182     RETPUSHYES;
5183 #else
5184     DIE(aTHX_ PL_no_func, "setgrent");
5185 #endif
5186 }
5187
5188 PP(pp_egrent)
5189 {
5190     djSP;
5191 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5192     endgrent();
5193     RETPUSHYES;
5194 #else
5195     DIE(aTHX_ PL_no_func, "endgrent");
5196 #endif
5197 }
5198
5199 PP(pp_getlogin)
5200 {
5201     djSP; dTARGET;
5202 #ifdef HAS_GETLOGIN
5203     char *tmps;
5204     EXTEND(SP, 1);
5205     if (!(tmps = PerlProc_getlogin()))
5206         RETPUSHUNDEF;
5207     PUSHp(tmps, strlen(tmps));
5208     RETURN;
5209 #else
5210     DIE(aTHX_ PL_no_func, "getlogin");
5211 #endif
5212 }
5213
5214 /* Miscellaneous. */
5215
5216 PP(pp_syscall)
5217 {
5218 #ifdef HAS_SYSCALL
5219     djSP; dMARK; dORIGMARK; dTARGET;
5220     register I32 items = SP - MARK;
5221     unsigned long a[20];
5222     register I32 i = 0;
5223     I32 retval = -1;
5224     STRLEN n_a;
5225
5226     if (PL_tainting) {
5227         while (++MARK <= SP) {
5228             if (SvTAINTED(*MARK)) {
5229                 TAINT;
5230                 break;
5231             }
5232         }
5233         MARK = ORIGMARK;
5234         TAINT_PROPER("syscall");
5235     }
5236
5237     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5238      * or where sizeof(long) != sizeof(char*).  But such machines will
5239      * not likely have syscall implemented either, so who cares?
5240      */
5241     while (++MARK <= SP) {
5242         if (SvNIOK(*MARK) || !i)
5243             a[i++] = SvIV(*MARK);
5244         else if (*MARK == &PL_sv_undef)
5245             a[i++] = 0;
5246         else
5247             a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
5248         if (i > 15)
5249             break;
5250     }
5251     switch (items) {
5252     default:
5253         DIE(aTHX_ "Too many args to syscall");
5254     case 0:
5255         DIE(aTHX_ "Too few args to syscall");
5256     case 1:
5257         retval = syscall(a[0]);
5258         break;
5259     case 2:
5260         retval = syscall(a[0],a[1]);
5261         break;
5262     case 3:
5263         retval = syscall(a[0],a[1],a[2]);
5264         break;
5265     case 4:
5266         retval = syscall(a[0],a[1],a[2],a[3]);
5267         break;
5268     case 5:
5269         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5270         break;
5271     case 6:
5272         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5273         break;
5274     case 7:
5275         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5276         break;
5277     case 8:
5278         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5279         break;
5280 #ifdef atarist
5281     case 9:
5282         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5283         break;
5284     case 10:
5285         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5286         break;
5287     case 11:
5288         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5289           a[10]);
5290         break;
5291     case 12:
5292         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5293           a[10],a[11]);
5294         break;
5295     case 13:
5296         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5297           a[10],a[11],a[12]);
5298         break;
5299     case 14:
5300         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5301           a[10],a[11],a[12],a[13]);
5302         break;
5303 #endif /* atarist */
5304     }
5305     SP = ORIGMARK;
5306     PUSHi(retval);
5307     RETURN;
5308 #else
5309     DIE(aTHX_ PL_no_func, "syscall");
5310 #endif
5311 }
5312
5313 #ifdef FCNTL_EMULATE_FLOCK
5314
5315 /*  XXX Emulate flock() with fcntl().
5316     What's really needed is a good file locking module.
5317 */
5318
5319 static int
5320 fcntl_emulate_flock(int fd, int operation)
5321 {
5322     struct flock flock;
5323
5324     switch (operation & ~LOCK_NB) {
5325     case LOCK_SH:
5326         flock.l_type = F_RDLCK;
5327         break;
5328     case LOCK_EX:
5329         flock.l_type = F_WRLCK;
5330         break;
5331     case LOCK_UN:
5332         flock.l_type = F_UNLCK;
5333         break;
5334     default:
5335         errno = EINVAL;
5336         return -1;
5337     }
5338     flock.l_whence = SEEK_SET;
5339     flock.l_start = flock.l_len = (Off_t)0;
5340
5341     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5342 }
5343
5344 #endif /* FCNTL_EMULATE_FLOCK */
5345
5346 #ifdef LOCKF_EMULATE_FLOCK
5347
5348 /*  XXX Emulate flock() with lockf().  This is just to increase
5349     portability of scripts.  The calls are not completely
5350     interchangeable.  What's really needed is a good file
5351     locking module.
5352 */
5353
5354 /*  The lockf() constants might have been defined in <unistd.h>.
5355     Unfortunately, <unistd.h> causes troubles on some mixed
5356     (BSD/POSIX) systems, such as SunOS 4.1.3.
5357
5358    Further, the lockf() constants aren't POSIX, so they might not be
5359    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5360    just stick in the SVID values and be done with it.  Sigh.
5361 */
5362
5363 # ifndef F_ULOCK
5364 #  define F_ULOCK       0       /* Unlock a previously locked region */
5365 # endif
5366 # ifndef F_LOCK
5367 #  define F_LOCK        1       /* Lock a region for exclusive use */
5368 # endif
5369 # ifndef F_TLOCK
5370 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5371 # endif
5372 # ifndef F_TEST
5373 #  define F_TEST        3       /* Test a region for other processes locks */
5374 # endif
5375
5376 static int
5377 lockf_emulate_flock(int fd, int operation)
5378 {
5379     int i;
5380     int save_errno;
5381     Off_t pos;
5382
5383     /* flock locks entire file so for lockf we need to do the same      */
5384     save_errno = errno;
5385     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5386     if (pos > 0)        /* is seekable and needs to be repositioned     */
5387         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5388             pos = -1;   /* seek failed, so don't seek back afterwards   */
5389     errno = save_errno;
5390
5391     switch (operation) {
5392
5393         /* LOCK_SH - get a shared lock */
5394         case LOCK_SH:
5395         /* LOCK_EX - get an exclusive lock */
5396         case LOCK_EX:
5397             i = lockf (fd, F_LOCK, 0);
5398             break;
5399
5400         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5401         case LOCK_SH|LOCK_NB:
5402         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5403         case LOCK_EX|LOCK_NB:
5404             i = lockf (fd, F_TLOCK, 0);
5405             if (i == -1)
5406                 if ((errno == EAGAIN) || (errno == EACCES))
5407                     errno = EWOULDBLOCK;
5408             break;
5409
5410         /* LOCK_UN - unlock (non-blocking is a no-op) */
5411         case LOCK_UN:
5412         case LOCK_UN|LOCK_NB:
5413             i = lockf (fd, F_ULOCK, 0);
5414             break;
5415
5416         /* Default - can't decipher operation */
5417         default:
5418             i = -1;
5419             errno = EINVAL;
5420             break;
5421     }
5422
5423     if (pos > 0)      /* need to restore position of the handle */
5424         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5425
5426     return (i);
5427 }
5428
5429 #endif /* LOCKF_EMULATE_FLOCK */