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