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