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