pp_sys.c

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