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