pp_sys.c

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