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 #if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4125     if (value >= 0)
4126         my_exit(value);
4127 #endif
4128
4129     SP = ORIGMARK;
4130     PUSHi(value);
4131     RETURN;
4132 }
4133
4134 PP(pp_kill)
4135 {
4136 #ifdef HAS_KILL
4137     dSP; dMARK; dTARGET;
4138     I32 value;
4139     value = (I32)apply(PL_op->op_type, MARK, SP);
4140     SP = MARK;
4141     PUSHi(value);
4142     RETURN;
4143 #else
4144     DIE(aTHX_ PL_no_func, "kill");
4145 #endif
4146 }
4147
4148 PP(pp_getppid)
4149 {
4150 #ifdef HAS_GETPPID
4151     dSP; dTARGET;
4152     XPUSHi( getppid() );
4153     RETURN;
4154 #else
4155     DIE(aTHX_ PL_no_func, "getppid");
4156 #endif
4157 }
4158
4159 PP(pp_getpgrp)
4160 {
4161 #ifdef HAS_GETPGRP
4162     dSP; dTARGET;
4163     Pid_t pid;
4164     Pid_t pgrp;
4165
4166     if (MAXARG < 1)
4167         pid = 0;
4168     else
4169         pid = SvIVx(POPs);
4170 #ifdef BSD_GETPGRP
4171     pgrp = (I32)BSD_GETPGRP(pid);
4172 #else
4173     if (pid != 0 && pid != PerlProc_getpid())
4174         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4175     pgrp = getpgrp();
4176 #endif
4177     XPUSHi(pgrp);
4178     RETURN;
4179 #else
4180     DIE(aTHX_ PL_no_func, "getpgrp()");
4181 #endif
4182 }
4183
4184 PP(pp_setpgrp)
4185 {
4186 #ifdef HAS_SETPGRP
4187     dSP; dTARGET;
4188     Pid_t pgrp;
4189     Pid_t pid;
4190     if (MAXARG < 2) {
4191         pgrp = 0;
4192         pid = 0;
4193     }
4194     else {
4195         pgrp = POPi;
4196         pid = TOPi;
4197     }
4198
4199     TAINT_PROPER("setpgrp");
4200 #ifdef BSD_SETPGRP
4201     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4202 #else
4203     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4204         || (pid != 0 && pid != PerlProc_getpid()))
4205     {
4206         DIE(aTHX_ "setpgrp can't take arguments");
4207     }
4208     SETi( setpgrp() >= 0 );
4209 #endif /* USE_BSDPGRP */
4210     RETURN;
4211 #else
4212     DIE(aTHX_ PL_no_func, "setpgrp()");
4213 #endif
4214 }
4215
4216 PP(pp_getpriority)
4217 {
4218 #ifdef HAS_GETPRIORITY
4219     dSP; dTARGET;
4220     int who = POPi;
4221     int which = TOPi;
4222     SETi( getpriority(which, who) );
4223     RETURN;
4224 #else
4225     DIE(aTHX_ PL_no_func, "getpriority()");
4226 #endif
4227 }
4228
4229 PP(pp_setpriority)
4230 {
4231 #ifdef HAS_SETPRIORITY
4232     dSP; dTARGET;
4233     int niceval = POPi;
4234     int who = POPi;
4235     int which = TOPi;
4236     TAINT_PROPER("setpriority");
4237     SETi( setpriority(which, who, niceval) >= 0 );
4238     RETURN;
4239 #else
4240     DIE(aTHX_ PL_no_func, "setpriority()");
4241 #endif
4242 }
4243
4244 /* Time calls. */
4245
4246 PP(pp_time)
4247 {
4248     dSP; dTARGET;
4249 #ifdef BIG_TIME
4250     XPUSHn( time(Null(Time_t*)) );
4251 #else
4252     XPUSHi( time(Null(Time_t*)) );
4253 #endif
4254     RETURN;
4255 }
4256
4257 /* XXX The POSIX name is CLK_TCK; it is to be preferred
4258    to HZ.  Probably.  For now, assume that if the system
4259    defines HZ, it does so correctly.  (Will this break
4260    on VMS?)
4261    Probably we ought to use _sysconf(_SC_CLK_TCK), if
4262    it's supported.    --AD  9/96.
4263 */
4264
4265 #ifndef HZ
4266 #  ifdef CLK_TCK
4267 #    define HZ CLK_TCK
4268 #  else
4269 #    define HZ 60
4270 #  endif
4271 #endif
4272
4273 PP(pp_tms)
4274 {
4275 #ifdef HAS_TIMES
4276     dSP;
4277     EXTEND(SP, 4);
4278 #ifndef VMS
4279     (void)PerlProc_times(&PL_timesbuf);
4280 #else
4281     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4282                                                    /* struct tms, though same data   */
4283                                                    /* is returned.                   */
4284 #endif
4285
4286     PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
4287     if (GIMME == G_ARRAY) {
4288         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4289         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4290         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
4291     }
4292     RETURN;
4293 #else
4294     DIE(aTHX_ "times not implemented");
4295 #endif /* HAS_TIMES */
4296 }
4297
4298 PP(pp_localtime)
4299 {
4300     return pp_gmtime();
4301 }
4302
4303 PP(pp_gmtime)
4304 {
4305     dSP;
4306     Time_t when;
4307     struct tm *tmbuf;
4308     static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4309     static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4310                               "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4311
4312     if (MAXARG < 1)
4313         (void)time(&when);
4314     else
4315 #ifdef BIG_TIME
4316         when = (Time_t)SvNVx(POPs);
4317 #else
4318         when = (Time_t)SvIVx(POPs);
4319 #endif
4320
4321     if (PL_op->op_type == OP_LOCALTIME)
4322         tmbuf = localtime(&when);
4323     else
4324         tmbuf = gmtime(&when);
4325
4326     EXTEND(SP, 9);
4327     EXTEND_MORTAL(9);
4328     if (GIMME != G_ARRAY) {
4329         SV *tsv;
4330         if (!tmbuf)
4331             RETPUSHUNDEF;
4332         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4333                             dayname[tmbuf->tm_wday],
4334                             monname[tmbuf->tm_mon],
4335                             tmbuf->tm_mday,
4336                             tmbuf->tm_hour,
4337                             tmbuf->tm_min,
4338                             tmbuf->tm_sec,
4339                             tmbuf->tm_year + 1900);
4340         PUSHs(sv_2mortal(tsv));
4341     }
4342     else if (tmbuf) {
4343         PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4344         PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4345         PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4346         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4347         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4348         PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4349         PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4350         PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4351         PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4352     }
4353     RETURN;
4354 }
4355
4356 PP(pp_alarm)
4357 {
4358 #ifdef HAS_ALARM
4359     dSP; dTARGET;
4360     int anum;
4361     anum = POPi;
4362     anum = alarm((unsigned int)anum);
4363     EXTEND(SP, 1);
4364     if (anum < 0)
4365         RETPUSHUNDEF;
4366     PUSHi(anum);
4367     RETURN;
4368 #else
4369     DIE(aTHX_ PL_no_func, "alarm");
4370 #endif
4371 }
4372
4373 PP(pp_sleep)
4374 {
4375     dSP; dTARGET;
4376     I32 duration;
4377     Time_t lasttime;
4378     Time_t when;
4379
4380     (void)time(&lasttime);
4381     if (MAXARG < 1)
4382         PerlProc_pause();
4383     else {
4384         duration = POPi;
4385         PerlProc_sleep((unsigned int)duration);
4386     }
4387     (void)time(&when);
4388     XPUSHi(when - lasttime);
4389     RETURN;
4390 }
4391
4392 /* Shared memory. */
4393
4394 PP(pp_shmget)
4395 {
4396     return pp_semget();
4397 }
4398
4399 PP(pp_shmctl)
4400 {
4401     return pp_semctl();
4402 }
4403
4404 PP(pp_shmread)
4405 {
4406     return pp_shmwrite();
4407 }
4408
4409 PP(pp_shmwrite)
4410 {
4411 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4412     dSP; dMARK; dTARGET;
4413     I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
4414     SP = MARK;
4415     PUSHi(value);
4416     RETURN;
4417 #else
4418     return pp_semget();
4419 #endif
4420 }
4421
4422 /* Message passing. */
4423
4424 PP(pp_msgget)
4425 {
4426     return pp_semget();
4427 }
4428
4429 PP(pp_msgctl)
4430 {
4431     return pp_semctl();
4432 }
4433
4434 PP(pp_msgsnd)
4435 {
4436 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4437     dSP; dMARK; dTARGET;
4438     I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4439     SP = MARK;
4440     PUSHi(value);
4441     RETURN;
4442 #else
4443     return pp_semget();
4444 #endif
4445 }
4446
4447 PP(pp_msgrcv)
4448 {
4449 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4450     dSP; dMARK; dTARGET;
4451     I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4452     SP = MARK;
4453     PUSHi(value);
4454     RETURN;
4455 #else
4456     return pp_semget();
4457 #endif
4458 }
4459
4460 /* Semaphores. */
4461
4462 PP(pp_semget)
4463 {
4464 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4465     dSP; dMARK; dTARGET;
4466     int anum = do_ipcget(PL_op->op_type, MARK, SP);
4467     SP = MARK;
4468     if (anum == -1)
4469         RETPUSHUNDEF;
4470     PUSHi(anum);
4471     RETURN;
4472 #else
4473     DIE(aTHX_ "System V IPC is not implemented on this machine");
4474 #endif
4475 }
4476
4477 PP(pp_semctl)
4478 {
4479 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4480     dSP; dMARK; dTARGET;
4481     int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4482     SP = MARK;
4483     if (anum == -1)
4484         RETSETUNDEF;
4485     if (anum != 0) {
4486         PUSHi(anum);
4487     }
4488     else {
4489         PUSHp(zero_but_true, ZBTLEN);
4490     }
4491     RETURN;
4492 #else
4493     return pp_semget();
4494 #endif
4495 }
4496
4497 PP(pp_semop)
4498 {
4499 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4500     dSP; dMARK; dTARGET;
4501     I32 value = (I32)(do_semop(MARK, SP) >= 0);
4502     SP = MARK;
4503     PUSHi(value);
4504     RETURN;
4505 #else
4506     return pp_semget();
4507 #endif
4508 }
4509
4510 /* Get system info. */
4511
4512 PP(pp_ghbyname)
4513 {
4514 #ifdef HAS_GETHOSTBYNAME
4515     return pp_ghostent();
4516 #else
4517     DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4518 #endif
4519 }
4520
4521 PP(pp_ghbyaddr)
4522 {
4523 #ifdef HAS_GETHOSTBYADDR
4524     return pp_ghostent();
4525 #else
4526     DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4527 #endif
4528 }
4529
4530 PP(pp_ghostent)
4531 {
4532 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4533     dSP;
4534     I32 which = PL_op->op_type;
4535     register char **elem;
4536     register SV *sv;
4537 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4538     struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4539     struct hostent *PerlSock_gethostbyname(Netdb_name_t);
4540     struct hostent *PerlSock_gethostent(void);
4541 #endif
4542     struct hostent *hent;
4543     unsigned long len;
4544     STRLEN n_a;
4545
4546     EXTEND(SP, 10);
4547     if (which == OP_GHBYNAME)
4548 #ifdef HAS_GETHOSTBYNAME
4549         hent = PerlSock_gethostbyname(POPpbytex);
4550 #else
4551         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4552 #endif
4553     else if (which == OP_GHBYADDR) {
4554 #ifdef HAS_GETHOSTBYADDR
4555         int addrtype = POPi;
4556         SV *addrsv = POPs;
4557         STRLEN addrlen;
4558         Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
4559
4560         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4561 #else
4562         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4563 #endif
4564     }
4565     else
4566 #ifdef HAS_GETHOSTENT
4567         hent = PerlSock_gethostent();
4568 #else
4569         DIE(aTHX_ PL_no_sock_func, "gethostent");
4570 #endif
4571
4572 #ifdef HOST_NOT_FOUND
4573     if (!hent)
4574         STATUS_NATIVE_SET(h_errno);
4575 #endif
4576
4577     if (GIMME != G_ARRAY) {
4578         PUSHs(sv = sv_newmortal());
4579         if (hent) {
4580             if (which == OP_GHBYNAME) {
4581                 if (hent->h_addr)
4582                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4583             }
4584             else
4585                 sv_setpv(sv, (char*)hent->h_name);
4586         }
4587         RETURN;
4588     }
4589
4590     if (hent) {
4591         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4592         sv_setpv(sv, (char*)hent->h_name);
4593         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4594         for (elem = hent->h_aliases; elem && *elem; elem++) {
4595             sv_catpv(sv, *elem);
4596             if (elem[1])
4597                 sv_catpvn(sv, " ", 1);
4598         }
4599         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4600         sv_setiv(sv, (IV)hent->h_addrtype);
4601         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4602         len = hent->h_length;
4603         sv_setiv(sv, (IV)len);
4604 #ifdef h_addr
4605         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4606             XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
4607             sv_setpvn(sv, *elem, len);
4608         }
4609 #else
4610         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4611         if (hent->h_addr)
4612             sv_setpvn(sv, hent->h_addr, len);
4613 #endif /* h_addr */
4614     }
4615     RETURN;
4616 #else
4617     DIE(aTHX_ PL_no_sock_func, "gethostent");
4618 #endif
4619 }
4620
4621 PP(pp_gnbyname)
4622 {
4623 #ifdef HAS_GETNETBYNAME
4624     return pp_gnetent();
4625 #else
4626     DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4627 #endif
4628 }
4629
4630 PP(pp_gnbyaddr)
4631 {
4632 #ifdef HAS_GETNETBYADDR
4633     return pp_gnetent();
4634 #else
4635     DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4636 #endif
4637 }
4638
4639 PP(pp_gnetent)
4640 {
4641 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4642     dSP;
4643     I32 which = PL_op->op_type;
4644     register char **elem;
4645     register SV *sv;
4646 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4647     struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4648     struct netent *PerlSock_getnetbyname(Netdb_name_t);
4649     struct netent *PerlSock_getnetent(void);
4650 #endif
4651     struct netent *nent;
4652     STRLEN n_a;
4653
4654     if (which == OP_GNBYNAME)
4655 #ifdef HAS_GETNETBYNAME
4656         nent = PerlSock_getnetbyname(POPpbytex);
4657 #else
4658         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4659 #endif
4660     else if (which == OP_GNBYADDR) {
4661 #ifdef HAS_GETNETBYADDR
4662         int addrtype = POPi;
4663         Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4664         nent = PerlSock_getnetbyaddr(addr, addrtype);
4665 #else
4666         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4667 #endif
4668     }
4669     else
4670 #ifdef HAS_GETNETENT
4671         nent = PerlSock_getnetent();
4672 #else
4673         DIE(aTHX_ PL_no_sock_func, "getnetent");
4674 #endif
4675
4676     EXTEND(SP, 4);
4677     if (GIMME != G_ARRAY) {
4678         PUSHs(sv = sv_newmortal());
4679         if (nent) {
4680             if (which == OP_GNBYNAME)
4681                 sv_setiv(sv, (IV)nent->n_net);
4682             else
4683                 sv_setpv(sv, nent->n_name);
4684         }
4685         RETURN;
4686     }
4687
4688     if (nent) {
4689         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4690         sv_setpv(sv, nent->n_name);
4691         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4692         for (elem = nent->n_aliases; elem && *elem; elem++) {
4693             sv_catpv(sv, *elem);
4694             if (elem[1])
4695                 sv_catpvn(sv, " ", 1);
4696         }
4697         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4698         sv_setiv(sv, (IV)nent->n_addrtype);
4699         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4700         sv_setiv(sv, (IV)nent->n_net);
4701     }
4702
4703     RETURN;
4704 #else
4705     DIE(aTHX_ PL_no_sock_func, "getnetent");
4706 #endif
4707 }
4708
4709 PP(pp_gpbyname)
4710 {
4711 #ifdef HAS_GETPROTOBYNAME
4712     return pp_gprotoent();
4713 #else
4714     DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4715 #endif
4716 }
4717
4718 PP(pp_gpbynumber)
4719 {
4720 #ifdef HAS_GETPROTOBYNUMBER
4721     return pp_gprotoent();
4722 #else
4723     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4724 #endif
4725 }
4726
4727 PP(pp_gprotoent)
4728 {
4729 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4730     dSP;
4731     I32 which = PL_op->op_type;
4732     register char **elem;
4733     register SV *sv;
4734 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4735     struct protoent *PerlSock_getprotobyname(Netdb_name_t);
4736     struct protoent *PerlSock_getprotobynumber(int);
4737     struct protoent *PerlSock_getprotoent(void);
4738 #endif
4739     struct protoent *pent;
4740     STRLEN n_a;
4741
4742     if (which == OP_GPBYNAME)
4743 #ifdef HAS_GETPROTOBYNAME
4744         pent = PerlSock_getprotobyname(POPpbytex);
4745 #else
4746         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4747 #endif
4748     else if (which == OP_GPBYNUMBER)
4749 #ifdef HAS_GETPROTOBYNUMBER
4750         pent = PerlSock_getprotobynumber(POPi);
4751 #else
4752     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4753 #endif
4754     else
4755 #ifdef HAS_GETPROTOENT
4756         pent = PerlSock_getprotoent();
4757 #else
4758         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4759 #endif
4760
4761     EXTEND(SP, 3);
4762     if (GIMME != G_ARRAY) {
4763         PUSHs(sv = sv_newmortal());
4764         if (pent) {
4765             if (which == OP_GPBYNAME)
4766                 sv_setiv(sv, (IV)pent->p_proto);
4767             else
4768                 sv_setpv(sv, pent->p_name);
4769         }
4770         RETURN;
4771     }
4772
4773     if (pent) {
4774         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4775         sv_setpv(sv, pent->p_name);
4776         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4777         for (elem = pent->p_aliases; elem && *elem; elem++) {
4778             sv_catpv(sv, *elem);
4779             if (elem[1])
4780                 sv_catpvn(sv, " ", 1);
4781         }
4782         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4783         sv_setiv(sv, (IV)pent->p_proto);
4784     }
4785
4786     RETURN;
4787 #else
4788     DIE(aTHX_ PL_no_sock_func, "getprotoent");
4789 #endif
4790 }
4791
4792 PP(pp_gsbyname)
4793 {
4794 #ifdef HAS_GETSERVBYNAME
4795     return pp_gservent();
4796 #else
4797     DIE(aTHX_ PL_no_sock_func, "getservbyname");
4798 #endif
4799 }
4800
4801 PP(pp_gsbyport)
4802 {
4803 #ifdef HAS_GETSERVBYPORT
4804     return pp_gservent();
4805 #else
4806     DIE(aTHX_ PL_no_sock_func, "getservbyport");
4807 #endif
4808 }
4809
4810 PP(pp_gservent)
4811 {
4812 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4813     dSP;
4814     I32 which = PL_op->op_type;
4815     register char **elem;
4816     register SV *sv;
4817 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4818     struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4819     struct servent *PerlSock_getservbyport(int, Netdb_name_t);
4820     struct servent *PerlSock_getservent(void);
4821 #endif
4822     struct servent *sent;
4823     STRLEN n_a;
4824
4825     if (which == OP_GSBYNAME) {
4826 #ifdef HAS_GETSERVBYNAME
4827         char *proto = POPpbytex;
4828         char *name = POPpbytex;
4829
4830         if (proto && !*proto)
4831             proto = Nullch;
4832
4833         sent = PerlSock_getservbyname(name, proto);
4834 #else
4835         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4836 #endif
4837     }
4838     else if (which == OP_GSBYPORT) {
4839 #ifdef HAS_GETSERVBYPORT
4840         char *proto = POPpbytex;
4841         unsigned short port = POPu;
4842
4843 #ifdef HAS_HTONS
4844         port = PerlSock_htons(port);
4845 #endif
4846         sent = PerlSock_getservbyport(port, proto);
4847 #else
4848         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4849 #endif
4850     }
4851     else
4852 #ifdef HAS_GETSERVENT
4853         sent = PerlSock_getservent();
4854 #else
4855         DIE(aTHX_ PL_no_sock_func, "getservent");
4856 #endif
4857
4858     EXTEND(SP, 4);
4859     if (GIMME != G_ARRAY) {
4860         PUSHs(sv = sv_newmortal());
4861         if (sent) {
4862             if (which == OP_GSBYNAME) {
4863 #ifdef HAS_NTOHS
4864                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4865 #else
4866                 sv_setiv(sv, (IV)(sent->s_port));
4867 #endif
4868             }
4869             else
4870                 sv_setpv(sv, sent->s_name);
4871         }
4872         RETURN;
4873     }
4874
4875     if (sent) {
4876         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4877         sv_setpv(sv, sent->s_name);
4878         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4879         for (elem = sent->s_aliases; elem && *elem; elem++) {
4880             sv_catpv(sv, *elem);
4881             if (elem[1])
4882                 sv_catpvn(sv, " ", 1);
4883         }
4884         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4885 #ifdef HAS_NTOHS
4886         sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4887 #else
4888         sv_setiv(sv, (IV)(sent->s_port));
4889 #endif
4890         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4891         sv_setpv(sv, sent->s_proto);
4892     }
4893
4894     RETURN;
4895 #else
4896     DIE(aTHX_ PL_no_sock_func, "getservent");
4897 #endif
4898 }
4899
4900 PP(pp_shostent)
4901 {
4902 #ifdef HAS_SETHOSTENT
4903     dSP;
4904     PerlSock_sethostent(TOPi);
4905     RETSETYES;
4906 #else
4907     DIE(aTHX_ PL_no_sock_func, "sethostent");
4908 #endif
4909 }
4910
4911 PP(pp_snetent)
4912 {
4913 #ifdef HAS_SETNETENT
4914     dSP;
4915     PerlSock_setnetent(TOPi);
4916     RETSETYES;
4917 #else
4918     DIE(aTHX_ PL_no_sock_func, "setnetent");
4919 #endif
4920 }
4921
4922 PP(pp_sprotoent)
4923 {
4924 #ifdef HAS_SETPROTOENT
4925     dSP;
4926     PerlSock_setprotoent(TOPi);
4927     RETSETYES;
4928 #else
4929     DIE(aTHX_ PL_no_sock_func, "setprotoent");
4930 #endif
4931 }
4932
4933 PP(pp_sservent)
4934 {
4935 #ifdef HAS_SETSERVENT
4936     dSP;
4937     PerlSock_setservent(TOPi);
4938     RETSETYES;
4939 #else
4940     DIE(aTHX_ PL_no_sock_func, "setservent");
4941 #endif
4942 }
4943
4944 PP(pp_ehostent)
4945 {
4946 #ifdef HAS_ENDHOSTENT
4947     dSP;
4948     PerlSock_endhostent();
4949     EXTEND(SP,1);
4950     RETPUSHYES;
4951 #else
4952     DIE(aTHX_ PL_no_sock_func, "endhostent");
4953 #endif
4954 }
4955
4956 PP(pp_enetent)
4957 {
4958 #ifdef HAS_ENDNETENT
4959     dSP;
4960     PerlSock_endnetent();
4961     EXTEND(SP,1);
4962     RETPUSHYES;
4963 #else
4964     DIE(aTHX_ PL_no_sock_func, "endnetent");
4965 #endif
4966 }
4967
4968 PP(pp_eprotoent)
4969 {
4970 #ifdef HAS_ENDPROTOENT
4971     dSP;
4972     PerlSock_endprotoent();
4973     EXTEND(SP,1);
4974     RETPUSHYES;
4975 #else
4976     DIE(aTHX_ PL_no_sock_func, "endprotoent");
4977 #endif
4978 }
4979
4980 PP(pp_eservent)
4981 {
4982 #ifdef HAS_ENDSERVENT
4983     dSP;
4984     PerlSock_endservent();
4985     EXTEND(SP,1);
4986     RETPUSHYES;
4987 #else
4988     DIE(aTHX_ PL_no_sock_func, "endservent");
4989 #endif
4990 }
4991
4992 PP(pp_gpwnam)
4993 {
4994 #ifdef HAS_PASSWD
4995     return pp_gpwent();
4996 #else
4997     DIE(aTHX_ PL_no_func, "getpwnam");
4998 #endif
4999 }
5000
5001 PP(pp_gpwuid)
5002 {
5003 #ifdef HAS_PASSWD
5004     return pp_gpwent();
5005 #else
5006     DIE(aTHX_ PL_no_func, "getpwuid");
5007 #endif
5008 }
5009
5010 PP(pp_gpwent)
5011 {
5012 #ifdef HAS_PASSWD
5013     dSP;
5014     I32 which = PL_op->op_type;
5015     register SV *sv;
5016     STRLEN n_a;
5017     struct passwd *pwent  = NULL;
5018     /*
5019      * We currently support only the SysV getsp* shadow password interface.
5020      * The interface is declared in <shadow.h> and often one needs to link
5021      * with -lsecurity or some such.
5022      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5023      * (and SCO?)
5024      *
5025      * AIX getpwnam() is clever enough to return the encrypted password
5026      * only if the caller (euid?) is root.
5027      *
5028      * There are at least two other shadow password APIs.  Many platforms
5029      * seem to contain more than one interface for accessing the shadow
5030      * password databases, possibly for compatibility reasons.
5031      * The getsp*() is by far he simplest one, the other two interfaces
5032      * are much more complicated, but also very similar to each other.
5033      *
5034      * <sys/types.h>
5035      * <sys/security.h>
5036      * <prot.h>
5037      * struct pr_passwd *getprpw*();
5038      * The password is in
5039      * char getprpw*(...).ufld.fd_encrypt[]
5040      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5041      *
5042      * <sys/types.h>
5043      * <sys/security.h>
5044      * <prot.h>
5045      * struct es_passwd *getespw*();
5046      * The password is in
5047      * char *(getespw*(...).ufld.fd_encrypt)
5048      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5049      *
5050      * Mention I_PROT here so that Configure probes for it.
5051      *
5052      * In HP-UX for getprpw*() the manual page claims that one should include
5053      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5054      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5055      * and pp_sys.c already includes <shadow.h> if there is such.
5056      *
5057      * Note that <sys/security.h> is already probed for, but currently
5058      * it is only included in special cases.
5059      *
5060      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5061      * be preferred interface, even though also the getprpw*() interface
5062      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5063      * One also needs to call set_auth_parameters() in main() before
5064      * doing anything else, whether one is using getespw*() or getprpw*().
5065      *
5066      * Note that accessing the shadow databases can be magnitudes
5067      * slower than accessing the standard databases.
5068      *
5069      * --jhi
5070      */
5071
5072     switch (which) {
5073     case OP_GPWNAM:
5074         pwent  = getpwnam(POPpbytex);
5075         break;
5076     case OP_GPWUID:
5077         pwent = getpwuid((Uid_t)POPi);
5078         break;
5079     case OP_GPWENT:
5080 #   ifdef HAS_GETPWENT
5081         pwent  = getpwent();
5082 #   else
5083         DIE(aTHX_ PL_no_func, "getpwent");
5084 #   endif
5085         break;
5086     }
5087
5088     EXTEND(SP, 10);
5089     if (GIMME != G_ARRAY) {
5090         PUSHs(sv = sv_newmortal());
5091         if (pwent) {
5092             if (which == OP_GPWNAM)
5093 #   if Uid_t_sign <= 0
5094                 sv_setiv(sv, (IV)pwent->pw_uid);
5095 #   else
5096                 sv_setuv(sv, (UV)pwent->pw_uid);
5097 #   endif
5098             else
5099                 sv_setpv(sv, pwent->pw_name);
5100         }
5101         RETURN;
5102     }
5103
5104     if (pwent) {
5105         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5106         sv_setpv(sv, pwent->pw_name);
5107
5108         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5109         SvPOK_off(sv);
5110         /* If we have getspnam(), we try to dig up the shadow
5111          * password.  If we are underprivileged, the shadow
5112          * interface will set the errno to EACCES or similar,
5113          * and return a null pointer.  If this happens, we will
5114          * use the dummy password (usually "*" or "x") from the
5115          * standard password database.
5116          *
5117          * In theory we could skip the shadow call completely
5118          * if euid != 0 but in practice we cannot know which
5119          * security measures are guarding the shadow databases
5120          * on a random platform.
5121          *
5122          * Resist the urge to use additional shadow interfaces.
5123          * Divert the urge to writing an extension instead.
5124          *
5125          * --jhi */
5126 #   ifdef HAS_GETSPNAM
5127         {
5128             struct spwd *spwent;
5129             int saverrno; /* Save and restore errno so that
5130                            * underprivileged attempts seem
5131                            * to have never made the unsccessful
5132                            * attempt to retrieve the shadow password. */
5133
5134             saverrno = errno;
5135             spwent = getspnam(pwent->pw_name);
5136             errno = saverrno;
5137             if (spwent && spwent->sp_pwdp)
5138                 sv_setpv(sv, spwent->sp_pwdp);
5139         }
5140 #   endif
5141 #   ifdef PWPASSWD
5142         if (!SvPOK(sv)) /* Use the standard password, then. */
5143             sv_setpv(sv, pwent->pw_passwd);
5144 #   endif
5145
5146 #   ifndef INCOMPLETE_TAINTS
5147         /* passwd is tainted because user himself can diddle with it.
5148          * admittedly not much and in a very limited way, but nevertheless. */
5149         SvTAINTED_on(sv);
5150 #   endif
5151
5152         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5153 #   if Uid_t_sign <= 0
5154         sv_setiv(sv, (IV)pwent->pw_uid);
5155 #   else
5156         sv_setuv(sv, (UV)pwent->pw_uid);
5157 #   endif
5158
5159         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5160 #   if Uid_t_sign <= 0
5161         sv_setiv(sv, (IV)pwent->pw_gid);
5162 #   else
5163         sv_setuv(sv, (UV)pwent->pw_gid);
5164 #   endif
5165         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5166          * because of the poor interface of the Perl getpw*(),
5167          * not because there's some standard/convention saying so.
5168          * A better interface would have been to return a hash,
5169          * but we are accursed by our history, alas. --jhi.  */
5170         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5171 #   ifdef PWCHANGE
5172         sv_setiv(sv, (IV)pwent->pw_change);
5173 #   else
5174 #       ifdef PWQUOTA
5175         sv_setiv(sv, (IV)pwent->pw_quota);
5176 #       else
5177 #           ifdef PWAGE
5178         sv_setpv(sv, pwent->pw_age);
5179 #           endif
5180 #       endif
5181 #   endif
5182
5183         /* pw_class and pw_comment are mutually exclusive--.
5184          * see the above note for pw_change, pw_quota, and pw_age. */
5185         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5186 #   ifdef PWCLASS
5187         sv_setpv(sv, pwent->pw_class);
5188 #   else
5189 #       ifdef PWCOMMENT
5190         sv_setpv(sv, pwent->pw_comment);
5191 #       endif
5192 #   endif
5193
5194         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5195 #   ifdef PWGECOS
5196         sv_setpv(sv, pwent->pw_gecos);
5197 #   endif
5198 #   ifndef INCOMPLETE_TAINTS
5199         /* pw_gecos is tainted because user himself can diddle with it. */
5200         SvTAINTED_on(sv);
5201 #   endif
5202
5203         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5204         sv_setpv(sv, pwent->pw_dir);
5205
5206         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5207         sv_setpv(sv, pwent->pw_shell);
5208 #   ifndef INCOMPLETE_TAINTS
5209         /* pw_shell is tainted because user himself can diddle with it. */
5210         SvTAINTED_on(sv);
5211 #   endif
5212
5213 #   ifdef PWEXPIRE
5214         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5215         sv_setiv(sv, (IV)pwent->pw_expire);
5216 #   endif
5217     }
5218     RETURN;
5219 #else
5220     DIE(aTHX_ PL_no_func, "getpwent");
5221 #endif
5222 }
5223
5224 PP(pp_spwent)
5225 {
5226 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5227     dSP;
5228     setpwent();
5229     RETPUSHYES;
5230 #else
5231     DIE(aTHX_ PL_no_func, "setpwent");
5232 #endif
5233 }
5234
5235 PP(pp_epwent)
5236 {
5237 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5238     dSP;
5239     endpwent();
5240     RETPUSHYES;
5241 #else
5242     DIE(aTHX_ PL_no_func, "endpwent");
5243 #endif
5244 }
5245
5246 PP(pp_ggrnam)
5247 {
5248 #ifdef HAS_GROUP
5249     return pp_ggrent();
5250 #else
5251     DIE(aTHX_ PL_no_func, "getgrnam");
5252 #endif
5253 }
5254
5255 PP(pp_ggrgid)
5256 {
5257 #ifdef HAS_GROUP
5258     return pp_ggrent();
5259 #else
5260     DIE(aTHX_ PL_no_func, "getgrgid");
5261 #endif
5262 }
5263
5264 PP(pp_ggrent)
5265 {
5266 #ifdef HAS_GROUP
5267     dSP;
5268     I32 which = PL_op->op_type;
5269     register char **elem;
5270     register SV *sv;
5271     struct group *grent;
5272     STRLEN n_a;
5273
5274     if (which == OP_GGRNAM)
5275         grent = (struct group *)getgrnam(POPpbytex);
5276     else if (which == OP_GGRGID)
5277         grent = (struct group *)getgrgid(POPi);
5278     else
5279 #ifdef HAS_GETGRENT
5280         grent = (struct group *)getgrent();
5281 #else
5282         DIE(aTHX_ PL_no_func, "getgrent");
5283 #endif
5284
5285     EXTEND(SP, 4);
5286     if (GIMME != G_ARRAY) {
5287         PUSHs(sv = sv_newmortal());
5288         if (grent) {
5289             if (which == OP_GGRNAM)
5290                 sv_setiv(sv, (IV)grent->gr_gid);
5291             else
5292                 sv_setpv(sv, grent->gr_name);
5293         }
5294         RETURN;
5295     }
5296
5297     if (grent) {
5298         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5299         sv_setpv(sv, grent->gr_name);
5300
5301         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5302 #ifdef GRPASSWD
5303         sv_setpv(sv, grent->gr_passwd);
5304 #endif
5305
5306         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5307         sv_setiv(sv, (IV)grent->gr_gid);
5308
5309         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5310         for (elem = grent->gr_mem; elem && *elem; elem++) {
5311             sv_catpv(sv, *elem);
5312             if (elem[1])
5313                 sv_catpvn(sv, " ", 1);
5314         }
5315     }
5316
5317     RETURN;
5318 #else
5319     DIE(aTHX_ PL_no_func, "getgrent");
5320 #endif
5321 }
5322
5323 PP(pp_sgrent)
5324 {
5325 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5326     dSP;
5327     setgrent();
5328     RETPUSHYES;
5329 #else
5330     DIE(aTHX_ PL_no_func, "setgrent");
5331 #endif
5332 }
5333
5334 PP(pp_egrent)
5335 {
5336 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5337     dSP;
5338     endgrent();
5339     RETPUSHYES;
5340 #else
5341     DIE(aTHX_ PL_no_func, "endgrent");
5342 #endif
5343 }
5344
5345 PP(pp_getlogin)
5346 {
5347 #ifdef HAS_GETLOGIN
5348     dSP; dTARGET;
5349     char *tmps;
5350     EXTEND(SP, 1);
5351     if (!(tmps = PerlProc_getlogin()))
5352         RETPUSHUNDEF;
5353     PUSHp(tmps, strlen(tmps));
5354     RETURN;
5355 #else
5356     DIE(aTHX_ PL_no_func, "getlogin");
5357 #endif
5358 }
5359
5360 /* Miscellaneous. */
5361
5362 PP(pp_syscall)
5363 {
5364 #ifdef HAS_SYSCALL
5365     dSP; dMARK; dORIGMARK; dTARGET;
5366     register I32 items = SP - MARK;
5367     unsigned long a[20];
5368     register I32 i = 0;
5369     I32 retval = -1;
5370     STRLEN n_a;
5371
5372     if (PL_tainting) {
5373         while (++MARK <= SP) {
5374             if (SvTAINTED(*MARK)) {
5375                 TAINT;
5376                 break;
5377             }
5378         }
5379         MARK = ORIGMARK;
5380         TAINT_PROPER("syscall");
5381     }
5382
5383     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5384      * or where sizeof(long) != sizeof(char*).  But such machines will
5385      * not likely have syscall implemented either, so who cares?
5386      */
5387     while (++MARK <= SP) {
5388         if (SvNIOK(*MARK) || !i)
5389             a[i++] = SvIV(*MARK);
5390         else if (*MARK == &PL_sv_undef)
5391             a[i++] = 0;
5392         else
5393             a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
5394         if (i > 15)
5395             break;
5396     }
5397     switch (items) {
5398     default:
5399         DIE(aTHX_ "Too many args to syscall");
5400     case 0:
5401         DIE(aTHX_ "Too few args to syscall");
5402     case 1:
5403         retval = syscall(a[0]);
5404         break;
5405     case 2:
5406         retval = syscall(a[0],a[1]);
5407         break;
5408     case 3:
5409         retval = syscall(a[0],a[1],a[2]);
5410         break;
5411     case 4:
5412         retval = syscall(a[0],a[1],a[2],a[3]);
5413         break;
5414     case 5:
5415         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5416         break;
5417     case 6:
5418         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5419         break;
5420     case 7:
5421         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5422         break;
5423     case 8:
5424         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5425         break;
5426 #ifdef atarist
5427     case 9:
5428         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5429         break;
5430     case 10:
5431         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5432         break;
5433     case 11:
5434         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5435           a[10]);
5436         break;
5437     case 12:
5438         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5439           a[10],a[11]);
5440         break;
5441     case 13:
5442         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5443           a[10],a[11],a[12]);
5444         break;
5445     case 14:
5446         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5447           a[10],a[11],a[12],a[13]);
5448         break;
5449 #endif /* atarist */
5450     }
5451     SP = ORIGMARK;
5452     PUSHi(retval);
5453     RETURN;
5454 #else
5455     DIE(aTHX_ PL_no_func, "syscall");
5456 #endif
5457 }
5458
5459 #ifdef FCNTL_EMULATE_FLOCK
5460
5461 /*  XXX Emulate flock() with fcntl().
5462     What's really needed is a good file locking module.
5463 */
5464
5465 static int
5466 fcntl_emulate_flock(int fd, int operation)
5467 {
5468     struct flock flock;
5469
5470     switch (operation & ~LOCK_NB) {
5471     case LOCK_SH:
5472         flock.l_type = F_RDLCK;
5473         break;
5474     case LOCK_EX:
5475         flock.l_type = F_WRLCK;
5476         break;
5477     case LOCK_UN:
5478         flock.l_type = F_UNLCK;
5479         break;
5480     default:
5481         errno = EINVAL;
5482         return -1;
5483     }
5484     flock.l_whence = SEEK_SET;
5485     flock.l_start = flock.l_len = (Off_t)0;
5486
5487     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5488 }
5489
5490 #endif /* FCNTL_EMULATE_FLOCK */
5491
5492 #ifdef LOCKF_EMULATE_FLOCK
5493
5494 /*  XXX Emulate flock() with lockf().  This is just to increase
5495     portability of scripts.  The calls are not completely
5496     interchangeable.  What's really needed is a good file
5497     locking module.
5498 */
5499
5500 /*  The lockf() constants might have been defined in <unistd.h>.
5501     Unfortunately, <unistd.h> causes troubles on some mixed
5502     (BSD/POSIX) systems, such as SunOS 4.1.3.
5503
5504    Further, the lockf() constants aren't POSIX, so they might not be
5505    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5506    just stick in the SVID values and be done with it.  Sigh.
5507 */
5508
5509 # ifndef F_ULOCK
5510 #  define F_ULOCK       0       /* Unlock a previously locked region */
5511 # endif
5512 # ifndef F_LOCK
5513 #  define F_LOCK        1       /* Lock a region for exclusive use */
5514 # endif
5515 # ifndef F_TLOCK
5516 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5517 # endif
5518 # ifndef F_TEST
5519 #  define F_TEST        3       /* Test a region for other processes locks */
5520 # endif
5521
5522 static int
5523 lockf_emulate_flock(int fd, int operation)
5524 {
5525     int i;
5526     int save_errno;
5527     Off_t pos;
5528
5529     /* flock locks entire file so for lockf we need to do the same      */
5530     save_errno = errno;
5531     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5532     if (pos > 0)        /* is seekable and needs to be repositioned     */
5533         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5534             pos = -1;   /* seek failed, so don't seek back afterwards   */
5535     errno = save_errno;
5536
5537     switch (operation) {
5538
5539         /* LOCK_SH - get a shared lock */
5540         case LOCK_SH:
5541         /* LOCK_EX - get an exclusive lock */
5542         case LOCK_EX:
5543             i = lockf (fd, F_LOCK, 0);
5544             break;
5545
5546         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5547         case LOCK_SH|LOCK_NB:
5548         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5549         case LOCK_EX|LOCK_NB:
5550             i = lockf (fd, F_TLOCK, 0);
5551             if (i == -1)
5552                 if ((errno == EAGAIN) || (errno == EACCES))
5553                     errno = EWOULDBLOCK;
5554             break;
5555
5556         /* LOCK_UN - unlock (non-blocking is a no-op) */
5557         case LOCK_UN:
5558         case LOCK_UN|LOCK_NB:
5559             i = lockf (fd, F_ULOCK, 0);
5560             break;
5561
5562         /* Default - can't decipher operation */
5563         default:
5564             i = -1;
5565             errno = EINVAL;
5566             break;
5567     }
5568
5569     if (pos > 0)      /* need to restore position of the handle */
5570         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5571
5572     return (i);
5573 }
5574
5575 #endif /* LOCKF_EMULATE_FLOCK */