pp_sys.c

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