pp_sys.c

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