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