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