pp_sys.c

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