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