pp_sys.c

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