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     dSP;
 581 #ifdef HAS_PIPE
 582     GV *rgv;
 583     GV *wgv;
 584     register IO *rstio;
 585     register IO *wstio;
 586     int fd[2];
 587
 588     wgv = (GV*)POPs;
 589     rgv = (GV*)POPs;
 590
 591     if (!rgv || !wgv)
 592         goto badexit;
 593
 594     if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
 595         DIE(aTHX_ PL_no_usym, "filehandle");
 596     rstio = GvIOn(rgv);
 597     wstio = GvIOn(wgv);
 598
 599     if (IoIFP(rstio))
 600         do_close(rgv, FALSE);
 601     if (IoIFP(wstio))
 602         do_close(wgv, FALSE);
 603
 604     if (PerlProc_pipe(fd) < 0)
 605         goto badexit;
 606
 607     IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
 608     IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
 609     IoIFP(wstio) = IoOFP(wstio);
 610     IoTYPE(rstio) = IoTYPE_RDONLY;
 611     IoTYPE(wstio) = IoTYPE_WRONLY;
 612
 613     if (!IoIFP(rstio) || !IoOFP(wstio)) {
 614         if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
 615         else PerlLIO_close(fd[0]);
 616         if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
 617         else PerlLIO_close(fd[1]);
 618         goto badexit;
 619     }
 620 #if defined(HAS_FCNTL) && defined(F_SETFD)
 621     fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);   /* ensure close-on-exec */
 622     fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);   /* ensure close-on-exec */
 623 #endif
 624     RETPUSHYES;
 625
 626 badexit:
 627     RETPUSHUNDEF;
 628 #else
 629     DIE(aTHX_ PL_no_func, "pipe");
 630 #endif
 631 }
 632
 633 PP(pp_fileno)
 634 {
 635     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     Mode_t anum;
 673
 674 #ifdef HAS_UMASK
 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     dSP; dTARGET;
 946 #ifdef HAS_SELECT
 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     dSP; dTARGET;
2156     I32 value;
2157     int argtype;
2158     GV *gv;
2159     IO *io = NULL;
2160     PerlIO *fp;
2161
2162 #ifdef FLOCK
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     dSP;
2196 #ifdef HAS_SOCKET
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     dSP;
2314 #ifdef HAS_SOCKET
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     dSP;
2373 #ifdef HAS_SOCKET
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     dSP;
2403 #ifdef HAS_SOCKET
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     dSP; dTARGET;
2429 #ifdef HAS_SOCKET
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     dSP; dTARGET;
2494 #ifdef HAS_SOCKET
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     dSP;
2527 #ifdef HAS_SOCKET
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     dSP;
2608 #ifdef HAS_SOCKET
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 #else
3489     DIE(aTHX_ PL_no_func, "link");
3490 #endif
3491     RETURN;
3492 }
3493
3494 PP(pp_symlink)
3495 {
3496 #ifdef HAS_SYMLINK
3497     dSP;
3498     dTARGET;
3499     STRLEN n_a;
3500     char *tmps2 = POPpx;
3501     char *tmps = SvPV(TOPs, n_a);
3502     TAINT_PROPER("symlink");
3503     SETi( symlink(tmps, tmps2) >= 0 );
3504     RETURN;
3505 #else
3506     DIE(aTHX_ PL_no_func, "symlink");
3507 #endif
3508 }
3509
3510 PP(pp_readlink)
3511 {
3512     dSP;
3513 #ifdef HAS_SYMLINK
3514     dTARGET;
3515     char *tmps;
3516     char buf[MAXPATHLEN];
3517     int len;
3518     STRLEN n_a;
3519
3520 #ifndef INCOMPLETE_TAINTS
3521     TAINT;
3522 #endif
3523     tmps = POPpx;
3524     len = readlink(tmps, buf, sizeof(buf) - 1);
3525     EXTEND(SP, 1);
3526     if (len < 0)
3527         RETPUSHUNDEF;
3528     PUSHp(buf, len);
3529     RETURN;
3530 #else
3531     EXTEND(SP, 1);
3532     RETSETUNDEF;                /* just pretend it's a normal file */
3533 #endif
3534 }
3535
3536 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3537 STATIC int
3538 S_dooneliner(pTHX_ char *cmd, char *filename)
3539 {
3540     char *save_filename = filename;
3541     char *cmdline;
3542     char *s;
3543     PerlIO *myfp;
3544     int anum = 1;
3545
3546     New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3547     strcpy(cmdline, cmd);
3548     strcat(cmdline, " ");
3549     for (s = cmdline + strlen(cmdline); *filename; ) {
3550         *s++ = '\\';
3551         *s++ = *filename++;
3552     }
3553     strcpy(s, " 2>&1");
3554     myfp = PerlProc_popen(cmdline, "r");
3555     Safefree(cmdline);
3556
3557     if (myfp) {
3558         SV *tmpsv = sv_newmortal();
3559         /* Need to save/restore 'PL_rs' ?? */
3560         s = sv_gets(tmpsv, myfp, 0);
3561         (void)PerlProc_pclose(myfp);
3562         if (s != Nullch) {
3563             int e;
3564             for (e = 1;
3565 #ifdef HAS_SYS_ERRLIST
3566                  e <= sys_nerr
3567 #endif
3568                  ; e++)
3569             {
3570                 /* you don't see this */
3571                 char *errmsg =
3572 #ifdef HAS_SYS_ERRLIST
3573                     sys_errlist[e]
3574 #else
3575                     strerror(e)
3576 #endif
3577                     ;
3578                 if (!errmsg)
3579                     break;
3580                 if (instr(s, errmsg)) {
3581                     SETERRNO(e,0);
3582                     return 0;
3583                 }
3584             }
3585             SETERRNO(0,0);
3586 #ifndef EACCES
3587 #define EACCES EPERM
3588 #endif
3589             if (instr(s, "cannot make"))
3590                 SETERRNO(EEXIST,RMS$_FEX);
3591             else if (instr(s, "existing file"))
3592                 SETERRNO(EEXIST,RMS$_FEX);
3593             else if (instr(s, "ile exists"))
3594                 SETERRNO(EEXIST,RMS$_FEX);
3595             else if (instr(s, "non-exist"))
3596                 SETERRNO(ENOENT,RMS$_FNF);
3597             else if (instr(s, "does not exist"))
3598                 SETERRNO(ENOENT,RMS$_FNF);
3599             else if (instr(s, "not empty"))
3600                 SETERRNO(EBUSY,SS$_DEVOFFLINE);
3601             else if (instr(s, "cannot access"))
3602                 SETERRNO(EACCES,RMS$_PRV);
3603             else
3604                 SETERRNO(EPERM,RMS$_PRV);
3605             return 0;
3606         }
3607         else {  /* some mkdirs return no failure indication */
3608             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3609             if (PL_op->op_type == OP_RMDIR)
3610                 anum = !anum;
3611             if (anum)
3612                 SETERRNO(0,0);
3613             else
3614                 SETERRNO(EACCES,RMS$_PRV);      /* a guess */
3615         }
3616         return anum;
3617     }
3618     else
3619         return 0;
3620 }
3621 #endif
3622
3623 PP(pp_mkdir)
3624 {
3625     dSP; dTARGET;
3626     int mode;
3627 #ifndef HAS_MKDIR
3628     int oldumask;
3629 #endif
3630     STRLEN len;
3631     char *tmps;
3632     bool copy = FALSE;
3633
3634     if (MAXARG > 1)
3635         mode = POPi;
3636     else
3637         mode = 0777;
3638
3639     tmps = SvPV(TOPs, len);
3640     /* Different operating and file systems take differently to
3641      * trailing slashes.  According to POSIX 1003.1 1996 Edition
3642      * any number of trailing slashes should be allowed.
3643      * Thusly we snip them away so that even non-conforming
3644      * systems are happy. */
3645     /* We should probably do this "filtering" for all
3646      * the functions that expect (potentially) directory names:
3647      * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3648      * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3649     if (len > 1 && tmps[len-1] == '/') {
3650         while (tmps[len] == '/' && len > 1)
3651             len--;
3652         tmps = savepvn(tmps, len);
3653         copy = TRUE;
3654     }
3655
3656     TAINT_PROPER("mkdir");
3657 #ifdef HAS_MKDIR
3658     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3659 #else
3660     SETi( dooneliner("mkdir", tmps) );
3661     oldumask = PerlLIO_umask(0);
3662     PerlLIO_umask(oldumask);
3663     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3664 #endif
3665     if (copy)
3666         Safefree(tmps);
3667     RETURN;
3668 }
3669
3670 PP(pp_rmdir)
3671 {
3672     dSP; dTARGET;
3673     char *tmps;
3674     STRLEN n_a;
3675
3676     tmps = POPpx;
3677     TAINT_PROPER("rmdir");
3678 #ifdef HAS_RMDIR
3679     XPUSHi( PerlDir_rmdir(tmps) >= 0 );
3680 #else
3681     XPUSHi( dooneliner("rmdir", tmps) );
3682 #endif
3683     RETURN;
3684 }
3685
3686 /* Directory calls. */
3687
3688 PP(pp_open_dir)
3689 {
3690     dSP;
3691 #if defined(Direntry_t) && defined(HAS_READDIR)
3692     STRLEN n_a;
3693     char *dirname = POPpx;
3694     GV *gv = (GV*)POPs;
3695     register IO *io = GvIOn(gv);
3696
3697     if (!io)
3698         goto nope;
3699
3700     if (IoDIRP(io))
3701         PerlDir_close(IoDIRP(io));
3702     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3703         goto nope;
3704
3705     RETPUSHYES;
3706 nope:
3707     if (!errno)
3708         SETERRNO(EBADF,RMS$_DIR);
3709     RETPUSHUNDEF;
3710 #else
3711     DIE(aTHX_ PL_no_dir_func, "opendir");
3712 #endif
3713 }
3714
3715 PP(pp_readdir)
3716 {
3717     dSP;
3718 #if defined(Direntry_t) && defined(HAS_READDIR)
3719 #if !defined(I_DIRENT) && !defined(VMS)
3720     Direntry_t *readdir (DIR *);
3721 #endif
3722     register Direntry_t *dp;
3723     GV *gv = (GV*)POPs;
3724     register IO *io = GvIOn(gv);
3725     SV *sv;
3726
3727     if (!io || !IoDIRP(io))
3728         goto nope;
3729
3730     if (GIMME == G_ARRAY) {
3731         /*SUPPRESS 560*/
3732         while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
3733 #ifdef DIRNAMLEN
3734             sv = newSVpvn(dp->d_name, dp->d_namlen);
3735 #else
3736             sv = newSVpv(dp->d_name, 0);
3737 #endif
3738 #ifndef INCOMPLETE_TAINTS
3739             if (!(IoFLAGS(io) & IOf_UNTAINT))
3740                 SvTAINTED_on(sv);
3741 #endif
3742             XPUSHs(sv_2mortal(sv));
3743         }
3744     }
3745     else {
3746         if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
3747             goto nope;
3748 #ifdef DIRNAMLEN
3749         sv = newSVpvn(dp->d_name, dp->d_namlen);
3750 #else
3751         sv = newSVpv(dp->d_name, 0);
3752 #endif
3753 #ifndef INCOMPLETE_TAINTS
3754         if (!(IoFLAGS(io) & IOf_UNTAINT))
3755             SvTAINTED_on(sv);
3756 #endif
3757         XPUSHs(sv_2mortal(sv));
3758     }
3759     RETURN;
3760
3761 nope:
3762     if (!errno)
3763         SETERRNO(EBADF,RMS$_ISI);
3764     if (GIMME == G_ARRAY)
3765         RETURN;
3766     else
3767         RETPUSHUNDEF;
3768 #else
3769     DIE(aTHX_ PL_no_dir_func, "readdir");
3770 #endif
3771 }
3772
3773 PP(pp_telldir)
3774 {
3775     dSP; dTARGET;
3776 #if defined(HAS_TELLDIR) || defined(telldir)
3777  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3778  /* XXX netbsd still seemed to.
3779     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3780     --JHI 1999-Feb-02 */
3781 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3782     long telldir (DIR *);
3783 # endif
3784     GV *gv = (GV*)POPs;
3785     register IO *io = GvIOn(gv);
3786
3787     if (!io || !IoDIRP(io))
3788         goto nope;
3789
3790     PUSHi( PerlDir_tell(IoDIRP(io)) );
3791     RETURN;
3792 nope:
3793     if (!errno)
3794         SETERRNO(EBADF,RMS$_ISI);
3795     RETPUSHUNDEF;
3796 #else
3797     DIE(aTHX_ PL_no_dir_func, "telldir");
3798 #endif
3799 }
3800
3801 PP(pp_seekdir)
3802 {
3803     dSP;
3804 #if defined(HAS_SEEKDIR) || defined(seekdir)
3805     long along = POPl;
3806     GV *gv = (GV*)POPs;
3807     register IO *io = GvIOn(gv);
3808
3809     if (!io || !IoDIRP(io))
3810         goto nope;
3811
3812     (void)PerlDir_seek(IoDIRP(io), along);
3813
3814     RETPUSHYES;
3815 nope:
3816     if (!errno)
3817         SETERRNO(EBADF,RMS$_ISI);
3818     RETPUSHUNDEF;
3819 #else
3820     DIE(aTHX_ PL_no_dir_func, "seekdir");
3821 #endif
3822 }
3823
3824 PP(pp_rewinddir)
3825 {
3826     dSP;
3827 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3828     GV *gv = (GV*)POPs;
3829     register IO *io = GvIOn(gv);
3830
3831     if (!io || !IoDIRP(io))
3832         goto nope;
3833
3834     (void)PerlDir_rewind(IoDIRP(io));
3835     RETPUSHYES;
3836 nope:
3837     if (!errno)
3838         SETERRNO(EBADF,RMS$_ISI);
3839     RETPUSHUNDEF;
3840 #else
3841     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3842 #endif
3843 }
3844
3845 PP(pp_closedir)
3846 {
3847     dSP;
3848 #if defined(Direntry_t) && defined(HAS_READDIR)
3849     GV *gv = (GV*)POPs;
3850     register IO *io = GvIOn(gv);
3851
3852     if (!io || !IoDIRP(io))
3853         goto nope;
3854
3855 #ifdef VOID_CLOSEDIR
3856     PerlDir_close(IoDIRP(io));
3857 #else
3858     if (PerlDir_close(IoDIRP(io)) < 0) {
3859         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3860         goto nope;
3861     }
3862 #endif
3863     IoDIRP(io) = 0;
3864
3865     RETPUSHYES;
3866 nope:
3867     if (!errno)
3868         SETERRNO(EBADF,RMS$_IFI);
3869     RETPUSHUNDEF;
3870 #else
3871     DIE(aTHX_ PL_no_dir_func, "closedir");
3872 #endif
3873 }
3874
3875 /* Process control. */
3876
3877 PP(pp_fork)
3878 {
3879 #ifdef HAS_FORK
3880     dSP; dTARGET;
3881     Pid_t childpid;
3882     GV *tmpgv;
3883
3884     EXTEND(SP, 1);
3885     PERL_FLUSHALL_FOR_CHILD;
3886     childpid = fork();
3887     if (childpid < 0)
3888         RETSETUNDEF;
3889     if (!childpid) {
3890         /*SUPPRESS 560*/
3891         if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
3892             sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3893         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3894     }
3895     PUSHi(childpid);
3896     RETURN;
3897 #else
3898 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3899     dSP; dTARGET;
3900     Pid_t childpid;
3901
3902     EXTEND(SP, 1);
3903     PERL_FLUSHALL_FOR_CHILD;
3904     childpid = PerlProc_fork();
3905     if (childpid == -1)
3906         RETSETUNDEF;
3907     PUSHi(childpid);
3908     RETURN;
3909 #  else
3910     DIE(aTHX_ PL_no_func, "fork");
3911 #  endif
3912 #endif
3913 }
3914
3915 PP(pp_wait)
3916 {
3917 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3918     dSP; dTARGET;
3919     Pid_t childpid;
3920     int argflags;
3921
3922 #ifdef PERL_OLD_SIGNALS
3923     childpid = wait4pid(-1, &argflags, 0);
3924 #else
3925     while ((childpid = wait4pid(-1, &argflags, 0)) == -1 && errno == EINTR) {
3926         PERL_ASYNC_CHECK();
3927     }
3928 #endif
3929 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3930     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3931     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3932 #  else
3933     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3934 #  endif
3935     XPUSHi(childpid);
3936     RETURN;
3937 #else
3938     DIE(aTHX_ PL_no_func, "wait");
3939 #endif
3940 }
3941
3942 PP(pp_waitpid)
3943 {
3944 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3945     dSP; dTARGET;
3946     Pid_t childpid;
3947     int optype;
3948     int argflags;
3949
3950     optype = POPi;
3951     childpid = TOPi;
3952 #ifdef PERL_OLD_SIGNALS
3953     childpid = wait4pid(childpid, &argflags, optype);
3954 #else
3955     while ((childpid = wait4pid(childpid, &argflags, optype)) == -1 && errno == EINTR) {
3956         PERL_ASYNC_CHECK();
3957     }
3958 #endif
3959 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3960     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3961     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3962 #  else
3963     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3964 #  endif
3965     SETi(childpid);
3966     RETURN;
3967 #else
3968     DIE(aTHX_ PL_no_func, "waitpid");
3969 #endif
3970 }
3971
3972 PP(pp_system)
3973 {
3974     dSP; dMARK; dORIGMARK; dTARGET;
3975     I32 value;
3976     STRLEN n_a;
3977     int result;
3978
3979     if (SP - MARK == 1) {
3980         if (PL_tainting) {
3981             (void)SvPV_nolen(TOPs);      /* stringify for taint check */
3982             TAINT_ENV();
3983             TAINT_PROPER("system");
3984         }
3985     }
3986     PERL_FLUSHALL_FOR_CHILD;
3987 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) && !defined(__CYGWIN__) || defined(PERL_MICRO)
3988   {
3989     Pid_t childpid;
3990     int status;
3991     Sigsave_t ihand,qhand;     /* place to save signals during system() */
3992     I32 did_pipes = 0;
3993     int pp[2];
3994
3995     if (PerlProc_pipe(pp) >= 0)
3996         did_pipes = 1;
3997     while ((childpid = vfork()) == -1) {
3998         if (errno != EAGAIN) {
3999             value = -1;
4000             SP = ORIGMARK;
4001             PUSHi(value);
4002             if (did_pipes) {
4003                 PerlLIO_close(pp[0]);
4004                 PerlLIO_close(pp[1]);
4005             }
4006             RETURN;
4007         }
4008         sleep(5);
4009     }
4010     if (childpid > 0) {
4011         if (did_pipes)
4012             PerlLIO_close(pp[1]);
4013 #ifndef PERL_MICRO
4014         rsignal_save(SIGINT, SIG_IGN, &ihand);
4015         rsignal_save(SIGQUIT, SIG_IGN, &qhand);
4016 #endif
4017         do {
4018             result = wait4pid(childpid, &status, 0);
4019         } while (result == -1 && errno == EINTR);
4020 #ifndef PERL_MICRO
4021         (void)rsignal_restore(SIGINT, &ihand);
4022         (void)rsignal_restore(SIGQUIT, &qhand);
4023 #endif
4024         STATUS_NATIVE_SET(result == -1 ? -1 : status);
4025         do_execfree();  /* free any memory child malloced on vfork */
4026         SP = ORIGMARK;
4027         if (did_pipes) {
4028             int errkid;
4029             int n = 0, n1;
4030
4031             while (n < sizeof(int)) {
4032                 n1 = PerlLIO_read(pp[0],
4033                                   (void*)(((char*)&errkid)+n),
4034                                   (sizeof(int)) - n);
4035                 if (n1 <= 0)
4036                     break;
4037                 n += n1;
4038             }
4039             PerlLIO_close(pp[0]);
4040             if (n) {                    /* Error */
4041                 if (n != sizeof(int))
4042                     DIE(aTHX_ "panic: kid popen errno read");
4043                 errno = errkid;         /* Propagate errno from kid */
4044                 STATUS_CURRENT = -1;
4045             }
4046         }
4047         PUSHi(STATUS_CURRENT);
4048         RETURN;
4049     }
4050     if (did_pipes) {
4051         PerlLIO_close(pp[0]);
4052 #if defined(HAS_FCNTL) && defined(F_SETFD)
4053         fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4054   }
4055 #endif
4056     }
4057     if (PL_op->op_flags & OPf_STACKED) {
4058         SV *really = *++MARK;
4059         value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4060     }
4061     else if (SP - MARK != 1)
4062         value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
4063     else {
4064         value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
4065     }
4066     PerlProc__exit(-1);
4067 #else /* ! FORK or VMS or OS/2 */
4068     PL_statusvalue = 0;
4069     result = 0;
4070     if (PL_op->op_flags & OPf_STACKED) {
4071         SV *really = *++MARK;
4072         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4073     }
4074     else if (SP - MARK != 1)
4075         value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
4076     else {
4077         value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
4078     }
4079     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4080         result = 1;
4081     STATUS_NATIVE_SET(value);
4082     do_execfree();
4083     SP = ORIGMARK;
4084     PUSHi(result ? value : STATUS_CURRENT);
4085 #endif /* !FORK or VMS */
4086     RETURN;
4087 }
4088
4089 PP(pp_exec)
4090 {
4091     dSP; dMARK; dORIGMARK; dTARGET;
4092     I32 value;
4093     STRLEN n_a;
4094
4095     PERL_FLUSHALL_FOR_CHILD;
4096     if (PL_op->op_flags & OPf_STACKED) {
4097         SV *really = *++MARK;
4098         value = (I32)do_aexec(really, MARK, SP);
4099     }
4100     else if (SP - MARK != 1)
4101 #ifdef VMS
4102         value = (I32)vms_do_aexec(Nullsv, MARK, SP);
4103 #else
4104 #  ifdef __OPEN_VM
4105         {
4106            (void ) do_aspawn(Nullsv, MARK, SP);
4107            value = 0;
4108         }
4109 #  else
4110         value = (I32)do_aexec(Nullsv, MARK, SP);
4111 #  endif
4112 #endif
4113     else {
4114         if (PL_tainting) {
4115             (void)SvPV_nolen(*SP);      /* stringify for taint check */
4116             TAINT_ENV();
4117             TAINT_PROPER("exec");
4118         }
4119 #ifdef VMS
4120         value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
4121 #else
4122 #  ifdef __OPEN_VM
4123         (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
4124         value = 0;
4125 #  else
4126         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
4127 #  endif
4128 #endif
4129     }
4130
4131 #if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4132     if (value >= 0)
4133         my_exit(value);
4134 #endif
4135
4136     SP = ORIGMARK;
4137     PUSHi(value);
4138     RETURN;
4139 }
4140
4141 PP(pp_kill)
4142 {
4143     dSP; dMARK; dTARGET;
4144     I32 value;
4145 #ifdef HAS_KILL
4146     value = (I32)apply(PL_op->op_type, MARK, SP);
4147     SP = MARK;
4148     PUSHi(value);
4149     RETURN;
4150 #else
4151     DIE(aTHX_ PL_no_func, "kill");
4152 #endif
4153 }
4154
4155 PP(pp_getppid)
4156 {
4157 #ifdef HAS_GETPPID
4158     dSP; dTARGET;
4159     XPUSHi( getppid() );
4160     RETURN;
4161 #else
4162     DIE(aTHX_ PL_no_func, "getppid");
4163 #endif
4164 }
4165
4166 PP(pp_getpgrp)
4167 {
4168 #ifdef HAS_GETPGRP
4169     dSP; dTARGET;
4170     Pid_t pid;
4171     Pid_t pgrp;
4172
4173     if (MAXARG < 1)
4174         pid = 0;
4175     else
4176         pid = SvIVx(POPs);
4177 #ifdef BSD_GETPGRP
4178     pgrp = (I32)BSD_GETPGRP(pid);
4179 #else
4180     if (pid != 0 && pid != PerlProc_getpid())
4181         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4182     pgrp = getpgrp();
4183 #endif
4184     XPUSHi(pgrp);
4185     RETURN;
4186 #else
4187     DIE(aTHX_ PL_no_func, "getpgrp()");
4188 #endif
4189 }
4190
4191 PP(pp_setpgrp)
4192 {
4193 #ifdef HAS_SETPGRP
4194     dSP; dTARGET;
4195     Pid_t pgrp;
4196     Pid_t pid;
4197     if (MAXARG < 2) {
4198         pgrp = 0;
4199         pid = 0;
4200     }
4201     else {
4202         pgrp = POPi;
4203         pid = TOPi;
4204     }
4205
4206     TAINT_PROPER("setpgrp");
4207 #ifdef BSD_SETPGRP
4208     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4209 #else
4210     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4211         || (pid != 0 && pid != PerlProc_getpid()))
4212     {
4213         DIE(aTHX_ "setpgrp can't take arguments");
4214     }
4215     SETi( setpgrp() >= 0 );
4216 #endif /* USE_BSDPGRP */
4217     RETURN;
4218 #else
4219     DIE(aTHX_ PL_no_func, "setpgrp()");
4220 #endif
4221 }
4222
4223 PP(pp_getpriority)
4224 {
4225     dSP; dTARGET;
4226 #ifdef HAS_GETPRIORITY
4227     int who = POPi;
4228     int which = TOPi;
4229     SETi( getpriority(which, who) );
4230     RETURN;
4231 #else
4232     DIE(aTHX_ PL_no_func, "getpriority()");
4233 #endif
4234 }
4235
4236 PP(pp_setpriority)
4237 {
4238     dSP; dTARGET;
4239 #ifdef HAS_SETPRIORITY
4240     int niceval = POPi;
4241     int who = POPi;
4242     int which = TOPi;
4243     TAINT_PROPER("setpriority");
4244     SETi( setpriority(which, who, niceval) >= 0 );
4245     RETURN;
4246 #else
4247     DIE(aTHX_ PL_no_func, "setpriority()");
4248 #endif
4249 }
4250
4251 /* Time calls. */
4252
4253 PP(pp_time)
4254 {
4255     dSP; dTARGET;
4256 #ifdef BIG_TIME
4257     XPUSHn( time(Null(Time_t*)) );
4258 #else
4259     XPUSHi( time(Null(Time_t*)) );
4260 #endif
4261     RETURN;
4262 }
4263
4264 /* XXX The POSIX name is CLK_TCK; it is to be preferred
4265    to HZ.  Probably.  For now, assume that if the system
4266    defines HZ, it does so correctly.  (Will this break
4267    on VMS?)
4268    Probably we ought to use _sysconf(_SC_CLK_TCK), if
4269    it's supported.    --AD  9/96.
4270 */
4271
4272 #ifndef HZ
4273 #  ifdef CLK_TCK
4274 #    define HZ CLK_TCK
4275 #  else
4276 #    define HZ 60
4277 #  endif
4278 #endif
4279
4280 PP(pp_tms)
4281 {
4282     dSP;
4283
4284 #ifndef HAS_TIMES
4285     DIE(aTHX_ "times not implemented");
4286 #else
4287     EXTEND(SP, 4);
4288
4289 #ifndef VMS
4290     (void)PerlProc_times(&PL_timesbuf);
4291 #else
4292     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4293                                                    /* struct tms, though same data   */
4294                                                    /* is returned.                   */
4295 #endif
4296
4297     PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
4298     if (GIMME == G_ARRAY) {
4299         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4300         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4301         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
4302     }
4303     RETURN;
4304 #endif /* HAS_TIMES */
4305 }
4306
4307 PP(pp_localtime)
4308 {
4309     return pp_gmtime();
4310 }
4311
4312 PP(pp_gmtime)
4313 {
4314     dSP;
4315     Time_t when;
4316     struct tm *tmbuf;
4317     static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4318     static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4319                               "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4320
4321     if (MAXARG < 1)
4322         (void)time(&when);
4323     else
4324 #ifdef BIG_TIME
4325         when = (Time_t)SvNVx(POPs);
4326 #else
4327         when = (Time_t)SvIVx(POPs);
4328 #endif
4329
4330     if (PL_op->op_type == OP_LOCALTIME)
4331         tmbuf = localtime(&when);
4332     else
4333         tmbuf = gmtime(&when);
4334
4335     EXTEND(SP, 9);
4336     EXTEND_MORTAL(9);
4337     if (GIMME != G_ARRAY) {
4338         SV *tsv;
4339         if (!tmbuf)
4340             RETPUSHUNDEF;
4341         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4342                             dayname[tmbuf->tm_wday],
4343                             monname[tmbuf->tm_mon],
4344                             tmbuf->tm_mday,
4345                             tmbuf->tm_hour,
4346                             tmbuf->tm_min,
4347                             tmbuf->tm_sec,
4348                             tmbuf->tm_year + 1900);
4349         PUSHs(sv_2mortal(tsv));
4350     }
4351     else if (tmbuf) {
4352         PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4353         PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4354         PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4355         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4356         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4357         PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4358         PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4359         PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4360         PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4361     }
4362     RETURN;
4363 }
4364
4365 PP(pp_alarm)
4366 {
4367     dSP; dTARGET;
4368     int anum;
4369 #ifdef HAS_ALARM
4370     anum = POPi;
4371     anum = alarm((unsigned int)anum);
4372     EXTEND(SP, 1);
4373     if (anum < 0)
4374         RETPUSHUNDEF;
4375     PUSHi(anum);
4376     RETURN;
4377 #else
4378     DIE(aTHX_ PL_no_func, "alarm");
4379 #endif
4380 }
4381
4382 PP(pp_sleep)
4383 {
4384     dSP; dTARGET;
4385     I32 duration;
4386     Time_t lasttime;
4387     Time_t when;
4388
4389     (void)time(&lasttime);
4390     if (MAXARG < 1)
4391         PerlProc_pause();
4392     else {
4393         duration = POPi;
4394         PerlProc_sleep((unsigned int)duration);
4395     }
4396     (void)time(&when);
4397     XPUSHi(when - lasttime);
4398     RETURN;
4399 }
4400
4401 /* Shared memory. */
4402
4403 PP(pp_shmget)
4404 {
4405     return pp_semget();
4406 }
4407
4408 PP(pp_shmctl)
4409 {
4410     return pp_semctl();
4411 }
4412
4413 PP(pp_shmread)
4414 {
4415     return pp_shmwrite();
4416 }
4417
4418 PP(pp_shmwrite)
4419 {
4420 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4421     dSP; dMARK; dTARGET;
4422     I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
4423     SP = MARK;
4424     PUSHi(value);
4425     RETURN;
4426 #else
4427     return pp_semget();
4428 #endif
4429 }
4430
4431 /* Message passing. */
4432
4433 PP(pp_msgget)
4434 {
4435     return pp_semget();
4436 }
4437
4438 PP(pp_msgctl)
4439 {
4440     return pp_semctl();
4441 }
4442
4443 PP(pp_msgsnd)
4444 {
4445 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4446     dSP; dMARK; dTARGET;
4447     I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4448     SP = MARK;
4449     PUSHi(value);
4450     RETURN;
4451 #else
4452     return pp_semget();
4453 #endif
4454 }
4455
4456 PP(pp_msgrcv)
4457 {
4458 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4459     dSP; dMARK; dTARGET;
4460     I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4461     SP = MARK;
4462     PUSHi(value);
4463     RETURN;
4464 #else
4465     return pp_semget();
4466 #endif
4467 }
4468
4469 /* Semaphores. */
4470
4471 PP(pp_semget)
4472 {
4473 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4474     dSP; dMARK; dTARGET;
4475     int anum = do_ipcget(PL_op->op_type, MARK, SP);
4476     SP = MARK;
4477     if (anum == -1)
4478         RETPUSHUNDEF;
4479     PUSHi(anum);
4480     RETURN;
4481 #else
4482     DIE(aTHX_ "System V IPC is not implemented on this machine");
4483 #endif
4484 }
4485
4486 PP(pp_semctl)
4487 {
4488 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4489     dSP; dMARK; dTARGET;
4490     int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4491     SP = MARK;
4492     if (anum == -1)
4493         RETSETUNDEF;
4494     if (anum != 0) {
4495         PUSHi(anum);
4496     }
4497     else {
4498         PUSHp(zero_but_true, ZBTLEN);
4499     }
4500     RETURN;
4501 #else
4502     return pp_semget();
4503 #endif
4504 }
4505
4506 PP(pp_semop)
4507 {
4508 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4509     dSP; dMARK; dTARGET;
4510     I32 value = (I32)(do_semop(MARK, SP) >= 0);
4511     SP = MARK;
4512     PUSHi(value);
4513     RETURN;
4514 #else
4515     return pp_semget();
4516 #endif
4517 }
4518
4519 /* Get system info. */
4520
4521 PP(pp_ghbyname)
4522 {
4523 #ifdef HAS_GETHOSTBYNAME
4524     return pp_ghostent();
4525 #else
4526     DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4527 #endif
4528 }
4529
4530 PP(pp_ghbyaddr)
4531 {
4532 #ifdef HAS_GETHOSTBYADDR
4533     return pp_ghostent();
4534 #else
4535     DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4536 #endif
4537 }
4538
4539 PP(pp_ghostent)
4540 {
4541     dSP;
4542 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4543     I32 which = PL_op->op_type;
4544     register char **elem;
4545     register SV *sv;
4546 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4547     struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4548     struct hostent *PerlSock_gethostbyname(Netdb_name_t);
4549     struct hostent *PerlSock_gethostent(void);
4550 #endif
4551     struct hostent *hent;
4552     unsigned long len;
4553     STRLEN n_a;
4554
4555     EXTEND(SP, 10);
4556     if (which == OP_GHBYNAME)
4557 #ifdef HAS_GETHOSTBYNAME
4558         hent = PerlSock_gethostbyname(POPpbytex);
4559 #else
4560         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4561 #endif
4562     else if (which == OP_GHBYADDR) {
4563 #ifdef HAS_GETHOSTBYADDR
4564         int addrtype = POPi;
4565         SV *addrsv = POPs;
4566         STRLEN addrlen;
4567         Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
4568
4569         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4570 #else
4571         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4572 #endif
4573     }
4574     else
4575 #ifdef HAS_GETHOSTENT
4576         hent = PerlSock_gethostent();
4577 #else
4578         DIE(aTHX_ PL_no_sock_func, "gethostent");
4579 #endif
4580
4581 #ifdef HOST_NOT_FOUND
4582     if (!hent)
4583         STATUS_NATIVE_SET(h_errno);
4584 #endif
4585
4586     if (GIMME != G_ARRAY) {
4587         PUSHs(sv = sv_newmortal());
4588         if (hent) {
4589             if (which == OP_GHBYNAME) {
4590                 if (hent->h_addr)
4591                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4592             }
4593             else
4594                 sv_setpv(sv, (char*)hent->h_name);
4595         }
4596         RETURN;
4597     }
4598
4599     if (hent) {
4600         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4601         sv_setpv(sv, (char*)hent->h_name);
4602         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4603         for (elem = hent->h_aliases; elem && *elem; elem++) {
4604             sv_catpv(sv, *elem);
4605             if (elem[1])
4606                 sv_catpvn(sv, " ", 1);
4607         }
4608         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4609         sv_setiv(sv, (IV)hent->h_addrtype);
4610         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4611         len = hent->h_length;
4612         sv_setiv(sv, (IV)len);
4613 #ifdef h_addr
4614         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4615             XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
4616             sv_setpvn(sv, *elem, len);
4617         }
4618 #else
4619         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4620         if (hent->h_addr)
4621             sv_setpvn(sv, hent->h_addr, len);
4622 #endif /* h_addr */
4623     }
4624     RETURN;
4625 #else
4626     DIE(aTHX_ PL_no_sock_func, "gethostent");
4627 #endif
4628 }
4629
4630 PP(pp_gnbyname)
4631 {
4632 #ifdef HAS_GETNETBYNAME
4633     return pp_gnetent();
4634 #else
4635     DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4636 #endif
4637 }
4638
4639 PP(pp_gnbyaddr)
4640 {
4641 #ifdef HAS_GETNETBYADDR
4642     return pp_gnetent();
4643 #else
4644     DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4645 #endif
4646 }
4647
4648 PP(pp_gnetent)
4649 {
4650     dSP;
4651 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4652     I32 which = PL_op->op_type;
4653     register char **elem;
4654     register SV *sv;
4655 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4656     struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4657     struct netent *PerlSock_getnetbyname(Netdb_name_t);
4658     struct netent *PerlSock_getnetent(void);
4659 #endif
4660     struct netent *nent;
4661     STRLEN n_a;
4662
4663     if (which == OP_GNBYNAME)
4664 #ifdef HAS_GETNETBYNAME
4665         nent = PerlSock_getnetbyname(POPpbytex);
4666 #else
4667         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4668 #endif
4669     else if (which == OP_GNBYADDR) {
4670 #ifdef HAS_GETNETBYADDR
4671         int addrtype = POPi;
4672         Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4673         nent = PerlSock_getnetbyaddr(addr, addrtype);
4674 #else
4675         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4676 #endif
4677     }
4678     else
4679 #ifdef HAS_GETNETENT
4680         nent = PerlSock_getnetent();
4681 #else
4682         DIE(aTHX_ PL_no_sock_func, "getnetent");
4683 #endif
4684
4685     EXTEND(SP, 4);
4686     if (GIMME != G_ARRAY) {
4687         PUSHs(sv = sv_newmortal());
4688         if (nent) {
4689             if (which == OP_GNBYNAME)
4690                 sv_setiv(sv, (IV)nent->n_net);
4691             else
4692                 sv_setpv(sv, nent->n_name);
4693         }
4694         RETURN;
4695     }
4696
4697     if (nent) {
4698         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4699         sv_setpv(sv, nent->n_name);
4700         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4701         for (elem = nent->n_aliases; elem && *elem; elem++) {
4702             sv_catpv(sv, *elem);
4703             if (elem[1])
4704                 sv_catpvn(sv, " ", 1);
4705         }
4706         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4707         sv_setiv(sv, (IV)nent->n_addrtype);
4708         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4709         sv_setiv(sv, (IV)nent->n_net);
4710     }
4711
4712     RETURN;
4713 #else
4714     DIE(aTHX_ PL_no_sock_func, "getnetent");
4715 #endif
4716 }
4717
4718 PP(pp_gpbyname)
4719 {
4720 #ifdef HAS_GETPROTOBYNAME
4721     return pp_gprotoent();
4722 #else
4723     DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4724 #endif
4725 }
4726
4727 PP(pp_gpbynumber)
4728 {
4729 #ifdef HAS_GETPROTOBYNUMBER
4730     return pp_gprotoent();
4731 #else
4732     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4733 #endif
4734 }
4735
4736 PP(pp_gprotoent)
4737 {
4738     dSP;
4739 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4740     I32 which = PL_op->op_type;
4741     register char **elem;
4742     register SV *sv;
4743 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4744     struct protoent *PerlSock_getprotobyname(Netdb_name_t);
4745     struct protoent *PerlSock_getprotobynumber(int);
4746     struct protoent *PerlSock_getprotoent(void);
4747 #endif
4748     struct protoent *pent;
4749     STRLEN n_a;
4750
4751     if (which == OP_GPBYNAME)
4752 #ifdef HAS_GETPROTOBYNAME
4753         pent = PerlSock_getprotobyname(POPpbytex);
4754 #else
4755         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4756 #endif
4757     else if (which == OP_GPBYNUMBER)
4758 #ifdef HAS_GETPROTOBYNUMBER
4759         pent = PerlSock_getprotobynumber(POPi);
4760 #else
4761     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4762 #endif
4763     else
4764 #ifdef HAS_GETPROTOENT
4765         pent = PerlSock_getprotoent();
4766 #else
4767         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4768 #endif
4769
4770     EXTEND(SP, 3);
4771     if (GIMME != G_ARRAY) {
4772         PUSHs(sv = sv_newmortal());
4773         if (pent) {
4774             if (which == OP_GPBYNAME)
4775                 sv_setiv(sv, (IV)pent->p_proto);
4776             else
4777                 sv_setpv(sv, pent->p_name);
4778         }
4779         RETURN;
4780     }
4781
4782     if (pent) {
4783         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4784         sv_setpv(sv, pent->p_name);
4785         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4786         for (elem = pent->p_aliases; elem && *elem; elem++) {
4787             sv_catpv(sv, *elem);
4788             if (elem[1])
4789                 sv_catpvn(sv, " ", 1);
4790         }
4791         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4792         sv_setiv(sv, (IV)pent->p_proto);
4793     }
4794
4795     RETURN;
4796 #else
4797     DIE(aTHX_ PL_no_sock_func, "getprotoent");
4798 #endif
4799 }
4800
4801 PP(pp_gsbyname)
4802 {
4803 #ifdef HAS_GETSERVBYNAME
4804     return pp_gservent();
4805 #else
4806     DIE(aTHX_ PL_no_sock_func, "getservbyname");
4807 #endif
4808 }
4809
4810 PP(pp_gsbyport)
4811 {
4812 #ifdef HAS_GETSERVBYPORT
4813     return pp_gservent();
4814 #else
4815     DIE(aTHX_ PL_no_sock_func, "getservbyport");
4816 #endif
4817 }
4818
4819 PP(pp_gservent)
4820 {
4821     dSP;
4822 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4823     I32 which = PL_op->op_type;
4824     register char **elem;
4825     register SV *sv;
4826 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4827     struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4828     struct servent *PerlSock_getservbyport(int, Netdb_name_t);
4829     struct servent *PerlSock_getservent(void);
4830 #endif
4831     struct servent *sent;
4832     STRLEN n_a;
4833
4834     if (which == OP_GSBYNAME) {
4835 #ifdef HAS_GETSERVBYNAME
4836         char *proto = POPpbytex;
4837         char *name = POPpbytex;
4838
4839         if (proto && !*proto)
4840             proto = Nullch;
4841
4842         sent = PerlSock_getservbyname(name, proto);
4843 #else
4844         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4845 #endif
4846     }
4847     else if (which == OP_GSBYPORT) {
4848 #ifdef HAS_GETSERVBYPORT
4849         char *proto = POPpbytex;
4850         unsigned short port = POPu;
4851
4852 #ifdef HAS_HTONS
4853         port = PerlSock_htons(port);
4854 #endif
4855         sent = PerlSock_getservbyport(port, proto);
4856 #else
4857         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4858 #endif
4859     }
4860     else
4861 #ifdef HAS_GETSERVENT
4862         sent = PerlSock_getservent();
4863 #else
4864         DIE(aTHX_ PL_no_sock_func, "getservent");
4865 #endif
4866
4867     EXTEND(SP, 4);
4868     if (GIMME != G_ARRAY) {
4869         PUSHs(sv = sv_newmortal());
4870         if (sent) {
4871             if (which == OP_GSBYNAME) {
4872 #ifdef HAS_NTOHS
4873                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4874 #else
4875                 sv_setiv(sv, (IV)(sent->s_port));
4876 #endif
4877             }
4878             else
4879                 sv_setpv(sv, sent->s_name);
4880         }
4881         RETURN;
4882     }
4883
4884     if (sent) {
4885         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4886         sv_setpv(sv, sent->s_name);
4887         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4888         for (elem = sent->s_aliases; elem && *elem; elem++) {
4889             sv_catpv(sv, *elem);
4890             if (elem[1])
4891                 sv_catpvn(sv, " ", 1);
4892         }
4893         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4894 #ifdef HAS_NTOHS
4895         sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4896 #else
4897         sv_setiv(sv, (IV)(sent->s_port));
4898 #endif
4899         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4900         sv_setpv(sv, sent->s_proto);
4901     }
4902
4903     RETURN;
4904 #else
4905     DIE(aTHX_ PL_no_sock_func, "getservent");
4906 #endif
4907 }
4908
4909 PP(pp_shostent)
4910 {
4911     dSP;
4912 #ifdef HAS_SETHOSTENT
4913     PerlSock_sethostent(TOPi);
4914     RETSETYES;
4915 #else
4916     DIE(aTHX_ PL_no_sock_func, "sethostent");
4917 #endif
4918 }
4919
4920 PP(pp_snetent)
4921 {
4922     dSP;
4923 #ifdef HAS_SETNETENT
4924     PerlSock_setnetent(TOPi);
4925     RETSETYES;
4926 #else
4927     DIE(aTHX_ PL_no_sock_func, "setnetent");
4928 #endif
4929 }
4930
4931 PP(pp_sprotoent)
4932 {
4933     dSP;
4934 #ifdef HAS_SETPROTOENT
4935     PerlSock_setprotoent(TOPi);
4936     RETSETYES;
4937 #else
4938     DIE(aTHX_ PL_no_sock_func, "setprotoent");
4939 #endif
4940 }
4941
4942 PP(pp_sservent)
4943 {
4944     dSP;
4945 #ifdef HAS_SETSERVENT
4946     PerlSock_setservent(TOPi);
4947     RETSETYES;
4948 #else
4949     DIE(aTHX_ PL_no_sock_func, "setservent");
4950 #endif
4951 }
4952
4953 PP(pp_ehostent)
4954 {
4955     dSP;
4956 #ifdef HAS_ENDHOSTENT
4957     PerlSock_endhostent();
4958     EXTEND(SP,1);
4959     RETPUSHYES;
4960 #else
4961     DIE(aTHX_ PL_no_sock_func, "endhostent");
4962 #endif
4963 }
4964
4965 PP(pp_enetent)
4966 {
4967     dSP;
4968 #ifdef HAS_ENDNETENT
4969     PerlSock_endnetent();
4970     EXTEND(SP,1);
4971     RETPUSHYES;
4972 #else
4973     DIE(aTHX_ PL_no_sock_func, "endnetent");
4974 #endif
4975 }
4976
4977 PP(pp_eprotoent)
4978 {
4979     dSP;
4980 #ifdef HAS_ENDPROTOENT
4981     PerlSock_endprotoent();
4982     EXTEND(SP,1);
4983     RETPUSHYES;
4984 #else
4985     DIE(aTHX_ PL_no_sock_func, "endprotoent");
4986 #endif
4987 }
4988
4989 PP(pp_eservent)
4990 {
4991     dSP;
4992 #ifdef HAS_ENDSERVENT
4993     PerlSock_endservent();
4994     EXTEND(SP,1);
4995     RETPUSHYES;
4996 #else
4997     DIE(aTHX_ PL_no_sock_func, "endservent");
4998 #endif
4999 }
5000
5001 PP(pp_gpwnam)
5002 {
5003 #ifdef HAS_PASSWD
5004     return pp_gpwent();
5005 #else
5006     DIE(aTHX_ PL_no_func, "getpwnam");
5007 #endif
5008 }
5009
5010 PP(pp_gpwuid)
5011 {
5012 #ifdef HAS_PASSWD
5013     return pp_gpwent();
5014 #else
5015     DIE(aTHX_ PL_no_func, "getpwuid");
5016 #endif
5017 }
5018
5019 PP(pp_gpwent)
5020 {
5021     dSP;
5022 #ifdef HAS_PASSWD
5023     I32 which = PL_op->op_type;
5024     register SV *sv;
5025     STRLEN n_a;
5026     struct passwd *pwent  = NULL;
5027     /*
5028      * We currently support only the SysV getsp* shadow password interface.
5029      * The interface is declared in <shadow.h> and often one needs to link
5030      * with -lsecurity or some such.
5031      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5032      * (and SCO?)
5033      *
5034      * AIX getpwnam() is clever enough to return the encrypted password
5035      * only if the caller (euid?) is root.
5036      *
5037      * There are at least two other shadow password APIs.  Many platforms
5038      * seem to contain more than one interface for accessing the shadow
5039      * password databases, possibly for compatibility reasons.
5040      * The getsp*() is by far he simplest one, the other two interfaces
5041      * are much more complicated, but also very similar to each other.
5042      *
5043      * <sys/types.h>
5044      * <sys/security.h>
5045      * <prot.h>
5046      * struct pr_passwd *getprpw*();
5047      * The password is in
5048      * char getprpw*(...).ufld.fd_encrypt[]
5049      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5050      *
5051      * <sys/types.h>
5052      * <sys/security.h>
5053      * <prot.h>
5054      * struct es_passwd *getespw*();
5055      * The password is in
5056      * char *(getespw*(...).ufld.fd_encrypt)
5057      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5058      *
5059      * Mention I_PROT here so that Configure probes for it.
5060      *
5061      * In HP-UX for getprpw*() the manual page claims that one should include
5062      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5063      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5064      * and pp_sys.c already includes <shadow.h> if there is such.
5065      *
5066      * Note that <sys/security.h> is already probed for, but currently
5067      * it is only included in special cases.
5068      *
5069      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5070      * be preferred interface, even though also the getprpw*() interface
5071      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5072      * One also needs to call set_auth_parameters() in main() before
5073      * doing anything else, whether one is using getespw*() or getprpw*().
5074      *
5075      * Note that accessing the shadow databases can be magnitudes
5076      * slower than accessing the standard databases.
5077      *
5078      * --jhi
5079      */
5080
5081     switch (which) {
5082     case OP_GPWNAM:
5083         pwent  = getpwnam(POPpbytex);
5084         break;
5085     case OP_GPWUID:
5086         pwent = getpwuid((Uid_t)POPi);
5087         break;
5088     case OP_GPWENT:
5089 #   ifdef HAS_GETPWENT
5090         pwent  = getpwent();
5091 #   else
5092         DIE(aTHX_ PL_no_func, "getpwent");
5093 #   endif
5094         break;
5095     }
5096
5097     EXTEND(SP, 10);
5098     if (GIMME != G_ARRAY) {
5099         PUSHs(sv = sv_newmortal());
5100         if (pwent) {
5101             if (which == OP_GPWNAM)
5102 #   if Uid_t_sign <= 0
5103                 sv_setiv(sv, (IV)pwent->pw_uid);
5104 #   else
5105                 sv_setuv(sv, (UV)pwent->pw_uid);
5106 #   endif
5107             else
5108                 sv_setpv(sv, pwent->pw_name);
5109         }
5110         RETURN;
5111     }
5112
5113     if (pwent) {
5114         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5115         sv_setpv(sv, pwent->pw_name);
5116
5117         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5118         SvPOK_off(sv);
5119         /* If we have getspnam(), we try to dig up the shadow
5120          * password.  If we are underprivileged, the shadow
5121          * interface will set the errno to EACCES or similar,
5122          * and return a null pointer.  If this happens, we will
5123          * use the dummy password (usually "*" or "x") from the
5124          * standard password database.
5125          *
5126          * In theory we could skip the shadow call completely
5127          * if euid != 0 but in practice we cannot know which
5128          * security measures are guarding the shadow databases
5129          * on a random platform.
5130          *
5131          * Resist the urge to use additional shadow interfaces.
5132          * Divert the urge to writing an extension instead.
5133          *
5134          * --jhi */
5135 #   ifdef HAS_GETSPNAM
5136         {
5137             struct spwd *spwent;
5138             int saverrno; /* Save and restore errno so that
5139                            * underprivileged attempts seem
5140                            * to have never made the unsccessful
5141                            * attempt to retrieve the shadow password. */
5142
5143             saverrno = errno;
5144             spwent = getspnam(pwent->pw_name);
5145             errno = saverrno;
5146             if (spwent && spwent->sp_pwdp)
5147                 sv_setpv(sv, spwent->sp_pwdp);
5148         }
5149 #   endif
5150 #   ifdef PWPASSWD
5151         if (!SvPOK(sv)) /* Use the standard password, then. */
5152             sv_setpv(sv, pwent->pw_passwd);
5153 #   endif
5154
5155 #   ifndef INCOMPLETE_TAINTS
5156         /* passwd is tainted because user himself can diddle with it.
5157          * admittedly not much and in a very limited way, but nevertheless. */
5158         SvTAINTED_on(sv);
5159 #   endif
5160
5161         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5162 #   if Uid_t_sign <= 0
5163         sv_setiv(sv, (IV)pwent->pw_uid);
5164 #   else
5165         sv_setuv(sv, (UV)pwent->pw_uid);
5166 #   endif
5167
5168         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5169 #   if Uid_t_sign <= 0
5170         sv_setiv(sv, (IV)pwent->pw_gid);
5171 #   else
5172         sv_setuv(sv, (UV)pwent->pw_gid);
5173 #   endif
5174         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5175          * because of the poor interface of the Perl getpw*(),
5176          * not because there's some standard/convention saying so.
5177          * A better interface would have been to return a hash,
5178          * but we are accursed by our history, alas. --jhi.  */
5179         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5180 #   ifdef PWCHANGE
5181         sv_setiv(sv, (IV)pwent->pw_change);
5182 #   else
5183 #       ifdef PWQUOTA
5184         sv_setiv(sv, (IV)pwent->pw_quota);
5185 #       else
5186 #           ifdef PWAGE
5187         sv_setpv(sv, pwent->pw_age);
5188 #           endif
5189 #       endif
5190 #   endif
5191
5192         /* pw_class and pw_comment are mutually exclusive--.
5193          * see the above note for pw_change, pw_quota, and pw_age. */
5194         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5195 #   ifdef PWCLASS
5196         sv_setpv(sv, pwent->pw_class);
5197 #   else
5198 #       ifdef PWCOMMENT
5199         sv_setpv(sv, pwent->pw_comment);
5200 #       endif
5201 #   endif
5202
5203         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5204 #   ifdef PWGECOS
5205         sv_setpv(sv, pwent->pw_gecos);
5206 #   endif
5207 #   ifndef INCOMPLETE_TAINTS
5208         /* pw_gecos is tainted because user himself can diddle with it. */
5209         SvTAINTED_on(sv);
5210 #   endif
5211
5212         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5213         sv_setpv(sv, pwent->pw_dir);
5214
5215         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5216         sv_setpv(sv, pwent->pw_shell);
5217 #   ifndef INCOMPLETE_TAINTS
5218         /* pw_shell is tainted because user himself can diddle with it. */
5219         SvTAINTED_on(sv);
5220 #   endif
5221
5222 #   ifdef PWEXPIRE
5223         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5224         sv_setiv(sv, (IV)pwent->pw_expire);
5225 #   endif
5226     }
5227     RETURN;
5228 #else
5229     DIE(aTHX_ PL_no_func, "getpwent");
5230 #endif
5231 }
5232
5233 PP(pp_spwent)
5234 {
5235     dSP;
5236 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5237     setpwent();
5238     RETPUSHYES;
5239 #else
5240     DIE(aTHX_ PL_no_func, "setpwent");
5241 #endif
5242 }
5243
5244 PP(pp_epwent)
5245 {
5246     dSP;
5247 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5248     endpwent();
5249     RETPUSHYES;
5250 #else
5251     DIE(aTHX_ PL_no_func, "endpwent");
5252 #endif
5253 }
5254
5255 PP(pp_ggrnam)
5256 {
5257 #ifdef HAS_GROUP
5258     return pp_ggrent();
5259 #else
5260     DIE(aTHX_ PL_no_func, "getgrnam");
5261 #endif
5262 }
5263
5264 PP(pp_ggrgid)
5265 {
5266 #ifdef HAS_GROUP
5267     return pp_ggrent();
5268 #else
5269     DIE(aTHX_ PL_no_func, "getgrgid");
5270 #endif
5271 }
5272
5273 PP(pp_ggrent)
5274 {
5275     dSP;
5276 #ifdef HAS_GROUP
5277     I32 which = PL_op->op_type;
5278     register char **elem;
5279     register SV *sv;
5280     struct group *grent;
5281     STRLEN n_a;
5282
5283     if (which == OP_GGRNAM)
5284         grent = (struct group *)getgrnam(POPpbytex);
5285     else if (which == OP_GGRGID)
5286         grent = (struct group *)getgrgid(POPi);
5287     else
5288 #ifdef HAS_GETGRENT
5289         grent = (struct group *)getgrent();
5290 #else
5291         DIE(aTHX_ PL_no_func, "getgrent");
5292 #endif
5293
5294     EXTEND(SP, 4);
5295     if (GIMME != G_ARRAY) {
5296         PUSHs(sv = sv_newmortal());
5297         if (grent) {
5298             if (which == OP_GGRNAM)
5299                 sv_setiv(sv, (IV)grent->gr_gid);
5300             else
5301                 sv_setpv(sv, grent->gr_name);
5302         }
5303         RETURN;
5304     }
5305
5306     if (grent) {
5307         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5308         sv_setpv(sv, grent->gr_name);
5309
5310         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5311 #ifdef GRPASSWD
5312         sv_setpv(sv, grent->gr_passwd);
5313 #endif
5314
5315         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5316         sv_setiv(sv, (IV)grent->gr_gid);
5317
5318         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5319         for (elem = grent->gr_mem; elem && *elem; elem++) {
5320             sv_catpv(sv, *elem);
5321             if (elem[1])
5322                 sv_catpvn(sv, " ", 1);
5323         }
5324     }
5325
5326     RETURN;
5327 #else
5328     DIE(aTHX_ PL_no_func, "getgrent");
5329 #endif
5330 }
5331
5332 PP(pp_sgrent)
5333 {
5334     dSP;
5335 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5336     setgrent();
5337     RETPUSHYES;
5338 #else
5339     DIE(aTHX_ PL_no_func, "setgrent");
5340 #endif
5341 }
5342
5343 PP(pp_egrent)
5344 {
5345     dSP;
5346 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5347     endgrent();
5348     RETPUSHYES;
5349 #else
5350     DIE(aTHX_ PL_no_func, "endgrent");
5351 #endif
5352 }
5353
5354 PP(pp_getlogin)
5355 {
5356     dSP; dTARGET;
5357 #ifdef HAS_GETLOGIN
5358     char *tmps;
5359     EXTEND(SP, 1);
5360     if (!(tmps = PerlProc_getlogin()))
5361         RETPUSHUNDEF;
5362     PUSHp(tmps, strlen(tmps));
5363     RETURN;
5364 #else
5365     DIE(aTHX_ PL_no_func, "getlogin");
5366 #endif
5367 }
5368
5369 /* Miscellaneous. */
5370
5371 PP(pp_syscall)
5372 {
5373 #ifdef HAS_SYSCALL
5374     dSP; dMARK; dORIGMARK; dTARGET;
5375     register I32 items = SP - MARK;
5376     unsigned long a[20];
5377     register I32 i = 0;
5378     I32 retval = -1;
5379     STRLEN n_a;
5380
5381     if (PL_tainting) {
5382         while (++MARK <= SP) {
5383             if (SvTAINTED(*MARK)) {
5384                 TAINT;
5385                 break;
5386             }
5387         }
5388         MARK = ORIGMARK;
5389         TAINT_PROPER("syscall");
5390     }
5391
5392     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5393      * or where sizeof(long) != sizeof(char*).  But such machines will
5394      * not likely have syscall implemented either, so who cares?
5395      */
5396     while (++MARK <= SP) {
5397         if (SvNIOK(*MARK) || !i)
5398             a[i++] = SvIV(*MARK);
5399         else if (*MARK == &PL_sv_undef)
5400             a[i++] = 0;
5401         else
5402             a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
5403         if (i > 15)
5404             break;
5405     }
5406     switch (items) {
5407     default:
5408         DIE(aTHX_ "Too many args to syscall");
5409     case 0:
5410         DIE(aTHX_ "Too few args to syscall");
5411     case 1:
5412         retval = syscall(a[0]);
5413         break;
5414     case 2:
5415         retval = syscall(a[0],a[1]);
5416         break;
5417     case 3:
5418         retval = syscall(a[0],a[1],a[2]);
5419         break;
5420     case 4:
5421         retval = syscall(a[0],a[1],a[2],a[3]);
5422         break;
5423     case 5:
5424         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5425         break;
5426     case 6:
5427         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5428         break;
5429     case 7:
5430         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5431         break;
5432     case 8:
5433         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5434         break;
5435 #ifdef atarist
5436     case 9:
5437         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5438         break;
5439     case 10:
5440         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5441         break;
5442     case 11:
5443         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5444           a[10]);
5445         break;
5446     case 12:
5447         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5448           a[10],a[11]);
5449         break;
5450     case 13:
5451         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5452           a[10],a[11],a[12]);
5453         break;
5454     case 14:
5455         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5456           a[10],a[11],a[12],a[13]);
5457         break;
5458 #endif /* atarist */
5459     }
5460     SP = ORIGMARK;
5461     PUSHi(retval);
5462     RETURN;
5463 #else
5464     DIE(aTHX_ PL_no_func, "syscall");
5465 #endif
5466 }
5467
5468 #ifdef FCNTL_EMULATE_FLOCK
5469
5470 /*  XXX Emulate flock() with fcntl().
5471     What's really needed is a good file locking module.
5472 */
5473
5474 static int
5475 fcntl_emulate_flock(int fd, int operation)
5476 {
5477     struct flock flock;
5478
5479     switch (operation & ~LOCK_NB) {
5480     case LOCK_SH:
5481         flock.l_type = F_RDLCK;
5482         break;
5483     case LOCK_EX:
5484         flock.l_type = F_WRLCK;
5485         break;
5486     case LOCK_UN:
5487         flock.l_type = F_UNLCK;
5488         break;
5489     default:
5490         errno = EINVAL;
5491         return -1;
5492     }
5493     flock.l_whence = SEEK_SET;
5494     flock.l_start = flock.l_len = (Off_t)0;
5495
5496     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5497 }
5498
5499 #endif /* FCNTL_EMULATE_FLOCK */
5500
5501 #ifdef LOCKF_EMULATE_FLOCK
5502
5503 /*  XXX Emulate flock() with lockf().  This is just to increase
5504     portability of scripts.  The calls are not completely
5505     interchangeable.  What's really needed is a good file
5506     locking module.
5507 */
5508
5509 /*  The lockf() constants might have been defined in <unistd.h>.
5510     Unfortunately, <unistd.h> causes troubles on some mixed
5511     (BSD/POSIX) systems, such as SunOS 4.1.3.
5512
5513    Further, the lockf() constants aren't POSIX, so they might not be
5514    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5515    just stick in the SVID values and be done with it.  Sigh.
5516 */
5517
5518 # ifndef F_ULOCK
5519 #  define F_ULOCK       0       /* Unlock a previously locked region */
5520 # endif
5521 # ifndef F_LOCK
5522 #  define F_LOCK        1       /* Lock a region for exclusive use */
5523 # endif
5524 # ifndef F_TLOCK
5525 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5526 # endif
5527 # ifndef F_TEST
5528 #  define F_TEST        3       /* Test a region for other processes locks */
5529 # endif
5530
5531 static int
5532 lockf_emulate_flock(int fd, int operation)
5533 {
5534     int i;
5535     int save_errno;
5536     Off_t pos;
5537
5538     /* flock locks entire file so for lockf we need to do the same      */
5539     save_errno = errno;
5540     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5541     if (pos > 0)        /* is seekable and needs to be repositioned     */
5542         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5543             pos = -1;   /* seek failed, so don't seek back afterwards   */
5544     errno = save_errno;
5545
5546     switch (operation) {
5547
5548         /* LOCK_SH - get a shared lock */
5549         case LOCK_SH:
5550         /* LOCK_EX - get an exclusive lock */
5551         case LOCK_EX:
5552             i = lockf (fd, F_LOCK, 0);
5553             break;
5554
5555         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5556         case LOCK_SH|LOCK_NB:
5557         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5558         case LOCK_EX|LOCK_NB:
5559             i = lockf (fd, F_TLOCK, 0);
5560             if (i == -1)
5561                 if ((errno == EAGAIN) || (errno == EACCES))
5562                     errno = EWOULDBLOCK;
5563             break;
5564
5565         /* LOCK_UN - unlock (non-blocking is a no-op) */
5566         case LOCK_UN:
5567         case LOCK_UN|LOCK_NB:
5568             i = lockf (fd, F_ULOCK, 0);
5569             break;
5570
5571         /* Default - can't decipher operation */
5572         default:
5573             i = -1;
5574             errno = EINVAL;
5575             break;
5576     }
5577
5578     if (pos > 0)      /* need to restore position of the handle */
5579         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5580
5581     return (i);
5582 }
5583
5584 #endif /* LOCKF_EMULATE_FLOCK */