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