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