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 HAS_SELECT
  53 # ifdef I_SYS_SELECT
  54 #  include <sys/select.h>
  55 # endif
  56 #endif
  57
  58 /* XXX Configure test needed.
  59    h_errno might not be a simple 'int', especially for multi-threaded
  60    applications, see "extern int errno in perl.h".  Creating such
  61    a test requires taking into account the differences between
  62    compiling multithreaded and singlethreaded ($ccflags et al).
  63    HOST_NOT_FOUND is typically defined in <netdb.h>.
  64 */
  65 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
  66 extern int h_errno;
  67 #endif
  68
  69 #ifdef HAS_PASSWD
  70 # ifdef I_PWD
  71 #  include <pwd.h>
  72 # else
  73     struct passwd *getpwnam (char *);
  74     struct passwd *getpwuid (Uid_t);
  75 # endif
  76 # ifdef HAS_GETPWENT
  77   struct passwd *getpwent (void);
  78 # endif
  79 #endif
  80
  81 #ifdef HAS_GROUP
  82 # ifdef I_GRP
  83 #  include <grp.h>
  84 # else
  85     struct group *getgrnam (char *);
  86     struct group *getgrgid (Gid_t);
  87 # endif
  88 # ifdef HAS_GETGRENT
  89     struct group *getgrent (void);
  90 # endif
  91 #endif
  92
  93 #ifdef I_UTIME
  94 #  if defined(_MSC_VER) || defined(__MINGW32__)
  95 #    include <sys/utime.h>
  96 #  else
  97 #    include <utime.h>
  98 #  endif
  99 #endif
 100
 101 #ifdef I_SYS_UN
 102 #  ifdef  __linux__
 103 #    include <sys/un.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 STATIC int
 282 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
 283 {
 284     Perl_croak(aTHX_ "switching effective uid is not implemented");
 285     /*NOTREACHED*/
 286     return -1;
 287 }
 288 #endif
 289
 290 PP(pp_backtick)
 291 {
 292     dSP; dTARGET;
 293     PerlIO *fp;
 294     STRLEN n_a;
 295     char *tmps = POPpx;
 296     I32 gimme = GIMME_V;
 297     char *mode = "r";
 298
 299     TAINT_PROPER("``");
 300     if (PL_op->op_private & OPpOPEN_IN_RAW)
 301         mode = "rb";
 302     else if (PL_op->op_private & OPpOPEN_IN_CRLF)
 303         mode = "rt";
 304     fp = PerlProc_popen(tmps, mode);
 305     if (fp) {
 306         char *type = NULL;
 307         if (PL_curcop->cop_io) {
 308             type = SvPV_nolen(PL_curcop->cop_io);
 309         }
 310         if (type && *type)
 311             PerlIO_apply_layers(aTHX_ fp,mode,type);
 312
 313         if (gimme == G_VOID) {
 314             char tmpbuf[256];
 315             while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
 316                 /*SUPPRESS 530*/
 317                 ;
 318         }
 319         else if (gimme == G_SCALAR) {
 320             sv_setpv(TARG, ""); /* note that this preserves previous buffer */
 321             while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
 322                 /*SUPPRESS 530*/
 323                 ;
 324             XPUSHs(TARG);
 325             SvTAINTED_on(TARG);
 326         }
 327         else {
 328             SV *sv;
 329
 330             for (;;) {
 331                 sv = NEWSV(56, 79);
 332                 if (sv_gets(sv, fp, 0) == Nullch) {
 333                     SvREFCNT_dec(sv);
 334                     break;
 335                 }
 336                 XPUSHs(sv_2mortal(sv));
 337                 if (SvLEN(sv) - SvCUR(sv) > 20) {
 338                     SvLEN_set(sv, SvCUR(sv)+1);
 339                     Renew(SvPVX(sv), SvLEN(sv), char);
 340                 }
 341                 SvTAINTED_on(sv);
 342             }
 343         }
 344         STATUS_NATIVE_SET(PerlProc_pclose(fp));
 345         TAINT;          /* "I believe that this is not gratuitous!" */
 346     }
 347     else {
 348         STATUS_NATIVE_SET(-1);
 349         if (gimme == G_SCALAR)
 350             RETPUSHUNDEF;
 351     }
 352
 353     RETURN;
 354 }
 355
 356 PP(pp_glob)
 357 {
 358     OP *result;
 359     tryAMAGICunTARGET(iter, -1);
 360
 361     /* Note that we only ever get here if File::Glob fails to load
 362      * without at the same time croaking, for some reason, or if
 363      * perl was built with PERL_EXTERNAL_GLOB */
 364
 365     ENTER;
 366
 367 #ifndef VMS
 368     if (PL_tainting) {
 369         /*
 370          * The external globbing program may use things we can't control,
 371          * so for security reasons we must assume the worst.
 372          */
 373         TAINT;
 374         taint_proper(PL_no_security, "glob");
 375     }
 376 #endif /* !VMS */
 377
 378     SAVESPTR(PL_last_in_gv);    /* We don't want this to be permanent. */
 379     PL_last_in_gv = (GV*)*PL_stack_sp--;
 380
 381     SAVESPTR(PL_rs);            /* This is not permanent, either. */
 382     PL_rs = sv_2mortal(newSVpvn("\000", 1));
 383 #ifndef DOSISH
 384 #ifndef CSH
 385     *SvPVX(PL_rs) = '\n';
 386 #endif  /* !CSH */
 387 #endif  /* !DOSISH */
 388
 389     result = do_readline();
 390     LEAVE;
 391     return result;
 392 }
 393
 394 #if 0           /* XXX never used! */
 395 PP(pp_indread)
 396 {
 397     STRLEN n_a;
 398     PL_last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*PL_stack_sp--)), n_a), TRUE,SVt_PVIO);
 399     return do_readline();
 400 }
 401 #endif
 402
 403 PP(pp_rcatline)
 404 {
 405     PL_last_in_gv = cGVOP_gv;
 406     return do_readline();
 407 }
 408
 409 PP(pp_warn)
 410 {
 411     dSP; dMARK;
 412     SV *tmpsv;
 413     char *tmps;
 414     STRLEN len;
 415     if (SP - MARK != 1) {
 416         dTARGET;
 417         do_join(TARG, &PL_sv_no, MARK, SP);
 418         tmpsv = TARG;
 419         SP = MARK + 1;
 420     }
 421     else {
 422         tmpsv = TOPs;
 423     }
 424     tmps = SvPV(tmpsv, len);
 425     if (!tmps || !len) {
 426         SV *error = ERRSV;
 427         (void)SvUPGRADE(error, SVt_PV);
 428         if (SvPOK(error) && SvCUR(error))
 429             sv_catpv(error, "\t...caught");
 430         tmpsv = error;
 431         tmps = SvPV(tmpsv, len);
 432     }
 433     if (!tmps || !len)
 434         tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26));
 435
 436     Perl_warn(aTHX_ "%"SVf, tmpsv);
 437     RETSETYES;
 438 }
 439
 440 PP(pp_die)
 441 {
 442     dSP; dMARK;
 443     char *tmps;
 444     SV *tmpsv;
 445     STRLEN len;
 446     bool multiarg = 0;
 447     if (SP - MARK != 1) {
 448         dTARGET;
 449         do_join(TARG, &PL_sv_no, MARK, SP);
 450         tmpsv = TARG;
 451         tmps = SvPV(tmpsv, len);
 452         multiarg = 1;
 453         SP = MARK + 1;
 454     }
 455     else {
 456         tmpsv = TOPs;
 457         tmps = (SvROK(tmpsv) && PL_in_eval) ? Nullch : SvPV(tmpsv, len);
 458     }
 459     if (!tmps || !len) {
 460         SV *error = ERRSV;
 461         (void)SvUPGRADE(error, SVt_PV);
 462         if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
 463             if (!multiarg)
 464                 SvSetSV(error,tmpsv);
 465             else if (sv_isobject(error)) {
 466                 HV *stash = SvSTASH(SvRV(error));
 467                 GV *gv = gv_fetchmethod(stash, "PROPAGATE");
 468                 if (gv) {
 469                     SV *file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
 470                     SV *line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
 471                     EXTEND(SP, 3);
 472                     PUSHMARK(SP);
 473                     PUSHs(error);
 474                     PUSHs(file);
 475                     PUSHs(line);
 476                     PUTBACK;
 477                     call_sv((SV*)GvCV(gv),
 478                             G_SCALAR|G_EVAL|G_KEEPERR);
 479                     sv_setsv(error,*PL_stack_sp--);
 480                 }
 481             }
 482             DIE(aTHX_ Nullch);
 483         }
 484         else {
 485             if (SvPOK(error) && SvCUR(error))
 486                 sv_catpv(error, "\t...propagated");
 487             tmpsv = error;
 488             tmps = SvPV(tmpsv, len);
 489         }
 490     }
 491     if (!tmps || !len)
 492         tmpsv = sv_2mortal(newSVpvn("Died", 4));
 493
 494     DIE(aTHX_ "%"SVf, tmpsv);
 495 }
 496
 497 /* I/O. */
 498
 499 PP(pp_open)
 500 {
 501     dSP;
 502     dMARK; dORIGMARK;
 503     dTARGET;
 504     GV *gv;
 505     SV *sv;
 506     char *tmps;
 507     STRLEN len;
 508     MAGIC *mg;
 509     bool  ok;
 510
 511     gv = (GV *)*++MARK;
 512     if (!isGV(gv))
 513         DIE(aTHX_ PL_no_usym, "filehandle");
 514     if (GvIOp(gv))
 515         IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
 516
 517     if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
 518         /* Method's args are same as ours ... */
 519         /* ... except handle is replaced by the object */
 520         *MARK-- = SvTIED_obj((SV*)gv, mg);
 521         PUSHMARK(MARK);
 522         PUTBACK;
 523         ENTER;
 524         call_method("OPEN", G_SCALAR);
 525         LEAVE;
 526         SPAGAIN;
 527         RETURN;
 528     }
 529
 530     if (MARK < SP) {
 531         sv = *++MARK;
 532     }
 533     else {
 534         sv = GvSV(gv);
 535     }
 536
 537     tmps = SvPV(sv, len);
 538     ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp, MARK+1, (SP-MARK));
 539     SP = ORIGMARK;
 540     if (ok)
 541         PUSHi( (I32)PL_forkprocess );
 542     else if (PL_forkprocess == 0)               /* we are a new child */
 543         PUSHi(0);
 544     else
 545         RETPUSHUNDEF;
 546     RETURN;
 547 }
 548
 549 PP(pp_close)
 550 {
 551     dSP;
 552     GV *gv;
 553     MAGIC *mg;
 554
 555     if (MAXARG == 0)
 556         gv = PL_defoutgv;
 557     else
 558         gv = (GV*)POPs;
 559
 560     if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
 561         PUSHMARK(SP);
 562         XPUSHs(SvTIED_obj((SV*)gv, mg));
 563         PUTBACK;
 564         ENTER;
 565         call_method("CLOSE", G_SCALAR);
 566         LEAVE;
 567         SPAGAIN;
 568         RETURN;
 569     }
 570     EXTEND(SP, 1);
 571     PUSHs(boolSV(do_close(gv, TRUE)));
 572     RETURN;
 573 }
 574
 575 PP(pp_pipe_op)
 576 {
 577     dSP;
 578 #ifdef HAS_PIPE
 579     GV *rgv;
 580     GV *wgv;
 581     register IO *rstio;
 582     register IO *wstio;
 583     int fd[2];
 584
 585     wgv = (GV*)POPs;
 586     rgv = (GV*)POPs;
 587
 588     if (!rgv || !wgv)
 589         goto badexit;
 590
 591     if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
 592         DIE(aTHX_ PL_no_usym, "filehandle");
 593     rstio = GvIOn(rgv);
 594     wstio = GvIOn(wgv);
 595
 596     if (IoIFP(rstio))
 597         do_close(rgv, FALSE);
 598     if (IoIFP(wstio))
 599         do_close(wgv, FALSE);
 600
 601     if (PerlProc_pipe(fd) < 0)
 602         goto badexit;
 603
 604     IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
 605     IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
 606     IoIFP(wstio) = IoOFP(wstio);
 607     IoTYPE(rstio) = IoTYPE_RDONLY;
 608     IoTYPE(wstio) = IoTYPE_WRONLY;
 609
 610     if (!IoIFP(rstio) || !IoOFP(wstio)) {
 611         if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
 612         else PerlLIO_close(fd[0]);
 613         if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
 614         else PerlLIO_close(fd[1]);
 615         goto badexit;
 616     }
 617 #if defined(HAS_FCNTL) && defined(F_SETFD)
 618     fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);   /* ensure close-on-exec */
 619     fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);   /* ensure close-on-exec */
 620 #endif
 621     RETPUSHYES;
 622
 623 badexit:
 624     RETPUSHUNDEF;
 625 #else
 626     DIE(aTHX_ PL_no_func, "pipe");
 627 #endif
 628 }
 629
 630 PP(pp_fileno)
 631 {
 632     dSP; dTARGET;
 633     GV *gv;
 634     IO *io;
 635     PerlIO *fp;
 636     MAGIC  *mg;
 637
 638     if (MAXARG < 1)
 639         RETPUSHUNDEF;
 640     gv = (GV*)POPs;
 641
 642     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
 643         PUSHMARK(SP);
 644         XPUSHs(SvTIED_obj((SV*)gv, mg));
 645         PUTBACK;
 646         ENTER;
 647         call_method("FILENO", G_SCALAR);
 648         LEAVE;
 649         SPAGAIN;
 650         RETURN;
 651     }
 652
 653     if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
 654         /* Can't do this because people seem to do things like
 655            defined(fileno($foo)) to check whether $foo is a valid fh.
 656           if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
 657               report_evil_fh(gv, io, PL_op->op_type);
 658             */
 659         RETPUSHUNDEF;
 660     }
 661
 662     PUSHi(PerlIO_fileno(fp));
 663     RETURN;
 664 }
 665
 666 PP(pp_umask)
 667 {
 668     dSP; dTARGET;
 669     Mode_t anum;
 670
 671 #ifdef HAS_UMASK
 672     if (MAXARG < 1) {
 673         anum = PerlLIO_umask(0);
 674         (void)PerlLIO_umask(anum);
 675     }
 676     else
 677         anum = PerlLIO_umask(POPi);
 678     TAINT_PROPER("umask");
 679     XPUSHi(anum);
 680 #else
 681     /* Only DIE if trying to restrict permissions on `user' (self).
 682      * Otherwise it's harmless and more useful to just return undef
 683      * since 'group' and 'other' concepts probably don't exist here. */
 684     if (MAXARG >= 1 && (POPi & 0700))
 685         DIE(aTHX_ "umask not implemented");
 686     XPUSHs(&PL_sv_undef);
 687 #endif
 688     RETURN;
 689 }
 690
 691 PP(pp_binmode)
 692 {
 693     dSP;
 694     GV *gv;
 695     IO *io;
 696     PerlIO *fp;
 697     MAGIC *mg;
 698     SV *discp = Nullsv;
 699     STRLEN len  = 0;
 700     char *names = NULL;
 701
 702     if (MAXARG < 1)
 703         RETPUSHUNDEF;
 704     if (MAXARG > 1) {
 705         discp = POPs;
 706     }
 707
 708     gv = (GV*)POPs;
 709
 710     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
 711         PUSHMARK(SP);
 712         XPUSHs(SvTIED_obj((SV*)gv, mg));
 713         if (discp)
 714             XPUSHs(discp);
 715         PUTBACK;
 716         ENTER;
 717         call_method("BINMODE", G_SCALAR);
 718         LEAVE;
 719         SPAGAIN;
 720         RETURN;
 721     }
 722
 723     EXTEND(SP, 1);
 724     if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
 725         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
 726             report_evil_fh(gv, io, PL_op->op_type);
 727         RETPUSHUNDEF;
 728     }
 729
 730     if (discp) {
 731         names = SvPV(discp,len);
 732     }
 733
 734     if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp),
 735                        (discp) ? SvPV_nolen(discp) : Nullch))
 736         RETPUSHYES;
 737     else
 738         RETPUSHUNDEF;
 739 }
 740
 741 PP(pp_tie)
 742 {
 743     dSP;
 744     dMARK;
 745     SV *varsv;
 746     HV* stash;
 747     GV *gv;
 748     SV *sv;
 749     I32 markoff = MARK - PL_stack_base;
 750     char *methname;
 751     int how = 'P';
 752     U32 items;
 753     STRLEN n_a;
 754
 755     varsv = *++MARK;
 756     switch(SvTYPE(varsv)) {
 757         case SVt_PVHV:
 758             methname = "TIEHASH";
 759             break;
 760         case SVt_PVAV:
 761             methname = "TIEARRAY";
 762             break;
 763         case SVt_PVGV:
 764 #ifdef GV_SHARED_CHECK
 765             if (GvSHARED((GV*)varsv)) {
 766                 Perl_croak(aTHX_ "Attempt to tie shared GV");
 767             }
 768 #endif
 769             methname = "TIEHANDLE";
 770             how = 'q';
 771             break;
 772         default:
 773             methname = "TIESCALAR";
 774             how = 'q';
 775             break;
 776     }
 777     items = SP - MARK++;
 778     if (sv_isobject(*MARK)) {
 779         ENTER;
 780         PUSHSTACKi(PERLSI_MAGIC);
 781         PUSHMARK(SP);
 782         EXTEND(SP,items);
 783         while (items--)
 784             PUSHs(*MARK++);
 785         PUTBACK;
 786         call_method(methname, G_SCALAR);
 787     }
 788     else {
 789         /* Not clear why we don't call call_method here too.
 790          * perhaps to get different error message ?
 791          */
 792         stash = gv_stashsv(*MARK, FALSE);
 793         if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
 794             DIE(aTHX_ "Can't locate object method \"%s\" via package \"%s\"",
 795                  methname, SvPV(*MARK,n_a));
 796         }
 797         ENTER;
 798         PUSHSTACKi(PERLSI_MAGIC);
 799         PUSHMARK(SP);
 800         EXTEND(SP,items);
 801         while (items--)
 802             PUSHs(*MARK++);
 803         PUTBACK;
 804         call_sv((SV*)GvCV(gv), G_SCALAR);
 805     }
 806     SPAGAIN;
 807
 808     sv = TOPs;
 809     POPSTACK;
 810     if (sv_isobject(sv)) {
 811         sv_unmagic(varsv, how);
 812         /* Croak if a self-tie on an aggregate is attempted. */
 813         if (varsv == SvRV(sv) &&
 814             (SvTYPE(sv) == SVt_PVAV ||
 815              SvTYPE(sv) == SVt_PVHV))
 816             Perl_croak(aTHX_
 817                        "Self-ties of arrays and hashes are not supported");
 818         sv_magic(varsv, sv, how, Nullch, 0);
 819     }
 820     LEAVE;
 821     SP = PL_stack_base + markoff;
 822     PUSHs(sv);
 823     RETURN;
 824 }
 825
 826 PP(pp_untie)
 827 {
 828     dSP;
 829     SV *sv = POPs;
 830     char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
 831
 832         MAGIC * mg ;
 833         if ((mg = SvTIED_mg(sv, how))) {
 834         SV *obj = SvRV(mg->mg_obj);
 835         GV *gv;
 836         CV *cv = NULL;
 837         if ((gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE)) &&
 838             isGV(gv) && (cv = GvCV(gv))) {
 839             PUSHMARK(SP);
 840             XPUSHs(SvTIED_obj((SV*)gv, mg));
 841             XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
 842             PUTBACK;
 843             ENTER;
 844             call_sv((SV *)cv, G_VOID);
 845             LEAVE;
 846             SPAGAIN;
 847         }
 848         else if (ckWARN(WARN_UNTIE)) {
 849             if (mg && SvREFCNT(obj) > 1)
 850                 Perl_warner(aTHX_ WARN_UNTIE,
 851                     "untie attempted while %"UVuf" inner references still exist",
 852                     (UV)SvREFCNT(obj) - 1 ) ;
 853         }
 854     }
 855     sv_unmagic(sv, how);
 856     RETPUSHYES;
 857 }
 858
 859 PP(pp_tied)
 860 {
 861     dSP;
 862     SV *sv = POPs;
 863     char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
 864     MAGIC *mg;
 865
 866     if ((mg = SvTIED_mg(sv, how))) {
 867         SV *osv = SvTIED_obj(sv, mg);
 868         if (osv == mg->mg_obj)
 869             osv = sv_mortalcopy(osv);
 870         PUSHs(osv);
 871         RETURN;
 872     }
 873     RETPUSHUNDEF;
 874 }
 875
 876 PP(pp_dbmopen)
 877 {
 878     dSP;
 879     HV *hv;
 880     dPOPPOPssrl;
 881     HV* stash;
 882     GV *gv;
 883     SV *sv;
 884
 885     hv = (HV*)POPs;
 886
 887     sv = sv_mortalcopy(&PL_sv_no);
 888     sv_setpv(sv, "AnyDBM_File");
 889     stash = gv_stashsv(sv, FALSE);
 890     if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
 891         PUTBACK;
 892         require_pv("AnyDBM_File.pm");
 893         SPAGAIN;
 894         if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
 895             DIE(aTHX_ "No dbm on this machine");
 896     }
 897
 898     ENTER;
 899     PUSHMARK(SP);
 900
 901     EXTEND(SP, 5);
 902     PUSHs(sv);
 903     PUSHs(left);
 904     if (SvIV(right))
 905         PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT)));
 906     else
 907         PUSHs(sv_2mortal(newSVuv(O_RDWR)));
 908     PUSHs(right);
 909     PUTBACK;
 910     call_sv((SV*)GvCV(gv), G_SCALAR);
 911     SPAGAIN;
 912
 913     if (!sv_isobject(TOPs)) {
 914         SP--;
 915         PUSHMARK(SP);
 916         PUSHs(sv);
 917         PUSHs(left);
 918         PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
 919         PUSHs(right);
 920         PUTBACK;
 921         call_sv((SV*)GvCV(gv), G_SCALAR);
 922         SPAGAIN;
 923     }
 924
 925     if (sv_isobject(TOPs)) {
 926         sv_unmagic((SV *) hv, 'P');
 927         sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
 928     }
 929     LEAVE;
 930     RETURN;
 931 }
 932
 933 PP(pp_dbmclose)
 934 {
 935     return pp_untie();
 936 }
 937
 938 PP(pp_sselect)
 939 {
 940     dSP; dTARGET;
 941 #ifdef HAS_SELECT
 942     register I32 i;
 943     register I32 j;
 944     register char *s;
 945     register SV *sv;
 946     NV value;
 947     I32 maxlen = 0;
 948     I32 nfound;
 949     struct timeval timebuf;
 950     struct timeval *tbuf = &timebuf;
 951     I32 growsize;
 952     char *fd_sets[4];
 953     STRLEN n_a;
 954 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
 955         I32 masksize;
 956         I32 offset;
 957         I32 k;
 958
 959 #   if BYTEORDER & 0xf0000
 960 #       define ORDERBYTE (0x88888888 - BYTEORDER)
 961 #   else
 962 #       define ORDERBYTE (0x4444 - BYTEORDER)
 963 #   endif
 964
 965 #endif
 966
 967     SP -= 4;
 968     for (i = 1; i <= 3; i++) {
 969         if (!SvPOK(SP[i]))
 970             continue;
 971         j = SvCUR(SP[i]);
 972         if (maxlen < j)
 973             maxlen = j;
 974     }
 975
 976 /* little endians can use vecs directly */
 977 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
 978 #  if SELECT_MIN_BITS > 1
 979     /* If SELECT_MIN_BITS is greater than one we most probably will want
 980      * to align the sizes with SELECT_MIN_BITS/8 because for example
 981      * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
 982      * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
 983      * on (sets/tests/clears bits) is 32 bits.  */
 984     growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
 985 #  else
 986     growsize = sizeof(fd_set);
 987 #  endif
 988 # else
 989 #  ifdef NFDBITS
 990
 991 #    ifndef NBBY
 992 #     define NBBY 8
 993 #    endif
 994
 995     masksize = NFDBITS / NBBY;
 996 #  else
 997     masksize = sizeof(long);    /* documented int, everyone seems to use long */
 998 #  endif
 999     growsize = maxlen + (masksize - (maxlen % masksize));
1000     Zero(&fd_sets[0], 4, char*);
1001 #endif
1002
1003     sv = SP[4];
1004     if (SvOK(sv)) {
1005         value = SvNV(sv);
1006         if (value < 0.0)
1007             value = 0.0;
1008         timebuf.tv_sec = (long)value;
1009         value -= (NV)timebuf.tv_sec;
1010         timebuf.tv_usec = (long)(value * 1000000.0);
1011     }
1012     else
1013         tbuf = Null(struct timeval*);
1014
1015     for (i = 1; i <= 3; i++) {
1016         sv = SP[i];
1017         if (!SvOK(sv)) {
1018             fd_sets[i] = 0;
1019             continue;
1020         }
1021         else if (!SvPOK(sv))
1022             SvPV_force(sv,n_a); /* force string conversion */
1023         j = SvLEN(sv);
1024         if (j < growsize) {
1025             Sv_Grow(sv, growsize);
1026         }
1027         j = SvCUR(sv);
1028         s = SvPVX(sv) + j;
1029         while (++j <= growsize) {
1030             *s++ = '\0';
1031         }
1032
1033 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1034         s = SvPVX(sv);
1035         New(403, fd_sets[i], growsize, char);
1036         for (offset = 0; offset < growsize; offset += masksize) {
1037             for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1038                 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1039         }
1040 #else
1041         fd_sets[i] = SvPVX(sv);
1042 #endif
1043     }
1044
1045     nfound = PerlSock_select(
1046         maxlen * 8,
1047         (Select_fd_set_t) fd_sets[1],
1048         (Select_fd_set_t) fd_sets[2],
1049         (Select_fd_set_t) fd_sets[3],
1050         tbuf);
1051     for (i = 1; i <= 3; i++) {
1052         if (fd_sets[i]) {
1053             sv = SP[i];
1054 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1055             s = SvPVX(sv);
1056             for (offset = 0; offset < growsize; offset += masksize) {
1057                 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1058                     s[(k % masksize) + offset] = fd_sets[i][j+offset];
1059             }
1060             Safefree(fd_sets[i]);
1061 #endif
1062             SvSETMAGIC(sv);
1063         }
1064     }
1065
1066     PUSHi(nfound);
1067     if (GIMME == G_ARRAY && tbuf) {
1068         value = (NV)(timebuf.tv_sec) +
1069                 (NV)(timebuf.tv_usec) / 1000000.0;
1070         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1071         sv_setnv(sv, value);
1072     }
1073     RETURN;
1074 #else
1075     DIE(aTHX_ "select not implemented");
1076 #endif
1077 }
1078
1079 void
1080 Perl_setdefout(pTHX_ GV *gv)
1081 {
1082     if (gv)
1083         (void)SvREFCNT_inc(gv);
1084     if (PL_defoutgv)
1085         SvREFCNT_dec(PL_defoutgv);
1086     PL_defoutgv = gv;
1087 }
1088
1089 PP(pp_select)
1090 {
1091     dSP; dTARGET;
1092     GV *newdefout, *egv;
1093     HV *hv;
1094
1095     newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
1096
1097     egv = GvEGV(PL_defoutgv);
1098     if (!egv)
1099         egv = PL_defoutgv;
1100     hv = GvSTASH(egv);
1101     if (! hv)
1102         XPUSHs(&PL_sv_undef);
1103     else {
1104         GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1105         if (gvp && *gvp == egv) {
1106             gv_efullname4(TARG, PL_defoutgv, Nullch, TRUE);
1107             XPUSHTARG;
1108         }
1109         else {
1110             XPUSHs(sv_2mortal(newRV((SV*)egv)));
1111         }
1112     }
1113
1114     if (newdefout) {
1115         if (!GvIO(newdefout))
1116             gv_IOadd(newdefout);
1117         setdefout(newdefout);
1118     }
1119
1120     RETURN;
1121 }
1122
1123 PP(pp_getc)
1124 {
1125     dSP; dTARGET;
1126     GV *gv;
1127     MAGIC *mg;
1128
1129     if (MAXARG == 0)
1130         gv = PL_stdingv;
1131     else
1132         gv = (GV*)POPs;
1133
1134     if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
1135         I32 gimme = GIMME_V;
1136         PUSHMARK(SP);
1137         XPUSHs(SvTIED_obj((SV*)gv, mg));
1138         PUTBACK;
1139         ENTER;
1140         call_method("GETC", gimme);
1141         LEAVE;
1142         SPAGAIN;
1143         if (gimme == G_SCALAR)
1144             SvSetMagicSV_nosteal(TARG, TOPs);
1145         RETURN;
1146     }
1147     if (!gv || do_eof(gv)) /* make sure we have fp with something */
1148         RETPUSHUNDEF;
1149     TAINT;
1150     sv_setpv(TARG, " ");
1151     *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1152     if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1153         /* Find out how many bytes the char needs */
1154         Size_t len = UTF8SKIP(SvPVX(TARG));
1155         if (len > 1) {
1156             SvGROW(TARG,len+1);
1157             len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1158             SvCUR_set(TARG,1+len);
1159         }
1160         SvUTF8_on(TARG);
1161     }
1162     PUSHTARG;
1163     RETURN;
1164 }
1165
1166 PP(pp_read)
1167 {
1168     return pp_sysread();
1169 }
1170
1171 STATIC OP *
1172 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1173 {
1174     register PERL_CONTEXT *cx;
1175     I32 gimme = GIMME_V;
1176     AV* padlist = CvPADLIST(cv);
1177     SV** svp = AvARRAY(padlist);
1178
1179     ENTER;
1180     SAVETMPS;
1181
1182     push_return(retop);
1183     PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1184     PUSHFORMAT(cx);
1185     SAVEVPTR(PL_curpad);
1186     PL_curpad = AvARRAY((AV*)svp[1]);
1187
1188     setdefout(gv);          /* locally select filehandle so $% et al work */
1189     return CvSTART(cv);
1190 }
1191
1192 PP(pp_enterwrite)
1193 {
1194     dSP;
1195     register GV *gv;
1196     register IO *io;
1197     GV *fgv;
1198     CV *cv;
1199
1200     if (MAXARG == 0)
1201         gv = PL_defoutgv;
1202     else {
1203         gv = (GV*)POPs;
1204         if (!gv)
1205             gv = PL_defoutgv;
1206     }
1207     EXTEND(SP, 1);
1208     io = GvIO(gv);
1209     if (!io) {
1210         RETPUSHNO;
1211     }
1212     if (IoFMT_GV(io))
1213         fgv = IoFMT_GV(io);
1214     else
1215         fgv = gv;
1216
1217     cv = GvFORM(fgv);
1218     if (!cv) {
1219         char *name = NULL;
1220         if (fgv) {
1221             SV *tmpsv = sv_newmortal();
1222             gv_efullname4(tmpsv, fgv, Nullch, FALSE);
1223             name = SvPV_nolen(tmpsv);
1224         }
1225         if (name && *name)
1226             DIE(aTHX_ "Undefined format \"%s\" called", name);
1227         DIE(aTHX_ "Not a format reference");
1228     }
1229     if (CvCLONE(cv))
1230         cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1231
1232     IoFLAGS(io) &= ~IOf_DIDTOP;
1233     return doform(cv,gv,PL_op->op_next);
1234 }
1235
1236 PP(pp_leavewrite)
1237 {
1238     dSP;
1239     GV *gv = cxstack[cxstack_ix].blk_sub.gv;
1240     register IO *io = GvIOp(gv);
1241     PerlIO *ofp = IoOFP(io);
1242     PerlIO *fp;
1243     SV **newsp;
1244     I32 gimme;
1245     register PERL_CONTEXT *cx;
1246
1247     DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1248           (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1249     if (!io || !ofp)
1250         goto forget_top;
1251     if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1252         PL_formtarget != PL_toptarget)
1253     {
1254         GV *fgv;
1255         CV *cv;
1256         if (!IoTOP_GV(io)) {
1257             GV *topgv;
1258             SV *topname;
1259
1260             if (!IoTOP_NAME(io)) {
1261                 if (!IoFMT_NAME(io))
1262                     IoFMT_NAME(io) = savepv(GvNAME(gv));
1263                 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", IoFMT_NAME(io)));
1264                 topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
1265                 if ((topgv && GvFORM(topgv)) ||
1266                   !gv_fetchpv("top",FALSE,SVt_PVFM))
1267                     IoTOP_NAME(io) = savepv(SvPVX(topname));
1268                 else
1269                     IoTOP_NAME(io) = savepv("top");
1270             }
1271             topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
1272             if (!topgv || !GvFORM(topgv)) {
1273                 IoLINES_LEFT(io) = 100000000;
1274                 goto forget_top;
1275             }
1276             IoTOP_GV(io) = topgv;
1277         }
1278         if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear.  It still doesn't fit. */
1279             I32 lines = IoLINES_LEFT(io);
1280             char *s = SvPVX(PL_formtarget);
1281             if (lines <= 0)             /* Yow, header didn't even fit!!! */
1282                 goto forget_top;
1283             while (lines-- > 0) {
1284                 s = strchr(s, '\n');
1285                 if (!s)
1286                     break;
1287                 s++;
1288             }
1289             if (s) {
1290                 STRLEN save = SvCUR(PL_formtarget);
1291                 SvCUR_set(PL_formtarget, s - SvPVX(PL_formtarget));
1292                 do_print(PL_formtarget, ofp);
1293                 SvCUR_set(PL_formtarget, save);
1294                 sv_chop(PL_formtarget, s);
1295                 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1296             }
1297         }
1298         if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1299             do_print(PL_formfeed, ofp);
1300         IoLINES_LEFT(io) = IoPAGE_LEN(io);
1301         IoPAGE(io)++;
1302         PL_formtarget = PL_toptarget;
1303         IoFLAGS(io) |= IOf_DIDTOP;
1304         fgv = IoTOP_GV(io);
1305         if (!fgv)
1306             DIE(aTHX_ "bad top format reference");
1307         cv = GvFORM(fgv);
1308         {
1309             char *name = NULL;
1310             if (!cv) {
1311                 SV *sv = sv_newmortal();
1312                 gv_efullname4(sv, fgv, Nullch, FALSE);
1313                 name = SvPV_nolen(sv);
1314             }
1315             if (name && *name)
1316                 DIE(aTHX_ "Undefined top format \"%s\" called",name);
1317             /* why no:
1318             else
1319                 DIE(aTHX_ "Undefined top format called");
1320             ?*/
1321         }
1322         if (CvCLONE(cv))
1323             cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1324         return doform(cv,gv,PL_op);
1325     }
1326
1327   forget_top:
1328     POPBLOCK(cx,PL_curpm);
1329     POPFORMAT(cx);
1330     LEAVE;
1331
1332     fp = IoOFP(io);
1333     if (!fp) {
1334         if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1335             if (IoIFP(io)) {
1336                 /* integrate with report_evil_fh()? */
1337                 char *name = NULL;
1338                 if (isGV(gv)) {
1339                     SV* sv = sv_newmortal();
1340                     gv_efullname4(sv, gv, Nullch, FALSE);
1341                     name = SvPV_nolen(sv);
1342                 }
1343                 if (name && *name)
1344                     Perl_warner(aTHX_ WARN_IO,
1345                                 "Filehandle %s opened only for input", name);
1346                 else
1347                     Perl_warner(aTHX_ WARN_IO,
1348                                 "Filehandle opened only for input");
1349             }
1350             else if (ckWARN(WARN_CLOSED))
1351                 report_evil_fh(gv, io, PL_op->op_type);
1352         }
1353         PUSHs(&PL_sv_no);
1354     }
1355     else {
1356         if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1357             if (ckWARN(WARN_IO))
1358                 Perl_warner(aTHX_ WARN_IO, "page overflow");
1359         }
1360         if (!do_print(PL_formtarget, fp))
1361             PUSHs(&PL_sv_no);
1362         else {
1363             FmLINES(PL_formtarget) = 0;
1364             SvCUR_set(PL_formtarget, 0);
1365             *SvEND(PL_formtarget) = '\0';
1366             if (IoFLAGS(io) & IOf_FLUSH)
1367                 (void)PerlIO_flush(fp);
1368             PUSHs(&PL_sv_yes);
1369         }
1370     }
1371     /* bad_ofp: */
1372     PL_formtarget = PL_bodytarget;
1373     PUTBACK;
1374     return pop_return();
1375 }
1376
1377 PP(pp_prtf)
1378 {
1379     dSP; dMARK; dORIGMARK;
1380     GV *gv;
1381     IO *io;
1382     PerlIO *fp;
1383     SV *sv;
1384     MAGIC *mg;
1385
1386     if (PL_op->op_flags & OPf_STACKED)
1387         gv = (GV*)*++MARK;
1388     else
1389         gv = PL_defoutgv;
1390
1391     if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
1392         if (MARK == ORIGMARK) {
1393             MEXTEND(SP, 1);
1394             ++MARK;
1395             Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1396             ++SP;
1397         }
1398         PUSHMARK(MARK - 1);
1399         *MARK = SvTIED_obj((SV*)gv, mg);
1400         PUTBACK;
1401         ENTER;
1402         call_method("PRINTF", G_SCALAR);
1403         LEAVE;
1404         SPAGAIN;
1405         MARK = ORIGMARK + 1;
1406         *MARK = *SP;
1407         SP = MARK;
1408         RETURN;
1409     }
1410
1411     sv = NEWSV(0,0);
1412     if (!(io = GvIO(gv))) {
1413         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1414             report_evil_fh(gv, io, PL_op->op_type);
1415         SETERRNO(EBADF,RMS$_IFI);
1416         goto just_say_no;
1417     }
1418     else if (!(fp = IoOFP(io))) {
1419         if (ckWARN2(WARN_CLOSED,WARN_IO))  {
1420             /* integrate with report_evil_fh()? */
1421             if (IoIFP(io)) {
1422                 char *name = NULL;
1423                 if (isGV(gv)) {
1424                     gv_efullname4(sv, gv, Nullch, FALSE);
1425                     name = SvPV_nolen(sv);
1426                 }
1427                 if (name && *name)
1428                     Perl_warner(aTHX_ WARN_IO,
1429                                 "Filehandle %s opened only for input", name);
1430                 else
1431                     Perl_warner(aTHX_ WARN_IO,
1432                                 "Filehandle opened only for input");
1433             }
1434             else if (ckWARN(WARN_CLOSED))
1435                 report_evil_fh(gv, io, PL_op->op_type);
1436         }
1437         SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
1438         goto just_say_no;
1439     }
1440     else {
1441         do_sprintf(sv, SP - MARK, MARK + 1);
1442         if (!do_print(sv, fp))
1443             goto just_say_no;
1444
1445         if (IoFLAGS(io) & IOf_FLUSH)
1446             if (PerlIO_flush(fp) == EOF)
1447                 goto just_say_no;
1448     }
1449     SvREFCNT_dec(sv);
1450     SP = ORIGMARK;
1451     PUSHs(&PL_sv_yes);
1452     RETURN;
1453
1454   just_say_no:
1455     SvREFCNT_dec(sv);
1456     SP = ORIGMARK;
1457     PUSHs(&PL_sv_undef);
1458     RETURN;
1459 }
1460
1461 PP(pp_sysopen)
1462 {
1463     dSP;
1464     GV *gv;
1465     SV *sv;
1466     char *tmps;
1467     STRLEN len;
1468     int mode, perm;
1469
1470     if (MAXARG > 3)
1471         perm = POPi;
1472     else
1473         perm = 0666;
1474     mode = POPi;
1475     sv = POPs;
1476     gv = (GV *)POPs;
1477
1478     /* Need TIEHANDLE method ? */
1479
1480     tmps = SvPV(sv, len);
1481     if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
1482         IoLINES(GvIOp(gv)) = 0;
1483         PUSHs(&PL_sv_yes);
1484     }
1485     else {
1486         PUSHs(&PL_sv_undef);
1487     }
1488     RETURN;
1489 }
1490
1491 PP(pp_sysread)
1492 {
1493     dSP; dMARK; dORIGMARK; dTARGET;
1494     int offset;
1495     GV *gv;
1496     IO *io;
1497     char *buffer;
1498     SSize_t length;
1499     SSize_t count;
1500     Sock_size_t bufsize;
1501     SV *bufsv;
1502     STRLEN blen;
1503     MAGIC *mg;
1504     int fp_utf8;
1505     Size_t got = 0;
1506     Size_t wanted;
1507
1508     gv = (GV*)*++MARK;
1509     if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) &&
1510         (mg = SvTIED_mg((SV*)gv, 'q')))
1511     {
1512         SV *sv;
1513
1514         PUSHMARK(MARK-1);
1515         *MARK = SvTIED_obj((SV*)gv, mg);
1516         ENTER;
1517         call_method("READ", G_SCALAR);
1518         LEAVE;
1519         SPAGAIN;
1520         sv = POPs;
1521         SP = ORIGMARK;
1522         PUSHs(sv);
1523         RETURN;
1524     }
1525
1526     if (!gv)
1527         goto say_undef;
1528     bufsv = *++MARK;
1529     if (! SvOK(bufsv))
1530         sv_setpvn(bufsv, "", 0);
1531     length = SvIVx(*++MARK);
1532     SETERRNO(0,0);
1533     if (MARK < SP)
1534         offset = SvIVx(*++MARK);
1535     else
1536         offset = 0;
1537     io = GvIO(gv);
1538     if (!io || !IoIFP(io))
1539         goto say_undef;
1540     if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTE) {
1541         buffer = SvPVutf8_force(bufsv, blen);
1542         /* UTF8 may not have been set if they are all low bytes */
1543         SvUTF8_on(bufsv);
1544     }
1545     else {
1546         buffer = SvPV_force(bufsv, blen);
1547     }
1548     if (length < 0)
1549         DIE(aTHX_ "Negative length");
1550     wanted = length;
1551
1552 #ifdef HAS_SOCKET
1553     if (PL_op->op_type == OP_RECV) {
1554         char namebuf[MAXPATHLEN];
1555 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE)
1556         bufsize = sizeof (struct sockaddr_in);
1557 #else
1558         bufsize = sizeof namebuf;
1559 #endif
1560 #ifdef OS2      /* At least Warp3+IAK: only the first byte of bufsize set */
1561         if (bufsize >= 256)
1562             bufsize = 255;
1563 #endif
1564         buffer = SvGROW(bufsv, length+1);
1565         /* 'offset' means 'flags' here */
1566         count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1567                           (struct sockaddr *)namebuf, &bufsize);
1568         if (count < 0)
1569             RETPUSHUNDEF;
1570         SvCUR_set(bufsv, count);
1571         *SvEND(bufsv) = '\0';
1572         (void)SvPOK_only(bufsv);
1573         if (fp_utf8)
1574             SvUTF8_on(bufsv);
1575         SvSETMAGIC(bufsv);
1576         /* This should not be marked tainted if the fp is marked clean */
1577         if (!(IoFLAGS(io) & IOf_UNTAINT))
1578             SvTAINTED_on(bufsv);
1579         SP = ORIGMARK;
1580 #if defined(I_SYS_UN) && defined(__linux__)
1581         /* Linux returns the sum of actual pathname string length and the
1582            size of the other members of sockaddr_un members. It should
1583            return sizeof(struct sockaddr_un). */
1584         if (((struct sockaddr *)namebuf)->sa_family == AF_UNIX)
1585             bufsize = sizeof(struct sockaddr_un);
1586 #endif
1587         sv_setpvn(TARG, namebuf, bufsize);
1588         PUSHs(TARG);
1589         RETURN;
1590     }
1591 #else
1592     if (PL_op->op_type == OP_RECV)
1593         DIE(aTHX_ PL_no_sock_func, "recv");
1594 #endif
1595     if (DO_UTF8(bufsv)) {
1596         /* offset adjust in characters not bytes */
1597         blen = sv_len_utf8(bufsv);
1598     }
1599     if (offset < 0) {
1600         if (-offset > blen)
1601             DIE(aTHX_ "Offset outside string");
1602         offset += blen;
1603     }
1604     if (DO_UTF8(bufsv)) {
1605         /* convert offset-as-chars to offset-as-bytes */
1606         offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1607     }
1608  more_bytes:
1609     bufsize = SvCUR(bufsv);
1610     buffer  = SvGROW(bufsv, length+offset+1);
1611     if (offset > bufsize) { /* Zero any newly allocated space */
1612         Zero(buffer+bufsize, offset-bufsize, char);
1613     }
1614     buffer = buffer + offset;
1615
1616     if (PL_op->op_type == OP_SYSREAD) {
1617 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1618         if (IoTYPE(io) == IoTYPE_SOCKET) {
1619             count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1620                                    buffer, length, 0);
1621         }
1622         else
1623 #endif
1624         {
1625             count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1626                                   buffer, length);
1627         }
1628     }
1629     else
1630 #ifdef HAS_SOCKET__bad_code_maybe
1631     if (IoTYPE(io) == IoTYPE_SOCKET) {
1632         char namebuf[MAXPATHLEN];
1633 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1634         bufsize = sizeof (struct sockaddr_in);
1635 #else
1636         bufsize = sizeof namebuf;
1637 #endif
1638         count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1639                           (struct sockaddr *)namebuf, &bufsize);
1640     }
1641     else
1642 #endif
1643     {
1644         count = PerlIO_read(IoIFP(io), buffer, length);
1645         /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1646         if (count == 0 && PerlIO_error(IoIFP(io)))
1647             count = -1;
1648     }
1649     if (count < 0) {
1650         if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1651         {
1652             /* integrate with report_evil_fh()? */
1653             char *name = NULL;
1654             if (isGV(gv)) {
1655                 SV* sv = sv_newmortal();
1656                 gv_efullname4(sv, gv, Nullch, FALSE);
1657                 name = SvPV_nolen(sv);
1658             }
1659             if (name && *name)
1660                 Perl_warner(aTHX_ WARN_IO,
1661                             "Filehandle %s opened only for output", name);
1662             else
1663                 Perl_warner(aTHX_ WARN_IO,
1664                             "Filehandle opened only for output");
1665         }
1666         goto say_undef;
1667     }
1668     SvCUR_set(bufsv, count+(buffer - SvPVX(bufsv)));
1669     *SvEND(bufsv) = '\0';
1670     (void)SvPOK_only(bufsv);
1671     if (fp_utf8 && !IN_BYTE) {
1672         /* Look at utf8 we got back and count the characters */
1673         char *bend = buffer + count;
1674         while (buffer < bend) {
1675             STRLEN skip = UTF8SKIP(buffer);
1676             if (buffer+skip > bend) {
1677                 /* partial character - try for rest of it */
1678                 length = skip - (bend-buffer);
1679                 offset = bend - SvPVX(bufsv);
1680                 goto more_bytes;
1681             }
1682             else {
1683                 got++;
1684                 buffer += skip;
1685             }
1686         }
1687         /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1688            provided amount read (count) was what was requested (length)
1689          */
1690         if (got < wanted && count == length) {
1691             length = (wanted-got);
1692             offset = bend - SvPVX(bufsv);
1693             goto more_bytes;
1694         }
1695         /* return value is character count */
1696         count = got;
1697         SvUTF8_on(bufsv);
1698     }
1699     SvSETMAGIC(bufsv);
1700     /* This should not be marked tainted if the fp is marked clean */
1701     if (!(IoFLAGS(io) & IOf_UNTAINT))
1702         SvTAINTED_on(bufsv);
1703     SP = ORIGMARK;
1704     PUSHi(count);
1705     RETURN;
1706
1707   say_undef:
1708     SP = ORIGMARK;
1709     RETPUSHUNDEF;
1710 }
1711
1712 PP(pp_syswrite)
1713 {
1714     dSP;
1715     int items = (SP - PL_stack_base) - TOPMARK;
1716     if (items == 2) {
1717         SV *sv;
1718         EXTEND(SP, 1);
1719         sv = sv_2mortal(newSViv(sv_len(*SP)));
1720         PUSHs(sv);
1721         PUTBACK;
1722     }
1723     return pp_send();
1724 }
1725
1726 PP(pp_send)
1727 {
1728     dSP; dMARK; dORIGMARK; dTARGET;
1729     GV *gv;
1730     IO *io;
1731     SV *bufsv;
1732     char *buffer;
1733     Size_t length;
1734     SSize_t retval;
1735     STRLEN blen;
1736     MAGIC *mg;
1737
1738     gv = (GV*)*++MARK;
1739     if (PL_op->op_type == OP_SYSWRITE && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1740         SV *sv;
1741
1742         PUSHMARK(MARK-1);
1743         *MARK = SvTIED_obj((SV*)gv, mg);
1744         ENTER;
1745         call_method("WRITE", G_SCALAR);
1746         LEAVE;
1747         SPAGAIN;
1748         sv = POPs;
1749         SP = ORIGMARK;
1750         PUSHs(sv);
1751         RETURN;
1752     }
1753     if (!gv)
1754         goto say_undef;
1755     bufsv = *++MARK;
1756 #if Size_t_size > IVSIZE
1757     length = (Size_t)SvNVx(*++MARK);
1758 #else
1759     length = (Size_t)SvIVx(*++MARK);
1760 #endif
1761     if ((SSize_t)length < 0)
1762         DIE(aTHX_ "Negative length");
1763     SETERRNO(0,0);
1764     io = GvIO(gv);
1765     if (!io || !IoIFP(io)) {
1766         retval = -1;
1767         if (ckWARN(WARN_CLOSED))
1768             report_evil_fh(gv, io, PL_op->op_type);
1769         goto say_undef;
1770     }
1771
1772     if (PerlIO_isutf8(IoIFP(io))) {
1773         buffer = SvPVutf8(bufsv, blen);
1774     }
1775     else {
1776         if (DO_UTF8(bufsv))
1777             sv_utf8_downgrade(bufsv, FALSE);
1778         buffer = SvPV(bufsv, blen);
1779     }
1780
1781     if (PL_op->op_type == OP_SYSWRITE) {
1782         IV offset;
1783         if (DO_UTF8(bufsv)) {
1784             /* length and offset are in chars */
1785             blen   = sv_len_utf8(bufsv);
1786         }
1787         if (MARK < SP) {
1788             offset = SvIVx(*++MARK);
1789             if (offset < 0) {
1790                 if (-offset > blen)
1791                     DIE(aTHX_ "Offset outside string");
1792                 offset += blen;
1793             } else if (offset >= blen && blen > 0)
1794                 DIE(aTHX_ "Offset outside string");
1795         } else
1796             offset = 0;
1797         if (length > blen - offset)
1798             length = blen - offset;
1799         if (DO_UTF8(bufsv)) {
1800             buffer = (char*)utf8_hop((U8 *)buffer, offset);
1801             length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1802         }
1803         else {
1804             buffer = buffer+offset;
1805         }
1806 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1807         if (IoTYPE(io) == IoTYPE_SOCKET) {
1808             retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1809                                    buffer, length, 0);
1810         }
1811         else
1812 #endif
1813         {
1814             /* See the note at doio.c:do_print about filesize limits. --jhi */
1815             retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1816                                    buffer, length);
1817         }
1818     }
1819 #ifdef HAS_SOCKET
1820     else if (SP > MARK) {
1821         char *sockbuf;
1822         STRLEN mlen;
1823         sockbuf = SvPVx(*++MARK, mlen);
1824         /* length is really flags */
1825         retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1826                                  length, (struct sockaddr *)sockbuf, mlen);
1827     }
1828     else
1829         /* length is really flags */
1830         retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
1831 #else
1832     else
1833         DIE(aTHX_ PL_no_sock_func, "send");
1834 #endif
1835     if (retval < 0)
1836         goto say_undef;
1837     SP = ORIGMARK;
1838 #if Size_t_size > IVSIZE
1839     PUSHn(retval);
1840 #else
1841     PUSHi(retval);
1842 #endif
1843     RETURN;
1844
1845   say_undef:
1846     SP = ORIGMARK;
1847     RETPUSHUNDEF;
1848 }
1849
1850 PP(pp_recv)
1851 {
1852     return pp_sysread();
1853 }
1854
1855 PP(pp_eof)
1856 {
1857     dSP;
1858     GV *gv;
1859     MAGIC *mg;
1860
1861     if (MAXARG == 0) {
1862         if (PL_op->op_flags & OPf_SPECIAL) {    /* eof() */
1863             IO *io;
1864             gv = PL_last_in_gv = PL_argvgv;
1865             io = GvIO(gv);
1866             if (io && !IoIFP(io)) {
1867                 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
1868                     IoLINES(io) = 0;
1869                     IoFLAGS(io) &= ~IOf_START;
1870                     do_open(gv, "-", 1, FALSE, O_RDONLY, 0, Nullfp);
1871                     sv_setpvn(GvSV(gv), "-", 1);
1872                     SvSETMAGIC(GvSV(gv));
1873                 }
1874                 else if (!nextargv(gv))
1875                     RETPUSHYES;
1876             }
1877         }
1878         else
1879             gv = PL_last_in_gv;                 /* eof */
1880     }
1881     else
1882         gv = PL_last_in_gv = (GV*)POPs;         /* eof(FH) */
1883
1884     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1885         PUSHMARK(SP);
1886         XPUSHs(SvTIED_obj((SV*)gv, mg));
1887         PUTBACK;
1888         ENTER;
1889         call_method("EOF", G_SCALAR);
1890         LEAVE;
1891         SPAGAIN;
1892         RETURN;
1893     }
1894
1895     PUSHs(boolSV(!gv || do_eof(gv)));
1896     RETURN;
1897 }
1898
1899 PP(pp_tell)
1900 {
1901     dSP; dTARGET;
1902     GV *gv;
1903     MAGIC *mg;
1904
1905     if (MAXARG == 0)
1906         gv = PL_last_in_gv;
1907     else
1908         gv = PL_last_in_gv = (GV*)POPs;
1909
1910     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1911         PUSHMARK(SP);
1912         XPUSHs(SvTIED_obj((SV*)gv, mg));
1913         PUTBACK;
1914         ENTER;
1915         call_method("TELL", G_SCALAR);
1916         LEAVE;
1917         SPAGAIN;
1918         RETURN;
1919     }
1920
1921 #if LSEEKSIZE > IVSIZE
1922     PUSHn( do_tell(gv) );
1923 #else
1924     PUSHi( do_tell(gv) );
1925 #endif
1926     RETURN;
1927 }
1928
1929 PP(pp_seek)
1930 {
1931     return pp_sysseek();
1932 }
1933
1934 PP(pp_sysseek)
1935 {
1936     dSP;
1937     GV *gv;
1938     int whence = POPi;
1939 #if LSEEKSIZE > IVSIZE
1940     Off_t offset = (Off_t)SvNVx(POPs);
1941 #else
1942     Off_t offset = (Off_t)SvIVx(POPs);
1943 #endif
1944     MAGIC *mg;
1945
1946     gv = PL_last_in_gv = (GV*)POPs;
1947
1948     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1949         PUSHMARK(SP);
1950         XPUSHs(SvTIED_obj((SV*)gv, mg));
1951 #if LSEEKSIZE > IVSIZE
1952         XPUSHs(sv_2mortal(newSVnv((NV) offset)));
1953 #else
1954         XPUSHs(sv_2mortal(newSViv(offset)));
1955 #endif
1956         XPUSHs(sv_2mortal(newSViv(whence)));
1957         PUTBACK;
1958         ENTER;
1959         call_method("SEEK", G_SCALAR);
1960         LEAVE;
1961         SPAGAIN;
1962         RETURN;
1963     }
1964
1965     if (PL_op->op_type == OP_SEEK)
1966         PUSHs(boolSV(do_seek(gv, offset, whence)));
1967     else {
1968         Off_t sought = do_sysseek(gv, offset, whence);
1969         if (sought < 0)
1970             PUSHs(&PL_sv_undef);
1971         else {
1972             SV* sv = sought ?
1973 #if LSEEKSIZE > IVSIZE
1974                 newSVnv((NV)sought)
1975 #else
1976                 newSViv(sought)
1977 #endif
1978                 : newSVpvn(zero_but_true, ZBTLEN);
1979             PUSHs(sv_2mortal(sv));
1980         }
1981     }
1982     RETURN;
1983 }
1984
1985 PP(pp_truncate)
1986 {
1987     dSP;
1988     /* There seems to be no consensus on the length type of truncate()
1989      * and ftruncate(), both off_t and size_t have supporters. In
1990      * general one would think that when using large files, off_t is
1991      * at least as wide as size_t, so using an off_t should be okay. */
1992     /* XXX Configure probe for the length type of *truncate() needed XXX */
1993     Off_t len;
1994     int result = 1;
1995     GV *tmpgv;
1996     STRLEN n_a;
1997
1998 #if Size_t_size > IVSIZE
1999     len = (Off_t)POPn;
2000 #else
2001     len = (Off_t)POPi;
2002 #endif
2003     /* Checking for length < 0 is problematic as the type might or
2004      * might not be signed: if it is not, clever compilers will moan. */
2005     /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2006     SETERRNO(0,0);
2007 #if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
2008     if (PL_op->op_flags & OPf_SPECIAL) {
2009         tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
2010     do_ftruncate:
2011         TAINT_PROPER("truncate");
2012         if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)))
2013             result = 0;
2014         else {
2015             PerlIO_flush(IoIFP(GvIOp(tmpgv)));
2016 #ifdef HAS_TRUNCATE
2017             if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
2018 #else
2019             if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
2020 #endif
2021                 result = 0;
2022         }
2023     }
2024     else {
2025         SV *sv = POPs;
2026         char *name;
2027         STRLEN n_a;
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             if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
2047                 result = 0;
2048             else {
2049                 if (my_chsize(tmpfd, len) < 0)
2050                     result = 0;
2051                 PerlLIO_close(tmpfd);
2052             }
2053         }
2054 #endif
2055     }
2056
2057     if (result)
2058         RETPUSHYES;
2059     if (!errno)
2060         SETERRNO(EBADF,RMS$_IFI);
2061     RETPUSHUNDEF;
2062 #else
2063     DIE(aTHX_ "truncate not implemented");
2064 #endif
2065 }
2066
2067 PP(pp_fcntl)
2068 {
2069     return pp_ioctl();
2070 }
2071
2072 PP(pp_ioctl)
2073 {
2074     dSP; dTARGET;
2075     SV *argsv = POPs;
2076     unsigned int func = U_I(POPn);
2077     int optype = PL_op->op_type;
2078     char *s;
2079     IV retval;
2080     GV *gv = (GV*)POPs;
2081     IO *io = gv ? GvIOn(gv) : 0;
2082
2083     if (!io || !argsv || !IoIFP(io)) {
2084         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2085             report_evil_fh(gv, io, PL_op->op_type);
2086         SETERRNO(EBADF,RMS$_IFI);       /* well, sort of... */
2087         RETPUSHUNDEF;
2088     }
2089
2090     if (SvPOK(argsv) || !SvNIOK(argsv)) {
2091         STRLEN len;
2092         STRLEN need;
2093         s = SvPV_force(argsv, len);
2094         need = IOCPARM_LEN(func);
2095         if (len < need) {
2096             s = Sv_Grow(argsv, need + 1);
2097             SvCUR_set(argsv, need);
2098         }
2099
2100         s[SvCUR(argsv)] = 17;   /* a little sanity check here */
2101     }
2102     else {
2103         retval = SvIV(argsv);
2104         s = INT2PTR(char*,retval);              /* ouch */
2105     }
2106
2107     TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
2108
2109     if (optype == OP_IOCTL)
2110 #ifdef HAS_IOCTL
2111         retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2112 #else
2113         DIE(aTHX_ "ioctl is not implemented");
2114 #endif
2115     else
2116 #ifdef HAS_FCNTL
2117 #if defined(OS2) && defined(__EMX__)
2118         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2119 #else
2120         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2121 #endif
2122 #else
2123         DIE(aTHX_ "fcntl is not implemented");
2124 #endif
2125
2126     if (SvPOK(argsv)) {
2127         if (s[SvCUR(argsv)] != 17)
2128             DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2129                 PL_op_name[optype]);
2130         s[SvCUR(argsv)] = 0;            /* put our null back */
2131         SvSETMAGIC(argsv);              /* Assume it has changed */
2132     }
2133
2134     if (retval == -1)
2135         RETPUSHUNDEF;
2136     if (retval != 0) {
2137         PUSHi(retval);
2138     }
2139     else {
2140         PUSHp(zero_but_true, ZBTLEN);
2141     }
2142     RETURN;
2143 }
2144
2145 PP(pp_flock)
2146 {
2147     dSP; dTARGET;
2148     I32 value;
2149     int argtype;
2150     GV *gv;
2151     IO *io = NULL;
2152     PerlIO *fp;
2153
2154 #ifdef FLOCK
2155     argtype = POPi;
2156     if (MAXARG == 0)
2157         gv = PL_last_in_gv;
2158     else
2159         gv = (GV*)POPs;
2160     if (gv && (io = GvIO(gv)))
2161         fp = IoIFP(io);
2162     else {
2163         fp = Nullfp;
2164         io = NULL;
2165     }
2166     if (fp) {
2167         (void)PerlIO_flush(fp);
2168         value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2169     }
2170     else {
2171         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2172             report_evil_fh(gv, io, PL_op->op_type);
2173         value = 0;
2174         SETERRNO(EBADF,RMS$_IFI);
2175     }
2176     PUSHi(value);
2177     RETURN;
2178 #else
2179     DIE(aTHX_ PL_no_func, "flock()");
2180 #endif
2181 }
2182
2183 /* Sockets. */
2184
2185 PP(pp_socket)
2186 {
2187     dSP;
2188 #ifdef HAS_SOCKET
2189     GV *gv;
2190     register IO *io;
2191     int protocol = POPi;
2192     int type = POPi;
2193     int domain = POPi;
2194     int fd;
2195
2196     gv = (GV*)POPs;
2197     io = gv ? GvIOn(gv) : NULL;
2198
2199     if (!gv || !io) {
2200         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2201             report_evil_fh(gv, io, PL_op->op_type);
2202         if (IoIFP(io))
2203             do_close(gv, FALSE);
2204         SETERRNO(EBADF,LIB$_INVARG);
2205         RETPUSHUNDEF;
2206     }
2207
2208     if (IoIFP(io))
2209         do_close(gv, FALSE);
2210
2211     TAINT_PROPER("socket");
2212     fd = PerlSock_socket(domain, type, protocol);
2213     if (fd < 0)
2214         RETPUSHUNDEF;
2215     IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
2216     IoOFP(io) = PerlIO_fdopen(fd, "w");
2217     IoTYPE(io) = IoTYPE_SOCKET;
2218     if (!IoIFP(io) || !IoOFP(io)) {
2219         if (IoIFP(io)) PerlIO_close(IoIFP(io));
2220         if (IoOFP(io)) PerlIO_close(IoOFP(io));
2221         if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2222         RETPUSHUNDEF;
2223     }
2224 #if defined(HAS_FCNTL) && defined(F_SETFD)
2225     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2226 #endif
2227
2228 #ifdef EPOC
2229     setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2230 #endif
2231
2232     RETPUSHYES;
2233 #else
2234     DIE(aTHX_ PL_no_sock_func, "socket");
2235 #endif
2236 }
2237
2238 PP(pp_sockpair)
2239 {
2240     dSP;
2241 #ifdef HAS_SOCKETPAIR
2242     GV *gv1;
2243     GV *gv2;
2244     register IO *io1;
2245     register IO *io2;
2246     int protocol = POPi;
2247     int type = POPi;
2248     int domain = POPi;
2249     int fd[2];
2250
2251     gv2 = (GV*)POPs;
2252     gv1 = (GV*)POPs;
2253     io1 = gv1 ? GvIOn(gv1) : NULL;
2254     io2 = gv2 ? GvIOn(gv2) : NULL;
2255     if (!gv1 || !gv2 || !io1 || !io2) {
2256         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2257             if (!gv1 || !io1)
2258                 report_evil_fh(gv1, io1, PL_op->op_type);
2259             if (!gv2 || !io2)
2260                 report_evil_fh(gv1, io2, PL_op->op_type);
2261         }
2262         if (IoIFP(io1))
2263             do_close(gv1, FALSE);
2264         if (IoIFP(io2))
2265             do_close(gv2, FALSE);
2266         RETPUSHUNDEF;
2267     }
2268
2269     if (IoIFP(io1))
2270         do_close(gv1, FALSE);
2271     if (IoIFP(io2))
2272         do_close(gv2, FALSE);
2273
2274     TAINT_PROPER("socketpair");
2275     if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2276         RETPUSHUNDEF;
2277     IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
2278     IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
2279     IoTYPE(io1) = IoTYPE_SOCKET;
2280     IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
2281     IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
2282     IoTYPE(io2) = IoTYPE_SOCKET;
2283     if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2284         if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2285         if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2286         if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2287         if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2288         if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2289         if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2290         RETPUSHUNDEF;
2291     }
2292 #if defined(HAS_FCNTL) && defined(F_SETFD)
2293     fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);   /* ensure close-on-exec */
2294     fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);   /* ensure close-on-exec */
2295 #endif
2296
2297     RETPUSHYES;
2298 #else
2299     DIE(aTHX_ PL_no_sock_func, "socketpair");
2300 #endif
2301 }
2302
2303 PP(pp_bind)
2304 {
2305     dSP;
2306 #ifdef HAS_SOCKET
2307 #ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
2308     extern GETPRIVMODE();
2309     extern GETUSERMODE();
2310 #endif
2311     SV *addrsv = POPs;
2312     char *addr;
2313     GV *gv = (GV*)POPs;
2314     register IO *io = GvIOn(gv);
2315     STRLEN len;
2316     int bind_ok = 0;
2317 #ifdef MPE
2318     int mpeprivmode = 0;
2319 #endif
2320
2321     if (!io || !IoIFP(io))
2322         goto nuts;
2323
2324     addr = SvPV(addrsv, len);
2325     TAINT_PROPER("bind");
2326 #ifdef MPE /* Deal with MPE bind() peculiarities */
2327     if (((struct sockaddr *)addr)->sa_family == AF_INET) {
2328         /* The address *MUST* stupidly be zero. */
2329         ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
2330         /* PRIV mode is required to bind() to ports < 1024. */
2331         if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
2332             ((struct sockaddr_in *)addr)->sin_port > 0) {
2333             GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
2334             mpeprivmode = 1;
2335         }
2336     }
2337 #endif /* MPE */
2338     if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
2339                       (struct sockaddr *)addr, len) >= 0)
2340         bind_ok = 1;
2341
2342 #ifdef MPE /* Switch back to USER mode */
2343     if (mpeprivmode)
2344         GETUSERMODE();
2345 #endif /* MPE */
2346
2347     if (bind_ok)
2348         RETPUSHYES;
2349     else
2350         RETPUSHUNDEF;
2351
2352 nuts:
2353     if (ckWARN(WARN_CLOSED))
2354         report_evil_fh(gv, io, PL_op->op_type);
2355     SETERRNO(EBADF,SS$_IVCHAN);
2356     RETPUSHUNDEF;
2357 #else
2358     DIE(aTHX_ PL_no_sock_func, "bind");
2359 #endif
2360 }
2361
2362 PP(pp_connect)
2363 {
2364     dSP;
2365 #ifdef HAS_SOCKET
2366     SV *addrsv = POPs;
2367     char *addr;
2368     GV *gv = (GV*)POPs;
2369     register IO *io = GvIOn(gv);
2370     STRLEN len;
2371
2372     if (!io || !IoIFP(io))
2373         goto nuts;
2374
2375     addr = SvPV(addrsv, len);
2376     TAINT_PROPER("connect");
2377     if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2378         RETPUSHYES;
2379     else
2380         RETPUSHUNDEF;
2381
2382 nuts:
2383     if (ckWARN(WARN_CLOSED))
2384         report_evil_fh(gv, io, PL_op->op_type);
2385     SETERRNO(EBADF,SS$_IVCHAN);
2386     RETPUSHUNDEF;
2387 #else
2388     DIE(aTHX_ PL_no_sock_func, "connect");
2389 #endif
2390 }
2391
2392 PP(pp_listen)
2393 {
2394     dSP;
2395 #ifdef HAS_SOCKET
2396     int backlog = POPi;
2397     GV *gv = (GV*)POPs;
2398     register IO *io = gv ? GvIOn(gv) : NULL;
2399
2400     if (!gv || !io || !IoIFP(io))
2401         goto nuts;
2402
2403     if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2404         RETPUSHYES;
2405     else
2406         RETPUSHUNDEF;
2407
2408 nuts:
2409     if (ckWARN(WARN_CLOSED))
2410         report_evil_fh(gv, io, PL_op->op_type);
2411     SETERRNO(EBADF,SS$_IVCHAN);
2412     RETPUSHUNDEF;
2413 #else
2414     DIE(aTHX_ PL_no_sock_func, "listen");
2415 #endif
2416 }
2417
2418 PP(pp_accept)
2419 {
2420     dSP; dTARGET;
2421 #ifdef HAS_SOCKET
2422     GV *ngv;
2423     GV *ggv;
2424     register IO *nstio;
2425     register IO *gstio;
2426     struct sockaddr saddr;      /* use a struct to avoid alignment problems */
2427     Sock_size_t len = sizeof saddr;
2428     int fd;
2429
2430     ggv = (GV*)POPs;
2431     ngv = (GV*)POPs;
2432
2433     if (!ngv)
2434         goto badexit;
2435     if (!ggv)
2436         goto nuts;
2437
2438     gstio = GvIO(ggv);
2439     if (!gstio || !IoIFP(gstio))
2440         goto nuts;
2441
2442     nstio = GvIOn(ngv);
2443     if (IoIFP(nstio))
2444         do_close(ngv, FALSE);
2445
2446     fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
2447     if (fd < 0)
2448         goto badexit;
2449     IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2450     IoOFP(nstio) = PerlIO_fdopen(fd, "w");
2451     IoTYPE(nstio) = IoTYPE_SOCKET;
2452     if (!IoIFP(nstio) || !IoOFP(nstio)) {
2453         if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2454         if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2455         if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2456         goto badexit;
2457     }
2458 #if defined(HAS_FCNTL) && defined(F_SETFD)
2459     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2460 #endif
2461
2462 #ifdef EPOC
2463     len = sizeof saddr;          /* EPOC somehow truncates info */
2464     setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2465 #endif
2466
2467 #if defined(I_SYS_UN) && defined(__linux__)
2468     /* see the comment in pp_sysread */
2469     if (saddr.sa_family == AF_UNIX)
2470         len = sizeof(struct sockaddr_un);
2471 #endif
2472
2473     PUSHp((char *)&saddr, len);
2474     RETURN;
2475
2476 nuts:
2477     if (ckWARN(WARN_CLOSED))
2478         report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2479     SETERRNO(EBADF,SS$_IVCHAN);
2480
2481 badexit:
2482     RETPUSHUNDEF;
2483
2484 #else
2485     DIE(aTHX_ PL_no_sock_func, "accept");
2486 #endif
2487 }
2488
2489 PP(pp_shutdown)
2490 {
2491     dSP; dTARGET;
2492 #ifdef HAS_SOCKET
2493     int how = POPi;
2494     GV *gv = (GV*)POPs;
2495     register IO *io = GvIOn(gv);
2496
2497     if (!io || !IoIFP(io))
2498         goto nuts;
2499
2500     PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2501     RETURN;
2502
2503 nuts:
2504     if (ckWARN(WARN_CLOSED))
2505         report_evil_fh(gv, io, PL_op->op_type);
2506     SETERRNO(EBADF,SS$_IVCHAN);
2507     RETPUSHUNDEF;
2508 #else
2509     DIE(aTHX_ PL_no_sock_func, "shutdown");
2510 #endif
2511 }
2512
2513 PP(pp_gsockopt)
2514 {
2515 #ifdef HAS_SOCKET
2516     return pp_ssockopt();
2517 #else
2518     DIE(aTHX_ PL_no_sock_func, "getsockopt");
2519 #endif
2520 }
2521
2522 PP(pp_ssockopt)
2523 {
2524     dSP;
2525 #ifdef HAS_SOCKET
2526     int optype = PL_op->op_type;
2527     SV *sv;
2528     int fd;
2529     unsigned int optname;
2530     unsigned int lvl;
2531     GV *gv;
2532     register IO *io;
2533     Sock_size_t len;
2534
2535     if (optype == OP_GSOCKOPT)
2536         sv = sv_2mortal(NEWSV(22, 257));
2537     else
2538         sv = POPs;
2539     optname = (unsigned int) POPi;
2540     lvl = (unsigned int) POPi;
2541
2542     gv = (GV*)POPs;
2543     io = GvIOn(gv);
2544     if (!io || !IoIFP(io))
2545         goto nuts;
2546
2547     fd = PerlIO_fileno(IoIFP(io));
2548     switch (optype) {
2549     case OP_GSOCKOPT:
2550         SvGROW(sv, 257);
2551         (void)SvPOK_only(sv);
2552         SvCUR_set(sv,256);
2553         *SvEND(sv) ='\0';
2554         len = SvCUR(sv);
2555         if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2556             goto nuts2;
2557         SvCUR_set(sv, len);
2558         *SvEND(sv) ='\0';
2559         PUSHs(sv);
2560         break;
2561     case OP_SSOCKOPT: {
2562             char *buf;
2563             int aint;
2564             if (SvPOKp(sv)) {
2565                 STRLEN l;
2566                 buf = SvPV(sv, l);
2567                 len = l;
2568             }
2569             else {
2570                 aint = (int)SvIV(sv);
2571                 buf = (char*)&aint;
2572                 len = sizeof(int);
2573             }
2574             if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2575                 goto nuts2;
2576             PUSHs(&PL_sv_yes);
2577         }
2578         break;
2579     }
2580     RETURN;
2581
2582 nuts:
2583     if (ckWARN(WARN_CLOSED))
2584         report_evil_fh(gv, io, optype);
2585     SETERRNO(EBADF,SS$_IVCHAN);
2586 nuts2:
2587     RETPUSHUNDEF;
2588
2589 #else
2590     DIE(aTHX_ PL_no_sock_func, "setsockopt");
2591 #endif
2592 }
2593
2594 PP(pp_getsockname)
2595 {
2596 #ifdef HAS_SOCKET
2597     return pp_getpeername();
2598 #else
2599     DIE(aTHX_ PL_no_sock_func, "getsockname");
2600 #endif
2601 }
2602
2603 PP(pp_getpeername)
2604 {
2605     dSP;
2606 #ifdef HAS_SOCKET
2607     int optype = PL_op->op_type;
2608     SV *sv;
2609     int fd;
2610     GV *gv = (GV*)POPs;
2611     register IO *io = GvIOn(gv);
2612     Sock_size_t len;
2613
2614     if (!io || !IoIFP(io))
2615         goto nuts;
2616
2617     sv = sv_2mortal(NEWSV(22, 257));
2618     (void)SvPOK_only(sv);
2619     len = 256;
2620     SvCUR_set(sv, len);
2621     *SvEND(sv) ='\0';
2622     fd = PerlIO_fileno(IoIFP(io));
2623     switch (optype) {
2624     case OP_GETSOCKNAME:
2625         if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2626             goto nuts2;
2627         break;
2628     case OP_GETPEERNAME:
2629         if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2630             goto nuts2;
2631 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2632         {
2633             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";
2634             /* If the call succeeded, make sure we don't have a zeroed port/addr */
2635             if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2636                 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2637                         sizeof(u_short) + sizeof(struct in_addr))) {
2638                 goto nuts2;
2639             }
2640         }
2641 #endif
2642         break;
2643     }
2644 #ifdef BOGUS_GETNAME_RETURN
2645     /* Interactive Unix, getpeername() and getsockname()
2646       does not return valid namelen */
2647     if (len == BOGUS_GETNAME_RETURN)
2648         len = sizeof(struct sockaddr);
2649 #endif
2650 #if defined(I_SYS_UN) && defined(__linux__)
2651     /* see the comment in pp_sysread */
2652     if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_UNIX)
2653         len = sizeof(struct sockaddr_un);
2654 #endif
2655     SvCUR_set(sv, len);
2656     *SvEND(sv) ='\0';
2657     PUSHs(sv);
2658     RETURN;
2659
2660 nuts:
2661     if (ckWARN(WARN_CLOSED))
2662         report_evil_fh(gv, io, optype);
2663     SETERRNO(EBADF,SS$_IVCHAN);
2664 nuts2:
2665     RETPUSHUNDEF;
2666
2667 #else
2668     DIE(aTHX_ PL_no_sock_func, "getpeername");
2669 #endif
2670 }
2671
2672 /* Stat calls. */
2673
2674 PP(pp_lstat)
2675 {
2676     return pp_stat();
2677 }
2678
2679 PP(pp_stat)
2680 {
2681     dSP;
2682     GV *gv;
2683     I32 gimme;
2684     I32 max = 13;
2685     STRLEN n_a;
2686
2687     if (PL_op->op_flags & OPf_REF) {
2688         gv = cGVOP_gv;
2689         if (PL_op->op_type == OP_LSTAT) {
2690             if (PL_laststype != OP_LSTAT)
2691                 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2692             if (ckWARN(WARN_IO) && gv != PL_defgv)
2693                 Perl_warner(aTHX_ WARN_IO,
2694                         "lstat() on filehandle %s", GvENAME(gv));
2695                 /* Perl_my_lstat (-l) croak's on filehandle, why warn here? */
2696         }
2697
2698       do_fstat:
2699         if (gv != PL_defgv) {
2700             PL_laststype = OP_STAT;
2701             PL_statgv = gv;
2702             sv_setpv(PL_statname, "");
2703             PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv))
2704                 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
2705         }
2706         if (PL_laststatval < 0) {
2707             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2708                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2709             max = 0;
2710         }
2711     }
2712     else {
2713         SV* sv = POPs;
2714         if (SvTYPE(sv) == SVt_PVGV) {
2715             gv = (GV*)sv;
2716             goto do_fstat;
2717         }
2718         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2719             gv = (GV*)SvRV(sv);
2720             goto do_fstat;
2721         }
2722         sv_setpv(PL_statname, SvPV(sv,n_a));
2723         PL_statgv = Nullgv;
2724 #ifdef HAS_LSTAT
2725         PL_laststype = PL_op->op_type;
2726         if (PL_op->op_type == OP_LSTAT)
2727             PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
2728         else
2729 #endif
2730             PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
2731         if (PL_laststatval < 0) {
2732             if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
2733                 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
2734             max = 0;
2735         }
2736     }
2737
2738     gimme = GIMME_V;
2739     if (gimme != G_ARRAY) {
2740         if (gimme != G_VOID)
2741             XPUSHs(boolSV(max));
2742         RETURN;
2743     }
2744     if (max) {
2745         EXTEND(SP, max);
2746         EXTEND_MORTAL(max);
2747         PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2748         PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2749         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2750         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
2751 #if Uid_t_size > IVSIZE
2752         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2753 #else
2754 #   if Uid_t_sign <= 0
2755         PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2756 #   else
2757         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2758 #   endif
2759 #endif
2760 #if Gid_t_size > IVSIZE
2761         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2762 #else
2763 #   if Gid_t_sign <= 0
2764         PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2765 #   else
2766         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2767 #   endif
2768 #endif
2769 #ifdef USE_STAT_RDEV
2770         PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2771 #else
2772         PUSHs(sv_2mortal(newSVpvn("", 0)));
2773 #endif
2774 #if Off_t_size > IVSIZE
2775         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size)));
2776 #else
2777         PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2778 #endif
2779 #ifdef BIG_TIME
2780         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2781         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2782         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2783 #else
2784         PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2785         PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2786         PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
2787 #endif
2788 #ifdef USE_STAT_BLOCKS
2789         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2790         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
2791 #else
2792         PUSHs(sv_2mortal(newSVpvn("", 0)));
2793         PUSHs(sv_2mortal(newSVpvn("", 0)));
2794 #endif
2795     }
2796     RETURN;
2797 }
2798
2799 PP(pp_ftrread)
2800 {
2801     I32 result;
2802     dSP;
2803 #if defined(HAS_ACCESS) && defined(R_OK)
2804     STRLEN n_a;
2805     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2806         result = access(TOPpx, R_OK);
2807         if (result == 0)
2808             RETPUSHYES;
2809         if (result < 0)
2810             RETPUSHUNDEF;
2811         RETPUSHNO;
2812     }
2813     else
2814         result = my_stat();
2815 #else
2816     result = my_stat();
2817 #endif
2818     SPAGAIN;
2819     if (result < 0)
2820         RETPUSHUNDEF;
2821     if (cando(S_IRUSR, 0, &PL_statcache))
2822         RETPUSHYES;
2823     RETPUSHNO;
2824 }
2825
2826 PP(pp_ftrwrite)
2827 {
2828     I32 result;
2829     dSP;
2830 #if defined(HAS_ACCESS) && defined(W_OK)
2831     STRLEN n_a;
2832     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2833         result = access(TOPpx, W_OK);
2834         if (result == 0)
2835             RETPUSHYES;
2836         if (result < 0)
2837             RETPUSHUNDEF;
2838         RETPUSHNO;
2839     }
2840     else
2841         result = my_stat();
2842 #else
2843     result = my_stat();
2844 #endif
2845     SPAGAIN;
2846     if (result < 0)
2847         RETPUSHUNDEF;
2848     if (cando(S_IWUSR, 0, &PL_statcache))
2849         RETPUSHYES;
2850     RETPUSHNO;
2851 }
2852
2853 PP(pp_ftrexec)
2854 {
2855     I32 result;
2856     dSP;
2857 #if defined(HAS_ACCESS) && defined(X_OK)
2858     STRLEN n_a;
2859     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2860         result = access(TOPpx, X_OK);
2861         if (result == 0)
2862             RETPUSHYES;
2863         if (result < 0)
2864             RETPUSHUNDEF;
2865         RETPUSHNO;
2866     }
2867     else
2868         result = my_stat();
2869 #else
2870     result = my_stat();
2871 #endif
2872     SPAGAIN;
2873     if (result < 0)
2874         RETPUSHUNDEF;
2875     if (cando(S_IXUSR, 0, &PL_statcache))
2876         RETPUSHYES;
2877     RETPUSHNO;
2878 }
2879
2880 PP(pp_fteread)
2881 {
2882     I32 result;
2883     dSP;
2884 #ifdef PERL_EFF_ACCESS_R_OK
2885     STRLEN n_a;
2886     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2887         result = PERL_EFF_ACCESS_R_OK(TOPpx);
2888         if (result == 0)
2889             RETPUSHYES;
2890         if (result < 0)
2891             RETPUSHUNDEF;
2892         RETPUSHNO;
2893     }
2894     else
2895         result = my_stat();
2896 #else
2897     result = my_stat();
2898 #endif
2899     SPAGAIN;
2900     if (result < 0)
2901         RETPUSHUNDEF;
2902     if (cando(S_IRUSR, 1, &PL_statcache))
2903         RETPUSHYES;
2904     RETPUSHNO;
2905 }
2906
2907 PP(pp_ftewrite)
2908 {
2909     I32 result;
2910     dSP;
2911 #ifdef PERL_EFF_ACCESS_W_OK
2912     STRLEN n_a;
2913     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2914         result = PERL_EFF_ACCESS_W_OK(TOPpx);
2915         if (result == 0)
2916             RETPUSHYES;
2917         if (result < 0)
2918             RETPUSHUNDEF;
2919         RETPUSHNO;
2920     }
2921     else
2922         result = my_stat();
2923 #else
2924     result = my_stat();
2925 #endif
2926     SPAGAIN;
2927     if (result < 0)
2928         RETPUSHUNDEF;
2929     if (cando(S_IWUSR, 1, &PL_statcache))
2930         RETPUSHYES;
2931     RETPUSHNO;
2932 }
2933
2934 PP(pp_fteexec)
2935 {
2936     I32 result;
2937     dSP;
2938 #ifdef PERL_EFF_ACCESS_X_OK
2939     STRLEN n_a;
2940     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2941         result = PERL_EFF_ACCESS_X_OK(TOPpx);
2942         if (result == 0)
2943             RETPUSHYES;
2944         if (result < 0)
2945             RETPUSHUNDEF;
2946         RETPUSHNO;
2947     }
2948     else
2949         result = my_stat();
2950 #else
2951     result = my_stat();
2952 #endif
2953     SPAGAIN;
2954     if (result < 0)
2955         RETPUSHUNDEF;
2956     if (cando(S_IXUSR, 1, &PL_statcache))
2957         RETPUSHYES;
2958     RETPUSHNO;
2959 }
2960
2961 PP(pp_ftis)
2962 {
2963     I32 result = my_stat();
2964     dSP;
2965     if (result < 0)
2966         RETPUSHUNDEF;
2967     RETPUSHYES;
2968 }
2969
2970 PP(pp_fteowned)
2971 {
2972     return pp_ftrowned();
2973 }
2974
2975 PP(pp_ftrowned)
2976 {
2977     I32 result = my_stat();
2978     dSP;
2979     if (result < 0)
2980         RETPUSHUNDEF;
2981     if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
2982                                 PL_euid : PL_uid) )
2983         RETPUSHYES;
2984     RETPUSHNO;
2985 }
2986
2987 PP(pp_ftzero)
2988 {
2989     I32 result = my_stat();
2990     dSP;
2991     if (result < 0)
2992         RETPUSHUNDEF;
2993     if (PL_statcache.st_size == 0)
2994         RETPUSHYES;
2995     RETPUSHNO;
2996 }
2997
2998 PP(pp_ftsize)
2999 {
3000     I32 result = my_stat();
3001     dSP; dTARGET;
3002     if (result < 0)
3003         RETPUSHUNDEF;
3004 #if Off_t_size > IVSIZE
3005     PUSHn(PL_statcache.st_size);
3006 #else
3007     PUSHi(PL_statcache.st_size);
3008 #endif
3009     RETURN;
3010 }
3011
3012 PP(pp_ftmtime)
3013 {
3014     I32 result = my_stat();
3015     dSP; dTARGET;
3016     if (result < 0)
3017         RETPUSHUNDEF;
3018     PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3019     RETURN;
3020 }
3021
3022 PP(pp_ftatime)
3023 {
3024     I32 result = my_stat();
3025     dSP; dTARGET;
3026     if (result < 0)
3027         RETPUSHUNDEF;
3028     PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
3029     RETURN;
3030 }
3031
3032 PP(pp_ftctime)
3033 {
3034     I32 result = my_stat();
3035     dSP; dTARGET;
3036     if (result < 0)
3037         RETPUSHUNDEF;
3038     PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3039     RETURN;
3040 }
3041
3042 PP(pp_ftsock)
3043 {
3044     I32 result = my_stat();
3045     dSP;
3046     if (result < 0)
3047         RETPUSHUNDEF;
3048     if (S_ISSOCK(PL_statcache.st_mode))
3049         RETPUSHYES;
3050     RETPUSHNO;
3051 }
3052
3053 PP(pp_ftchr)
3054 {
3055     I32 result = my_stat();
3056     dSP;
3057     if (result < 0)
3058         RETPUSHUNDEF;
3059     if (S_ISCHR(PL_statcache.st_mode))
3060         RETPUSHYES;
3061     RETPUSHNO;
3062 }
3063
3064 PP(pp_ftblk)
3065 {
3066     I32 result = my_stat();
3067     dSP;
3068     if (result < 0)
3069         RETPUSHUNDEF;
3070     if (S_ISBLK(PL_statcache.st_mode))
3071         RETPUSHYES;
3072     RETPUSHNO;
3073 }
3074
3075 PP(pp_ftfile)
3076 {
3077     I32 result = my_stat();
3078     dSP;
3079     if (result < 0)
3080         RETPUSHUNDEF;
3081     if (S_ISREG(PL_statcache.st_mode))
3082         RETPUSHYES;
3083     RETPUSHNO;
3084 }
3085
3086 PP(pp_ftdir)
3087 {
3088     I32 result = my_stat();
3089     dSP;
3090     if (result < 0)
3091         RETPUSHUNDEF;
3092     if (S_ISDIR(PL_statcache.st_mode))
3093         RETPUSHYES;
3094     RETPUSHNO;
3095 }
3096
3097 PP(pp_ftpipe)
3098 {
3099     I32 result = my_stat();
3100     dSP;
3101     if (result < 0)
3102         RETPUSHUNDEF;
3103     if (S_ISFIFO(PL_statcache.st_mode))
3104         RETPUSHYES;
3105     RETPUSHNO;
3106 }
3107
3108 PP(pp_ftlink)
3109 {
3110     I32 result = my_lstat();
3111     dSP;
3112     if (result < 0)
3113         RETPUSHUNDEF;
3114     if (S_ISLNK(PL_statcache.st_mode))
3115         RETPUSHYES;
3116     RETPUSHNO;
3117 }
3118
3119 PP(pp_ftsuid)
3120 {
3121     dSP;
3122 #ifdef S_ISUID
3123     I32 result = my_stat();
3124     SPAGAIN;
3125     if (result < 0)
3126         RETPUSHUNDEF;
3127     if (PL_statcache.st_mode & S_ISUID)
3128         RETPUSHYES;
3129 #endif
3130     RETPUSHNO;
3131 }
3132
3133 PP(pp_ftsgid)
3134 {
3135     dSP;
3136 #ifdef S_ISGID
3137     I32 result = my_stat();
3138     SPAGAIN;
3139     if (result < 0)
3140         RETPUSHUNDEF;
3141     if (PL_statcache.st_mode & S_ISGID)
3142         RETPUSHYES;
3143 #endif
3144     RETPUSHNO;
3145 }
3146
3147 PP(pp_ftsvtx)
3148 {
3149     dSP;
3150 #ifdef S_ISVTX
3151     I32 result = my_stat();
3152     SPAGAIN;
3153     if (result < 0)
3154         RETPUSHUNDEF;
3155     if (PL_statcache.st_mode & S_ISVTX)
3156         RETPUSHYES;
3157 #endif
3158     RETPUSHNO;
3159 }
3160
3161 PP(pp_fttty)
3162 {
3163     dSP;
3164     int fd;
3165     GV *gv;
3166     char *tmps = Nullch;
3167     STRLEN n_a;
3168
3169     if (PL_op->op_flags & OPf_REF)
3170         gv = cGVOP_gv;
3171     else if (isGV(TOPs))
3172         gv = (GV*)POPs;
3173     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3174         gv = (GV*)SvRV(POPs);
3175     else
3176         gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
3177
3178     if (GvIO(gv) && IoIFP(GvIOp(gv)))
3179         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3180     else if (tmps && isDIGIT(*tmps))
3181         fd = atoi(tmps);
3182     else
3183         RETPUSHUNDEF;
3184     if (PerlLIO_isatty(fd))
3185         RETPUSHYES;
3186     RETPUSHNO;
3187 }
3188
3189 #if defined(atarist) /* this will work with atariST. Configure will
3190                         make guesses for other systems. */
3191 # define FILE_base(f) ((f)->_base)
3192 # define FILE_ptr(f) ((f)->_ptr)
3193 # define FILE_cnt(f) ((f)->_cnt)
3194 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3195 #endif
3196
3197 PP(pp_fttext)
3198 {
3199     dSP;
3200     I32 i;
3201     I32 len;
3202     I32 odd = 0;
3203     STDCHAR tbuf[512];
3204     register STDCHAR *s;
3205     register IO *io;
3206     register SV *sv;
3207     GV *gv;
3208     STRLEN n_a;
3209     PerlIO *fp;
3210
3211     if (PL_op->op_flags & OPf_REF)
3212         gv = cGVOP_gv;
3213     else if (isGV(TOPs))
3214         gv = (GV*)POPs;
3215     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3216         gv = (GV*)SvRV(POPs);
3217     else
3218         gv = Nullgv;
3219
3220     if (gv) {
3221         EXTEND(SP, 1);
3222         if (gv == PL_defgv) {
3223             if (PL_statgv)
3224                 io = GvIO(PL_statgv);
3225             else {
3226                 sv = PL_statname;
3227                 goto really_filename;
3228             }
3229         }
3230         else {
3231             PL_statgv = gv;
3232             PL_laststatval = -1;
3233             sv_setpv(PL_statname, "");
3234             io = GvIO(PL_statgv);
3235         }
3236         if (io && IoIFP(io)) {
3237             if (! PerlIO_has_base(IoIFP(io)))
3238                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3239             PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3240             if (PL_laststatval < 0)
3241                 RETPUSHUNDEF;
3242             if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3243                 if (PL_op->op_type == OP_FTTEXT)
3244                     RETPUSHNO;
3245                 else
3246                     RETPUSHYES;
3247             }
3248             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3249                 i = PerlIO_getc(IoIFP(io));
3250                 if (i != EOF)
3251                     (void)PerlIO_ungetc(IoIFP(io),i);
3252             }
3253             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3254                 RETPUSHYES;
3255             len = PerlIO_get_bufsiz(IoIFP(io));
3256             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3257             /* sfio can have large buffers - limit to 512 */
3258             if (len > 512)
3259                 len = 512;
3260         }
3261         else {
3262             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3263                 gv = cGVOP_gv;
3264                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3265             }
3266             SETERRNO(EBADF,RMS$_IFI);
3267             RETPUSHUNDEF;
3268         }
3269     }
3270     else {
3271         sv = POPs;
3272       really_filename:
3273         PL_statgv = Nullgv;
3274         PL_laststatval = -1;
3275         sv_setpv(PL_statname, SvPV(sv, n_a));
3276         if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
3277             if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
3278                 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
3279             RETPUSHUNDEF;
3280         }
3281         PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3282         if (PL_laststatval < 0) {
3283             (void)PerlIO_close(fp);
3284             RETPUSHUNDEF;
3285         }
3286         PerlIO_binmode(aTHX_ fp, '<', O_BINARY, Nullch);
3287         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3288         (void)PerlIO_close(fp);
3289         if (len <= 0) {
3290             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3291                 RETPUSHNO;              /* special case NFS directories */
3292             RETPUSHYES;         /* null file is anything */
3293         }
3294         s = tbuf;
3295     }
3296
3297     /* now scan s to look for textiness */
3298     /*   XXX ASCII dependent code */
3299
3300 #if defined(DOSISH) || defined(USEMYBINMODE)
3301     /* ignore trailing ^Z on short files */
3302     if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3303         --len;
3304 #endif
3305
3306     for (i = 0; i < len; i++, s++) {
3307         if (!*s) {                      /* null never allowed in text */
3308             odd += len;
3309             break;
3310         }
3311 #ifdef EBCDIC
3312         else if (!(isPRINT(*s) || isSPACE(*s)))
3313             odd++;
3314 #else
3315         else if (*s & 128) {
3316 #ifdef USE_LOCALE
3317             if ((PL_op->op_private & OPpLOCALE) && isALPHA_LC(*s))
3318                 continue;
3319 #endif
3320             /* utf8 characters don't count as odd */
3321             if (UTF8_IS_START(*s)) {
3322                 int ulen = UTF8SKIP(s);
3323                 if (ulen < len - i) {
3324                     int j;
3325                     for (j = 1; j < ulen; j++) {
3326                         if (!UTF8_IS_CONTINUATION(s[j]))
3327                             goto not_utf8;
3328                     }
3329                     --ulen;     /* loop does extra increment */
3330                     s += ulen;
3331                     i += ulen;
3332                     continue;
3333                 }
3334             }
3335           not_utf8:
3336             odd++;
3337         }
3338         else if (*s < 32 &&
3339           *s != '\n' && *s != '\r' && *s != '\b' &&
3340           *s != '\t' && *s != '\f' && *s != 27)
3341             odd++;
3342 #endif
3343     }
3344
3345     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3346         RETPUSHNO;
3347     else
3348         RETPUSHYES;
3349 }
3350
3351 PP(pp_ftbinary)
3352 {
3353     return pp_fttext();
3354 }
3355
3356 /* File calls. */
3357
3358 PP(pp_chdir)
3359 {
3360     dSP; dTARGET;
3361     char *tmps;
3362     SV **svp;
3363     STRLEN n_a;
3364
3365     if (MAXARG < 1)
3366         tmps = Nullch;
3367     else
3368         tmps = POPpx;
3369     if (!tmps || !*tmps) {
3370         svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
3371         if (svp)
3372             tmps = SvPV(*svp, n_a);
3373     }
3374     if (!tmps || !*tmps) {
3375         svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
3376         if (svp)
3377             tmps = SvPV(*svp, n_a);
3378     }
3379 #ifdef VMS
3380     if (!tmps || !*tmps) {
3381        svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
3382        if (svp)
3383            tmps = SvPV(*svp, n_a);
3384     }
3385 #endif
3386     TAINT_PROPER("chdir");
3387     PUSHi( PerlDir_chdir(tmps) >= 0 );
3388 #ifdef VMS
3389     /* Clear the DEFAULT element of ENV so we'll get the new value
3390      * in the future. */
3391     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3392 #endif
3393     RETURN;
3394 }
3395
3396 PP(pp_chown)
3397 {
3398     dSP; dMARK; dTARGET;
3399     I32 value;
3400 #ifdef HAS_CHOWN
3401     value = (I32)apply(PL_op->op_type, MARK, SP);
3402     SP = MARK;
3403     PUSHi(value);
3404     RETURN;
3405 #else
3406     DIE(aTHX_ PL_no_func, "Unsupported function chown");
3407 #endif
3408 }
3409
3410 PP(pp_chroot)
3411 {
3412     dSP; dTARGET;
3413     char *tmps;
3414 #ifdef HAS_CHROOT
3415     STRLEN n_a;
3416     tmps = POPpx;
3417     TAINT_PROPER("chroot");
3418     PUSHi( chroot(tmps) >= 0 );
3419     RETURN;
3420 #else
3421     DIE(aTHX_ PL_no_func, "chroot");
3422 #endif
3423 }
3424
3425 PP(pp_unlink)
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_chmod)
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_utime)
3446 {
3447     dSP; dMARK; dTARGET;
3448     I32 value;
3449     value = (I32)apply(PL_op->op_type, MARK, SP);
3450     SP = MARK;
3451     PUSHi(value);
3452     RETURN;
3453 }
3454
3455 PP(pp_rename)
3456 {
3457     dSP; dTARGET;
3458     int anum;
3459     STRLEN n_a;
3460
3461     char *tmps2 = POPpx;
3462     char *tmps = SvPV(TOPs, n_a);
3463     TAINT_PROPER("rename");
3464 #ifdef HAS_RENAME
3465     anum = PerlLIO_rename(tmps, tmps2);
3466 #else
3467     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3468         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3469             anum = 1;
3470         else {
3471             if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3472                 (void)UNLINK(tmps2);
3473             if (!(anum = link(tmps, tmps2)))
3474                 anum = UNLINK(tmps);
3475         }
3476     }
3477 #endif
3478     SETi( anum >= 0 );
3479     RETURN;
3480 }
3481
3482 PP(pp_link)
3483 {
3484     dSP; dTARGET;
3485 #ifdef HAS_LINK
3486     STRLEN n_a;
3487     char *tmps2 = POPpx;
3488     char *tmps = SvPV(TOPs, n_a);
3489     TAINT_PROPER("link");
3490     SETi( PerlLIO_link(tmps, tmps2) >= 0 );
3491 #else
3492     DIE(aTHX_ PL_no_func, "Unsupported function link");
3493 #endif
3494     RETURN;
3495 }
3496
3497 PP(pp_symlink)
3498 {
3499     dSP; dTARGET;
3500 #ifdef HAS_SYMLINK
3501     STRLEN n_a;
3502     char *tmps2 = POPpx;
3503     char *tmps = SvPV(TOPs, n_a);
3504     TAINT_PROPER("symlink");
3505     SETi( symlink(tmps, tmps2) >= 0 );
3506     RETURN;
3507 #else
3508     DIE(aTHX_ PL_no_func, "symlink");
3509 #endif
3510 }
3511
3512 PP(pp_readlink)
3513 {
3514     dSP; dTARGET;
3515 #ifdef HAS_SYMLINK
3516     char *tmps;
3517     char buf[MAXPATHLEN];
3518     int len;
3519     STRLEN n_a;
3520
3521 #ifndef INCOMPLETE_TAINTS
3522     TAINT;
3523 #endif
3524     tmps = POPpx;
3525     len = readlink(tmps, buf, sizeof buf);
3526     EXTEND(SP, 1);
3527     if (len < 0)
3528         RETPUSHUNDEF;
3529     PUSHp(buf, len);
3530     RETURN;
3531 #else
3532     EXTEND(SP, 1);
3533     RETSETUNDEF;                /* just pretend it's a normal file */
3534 #endif
3535 }
3536
3537 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3538 STATIC int
3539 S_dooneliner(pTHX_ char *cmd, char *filename)
3540 {
3541     char *save_filename = filename;
3542     char *cmdline;
3543     char *s;
3544     PerlIO *myfp;
3545     int anum = 1;
3546
3547     New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3548     strcpy(cmdline, cmd);
3549     strcat(cmdline, " ");
3550     for (s = cmdline + strlen(cmdline); *filename; ) {
3551         *s++ = '\\';
3552         *s++ = *filename++;
3553     }
3554     strcpy(s, " 2>&1");
3555     myfp = PerlProc_popen(cmdline, "r");
3556     Safefree(cmdline);
3557
3558     if (myfp) {
3559         SV *tmpsv = sv_newmortal();
3560         /* Need to save/restore 'PL_rs' ?? */
3561         s = sv_gets(tmpsv, myfp, 0);
3562         (void)PerlProc_pclose(myfp);
3563         if (s != Nullch) {
3564             int e;
3565             for (e = 1;
3566 #ifdef HAS_SYS_ERRLIST
3567                  e <= sys_nerr
3568 #endif
3569                  ; e++)
3570             {
3571                 /* you don't see this */
3572                 char *errmsg =
3573 #ifdef HAS_SYS_ERRLIST
3574                     sys_errlist[e]
3575 #else
3576                     strerror(e)
3577 #endif
3578                     ;
3579                 if (!errmsg)
3580                     break;
3581                 if (instr(s, errmsg)) {
3582                     SETERRNO(e,0);
3583                     return 0;
3584                 }
3585             }
3586             SETERRNO(0,0);
3587 #ifndef EACCES
3588 #define EACCES EPERM
3589 #endif
3590             if (instr(s, "cannot make"))
3591                 SETERRNO(EEXIST,RMS$_FEX);
3592             else if (instr(s, "existing file"))
3593                 SETERRNO(EEXIST,RMS$_FEX);
3594             else if (instr(s, "ile exists"))
3595                 SETERRNO(EEXIST,RMS$_FEX);
3596             else if (instr(s, "non-exist"))
3597                 SETERRNO(ENOENT,RMS$_FNF);
3598             else if (instr(s, "does not exist"))
3599                 SETERRNO(ENOENT,RMS$_FNF);
3600             else if (instr(s, "not empty"))
3601                 SETERRNO(EBUSY,SS$_DEVOFFLINE);
3602             else if (instr(s, "cannot access"))
3603                 SETERRNO(EACCES,RMS$_PRV);
3604             else
3605                 SETERRNO(EPERM,RMS$_PRV);
3606             return 0;
3607         }
3608         else {  /* some mkdirs return no failure indication */
3609             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3610             if (PL_op->op_type == OP_RMDIR)
3611                 anum = !anum;
3612             if (anum)
3613                 SETERRNO(0,0);
3614             else
3615                 SETERRNO(EACCES,RMS$_PRV);      /* a guess */
3616         }
3617         return anum;
3618     }
3619     else
3620         return 0;
3621 }
3622 #endif
3623
3624 PP(pp_mkdir)
3625 {
3626     dSP; dTARGET;
3627     int mode;
3628 #ifndef HAS_MKDIR
3629     int oldumask;
3630 #endif
3631     STRLEN len;
3632     char *tmps;
3633     bool copy = FALSE;
3634
3635     if (MAXARG > 1)
3636         mode = POPi;
3637     else
3638         mode = 0777;
3639
3640     tmps = SvPV(TOPs, len);
3641     /* Different operating and file systems take differently to
3642      * trailing slashes.  According to POSIX 1003.1 1996 Edition
3643      * any number of trailing slashes should be allowed.
3644      * Thusly we snip them away so that even non-conforming
3645      * systems are happy. */
3646     /* We should probably do this "filtering" for all
3647      * the functions that expect (potentially) directory names:
3648      * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3649      * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3650     if (len > 1 && tmps[len-1] == '/') {
3651         while (tmps[len] == '/' && len > 1)
3652             len--;
3653         tmps = savepvn(tmps, len);
3654         copy = TRUE;
3655     }
3656
3657     TAINT_PROPER("mkdir");
3658 #ifdef HAS_MKDIR
3659     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3660 #else
3661     SETi( dooneliner("mkdir", tmps) );
3662     oldumask = PerlLIO_umask(0);
3663     PerlLIO_umask(oldumask);
3664     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3665 #endif
3666     if (copy)
3667         Safefree(tmps);
3668     RETURN;
3669 }
3670
3671 PP(pp_rmdir)
3672 {
3673     dSP; dTARGET;
3674     char *tmps;
3675     STRLEN n_a;
3676
3677     tmps = POPpx;
3678     TAINT_PROPER("rmdir");
3679 #ifdef HAS_RMDIR
3680     XPUSHi( PerlDir_rmdir(tmps) >= 0 );
3681 #else
3682     XPUSHi( dooneliner("rmdir", tmps) );
3683 #endif
3684     RETURN;
3685 }
3686
3687 /* Directory calls. */
3688
3689 PP(pp_open_dir)
3690 {
3691     dSP;
3692 #if defined(Direntry_t) && defined(HAS_READDIR)
3693     STRLEN n_a;
3694     char *dirname = POPpx;
3695     GV *gv = (GV*)POPs;
3696     register IO *io = GvIOn(gv);
3697
3698     if (!io)
3699         goto nope;
3700
3701     if (IoDIRP(io))
3702         PerlDir_close(IoDIRP(io));
3703     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3704         goto nope;
3705
3706     RETPUSHYES;
3707 nope:
3708     if (!errno)
3709         SETERRNO(EBADF,RMS$_DIR);
3710     RETPUSHUNDEF;
3711 #else
3712     DIE(aTHX_ PL_no_dir_func, "opendir");
3713 #endif
3714 }
3715
3716 PP(pp_readdir)
3717 {
3718     dSP;
3719 #if defined(Direntry_t) && defined(HAS_READDIR)
3720 #ifndef I_DIRENT
3721     Direntry_t *readdir (DIR *);
3722 #endif
3723     register Direntry_t *dp;
3724     GV *gv = (GV*)POPs;
3725     register IO *io = GvIOn(gv);
3726     SV *sv;
3727
3728     if (!io || !IoDIRP(io))
3729         goto nope;
3730
3731     if (GIMME == G_ARRAY) {
3732         /*SUPPRESS 560*/
3733         while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
3734 #ifdef DIRNAMLEN
3735             sv = newSVpvn(dp->d_name, dp->d_namlen);
3736 #else
3737             sv = newSVpv(dp->d_name, 0);
3738 #endif
3739 #ifndef INCOMPLETE_TAINTS
3740             if (!(IoFLAGS(io) & IOf_UNTAINT))
3741                 SvTAINTED_on(sv);
3742 #endif
3743             XPUSHs(sv_2mortal(sv));
3744         }
3745     }
3746     else {
3747         if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
3748             goto nope;
3749 #ifdef DIRNAMLEN
3750         sv = newSVpvn(dp->d_name, dp->d_namlen);
3751 #else
3752         sv = newSVpv(dp->d_name, 0);
3753 #endif
3754 #ifndef INCOMPLETE_TAINTS
3755         if (!(IoFLAGS(io) & IOf_UNTAINT))
3756             SvTAINTED_on(sv);
3757 #endif
3758         XPUSHs(sv_2mortal(sv));
3759     }
3760     RETURN;
3761
3762 nope:
3763     if (!errno)
3764         SETERRNO(EBADF,RMS$_ISI);
3765     if (GIMME == G_ARRAY)
3766         RETURN;
3767     else
3768         RETPUSHUNDEF;
3769 #else
3770     DIE(aTHX_ PL_no_dir_func, "readdir");
3771 #endif
3772 }
3773
3774 PP(pp_telldir)
3775 {
3776     dSP; dTARGET;
3777 #if defined(HAS_TELLDIR) || defined(telldir)
3778  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3779  /* XXX netbsd still seemed to.
3780     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3781     --JHI 1999-Feb-02 */
3782 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3783     long telldir (DIR *);
3784 # endif
3785     GV *gv = (GV*)POPs;
3786     register IO *io = GvIOn(gv);
3787
3788     if (!io || !IoDIRP(io))
3789         goto nope;
3790
3791     PUSHi( PerlDir_tell(IoDIRP(io)) );
3792     RETURN;
3793 nope:
3794     if (!errno)
3795         SETERRNO(EBADF,RMS$_ISI);
3796     RETPUSHUNDEF;
3797 #else
3798     DIE(aTHX_ PL_no_dir_func, "telldir");
3799 #endif
3800 }
3801
3802 PP(pp_seekdir)
3803 {
3804     dSP;
3805 #if defined(HAS_SEEKDIR) || defined(seekdir)
3806     long along = POPl;
3807     GV *gv = (GV*)POPs;
3808     register IO *io = GvIOn(gv);
3809
3810     if (!io || !IoDIRP(io))
3811         goto nope;
3812
3813     (void)PerlDir_seek(IoDIRP(io), along);
3814
3815     RETPUSHYES;
3816 nope:
3817     if (!errno)
3818         SETERRNO(EBADF,RMS$_ISI);
3819     RETPUSHUNDEF;
3820 #else
3821     DIE(aTHX_ PL_no_dir_func, "seekdir");
3822 #endif
3823 }
3824
3825 PP(pp_rewinddir)
3826 {
3827     dSP;
3828 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3829     GV *gv = (GV*)POPs;
3830     register IO *io = GvIOn(gv);
3831
3832     if (!io || !IoDIRP(io))
3833         goto nope;
3834
3835     (void)PerlDir_rewind(IoDIRP(io));
3836     RETPUSHYES;
3837 nope:
3838     if (!errno)
3839         SETERRNO(EBADF,RMS$_ISI);
3840     RETPUSHUNDEF;
3841 #else
3842     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3843 #endif
3844 }
3845
3846 PP(pp_closedir)
3847 {
3848     dSP;
3849 #if defined(Direntry_t) && defined(HAS_READDIR)
3850     GV *gv = (GV*)POPs;
3851     register IO *io = GvIOn(gv);
3852
3853     if (!io || !IoDIRP(io))
3854         goto nope;
3855
3856 #ifdef VOID_CLOSEDIR
3857     PerlDir_close(IoDIRP(io));
3858 #else
3859     if (PerlDir_close(IoDIRP(io)) < 0) {
3860         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3861         goto nope;
3862     }
3863 #endif
3864     IoDIRP(io) = 0;
3865
3866     RETPUSHYES;
3867 nope:
3868     if (!errno)
3869         SETERRNO(EBADF,RMS$_IFI);
3870     RETPUSHUNDEF;
3871 #else
3872     DIE(aTHX_ PL_no_dir_func, "closedir");
3873 #endif
3874 }
3875
3876 /* Process control. */
3877
3878 PP(pp_fork)
3879 {
3880 #ifdef HAS_FORK
3881     dSP; dTARGET;
3882     Pid_t childpid;
3883     GV *tmpgv;
3884
3885     EXTEND(SP, 1);
3886     PERL_FLUSHALL_FOR_CHILD;
3887     childpid = fork();
3888     if (childpid < 0)
3889         RETSETUNDEF;
3890     if (!childpid) {
3891         /*SUPPRESS 560*/
3892         if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
3893             sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3894         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3895     }
3896     PUSHi(childpid);
3897     RETURN;
3898 #else
3899 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3900     dSP; dTARGET;
3901     Pid_t childpid;
3902
3903     EXTEND(SP, 1);
3904     PERL_FLUSHALL_FOR_CHILD;
3905     childpid = PerlProc_fork();
3906     if (childpid == -1)
3907         RETSETUNDEF;
3908     PUSHi(childpid);
3909     RETURN;
3910 #  else
3911     DIE(aTHX_ PL_no_func, "Unsupported function fork");
3912 #  endif
3913 #endif
3914 }
3915
3916 PP(pp_wait)
3917 {
3918 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3919     dSP; dTARGET;
3920     Pid_t childpid;
3921     int argflags;
3922
3923     childpid = wait4pid(-1, &argflags, 0);
3924 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3925     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3926     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3927 #  else
3928     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3929 #  endif
3930     XPUSHi(childpid);
3931     RETURN;
3932 #else
3933     DIE(aTHX_ PL_no_func, "Unsupported function wait");
3934 #endif
3935 }
3936
3937 PP(pp_waitpid)
3938 {
3939 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3940     dSP; dTARGET;
3941     Pid_t childpid;
3942     int optype;
3943     int argflags;
3944
3945     optype = POPi;
3946     childpid = TOPi;
3947     childpid = wait4pid(childpid, &argflags, optype);
3948 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3949     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3950     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3951 #  else
3952     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3953 #  endif
3954     SETi(childpid);
3955     RETURN;
3956 #else
3957     DIE(aTHX_ PL_no_func, "Unsupported function waitpid");
3958 #endif
3959 }
3960
3961 PP(pp_system)
3962 {
3963     dSP; dMARK; dORIGMARK; dTARGET;
3964     I32 value;
3965     Pid_t childpid;
3966     int result;
3967     int status;
3968     Sigsave_t ihand,qhand;     /* place to save signals during system() */
3969     STRLEN n_a;
3970     I32 did_pipes = 0;
3971     int pp[2];
3972
3973     if (SP - MARK == 1) {
3974         if (PL_tainting) {
3975             char *junk = SvPV(TOPs, n_a);
3976             TAINT_ENV();
3977             TAINT_PROPER("system");
3978         }
3979     }
3980     PERL_FLUSHALL_FOR_CHILD;
3981 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) && !defined(__CYGWIN__) || defined(PERL_MICRO)
3982     if (PerlProc_pipe(pp) >= 0)
3983         did_pipes = 1;
3984     while ((childpid = vfork()) == -1) {
3985         if (errno != EAGAIN) {
3986             value = -1;
3987             SP = ORIGMARK;
3988             PUSHi(value);
3989             if (did_pipes) {
3990                 PerlLIO_close(pp[0]);
3991                 PerlLIO_close(pp[1]);
3992             }
3993             RETURN;
3994         }
3995         sleep(5);
3996     }
3997     if (childpid > 0) {
3998         if (did_pipes)
3999             PerlLIO_close(pp[1]);
4000 #ifndef PERL_MICRO
4001         rsignal_save(SIGINT, SIG_IGN, &ihand);
4002         rsignal_save(SIGQUIT, SIG_IGN, &qhand);
4003 #endif
4004         do {
4005             result = wait4pid(childpid, &status, 0);
4006         } while (result == -1 && errno == EINTR);
4007 #ifndef PERL_MICRO
4008         (void)rsignal_restore(SIGINT, &ihand);
4009         (void)rsignal_restore(SIGQUIT, &qhand);
4010 #endif
4011         STATUS_NATIVE_SET(result == -1 ? -1 : status);
4012         do_execfree();  /* free any memory child malloced on vfork */
4013         SP = ORIGMARK;
4014         if (did_pipes) {
4015             int errkid;
4016             int n = 0, n1;
4017
4018             while (n < sizeof(int)) {
4019                 n1 = PerlLIO_read(pp[0],
4020                                   (void*)(((char*)&errkid)+n),
4021                                   (sizeof(int)) - n);
4022                 if (n1 <= 0)
4023                     break;
4024                 n += n1;
4025             }
4026             PerlLIO_close(pp[0]);
4027             if (n) {                    /* Error */
4028                 if (n != sizeof(int))
4029                     DIE(aTHX_ "panic: kid popen errno read");
4030                 errno = errkid;         /* Propagate errno from kid */
4031                 STATUS_CURRENT = -1;
4032             }
4033         }
4034         PUSHi(STATUS_CURRENT);
4035         RETURN;
4036     }
4037     if (did_pipes) {
4038         PerlLIO_close(pp[0]);
4039 #if defined(HAS_FCNTL) && defined(F_SETFD)
4040         fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4041 #endif
4042     }
4043     if (PL_op->op_flags & OPf_STACKED) {
4044         SV *really = *++MARK;
4045         value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4046     }
4047     else if (SP - MARK != 1)
4048         value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
4049     else {
4050         value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
4051     }
4052     PerlProc__exit(-1);
4053 #else /* ! FORK or VMS or OS/2 */
4054     PL_statusvalue = 0;
4055     result = 0;
4056     if (PL_op->op_flags & OPf_STACKED) {
4057         SV *really = *++MARK;
4058         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4059     }
4060     else if (SP - MARK != 1)
4061         value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
4062     else {
4063         value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
4064     }
4065     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4066         result = 1;
4067     STATUS_NATIVE_SET(value);
4068     do_execfree();
4069     SP = ORIGMARK;
4070     PUSHi(result ? value : STATUS_CURRENT);
4071 #endif /* !FORK or VMS */
4072     RETURN;
4073 }
4074
4075 PP(pp_exec)
4076 {
4077     dSP; dMARK; dORIGMARK; dTARGET;
4078     I32 value;
4079     STRLEN n_a;
4080
4081     PERL_FLUSHALL_FOR_CHILD;
4082     if (PL_op->op_flags & OPf_STACKED) {
4083         SV *really = *++MARK;
4084         value = (I32)do_aexec(really, MARK, SP);
4085     }
4086     else if (SP - MARK != 1)
4087 #ifdef VMS
4088         value = (I32)vms_do_aexec(Nullsv, MARK, SP);
4089 #else
4090 #  ifdef __OPEN_VM
4091         {
4092            (void ) do_aspawn(Nullsv, MARK, SP);
4093            value = 0;
4094         }
4095 #  else
4096         value = (I32)do_aexec(Nullsv, MARK, SP);
4097 #  endif
4098 #endif
4099     else {
4100         if (PL_tainting) {
4101             char *junk = SvPV(*SP, n_a);
4102             TAINT_ENV();
4103             TAINT_PROPER("exec");
4104         }
4105 #ifdef VMS
4106         value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
4107 #else
4108 #  ifdef __OPEN_VM
4109         (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
4110         value = 0;
4111 #  else
4112         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
4113 #  endif
4114 #endif
4115     }
4116
4117 #if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4118     if (value >= 0)
4119         my_exit(value);
4120 #endif
4121
4122     SP = ORIGMARK;
4123     PUSHi(value);
4124     RETURN;
4125 }
4126
4127 PP(pp_kill)
4128 {
4129     dSP; dMARK; dTARGET;
4130     I32 value;
4131 #ifdef HAS_KILL
4132     value = (I32)apply(PL_op->op_type, MARK, SP);
4133     SP = MARK;
4134     PUSHi(value);
4135     RETURN;
4136 #else
4137     DIE(aTHX_ PL_no_func, "Unsupported function kill");
4138 #endif
4139 }
4140
4141 PP(pp_getppid)
4142 {
4143 #ifdef HAS_GETPPID
4144     dSP; dTARGET;
4145     XPUSHi( getppid() );
4146     RETURN;
4147 #else
4148     DIE(aTHX_ PL_no_func, "getppid");
4149 #endif
4150 }
4151
4152 PP(pp_getpgrp)
4153 {
4154 #ifdef HAS_GETPGRP
4155     dSP; dTARGET;
4156     Pid_t pid;
4157     Pid_t pgrp;
4158
4159     if (MAXARG < 1)
4160         pid = 0;
4161     else
4162         pid = SvIVx(POPs);
4163 #ifdef BSD_GETPGRP
4164     pgrp = (I32)BSD_GETPGRP(pid);
4165 #else
4166     if (pid != 0 && pid != PerlProc_getpid())
4167         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4168     pgrp = getpgrp();
4169 #endif
4170     XPUSHi(pgrp);
4171     RETURN;
4172 #else
4173     DIE(aTHX_ PL_no_func, "getpgrp()");
4174 #endif
4175 }
4176
4177 PP(pp_setpgrp)
4178 {
4179 #ifdef HAS_SETPGRP
4180     dSP; dTARGET;
4181     Pid_t pgrp;
4182     Pid_t pid;
4183     if (MAXARG < 2) {
4184         pgrp = 0;
4185         pid = 0;
4186     }
4187     else {
4188         pgrp = POPi;
4189         pid = TOPi;
4190     }
4191
4192     TAINT_PROPER("setpgrp");
4193 #ifdef BSD_SETPGRP
4194     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4195 #else
4196     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4197         || (pid != 0 && pid != PerlProc_getpid()))
4198     {
4199         DIE(aTHX_ "setpgrp can't take arguments");
4200     }
4201     SETi( setpgrp() >= 0 );
4202 #endif /* USE_BSDPGRP */
4203     RETURN;
4204 #else
4205     DIE(aTHX_ PL_no_func, "setpgrp()");
4206 #endif
4207 }
4208
4209 PP(pp_getpriority)
4210 {
4211     dSP; dTARGET;
4212     int which;
4213     int who;
4214 #ifdef HAS_GETPRIORITY
4215     who = POPi;
4216     which = TOPi;
4217     SETi( getpriority(which, who) );
4218     RETURN;
4219 #else
4220     DIE(aTHX_ PL_no_func, "getpriority()");
4221 #endif
4222 }
4223
4224 PP(pp_setpriority)
4225 {
4226     dSP; dTARGET;
4227     int which;
4228     int who;
4229     int niceval;
4230 #ifdef HAS_SETPRIORITY
4231     niceval = POPi;
4232     who = POPi;
4233     which = TOPi;
4234     TAINT_PROPER("setpriority");
4235     SETi( setpriority(which, who, niceval) >= 0 );
4236     RETURN;
4237 #else
4238     DIE(aTHX_ PL_no_func, "setpriority()");
4239 #endif
4240 }
4241
4242 /* Time calls. */
4243
4244 PP(pp_time)
4245 {
4246     dSP; dTARGET;
4247 #ifdef BIG_TIME
4248     XPUSHn( time(Null(Time_t*)) );
4249 #else
4250     XPUSHi( time(Null(Time_t*)) );
4251 #endif
4252     RETURN;
4253 }
4254
4255 /* XXX The POSIX name is CLK_TCK; it is to be preferred
4256    to HZ.  Probably.  For now, assume that if the system
4257    defines HZ, it does so correctly.  (Will this break
4258    on VMS?)
4259    Probably we ought to use _sysconf(_SC_CLK_TCK), if
4260    it's supported.    --AD  9/96.
4261 */
4262
4263 #ifndef HZ
4264 #  ifdef CLK_TCK
4265 #    define HZ CLK_TCK
4266 #  else
4267 #    define HZ 60
4268 #  endif
4269 #endif
4270
4271 PP(pp_tms)
4272 {
4273     dSP;
4274
4275 #ifndef HAS_TIMES
4276     DIE(aTHX_ "times not implemented");
4277 #else
4278     EXTEND(SP, 4);
4279
4280 #ifndef VMS
4281     (void)PerlProc_times(&PL_timesbuf);
4282 #else
4283     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4284                                                    /* struct tms, though same data   */
4285                                                    /* is returned.                   */
4286 #endif
4287
4288     PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
4289     if (GIMME == G_ARRAY) {
4290         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4291         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4292         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
4293     }
4294     RETURN;
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     dSP; dTARGET;
4359     int anum;
4360 #ifdef HAS_ALARM
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, "Unsupported function 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     dSP;
4533 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
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     dSP;
4642 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
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) U_L(POPn);
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     dSP;
4730 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
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     dSP;
4813 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
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     dSP;
4903 #ifdef HAS_SETHOSTENT
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     dSP;
4914 #ifdef HAS_SETNETENT
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     dSP;
4925 #ifdef HAS_SETPROTOENT
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     dSP;
4936 #ifdef HAS_SETSERVENT
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     dSP;
4947 #ifdef HAS_ENDHOSTENT
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     dSP;
4959 #ifdef HAS_ENDNETENT
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     dSP;
4971 #ifdef HAS_ENDPROTOENT
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     dSP;
4983 #ifdef HAS_ENDSERVENT
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     dSP;
5013 #ifdef HAS_PASSWD
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     dSP;
5227 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5228     setpwent();
5229     RETPUSHYES;
5230 #else
5231     DIE(aTHX_ PL_no_func, "setpwent");
5232 #endif
5233 }
5234
5235 PP(pp_epwent)
5236 {
5237     dSP;
5238 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
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     dSP;
5267 #ifdef HAS_GROUP
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     dSP;
5326 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5327     setgrent();
5328     RETPUSHYES;
5329 #else
5330     DIE(aTHX_ PL_no_func, "setgrent");
5331 #endif
5332 }
5333
5334 PP(pp_egrent)
5335 {
5336     dSP;
5337 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5338     endgrent();
5339     RETPUSHYES;
5340 #else
5341     DIE(aTHX_ PL_no_func, "endgrent");
5342 #endif
5343 }
5344
5345 PP(pp_getlogin)
5346 {
5347     dSP; dTARGET;
5348 #ifdef HAS_GETLOGIN
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 */