pp_sys.c

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