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 #ifdef SOCKS_64BIT_BUG
3728         Perl_do_s64_init_buffer();
3729 #endif
3730         /*SUPPRESS 560*/
3731         if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
3732             sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3733         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3734     }
3735     PUSHi(childpid);
3736     RETURN;
3737 #else
3738 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3739     djSP; dTARGET;
3740     Pid_t childpid;
3741
3742     EXTEND(SP, 1);
3743     PERL_FLUSHALL_FOR_CHILD;
3744     childpid = PerlProc_fork();
3745     if (childpid == -1)
3746         RETSETUNDEF;
3747     PUSHi(childpid);
3748     RETURN;
3749 #  else
3750     DIE(aTHX_ PL_no_func, "Unsupported function fork");
3751 #  endif
3752 #endif
3753 }
3754
3755 PP(pp_wait)
3756 {
3757 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3758     djSP; dTARGET;
3759     Pid_t childpid;
3760     int argflags;
3761
3762     childpid = wait4pid(-1, &argflags, 0);
3763 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3764     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3765     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3766 #  else
3767     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3768 #  endif
3769     XPUSHi(childpid);
3770     RETURN;
3771 #else
3772     DIE(aTHX_ PL_no_func, "Unsupported function wait");
3773 #endif
3774 }
3775
3776 PP(pp_waitpid)
3777 {
3778 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3779     djSP; dTARGET;
3780     Pid_t childpid;
3781     int optype;
3782     int argflags;
3783
3784     optype = POPi;
3785     childpid = TOPi;
3786     childpid = wait4pid(childpid, &argflags, optype);
3787 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3788     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3789     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3790 #  else
3791     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3792 #  endif
3793     SETi(childpid);
3794     RETURN;
3795 #else
3796     DIE(aTHX_ PL_no_func, "Unsupported function waitpid");
3797 #endif
3798 }
3799
3800 PP(pp_system)
3801 {
3802     djSP; dMARK; dORIGMARK; dTARGET;
3803     I32 value;
3804     Pid_t childpid;
3805     int result;
3806     int status;
3807     Sigsave_t ihand,qhand;     /* place to save signals during system() */
3808     STRLEN n_a;
3809     I32 did_pipes = 0;
3810     int pp[2];
3811
3812     if (SP - MARK == 1) {
3813         if (PL_tainting) {
3814             char *junk = SvPV(TOPs, n_a);
3815             TAINT_ENV();
3816             TAINT_PROPER("system");
3817         }
3818     }
3819     PERL_FLUSHALL_FOR_CHILD;
3820 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) && !defined(__CYGWIN__) || defined(PERL_MICRO)
3821     if (PerlProc_pipe(pp) >= 0)
3822         did_pipes = 1;
3823     while ((childpid = vfork()) == -1) {
3824         if (errno != EAGAIN) {
3825             value = -1;
3826             SP = ORIGMARK;
3827             PUSHi(value);
3828             if (did_pipes) {
3829                 PerlLIO_close(pp[0]);
3830                 PerlLIO_close(pp[1]);
3831             }
3832             RETURN;
3833         }
3834         sleep(5);
3835     }
3836     if (childpid > 0) {
3837         if (did_pipes)
3838             PerlLIO_close(pp[1]);
3839 #ifndef PERL_MICRO
3840         rsignal_save(SIGINT, SIG_IGN, &ihand);
3841         rsignal_save(SIGQUIT, SIG_IGN, &qhand);
3842 #endif
3843         do {
3844             result = wait4pid(childpid, &status, 0);
3845         } while (result == -1 && errno == EINTR);
3846 #ifndef PERL_MICRO
3847         (void)rsignal_restore(SIGINT, &ihand);
3848         (void)rsignal_restore(SIGQUIT, &qhand);
3849 #endif
3850         STATUS_NATIVE_SET(result == -1 ? -1 : status);
3851         do_execfree();  /* free any memory child malloced on vfork */
3852         SP = ORIGMARK;
3853         if (did_pipes) {
3854             int errkid;
3855             int n = 0, n1;
3856
3857             while (n < sizeof(int)) {
3858                 n1 = PerlLIO_read(pp[0],
3859                                   (void*)(((char*)&errkid)+n),
3860                                   (sizeof(int)) - n);
3861                 if (n1 <= 0)
3862                     break;
3863                 n += n1;
3864             }
3865             PerlLIO_close(pp[0]);
3866             if (n) {                    /* Error */
3867                 if (n != sizeof(int))
3868                     DIE(aTHX_ "panic: kid popen errno read");
3869                 errno = errkid;         /* Propagate errno from kid */
3870                 STATUS_CURRENT = -1;
3871             }
3872         }
3873         PUSHi(STATUS_CURRENT);
3874         RETURN;
3875     }
3876     if (did_pipes) {
3877         PerlLIO_close(pp[0]);
3878 #if defined(HAS_FCNTL) && defined(F_SETFD)
3879         fcntl(pp[1], F_SETFD, FD_CLOEXEC);
3880 #endif
3881     }
3882     if (PL_op->op_flags & OPf_STACKED) {
3883         SV *really = *++MARK;
3884         value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
3885     }
3886     else if (SP - MARK != 1)
3887         value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
3888     else {
3889         value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
3890     }
3891     PerlProc__exit(-1);
3892 #else /* ! FORK or VMS or OS/2 */
3893     PL_statusvalue = 0;
3894     result = 0;
3895     if (PL_op->op_flags & OPf_STACKED) {
3896         SV *really = *++MARK;
3897         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
3898     }
3899     else if (SP - MARK != 1)
3900         value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
3901     else {
3902         value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
3903     }
3904     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
3905         result = 1;
3906     STATUS_NATIVE_SET(value);
3907     do_execfree();
3908     SP = ORIGMARK;
3909     PUSHi(result ? value : STATUS_CURRENT);
3910 #endif /* !FORK or VMS */
3911     RETURN;
3912 }
3913
3914 PP(pp_exec)
3915 {
3916     djSP; dMARK; dORIGMARK; dTARGET;
3917     I32 value;
3918     STRLEN n_a;
3919
3920     PERL_FLUSHALL_FOR_CHILD;
3921     if (PL_op->op_flags & OPf_STACKED) {
3922         SV *really = *++MARK;
3923         value = (I32)do_aexec(really, MARK, SP);
3924     }
3925     else if (SP - MARK != 1)
3926 #ifdef VMS
3927         value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3928 #else
3929 #  ifdef __OPEN_VM
3930         {
3931            (void ) do_aspawn(Nullsv, MARK, SP);
3932            value = 0;
3933         }
3934 #  else
3935         value = (I32)do_aexec(Nullsv, MARK, SP);
3936 #  endif
3937 #endif
3938     else {
3939         if (PL_tainting) {
3940             char *junk = SvPV(*SP, n_a);
3941             TAINT_ENV();
3942             TAINT_PROPER("exec");
3943         }
3944 #ifdef VMS
3945         value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
3946 #else
3947 #  ifdef __OPEN_VM
3948         (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
3949         value = 0;
3950 #  else
3951         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
3952 #  endif
3953 #endif
3954     }
3955
3956 #if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3957     if (value >= 0)
3958         my_exit(value);
3959 #endif
3960
3961     SP = ORIGMARK;
3962     PUSHi(value);
3963     RETURN;
3964 }
3965
3966 PP(pp_kill)
3967 {
3968     djSP; dMARK; dTARGET;
3969     I32 value;
3970 #ifdef HAS_KILL
3971     value = (I32)apply(PL_op->op_type, MARK, SP);
3972     SP = MARK;
3973     PUSHi(value);
3974     RETURN;
3975 #else
3976     DIE(aTHX_ PL_no_func, "Unsupported function kill");
3977 #endif
3978 }
3979
3980 PP(pp_getppid)
3981 {
3982 #ifdef HAS_GETPPID
3983     djSP; dTARGET;
3984     XPUSHi( getppid() );
3985     RETURN;
3986 #else
3987     DIE(aTHX_ PL_no_func, "getppid");
3988 #endif
3989 }
3990
3991 PP(pp_getpgrp)
3992 {
3993 #ifdef HAS_GETPGRP
3994     djSP; dTARGET;
3995     Pid_t pid;
3996     Pid_t pgrp;
3997
3998     if (MAXARG < 1)
3999         pid = 0;
4000     else
4001         pid = SvIVx(POPs);
4002 #ifdef BSD_GETPGRP
4003     pgrp = (I32)BSD_GETPGRP(pid);
4004 #else
4005     if (pid != 0 && pid != PerlProc_getpid())
4006         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4007     pgrp = getpgrp();
4008 #endif
4009     XPUSHi(pgrp);
4010     RETURN;
4011 #else
4012     DIE(aTHX_ PL_no_func, "getpgrp()");
4013 #endif
4014 }
4015
4016 PP(pp_setpgrp)
4017 {
4018 #ifdef HAS_SETPGRP
4019     djSP; dTARGET;
4020     Pid_t pgrp;
4021     Pid_t pid;
4022     if (MAXARG < 2) {
4023         pgrp = 0;
4024         pid = 0;
4025     }
4026     else {
4027         pgrp = POPi;
4028         pid = TOPi;
4029     }
4030
4031     TAINT_PROPER("setpgrp");
4032 #ifdef BSD_SETPGRP
4033     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4034 #else
4035     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4036         || (pid != 0 && pid != PerlProc_getpid()))
4037     {
4038         DIE(aTHX_ "setpgrp can't take arguments");
4039     }
4040     SETi( setpgrp() >= 0 );
4041 #endif /* USE_BSDPGRP */
4042     RETURN;
4043 #else
4044     DIE(aTHX_ PL_no_func, "setpgrp()");
4045 #endif
4046 }
4047
4048 PP(pp_getpriority)
4049 {
4050     djSP; dTARGET;
4051     int which;
4052     int who;
4053 #ifdef HAS_GETPRIORITY
4054     who = POPi;
4055     which = TOPi;
4056     SETi( getpriority(which, who) );
4057     RETURN;
4058 #else
4059     DIE(aTHX_ PL_no_func, "getpriority()");
4060 #endif
4061 }
4062
4063 PP(pp_setpriority)
4064 {
4065     djSP; dTARGET;
4066     int which;
4067     int who;
4068     int niceval;
4069 #ifdef HAS_SETPRIORITY
4070     niceval = POPi;
4071     who = POPi;
4072     which = TOPi;
4073     TAINT_PROPER("setpriority");
4074     SETi( setpriority(which, who, niceval) >= 0 );
4075     RETURN;
4076 #else
4077     DIE(aTHX_ PL_no_func, "setpriority()");
4078 #endif
4079 }
4080
4081 /* Time calls. */
4082
4083 PP(pp_time)
4084 {
4085     djSP; dTARGET;
4086 #ifdef BIG_TIME
4087     XPUSHn( time(Null(Time_t*)) );
4088 #else
4089     XPUSHi( time(Null(Time_t*)) );
4090 #endif
4091     RETURN;
4092 }
4093
4094 /* XXX The POSIX name is CLK_TCK; it is to be preferred
4095    to HZ.  Probably.  For now, assume that if the system
4096    defines HZ, it does so correctly.  (Will this break
4097    on VMS?)
4098    Probably we ought to use _sysconf(_SC_CLK_TCK), if
4099    it's supported.    --AD  9/96.
4100 */
4101
4102 #ifndef HZ
4103 #  ifdef CLK_TCK
4104 #    define HZ CLK_TCK
4105 #  else
4106 #    define HZ 60
4107 #  endif
4108 #endif
4109
4110 PP(pp_tms)
4111 {
4112     djSP;
4113
4114 #ifndef HAS_TIMES
4115     DIE(aTHX_ "times not implemented");
4116 #else
4117     EXTEND(SP, 4);
4118
4119 #ifndef VMS
4120     (void)PerlProc_times(&PL_timesbuf);
4121 #else
4122     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4123                                                    /* struct tms, though same data   */
4124                                                    /* is returned.                   */
4125 #endif
4126
4127     PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
4128     if (GIMME == G_ARRAY) {
4129         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4130         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4131         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
4132     }
4133     RETURN;
4134 #endif /* HAS_TIMES */
4135 }
4136
4137 PP(pp_localtime)
4138 {
4139     return pp_gmtime();
4140 }
4141
4142 PP(pp_gmtime)
4143 {
4144     djSP;
4145     Time_t when;
4146     struct tm *tmbuf;
4147     static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4148     static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4149                               "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4150
4151     if (MAXARG < 1)
4152         (void)time(&when);
4153     else
4154 #ifdef BIG_TIME
4155         when = (Time_t)SvNVx(POPs);
4156 #else
4157         when = (Time_t)SvIVx(POPs);
4158 #endif
4159
4160     if (PL_op->op_type == OP_LOCALTIME)
4161         tmbuf = localtime(&when);
4162     else
4163         tmbuf = gmtime(&when);
4164
4165     EXTEND(SP, 9);
4166     EXTEND_MORTAL(9);
4167     if (GIMME != G_ARRAY) {
4168         SV *tsv;
4169         if (!tmbuf)
4170             RETPUSHUNDEF;
4171         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4172                             dayname[tmbuf->tm_wday],
4173                             monname[tmbuf->tm_mon],
4174                             tmbuf->tm_mday,
4175                             tmbuf->tm_hour,
4176                             tmbuf->tm_min,
4177                             tmbuf->tm_sec,
4178                             tmbuf->tm_year + 1900);
4179         PUSHs(sv_2mortal(tsv));
4180     }
4181     else if (tmbuf) {
4182         PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4183         PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4184         PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4185         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4186         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4187         PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4188         PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4189         PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4190         PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4191     }
4192     RETURN;
4193 }
4194
4195 PP(pp_alarm)
4196 {
4197     djSP; dTARGET;
4198     int anum;
4199 #ifdef HAS_ALARM
4200     anum = POPi;
4201     anum = alarm((unsigned int)anum);
4202     EXTEND(SP, 1);
4203     if (anum < 0)
4204         RETPUSHUNDEF;
4205     PUSHi(anum);
4206     RETURN;
4207 #else
4208     DIE(aTHX_ PL_no_func, "Unsupported function alarm");
4209 #endif
4210 }
4211
4212 PP(pp_sleep)
4213 {
4214     djSP; dTARGET;
4215     I32 duration;
4216     Time_t lasttime;
4217     Time_t when;
4218
4219     (void)time(&lasttime);
4220     if (MAXARG < 1)
4221         PerlProc_pause();
4222     else {
4223         duration = POPi;
4224         PerlProc_sleep((unsigned int)duration);
4225     }
4226     (void)time(&when);
4227     XPUSHi(when - lasttime);
4228     RETURN;
4229 }
4230
4231 /* Shared memory. */
4232
4233 PP(pp_shmget)
4234 {
4235     return pp_semget();
4236 }
4237
4238 PP(pp_shmctl)
4239 {
4240     return pp_semctl();
4241 }
4242
4243 PP(pp_shmread)
4244 {
4245     return pp_shmwrite();
4246 }
4247
4248 PP(pp_shmwrite)
4249 {
4250 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4251     djSP; dMARK; dTARGET;
4252     I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
4253     SP = MARK;
4254     PUSHi(value);
4255     RETURN;
4256 #else
4257     return pp_semget();
4258 #endif
4259 }
4260
4261 /* Message passing. */
4262
4263 PP(pp_msgget)
4264 {
4265     return pp_semget();
4266 }
4267
4268 PP(pp_msgctl)
4269 {
4270     return pp_semctl();
4271 }
4272
4273 PP(pp_msgsnd)
4274 {
4275 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4276     djSP; dMARK; dTARGET;
4277     I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4278     SP = MARK;
4279     PUSHi(value);
4280     RETURN;
4281 #else
4282     return pp_semget();
4283 #endif
4284 }
4285
4286 PP(pp_msgrcv)
4287 {
4288 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4289     djSP; dMARK; dTARGET;
4290     I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4291     SP = MARK;
4292     PUSHi(value);
4293     RETURN;
4294 #else
4295     return pp_semget();
4296 #endif
4297 }
4298
4299 /* Semaphores. */
4300
4301 PP(pp_semget)
4302 {
4303 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4304     djSP; dMARK; dTARGET;
4305     int anum = do_ipcget(PL_op->op_type, MARK, SP);
4306     SP = MARK;
4307     if (anum == -1)
4308         RETPUSHUNDEF;
4309     PUSHi(anum);
4310     RETURN;
4311 #else
4312     DIE(aTHX_ "System V IPC is not implemented on this machine");
4313 #endif
4314 }
4315
4316 PP(pp_semctl)
4317 {
4318 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4319     djSP; dMARK; dTARGET;
4320     int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4321     SP = MARK;
4322     if (anum == -1)
4323         RETSETUNDEF;
4324     if (anum != 0) {
4325         PUSHi(anum);
4326     }
4327     else {
4328         PUSHp(zero_but_true, ZBTLEN);
4329     }
4330     RETURN;
4331 #else
4332     return pp_semget();
4333 #endif
4334 }
4335
4336 PP(pp_semop)
4337 {
4338 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4339     djSP; dMARK; dTARGET;
4340     I32 value = (I32)(do_semop(MARK, SP) >= 0);
4341     SP = MARK;
4342     PUSHi(value);
4343     RETURN;
4344 #else
4345     return pp_semget();
4346 #endif
4347 }
4348
4349 /* Get system info. */
4350
4351 PP(pp_ghbyname)
4352 {
4353 #ifdef HAS_GETHOSTBYNAME
4354     return pp_ghostent();
4355 #else
4356     DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4357 #endif
4358 }
4359
4360 PP(pp_ghbyaddr)
4361 {
4362 #ifdef HAS_GETHOSTBYADDR
4363     return pp_ghostent();
4364 #else
4365     DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4366 #endif
4367 }
4368
4369 PP(pp_ghostent)
4370 {
4371     djSP;
4372 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4373     I32 which = PL_op->op_type;
4374     register char **elem;
4375     register SV *sv;
4376 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4377     struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4378     struct hostent *PerlSock_gethostbyname(Netdb_name_t);
4379     struct hostent *PerlSock_gethostent(void);
4380 #endif
4381     struct hostent *hent;
4382     unsigned long len;
4383     STRLEN n_a;
4384
4385     EXTEND(SP, 10);
4386     if (which == OP_GHBYNAME)
4387 #ifdef HAS_GETHOSTBYNAME
4388         hent = PerlSock_gethostbyname(POPpx);
4389 #else
4390         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4391 #endif
4392     else if (which == OP_GHBYADDR) {
4393 #ifdef HAS_GETHOSTBYADDR
4394         int addrtype = POPi;
4395         SV *addrsv = POPs;
4396         STRLEN addrlen;
4397         Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen);
4398
4399         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4400 #else
4401         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4402 #endif
4403     }
4404     else
4405 #ifdef HAS_GETHOSTENT
4406         hent = PerlSock_gethostent();
4407 #else
4408         DIE(aTHX_ PL_no_sock_func, "gethostent");
4409 #endif
4410
4411 #ifdef HOST_NOT_FOUND
4412     if (!hent)
4413         STATUS_NATIVE_SET(h_errno);
4414 #endif
4415
4416     if (GIMME != G_ARRAY) {
4417         PUSHs(sv = sv_newmortal());
4418         if (hent) {
4419             if (which == OP_GHBYNAME) {
4420                 if (hent->h_addr)
4421                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4422             }
4423             else
4424                 sv_setpv(sv, (char*)hent->h_name);
4425         }
4426         RETURN;
4427     }
4428
4429     if (hent) {
4430         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4431         sv_setpv(sv, (char*)hent->h_name);
4432         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4433         for (elem = hent->h_aliases; elem && *elem; elem++) {
4434             sv_catpv(sv, *elem);
4435             if (elem[1])
4436                 sv_catpvn(sv, " ", 1);
4437         }
4438         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4439         sv_setiv(sv, (IV)hent->h_addrtype);
4440         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4441         len = hent->h_length;
4442         sv_setiv(sv, (IV)len);
4443 #ifdef h_addr
4444         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4445             XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
4446             sv_setpvn(sv, *elem, len);
4447         }
4448 #else
4449         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4450         if (hent->h_addr)
4451             sv_setpvn(sv, hent->h_addr, len);
4452 #endif /* h_addr */
4453     }
4454     RETURN;
4455 #else
4456     DIE(aTHX_ PL_no_sock_func, "gethostent");
4457 #endif
4458 }
4459
4460 PP(pp_gnbyname)
4461 {
4462 #ifdef HAS_GETNETBYNAME
4463     return pp_gnetent();
4464 #else
4465     DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4466 #endif
4467 }
4468
4469 PP(pp_gnbyaddr)
4470 {
4471 #ifdef HAS_GETNETBYADDR
4472     return pp_gnetent();
4473 #else
4474     DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4475 #endif
4476 }
4477
4478 PP(pp_gnetent)
4479 {
4480     djSP;
4481 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4482     I32 which = PL_op->op_type;
4483     register char **elem;
4484     register SV *sv;
4485 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4486     struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4487     struct netent *PerlSock_getnetbyname(Netdb_name_t);
4488     struct netent *PerlSock_getnetent(void);
4489 #endif
4490     struct netent *nent;
4491     STRLEN n_a;
4492
4493     if (which == OP_GNBYNAME)
4494 #ifdef HAS_GETNETBYNAME
4495         nent = PerlSock_getnetbyname(POPpx);
4496 #else
4497         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4498 #endif
4499     else if (which == OP_GNBYADDR) {
4500 #ifdef HAS_GETNETBYADDR
4501         int addrtype = POPi;
4502         Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
4503         nent = PerlSock_getnetbyaddr(addr, addrtype);
4504 #else
4505         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4506 #endif
4507     }
4508     else
4509 #ifdef HAS_GETNETENT
4510         nent = PerlSock_getnetent();
4511 #else
4512         DIE(aTHX_ PL_no_sock_func, "getnetent");
4513 #endif
4514
4515     EXTEND(SP, 4);
4516     if (GIMME != G_ARRAY) {
4517         PUSHs(sv = sv_newmortal());
4518         if (nent) {
4519             if (which == OP_GNBYNAME)
4520                 sv_setiv(sv, (IV)nent->n_net);
4521             else
4522                 sv_setpv(sv, nent->n_name);
4523         }
4524         RETURN;
4525     }
4526
4527     if (nent) {
4528         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4529         sv_setpv(sv, nent->n_name);
4530         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4531         for (elem = nent->n_aliases; elem && *elem; elem++) {
4532             sv_catpv(sv, *elem);
4533             if (elem[1])
4534                 sv_catpvn(sv, " ", 1);
4535         }
4536         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4537         sv_setiv(sv, (IV)nent->n_addrtype);
4538         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4539         sv_setiv(sv, (IV)nent->n_net);
4540     }
4541
4542     RETURN;
4543 #else
4544     DIE(aTHX_ PL_no_sock_func, "getnetent");
4545 #endif
4546 }
4547
4548 PP(pp_gpbyname)
4549 {
4550 #ifdef HAS_GETPROTOBYNAME
4551     return pp_gprotoent();
4552 #else
4553     DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4554 #endif
4555 }
4556
4557 PP(pp_gpbynumber)
4558 {
4559 #ifdef HAS_GETPROTOBYNUMBER
4560     return pp_gprotoent();
4561 #else
4562     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4563 #endif
4564 }
4565
4566 PP(pp_gprotoent)
4567 {
4568     djSP;
4569 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4570     I32 which = PL_op->op_type;
4571     register char **elem;
4572     register SV *sv;
4573 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4574     struct protoent *PerlSock_getprotobyname(Netdb_name_t);
4575     struct protoent *PerlSock_getprotobynumber(int);
4576     struct protoent *PerlSock_getprotoent(void);
4577 #endif
4578     struct protoent *pent;
4579     STRLEN n_a;
4580
4581     if (which == OP_GPBYNAME)
4582 #ifdef HAS_GETPROTOBYNAME
4583         pent = PerlSock_getprotobyname(POPpx);
4584 #else
4585         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4586 #endif
4587     else if (which == OP_GPBYNUMBER)
4588 #ifdef HAS_GETPROTOBYNUMBER
4589         pent = PerlSock_getprotobynumber(POPi);
4590 #else
4591     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4592 #endif
4593     else
4594 #ifdef HAS_GETPROTOENT
4595         pent = PerlSock_getprotoent();
4596 #else
4597         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4598 #endif
4599
4600     EXTEND(SP, 3);
4601     if (GIMME != G_ARRAY) {
4602         PUSHs(sv = sv_newmortal());
4603         if (pent) {
4604             if (which == OP_GPBYNAME)
4605                 sv_setiv(sv, (IV)pent->p_proto);
4606             else
4607                 sv_setpv(sv, pent->p_name);
4608         }
4609         RETURN;
4610     }
4611
4612     if (pent) {
4613         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4614         sv_setpv(sv, pent->p_name);
4615         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4616         for (elem = pent->p_aliases; elem && *elem; elem++) {
4617             sv_catpv(sv, *elem);
4618             if (elem[1])
4619                 sv_catpvn(sv, " ", 1);
4620         }
4621         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4622         sv_setiv(sv, (IV)pent->p_proto);
4623     }
4624
4625     RETURN;
4626 #else
4627     DIE(aTHX_ PL_no_sock_func, "getprotoent");
4628 #endif
4629 }
4630
4631 PP(pp_gsbyname)
4632 {
4633 #ifdef HAS_GETSERVBYNAME
4634     return pp_gservent();
4635 #else
4636     DIE(aTHX_ PL_no_sock_func, "getservbyname");
4637 #endif
4638 }
4639
4640 PP(pp_gsbyport)
4641 {
4642 #ifdef HAS_GETSERVBYPORT
4643     return pp_gservent();
4644 #else
4645     DIE(aTHX_ PL_no_sock_func, "getservbyport");
4646 #endif
4647 }
4648
4649 PP(pp_gservent)
4650 {
4651     djSP;
4652 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4653     I32 which = PL_op->op_type;
4654     register char **elem;
4655     register SV *sv;
4656 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4657     struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4658     struct servent *PerlSock_getservbyport(int, Netdb_name_t);
4659     struct servent *PerlSock_getservent(void);
4660 #endif
4661     struct servent *sent;
4662     STRLEN n_a;
4663
4664     if (which == OP_GSBYNAME) {
4665 #ifdef HAS_GETSERVBYNAME
4666         char *proto = POPpx;
4667         char *name = POPpx;
4668
4669         if (proto && !*proto)
4670             proto = Nullch;
4671
4672         sent = PerlSock_getservbyname(name, proto);
4673 #else
4674         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4675 #endif
4676     }
4677     else if (which == OP_GSBYPORT) {
4678 #ifdef HAS_GETSERVBYPORT
4679         char *proto = POPpx;
4680         unsigned short port = POPu;
4681
4682 #ifdef HAS_HTONS
4683         port = PerlSock_htons(port);
4684 #endif
4685         sent = PerlSock_getservbyport(port, proto);
4686 #else
4687         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4688 #endif
4689     }
4690     else
4691 #ifdef HAS_GETSERVENT
4692         sent = PerlSock_getservent();
4693 #else
4694         DIE(aTHX_ PL_no_sock_func, "getservent");
4695 #endif
4696
4697     EXTEND(SP, 4);
4698     if (GIMME != G_ARRAY) {
4699         PUSHs(sv = sv_newmortal());
4700         if (sent) {
4701             if (which == OP_GSBYNAME) {
4702 #ifdef HAS_NTOHS
4703                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4704 #else
4705                 sv_setiv(sv, (IV)(sent->s_port));
4706 #endif
4707             }
4708             else
4709                 sv_setpv(sv, sent->s_name);
4710         }
4711         RETURN;
4712     }
4713
4714     if (sent) {
4715         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4716         sv_setpv(sv, sent->s_name);
4717         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4718         for (elem = sent->s_aliases; elem && *elem; elem++) {
4719             sv_catpv(sv, *elem);
4720             if (elem[1])
4721                 sv_catpvn(sv, " ", 1);
4722         }
4723         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4724 #ifdef HAS_NTOHS
4725         sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4726 #else
4727         sv_setiv(sv, (IV)(sent->s_port));
4728 #endif
4729         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4730         sv_setpv(sv, sent->s_proto);
4731     }
4732
4733     RETURN;
4734 #else
4735     DIE(aTHX_ PL_no_sock_func, "getservent");
4736 #endif
4737 }
4738
4739 PP(pp_shostent)
4740 {
4741     djSP;
4742 #ifdef HAS_SETHOSTENT
4743     PerlSock_sethostent(TOPi);
4744     RETSETYES;
4745 #else
4746     DIE(aTHX_ PL_no_sock_func, "sethostent");
4747 #endif
4748 }
4749
4750 PP(pp_snetent)
4751 {
4752     djSP;
4753 #ifdef HAS_SETNETENT
4754     PerlSock_setnetent(TOPi);
4755     RETSETYES;
4756 #else
4757     DIE(aTHX_ PL_no_sock_func, "setnetent");
4758 #endif
4759 }
4760
4761 PP(pp_sprotoent)
4762 {
4763     djSP;
4764 #ifdef HAS_SETPROTOENT
4765     PerlSock_setprotoent(TOPi);
4766     RETSETYES;
4767 #else
4768     DIE(aTHX_ PL_no_sock_func, "setprotoent");
4769 #endif
4770 }
4771
4772 PP(pp_sservent)
4773 {
4774     djSP;
4775 #ifdef HAS_SETSERVENT
4776     PerlSock_setservent(TOPi);
4777     RETSETYES;
4778 #else
4779     DIE(aTHX_ PL_no_sock_func, "setservent");
4780 #endif
4781 }
4782
4783 PP(pp_ehostent)
4784 {
4785     djSP;
4786 #ifdef HAS_ENDHOSTENT
4787     PerlSock_endhostent();
4788     EXTEND(SP,1);
4789     RETPUSHYES;
4790 #else
4791     DIE(aTHX_ PL_no_sock_func, "endhostent");
4792 #endif
4793 }
4794
4795 PP(pp_enetent)
4796 {
4797     djSP;
4798 #ifdef HAS_ENDNETENT
4799     PerlSock_endnetent();
4800     EXTEND(SP,1);
4801     RETPUSHYES;
4802 #else
4803     DIE(aTHX_ PL_no_sock_func, "endnetent");
4804 #endif
4805 }
4806
4807 PP(pp_eprotoent)
4808 {
4809     djSP;
4810 #ifdef HAS_ENDPROTOENT
4811     PerlSock_endprotoent();
4812     EXTEND(SP,1);
4813     RETPUSHYES;
4814 #else
4815     DIE(aTHX_ PL_no_sock_func, "endprotoent");
4816 #endif
4817 }
4818
4819 PP(pp_eservent)
4820 {
4821     djSP;
4822 #ifdef HAS_ENDSERVENT
4823     PerlSock_endservent();
4824     EXTEND(SP,1);
4825     RETPUSHYES;
4826 #else
4827     DIE(aTHX_ PL_no_sock_func, "endservent");
4828 #endif
4829 }
4830
4831 PP(pp_gpwnam)
4832 {
4833 #ifdef HAS_PASSWD
4834     return pp_gpwent();
4835 #else
4836     DIE(aTHX_ PL_no_func, "getpwnam");
4837 #endif
4838 }
4839
4840 PP(pp_gpwuid)
4841 {
4842 #ifdef HAS_PASSWD
4843     return pp_gpwent();
4844 #else
4845     DIE(aTHX_ PL_no_func, "getpwuid");
4846 #endif
4847 }
4848
4849 PP(pp_gpwent)
4850 {
4851     djSP;
4852 #ifdef HAS_PASSWD
4853     I32 which = PL_op->op_type;
4854     register SV *sv;
4855     STRLEN n_a;
4856     struct passwd *pwent  = NULL;
4857     /*
4858      * We currently support only the SysV getsp* shadow password interface.
4859      * The interface is declared in <shadow.h> and often one needs to link
4860      * with -lsecurity or some such.
4861      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
4862      * (and SCO?)
4863      *
4864      * AIX getpwnam() is clever enough to return the encrypted password
4865      * only if the caller (euid?) is root.
4866      *
4867      * There are at least two other shadow password APIs.  Many platforms
4868      * seem to contain more than one interface for accessing the shadow
4869      * password databases, possibly for compatibility reasons.
4870      * The getsp*() is by far he simplest one, the other two interfaces
4871      * are much more complicated, but also very similar to each other.
4872      *
4873      * <sys/types.h>
4874      * <sys/security.h>
4875      * <prot.h>
4876      * struct pr_passwd *getprpw*();
4877      * The password is in
4878      * char getprpw*(...).ufld.fd_encrypt[]
4879      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
4880      *
4881      * <sys/types.h>
4882      * <sys/security.h>
4883      * <prot.h>
4884      * struct es_passwd *getespw*();
4885      * The password is in
4886      * char *(getespw*(...).ufld.fd_encrypt)
4887      * Mention HAS_GETESPWNAM here so that Configure probes for it.
4888      *
4889      * Mention I_PROT here so that Configure probes for it.
4890      *
4891      * In HP-UX for getprpw*() the manual page claims that one should include
4892      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
4893      * if one includes <shadow.h> as that includes <hpsecurity.h>,
4894      * and pp_sys.c already includes <shadow.h> if there is such.
4895      *
4896      * Note that <sys/security.h> is already probed for, but currently
4897      * it is only included in special cases.
4898      *
4899      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
4900      * be preferred interface, even though also the getprpw*() interface
4901      * is available) one needs to link with -lsecurity -ldb -laud -lm.
4902      * One also needs to call set_auth_parameters() in main() before
4903      * doing anything else, whether one is using getespw*() or getprpw*().
4904      *
4905      * Note that accessing the shadow databases can be magnitudes
4906      * slower than accessing the standard databases.
4907      *
4908      * --jhi
4909      */
4910
4911     switch (which) {
4912     case OP_GPWNAM:
4913         pwent  = getpwnam(POPpx);
4914         break;
4915     case OP_GPWUID:
4916         pwent = getpwuid((Uid_t)POPi);
4917         break;
4918     case OP_GPWENT:
4919 #   ifdef HAS_GETPWENT
4920         pwent  = getpwent();
4921 #   else
4922         DIE(aTHX_ PL_no_func, "getpwent");
4923 #   endif
4924         break;
4925     }
4926
4927     EXTEND(SP, 10);
4928     if (GIMME != G_ARRAY) {
4929         PUSHs(sv = sv_newmortal());
4930         if (pwent) {
4931             if (which == OP_GPWNAM)
4932 #   if Uid_t_sign <= 0
4933                 sv_setiv(sv, (IV)pwent->pw_uid);
4934 #   else
4935                 sv_setuv(sv, (UV)pwent->pw_uid);
4936 #   endif
4937             else
4938                 sv_setpv(sv, pwent->pw_name);
4939         }
4940         RETURN;
4941     }
4942
4943     if (pwent) {
4944         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4945         sv_setpv(sv, pwent->pw_name);
4946
4947         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4948         SvPOK_off(sv);
4949         /* If we have getspnam(), we try to dig up the shadow
4950          * password.  If we are underprivileged, the shadow
4951          * interface will set the errno to EACCES or similar,
4952          * and return a null pointer.  If this happens, we will
4953          * use the dummy password (usually "*" or "x") from the
4954          * standard password database.
4955          *
4956          * In theory we could skip the shadow call completely
4957          * if euid != 0 but in practice we cannot know which
4958          * security measures are guarding the shadow databases
4959          * on a random platform.
4960          *
4961          * Resist the urge to use additional shadow interfaces.
4962          * Divert the urge to writing an extension instead.
4963          *
4964          * --jhi */
4965 #   ifdef HAS_GETSPNAM
4966         {
4967             struct spwd *spwent;
4968             int saverrno; /* Save and restore errno so that
4969                            * underprivileged attempts seem
4970                            * to have never made the unsccessful
4971                            * attempt to retrieve the shadow password. */
4972
4973             saverrno = errno;
4974             spwent = getspnam(pwent->pw_name);
4975             errno = saverrno;
4976             if (spwent && spwent->sp_pwdp)
4977                 sv_setpv(sv, spwent->sp_pwdp);
4978         }
4979 #   endif
4980 #   ifdef PWPASSWD
4981         if (!SvPOK(sv)) /* Use the standard password, then. */
4982             sv_setpv(sv, pwent->pw_passwd);
4983 #   endif
4984
4985 #   ifndef INCOMPLETE_TAINTS
4986         /* passwd is tainted because user himself can diddle with it.
4987          * admittedly not much and in a very limited way, but nevertheless. */
4988         SvTAINTED_on(sv);
4989 #   endif
4990
4991         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4992 #   if Uid_t_sign <= 0
4993         sv_setiv(sv, (IV)pwent->pw_uid);
4994 #   else
4995         sv_setuv(sv, (UV)pwent->pw_uid);
4996 #   endif
4997
4998         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4999 #   if Uid_t_sign <= 0
5000         sv_setiv(sv, (IV)pwent->pw_gid);
5001 #   else
5002         sv_setuv(sv, (UV)pwent->pw_gid);
5003 #   endif
5004         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5005          * because of the poor interface of the Perl getpw*(),
5006          * not because there's some standard/convention saying so.
5007          * A better interface would have been to return a hash,
5008          * but we are accursed by our history, alas. --jhi.  */
5009         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5010 #   ifdef PWCHANGE
5011         sv_setiv(sv, (IV)pwent->pw_change);
5012 #   else
5013 #       ifdef PWQUOTA
5014         sv_setiv(sv, (IV)pwent->pw_quota);
5015 #       else
5016 #           ifdef PWAGE
5017         sv_setpv(sv, pwent->pw_age);
5018 #           endif
5019 #       endif
5020 #   endif
5021
5022         /* pw_class and pw_comment are mutually exclusive--.
5023          * see the above note for pw_change, pw_quota, and pw_age. */
5024         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5025 #   ifdef PWCLASS
5026         sv_setpv(sv, pwent->pw_class);
5027 #   else
5028 #       ifdef PWCOMMENT
5029         sv_setpv(sv, pwent->pw_comment);
5030 #       endif
5031 #   endif
5032
5033         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5034 #   ifdef PWGECOS
5035         sv_setpv(sv, pwent->pw_gecos);
5036 #   endif
5037 #   ifndef INCOMPLETE_TAINTS
5038         /* pw_gecos is tainted because user himself can diddle with it. */
5039         SvTAINTED_on(sv);
5040 #   endif
5041
5042         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5043         sv_setpv(sv, pwent->pw_dir);
5044
5045         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5046         sv_setpv(sv, pwent->pw_shell);
5047 #   ifndef INCOMPLETE_TAINTS
5048         /* pw_shell is tainted because user himself can diddle with it. */
5049         SvTAINTED_on(sv);
5050 #   endif
5051
5052 #   ifdef PWEXPIRE
5053         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5054         sv_setiv(sv, (IV)pwent->pw_expire);
5055 #   endif
5056     }
5057     RETURN;
5058 #else
5059     DIE(aTHX_ PL_no_func, "getpwent");
5060 #endif
5061 }
5062
5063 PP(pp_spwent)
5064 {
5065     djSP;
5066 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5067     setpwent();
5068     RETPUSHYES;
5069 #else
5070     DIE(aTHX_ PL_no_func, "setpwent");
5071 #endif
5072 }
5073
5074 PP(pp_epwent)
5075 {
5076     djSP;
5077 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5078     endpwent();
5079     RETPUSHYES;
5080 #else
5081     DIE(aTHX_ PL_no_func, "endpwent");
5082 #endif
5083 }
5084
5085 PP(pp_ggrnam)
5086 {
5087 #ifdef HAS_GROUP
5088     return pp_ggrent();
5089 #else
5090     DIE(aTHX_ PL_no_func, "getgrnam");
5091 #endif
5092 }
5093
5094 PP(pp_ggrgid)
5095 {
5096 #ifdef HAS_GROUP
5097     return pp_ggrent();
5098 #else
5099     DIE(aTHX_ PL_no_func, "getgrgid");
5100 #endif
5101 }
5102
5103 PP(pp_ggrent)
5104 {
5105     djSP;
5106 #ifdef HAS_GROUP
5107     I32 which = PL_op->op_type;
5108     register char **elem;
5109     register SV *sv;
5110     struct group *grent;
5111     STRLEN n_a;
5112
5113     if (which == OP_GGRNAM)
5114         grent = (struct group *)getgrnam(POPpx);
5115     else if (which == OP_GGRGID)
5116         grent = (struct group *)getgrgid(POPi);
5117     else
5118 #ifdef HAS_GETGRENT
5119         grent = (struct group *)getgrent();
5120 #else
5121         DIE(aTHX_ PL_no_func, "getgrent");
5122 #endif
5123
5124     EXTEND(SP, 4);
5125     if (GIMME != G_ARRAY) {
5126         PUSHs(sv = sv_newmortal());
5127         if (grent) {
5128             if (which == OP_GGRNAM)
5129                 sv_setiv(sv, (IV)grent->gr_gid);
5130             else
5131                 sv_setpv(sv, grent->gr_name);
5132         }
5133         RETURN;
5134     }
5135
5136     if (grent) {
5137         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5138         sv_setpv(sv, grent->gr_name);
5139
5140         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5141 #ifdef GRPASSWD
5142         sv_setpv(sv, grent->gr_passwd);
5143 #endif
5144
5145         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5146         sv_setiv(sv, (IV)grent->gr_gid);
5147
5148         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5149         for (elem = grent->gr_mem; elem && *elem; elem++) {
5150             sv_catpv(sv, *elem);
5151             if (elem[1])
5152                 sv_catpvn(sv, " ", 1);
5153         }
5154     }
5155
5156     RETURN;
5157 #else
5158     DIE(aTHX_ PL_no_func, "getgrent");
5159 #endif
5160 }
5161
5162 PP(pp_sgrent)
5163 {
5164     djSP;
5165 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5166     setgrent();
5167     RETPUSHYES;
5168 #else
5169     DIE(aTHX_ PL_no_func, "setgrent");
5170 #endif
5171 }
5172
5173 PP(pp_egrent)
5174 {
5175     djSP;
5176 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5177     endgrent();
5178     RETPUSHYES;
5179 #else
5180     DIE(aTHX_ PL_no_func, "endgrent");
5181 #endif
5182 }
5183
5184 PP(pp_getlogin)
5185 {
5186     djSP; dTARGET;
5187 #ifdef HAS_GETLOGIN
5188     char *tmps;
5189     EXTEND(SP, 1);
5190     if (!(tmps = PerlProc_getlogin()))
5191         RETPUSHUNDEF;
5192     PUSHp(tmps, strlen(tmps));
5193     RETURN;
5194 #else
5195     DIE(aTHX_ PL_no_func, "getlogin");
5196 #endif
5197 }
5198
5199 /* Miscellaneous. */
5200
5201 PP(pp_syscall)
5202 {
5203 #ifdef HAS_SYSCALL
5204     djSP; dMARK; dORIGMARK; dTARGET;
5205     register I32 items = SP - MARK;
5206     unsigned long a[20];
5207     register I32 i = 0;
5208     I32 retval = -1;
5209     STRLEN n_a;
5210
5211     if (PL_tainting) {
5212         while (++MARK <= SP) {
5213             if (SvTAINTED(*MARK)) {
5214                 TAINT;
5215                 break;
5216             }
5217         }
5218         MARK = ORIGMARK;
5219         TAINT_PROPER("syscall");
5220     }
5221
5222     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5223      * or where sizeof(long) != sizeof(char*).  But such machines will
5224      * not likely have syscall implemented either, so who cares?
5225      */
5226     while (++MARK <= SP) {
5227         if (SvNIOK(*MARK) || !i)
5228             a[i++] = SvIV(*MARK);
5229         else if (*MARK == &PL_sv_undef)
5230             a[i++] = 0;
5231         else
5232             a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
5233         if (i > 15)
5234             break;
5235     }
5236     switch (items) {
5237     default:
5238         DIE(aTHX_ "Too many args to syscall");
5239     case 0:
5240         DIE(aTHX_ "Too few args to syscall");
5241     case 1:
5242         retval = syscall(a[0]);
5243         break;
5244     case 2:
5245         retval = syscall(a[0],a[1]);
5246         break;
5247     case 3:
5248         retval = syscall(a[0],a[1],a[2]);
5249         break;
5250     case 4:
5251         retval = syscall(a[0],a[1],a[2],a[3]);
5252         break;
5253     case 5:
5254         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5255         break;
5256     case 6:
5257         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5258         break;
5259     case 7:
5260         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5261         break;
5262     case 8:
5263         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5264         break;
5265 #ifdef atarist