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(io))
2270         do_close(gv, FALSE);
2271
2272     TAINT_PROPER("socketpair");
2273     if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2274         RETPUSHUNDEF;
2275     IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
2276     IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
2277     IoTYPE(io1) = IoTYPE_SOCKET;
2278     IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
2279     IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
2280     IoTYPE(io2) = IoTYPE_SOCKET;
2281     if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2282         if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2283         if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2284         if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2285         if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2286         if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2287         if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2288         RETPUSHUNDEF;
2289     }
2290 #if defined(HAS_FCNTL) && defined(F_SETFD)
2291     fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);   /* ensure close-on-exec */
2292     fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);   /* ensure close-on-exec */
2293 #endif
2294
2295     RETPUSHYES;
2296 #else
2297     DIE(aTHX_ PL_no_sock_func, "socketpair");
2298 #endif
2299 }
2300
2301 PP(pp_bind)
2302 {
2303     dSP;
2304 #ifdef HAS_SOCKET
2305 #ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
2306     extern GETPRIVMODE();
2307     extern GETUSERMODE();
2308 #endif
2309     SV *addrsv = POPs;
2310     char *addr;
2311     GV *gv = (GV*)POPs;
2312     register IO *io = GvIOn(gv);
2313     STRLEN len;
2314     int bind_ok = 0;
2315 #ifdef MPE
2316     int mpeprivmode = 0;
2317 #endif
2318
2319     if (!io || !IoIFP(io))
2320         goto nuts;
2321
2322     addr = SvPV(addrsv, len);
2323     TAINT_PROPER("bind");
2324 #ifdef MPE /* Deal with MPE bind() peculiarities */
2325     if (((struct sockaddr *)addr)->sa_family == AF_INET) {
2326         /* The address *MUST* stupidly be zero. */
2327         ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
2328         /* PRIV mode is required to bind() to ports < 1024. */
2329         if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
2330             ((struct sockaddr_in *)addr)->sin_port > 0) {
2331             GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
2332             mpeprivmode = 1;
2333         }
2334     }
2335 #endif /* MPE */
2336     if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
2337                       (struct sockaddr *)addr, len) >= 0)
2338         bind_ok = 1;
2339
2340 #ifdef MPE /* Switch back to USER mode */
2341     if (mpeprivmode)
2342         GETUSERMODE();
2343 #endif /* MPE */
2344
2345     if (bind_ok)
2346         RETPUSHYES;
2347     else
2348         RETPUSHUNDEF;
2349
2350 nuts:
2351     if (ckWARN(WARN_CLOSED))
2352         report_evil_fh(gv, io, PL_op->op_type);
2353     SETERRNO(EBADF,SS$_IVCHAN);
2354     RETPUSHUNDEF;
2355 #else
2356     DIE(aTHX_ PL_no_sock_func, "bind");
2357 #endif
2358 }
2359
2360 PP(pp_connect)
2361 {
2362     dSP;
2363 #ifdef HAS_SOCKET
2364     SV *addrsv = POPs;
2365     char *addr;
2366     GV *gv = (GV*)POPs;
2367     register IO *io = GvIOn(gv);
2368     STRLEN len;
2369
2370     if (!io || !IoIFP(io))
2371         goto nuts;
2372
2373     addr = SvPV(addrsv, len);
2374     TAINT_PROPER("connect");
2375     if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2376         RETPUSHYES;
2377     else
2378         RETPUSHUNDEF;
2379
2380 nuts:
2381     if (ckWARN(WARN_CLOSED))
2382         report_evil_fh(gv, io, PL_op->op_type);
2383     SETERRNO(EBADF,SS$_IVCHAN);
2384     RETPUSHUNDEF;
2385 #else
2386     DIE(aTHX_ PL_no_sock_func, "connect");
2387 #endif
2388 }
2389
2390 PP(pp_listen)
2391 {
2392     dSP;
2393 #ifdef HAS_SOCKET
2394     int backlog = POPi;
2395     GV *gv = (GV*)POPs;
2396     register IO *io = gv ? GvIOn(gv) : NULL;
2397
2398     if (!gv || !io || !IoIFP(io))
2399         goto nuts;
2400
2401     if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2402         RETPUSHYES;
2403     else
2404         RETPUSHUNDEF;
2405
2406 nuts:
2407     if (ckWARN(WARN_CLOSED))
2408         report_evil_fh(gv, io, PL_op->op_type);
2409     SETERRNO(EBADF,SS$_IVCHAN);
2410     RETPUSHUNDEF;
2411 #else
2412     DIE(aTHX_ PL_no_sock_func, "listen");
2413 #endif
2414 }
2415
2416 PP(pp_accept)
2417 {
2418     dSP; dTARGET;
2419 #ifdef HAS_SOCKET
2420     GV *ngv;
2421     GV *ggv;
2422     register IO *nstio;
2423     register IO *gstio;
2424     struct sockaddr saddr;      /* use a struct to avoid alignment problems */
2425     Sock_size_t len = sizeof saddr;
2426     int fd;
2427
2428     ggv = (GV*)POPs;
2429     ngv = (GV*)POPs;
2430
2431     if (!ngv)
2432         goto badexit;
2433     if (!ggv)
2434         goto nuts;
2435
2436     gstio = GvIO(ggv);
2437     if (!gstio || !IoIFP(gstio))
2438         goto nuts;
2439
2440     nstio = GvIOn(ngv);
2441     if (IoIFP(nstio))
2442         do_close(ngv, FALSE);
2443
2444     fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
2445     if (fd < 0)
2446         goto badexit;
2447     IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2448     IoOFP(nstio) = PerlIO_fdopen(fd, "w");
2449     IoTYPE(nstio) = IoTYPE_SOCKET;
2450     if (!IoIFP(nstio) || !IoOFP(nstio)) {
2451         if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2452         if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2453         if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2454         goto badexit;
2455     }
2456 #if defined(HAS_FCNTL) && defined(F_SETFD)
2457     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2458 #endif
2459
2460 #ifdef EPOC
2461     len = sizeof saddr;          /* EPOC somehow truncates info */
2462     setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2463 #endif
2464
2465 #if defined(I_SYS_UN) && defined(__linux__)
2466     /* see the comment in pp_sysread */
2467     if (saddr.sa_family == AF_UNIX)
2468         len = sizeof(struct sockaddr_un);
2469 #endif
2470
2471     PUSHp((char *)&saddr, len);
2472     RETURN;
2473
2474 nuts:
2475     if (ckWARN(WARN_CLOSED))
2476         report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2477     SETERRNO(EBADF,SS$_IVCHAN);
2478
2479 badexit:
2480     RETPUSHUNDEF;
2481
2482 #else
2483     DIE(aTHX_ PL_no_sock_func, "accept");
2484 #endif
2485 }
2486
2487 PP(pp_shutdown)
2488 {
2489     dSP; dTARGET;
2490 #ifdef HAS_SOCKET
2491     int how = POPi;
2492     GV *gv = (GV*)POPs;
2493     register IO *io = GvIOn(gv);
2494
2495     if (!io || !IoIFP(io))
2496         goto nuts;
2497
2498     PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2499     RETURN;
2500
2501 nuts:
2502     if (ckWARN(WARN_CLOSED))
2503         report_evil_fh(gv, io, PL_op->op_type);
2504     SETERRNO(EBADF,SS$_IVCHAN);
2505     RETPUSHUNDEF;
2506 #else
2507     DIE(aTHX_ PL_no_sock_func, "shutdown");
2508 #endif
2509 }
2510
2511 PP(pp_gsockopt)
2512 {
2513 #ifdef HAS_SOCKET
2514     return pp_ssockopt();
2515 #else
2516     DIE(aTHX_ PL_no_sock_func, "getsockopt");
2517 #endif
2518 }
2519
2520 PP(pp_ssockopt)
2521 {
2522     dSP;
2523 #ifdef HAS_SOCKET
2524     int optype = PL_op->op_type;
2525     SV *sv;
2526     int fd;
2527     unsigned int optname;
2528     unsigned int lvl;
2529     GV *gv;
2530     register IO *io;
2531     Sock_size_t len;
2532
2533     if (optype == OP_GSOCKOPT)
2534         sv = sv_2mortal(NEWSV(22, 257));
2535     else
2536         sv = POPs;
2537     optname = (unsigned int) POPi;
2538     lvl = (unsigned int) POPi;
2539
2540     gv = (GV*)POPs;
2541     io = GvIOn(gv);
2542     if (!io || !IoIFP(io))
2543         goto nuts;
2544
2545     fd = PerlIO_fileno(IoIFP(io));
2546     switch (optype) {
2547     case OP_GSOCKOPT:
2548         SvGROW(sv, 257);
2549         (void)SvPOK_only(sv);
2550         SvCUR_set(sv,256);
2551         *SvEND(sv) ='\0';
2552         len = SvCUR(sv);
2553         if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2554             goto nuts2;
2555         SvCUR_set(sv, len);
2556         *SvEND(sv) ='\0';
2557         PUSHs(sv);
2558         break;
2559     case OP_SSOCKOPT: {
2560             char *buf;
2561             int aint;
2562             if (SvPOKp(sv)) {
2563                 STRLEN l;
2564                 buf = SvPV(sv, l);
2565                 len = l;
2566             }
2567             else {
2568                 aint = (int)SvIV(sv);
2569                 buf = (char*)&aint;
2570                 len = sizeof(int);
2571             }
2572             if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2573                 goto nuts2;
2574             PUSHs(&PL_sv_yes);
2575         }
2576         break;
2577     }
2578     RETURN;
2579
2580 nuts:
2581     if (ckWARN(WARN_CLOSED))
2582         report_evil_fh(gv, io, optype);
2583     SETERRNO(EBADF,SS$_IVCHAN);
2584 nuts2:
2585     RETPUSHUNDEF;
2586
2587 #else
2588     DIE(aTHX_ PL_no_sock_func, "setsockopt");
2589 #endif
2590 }
2591
2592 PP(pp_getsockname)
2593 {
2594 #ifdef HAS_SOCKET
2595     return pp_getpeername();
2596 #else
2597     DIE(aTHX_ PL_no_sock_func, "getsockname");
2598 #endif
2599 }
2600
2601 PP(pp_getpeername)
2602 {
2603     dSP;
2604 #ifdef HAS_SOCKET
2605     int optype = PL_op->op_type;
2606     SV *sv;
2607     int fd;
2608     GV *gv = (GV*)POPs;
2609     register IO *io = GvIOn(gv);
2610     Sock_size_t len;
2611
2612     if (!io || !IoIFP(io))
2613         goto nuts;
2614
2615     sv = sv_2mortal(NEWSV(22, 257));
2616     (void)SvPOK_only(sv);
2617     len = 256;
2618     SvCUR_set(sv, len);
2619     *SvEND(sv) ='\0';
2620     fd = PerlIO_fileno(IoIFP(io));
2621     switch (optype) {
2622     case OP_GETSOCKNAME:
2623         if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2624             goto nuts2;
2625         break;
2626     case OP_GETPEERNAME:
2627         if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2628             goto nuts2;
2629 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2630         {
2631             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";
2632             /* If the call succeeded, make sure we don't have a zeroed port/addr */
2633             if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2634                 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2635                         sizeof(u_short) + sizeof(struct in_addr))) {
2636                 goto nuts2;
2637             }
2638         }
2639 #endif
2640         break;
2641     }
2642 #ifdef BOGUS_GETNAME_RETURN
2643     /* Interactive Unix, getpeername() and getsockname()
2644       does not return valid namelen */
2645     if (len == BOGUS_GETNAME_RETURN)
2646         len = sizeof(struct sockaddr);
2647 #endif
2648 #if defined(I_SYS_UN) && defined(__linux__)
2649     /* see the comment in pp_sysread */
2650     if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_UNIX)
2651         len = sizeof(struct sockaddr_un);
2652 #endif
2653     SvCUR_set(sv, len);
2654     *SvEND(sv) ='\0';
2655     PUSHs(sv);
2656     RETURN;
2657
2658 nuts:
2659     if (ckWARN(WARN_CLOSED))
2660         report_evil_fh(gv, io, optype);
2661     SETERRNO(EBADF,SS$_IVCHAN);
2662 nuts2:
2663     RETPUSHUNDEF;
2664
2665 #else
2666     DIE(aTHX_ PL_no_sock_func, "getpeername");
2667 #endif
2668 }
2669
2670 /* Stat calls. */
2671
2672 PP(pp_lstat)
2673 {
2674     return pp_stat();
2675 }
2676
2677 PP(pp_stat)
2678 {
2679     dSP;
2680     GV *gv;
2681     I32 gimme;
2682     I32 max = 13;
2683     STRLEN n_a;
2684
2685     if (PL_op->op_flags & OPf_REF) {
2686         gv = cGVOP_gv;
2687         if (PL_op->op_type == OP_LSTAT) {
2688             if (PL_laststype != OP_LSTAT)
2689                 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2690             if (ckWARN(WARN_IO) && gv != PL_defgv)
2691                 Perl_warner(aTHX_ WARN_IO,
2692                         "lstat() on filehandle %s", GvENAME(gv));
2693                 /* Perl_my_lstat (-l) croak's on filehandle, why warn here? */
2694         }
2695
2696       do_fstat:
2697         if (gv != PL_defgv) {
2698             PL_laststype = OP_STAT;
2699             PL_statgv = gv;
2700             sv_setpv(PL_statname, "");
2701             PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv))
2702                 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
2703         }
2704         if (PL_laststatval < 0) {
2705             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2706                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2707             max = 0;
2708         }
2709     }
2710     else {
2711         SV* sv = POPs;
2712         if (SvTYPE(sv) == SVt_PVGV) {
2713             gv = (GV*)sv;
2714             goto do_fstat;
2715         }
2716         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2717             gv = (GV*)SvRV(sv);
2718             goto do_fstat;
2719         }
2720         sv_setpv(PL_statname, SvPV(sv,n_a));
2721         PL_statgv = Nullgv;
2722 #ifdef HAS_LSTAT
2723         PL_laststype = PL_op->op_type;
2724         if (PL_op->op_type == OP_LSTAT)
2725             PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
2726         else
2727 #endif
2728             PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
2729         if (PL_laststatval < 0) {
2730             if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
2731                 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
2732             max = 0;
2733         }
2734     }
2735
2736     gimme = GIMME_V;
2737     if (gimme != G_ARRAY) {
2738         if (gimme != G_VOID)
2739             XPUSHs(boolSV(max));
2740         RETURN;
2741     }
2742     if (max) {
2743         EXTEND(SP, max);
2744         EXTEND_MORTAL(max);
2745         PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2746         PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2747         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2748         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
2749 #if Uid_t_size > IVSIZE
2750         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2751 #else
2752 #   if Uid_t_sign <= 0
2753         PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2754 #   else
2755         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2756 #   endif
2757 #endif
2758 #if Gid_t_size > IVSIZE
2759         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2760 #else
2761 #   if Gid_t_sign <= 0
2762         PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2763 #   else
2764         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2765 #   endif
2766 #endif
2767 #ifdef USE_STAT_RDEV
2768         PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2769 #else
2770         PUSHs(sv_2mortal(newSVpvn("", 0)));
2771 #endif
2772 #if Off_t_size > IVSIZE
2773         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size)));
2774 #else
2775         PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2776 #endif
2777 #ifdef BIG_TIME
2778         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2779         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2780         PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2781 #else
2782         PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2783         PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2784         PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
2785 #endif
2786 #ifdef USE_STAT_BLOCKS
2787         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2788         PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
2789 #else
2790         PUSHs(sv_2mortal(newSVpvn("", 0)));
2791         PUSHs(sv_2mortal(newSVpvn("", 0)));
2792 #endif
2793     }
2794     RETURN;
2795 }
2796
2797 PP(pp_ftrread)
2798 {
2799     I32 result;
2800     dSP;
2801 #if defined(HAS_ACCESS) && defined(R_OK)
2802     STRLEN n_a;
2803     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2804         result = access(TOPpx, R_OK);
2805         if (result == 0)
2806             RETPUSHYES;
2807         if (result < 0)
2808             RETPUSHUNDEF;
2809         RETPUSHNO;
2810     }
2811     else
2812         result = my_stat();
2813 #else
2814     result = my_stat();
2815 #endif
2816     SPAGAIN;
2817     if (result < 0)
2818         RETPUSHUNDEF;
2819     if (cando(S_IRUSR, 0, &PL_statcache))
2820         RETPUSHYES;
2821     RETPUSHNO;
2822 }
2823
2824 PP(pp_ftrwrite)
2825 {
2826     I32 result;
2827     dSP;
2828 #if defined(HAS_ACCESS) && defined(W_OK)
2829     STRLEN n_a;
2830     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2831         result = access(TOPpx, W_OK);
2832         if (result == 0)
2833             RETPUSHYES;
2834         if (result < 0)
2835             RETPUSHUNDEF;
2836         RETPUSHNO;
2837     }
2838     else
2839         result = my_stat();
2840 #else
2841     result = my_stat();
2842 #endif
2843     SPAGAIN;
2844     if (result < 0)
2845         RETPUSHUNDEF;
2846     if (cando(S_IWUSR, 0, &PL_statcache))
2847         RETPUSHYES;
2848     RETPUSHNO;
2849 }
2850
2851 PP(pp_ftrexec)
2852 {
2853     I32 result;
2854     dSP;
2855 #if defined(HAS_ACCESS) && defined(X_OK)
2856     STRLEN n_a;
2857     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2858         result = access(TOPpx, X_OK);
2859         if (result == 0)
2860             RETPUSHYES;
2861         if (result < 0)
2862             RETPUSHUNDEF;
2863         RETPUSHNO;
2864     }
2865     else
2866         result = my_stat();
2867 #else
2868     result = my_stat();
2869 #endif
2870     SPAGAIN;
2871     if (result < 0)
2872         RETPUSHUNDEF;
2873     if (cando(S_IXUSR, 0, &PL_statcache))
2874         RETPUSHYES;
2875     RETPUSHNO;
2876 }
2877
2878 PP(pp_fteread)
2879 {
2880     I32 result;
2881     dSP;
2882 #ifdef PERL_EFF_ACCESS_R_OK
2883     STRLEN n_a;
2884     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2885         result = PERL_EFF_ACCESS_R_OK(TOPpx);
2886         if (result == 0)
2887             RETPUSHYES;
2888         if (result < 0)
2889             RETPUSHUNDEF;
2890         RETPUSHNO;
2891     }
2892     else
2893         result = my_stat();
2894 #else
2895     result = my_stat();
2896 #endif
2897     SPAGAIN;
2898     if (result < 0)
2899         RETPUSHUNDEF;
2900     if (cando(S_IRUSR, 1, &PL_statcache))
2901         RETPUSHYES;
2902     RETPUSHNO;
2903 }
2904
2905 PP(pp_ftewrite)
2906 {
2907     I32 result;
2908     dSP;
2909 #ifdef PERL_EFF_ACCESS_W_OK
2910     STRLEN n_a;
2911     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2912         result = PERL_EFF_ACCESS_W_OK(TOPpx);
2913         if (result == 0)
2914             RETPUSHYES;
2915         if (result < 0)
2916             RETPUSHUNDEF;
2917         RETPUSHNO;
2918     }
2919     else
2920         result = my_stat();
2921 #else
2922     result = my_stat();
2923 #endif
2924     SPAGAIN;
2925     if (result < 0)
2926         RETPUSHUNDEF;
2927     if (cando(S_IWUSR, 1, &PL_statcache))
2928         RETPUSHYES;
2929     RETPUSHNO;
2930 }
2931
2932 PP(pp_fteexec)
2933 {
2934     I32 result;
2935     dSP;
2936 #ifdef PERL_EFF_ACCESS_X_OK
2937     STRLEN n_a;
2938     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2939         result = PERL_EFF_ACCESS_X_OK(TOPpx);
2940         if (result == 0)
2941             RETPUSHYES;
2942         if (result < 0)
2943             RETPUSHUNDEF;
2944         RETPUSHNO;
2945     }
2946     else
2947         result = my_stat();
2948 #else
2949     result = my_stat();
2950 #endif
2951     SPAGAIN;
2952     if (result < 0)
2953         RETPUSHUNDEF;
2954     if (cando(S_IXUSR, 1, &PL_statcache))
2955         RETPUSHYES;
2956     RETPUSHNO;
2957 }
2958
2959 PP(pp_ftis)
2960 {
2961     I32 result = my_stat();
2962     dSP;
2963     if (result < 0)
2964         RETPUSHUNDEF;
2965     RETPUSHYES;
2966 }
2967
2968 PP(pp_fteowned)
2969 {
2970     return pp_ftrowned();
2971 }
2972
2973 PP(pp_ftrowned)
2974 {
2975     I32 result = my_stat();
2976     dSP;
2977     if (result < 0)
2978         RETPUSHUNDEF;
2979     if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
2980                                 PL_euid : PL_uid) )
2981         RETPUSHYES;
2982     RETPUSHNO;
2983 }
2984
2985 PP(pp_ftzero)
2986 {
2987     I32 result = my_stat();
2988     dSP;
2989     if (result < 0)
2990         RETPUSHUNDEF;
2991     if (PL_statcache.st_size == 0)
2992         RETPUSHYES;
2993     RETPUSHNO;
2994 }
2995
2996 PP(pp_ftsize)
2997 {
2998     I32 result = my_stat();
2999     dSP; dTARGET;
3000     if (result < 0)
3001         RETPUSHUNDEF;
3002 #if Off_t_size > IVSIZE
3003     PUSHn(PL_statcache.st_size);
3004 #else
3005     PUSHi(PL_statcache.st_size);
3006 #endif
3007     RETURN;
3008 }
3009
3010 PP(pp_ftmtime)
3011 {
3012     I32 result = my_stat();
3013     dSP; dTARGET;
3014     if (result < 0)
3015         RETPUSHUNDEF;
3016     PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3017     RETURN;
3018 }
3019
3020 PP(pp_ftatime)
3021 {
3022     I32 result = my_stat();
3023     dSP; dTARGET;
3024     if (result < 0)
3025         RETPUSHUNDEF;
3026     PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
3027     RETURN;
3028 }
3029
3030 PP(pp_ftctime)
3031 {
3032     I32 result = my_stat();
3033     dSP; dTARGET;
3034     if (result < 0)
3035         RETPUSHUNDEF;
3036     PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3037     RETURN;
3038 }
3039
3040 PP(pp_ftsock)
3041 {
3042     I32 result = my_stat();
3043     dSP;
3044     if (result < 0)
3045         RETPUSHUNDEF;
3046     if (S_ISSOCK(PL_statcache.st_mode))
3047         RETPUSHYES;
3048     RETPUSHNO;
3049 }
3050
3051 PP(pp_ftchr)
3052 {
3053     I32 result = my_stat();
3054     dSP;
3055     if (result < 0)
3056         RETPUSHUNDEF;
3057     if (S_ISCHR(PL_statcache.st_mode))
3058         RETPUSHYES;
3059     RETPUSHNO;
3060 }
3061
3062 PP(pp_ftblk)
3063 {
3064     I32 result = my_stat();
3065     dSP;
3066     if (result < 0)
3067         RETPUSHUNDEF;
3068     if (S_ISBLK(PL_statcache.st_mode))
3069         RETPUSHYES;
3070     RETPUSHNO;
3071 }
3072
3073 PP(pp_ftfile)
3074 {
3075     I32 result = my_stat();
3076     dSP;
3077     if (result < 0)
3078         RETPUSHUNDEF;
3079     if (S_ISREG(PL_statcache.st_mode))
3080         RETPUSHYES;
3081     RETPUSHNO;
3082 }
3083
3084 PP(pp_ftdir)
3085 {
3086     I32 result = my_stat();
3087     dSP;
3088     if (result < 0)
3089         RETPUSHUNDEF;
3090     if (S_ISDIR(PL_statcache.st_mode))
3091         RETPUSHYES;
3092     RETPUSHNO;
3093 }
3094
3095 PP(pp_ftpipe)
3096 {
3097     I32 result = my_stat();
3098     dSP;
3099     if (result < 0)
3100         RETPUSHUNDEF;
3101     if (S_ISFIFO(PL_statcache.st_mode))
3102         RETPUSHYES;
3103     RETPUSHNO;
3104 }
3105
3106 PP(pp_ftlink)
3107 {
3108     I32 result = my_lstat();
3109     dSP;
3110     if (result < 0)
3111         RETPUSHUNDEF;
3112     if (S_ISLNK(PL_statcache.st_mode))
3113         RETPUSHYES;
3114     RETPUSHNO;
3115 }
3116
3117 PP(pp_ftsuid)
3118 {
3119     dSP;
3120 #ifdef S_ISUID
3121     I32 result = my_stat();
3122     SPAGAIN;
3123     if (result < 0)
3124         RETPUSHUNDEF;
3125     if (PL_statcache.st_mode & S_ISUID)
3126         RETPUSHYES;
3127 #endif
3128     RETPUSHNO;
3129 }
3130
3131 PP(pp_ftsgid)
3132 {
3133     dSP;
3134 #ifdef S_ISGID
3135     I32 result = my_stat();
3136     SPAGAIN;
3137     if (result < 0)
3138         RETPUSHUNDEF;
3139     if (PL_statcache.st_mode & S_ISGID)
3140         RETPUSHYES;
3141 #endif
3142     RETPUSHNO;
3143 }
3144
3145 PP(pp_ftsvtx)
3146 {
3147     dSP;
3148 #ifdef S_ISVTX
3149     I32 result = my_stat();
3150     SPAGAIN;
3151     if (result < 0)
3152         RETPUSHUNDEF;
3153     if (PL_statcache.st_mode & S_ISVTX)
3154         RETPUSHYES;
3155 #endif
3156     RETPUSHNO;
3157 }
3158
3159 PP(pp_fttty)
3160 {
3161     dSP;
3162     int fd;
3163     GV *gv;
3164     char *tmps = Nullch;
3165     STRLEN n_a;
3166
3167     if (PL_op->op_flags & OPf_REF)
3168         gv = cGVOP_gv;
3169     else if (isGV(TOPs))
3170         gv = (GV*)POPs;
3171     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3172         gv = (GV*)SvRV(POPs);
3173     else
3174         gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
3175
3176     if (GvIO(gv) && IoIFP(GvIOp(gv)))
3177         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3178     else if (tmps && isDIGIT(*tmps))
3179         fd = atoi(tmps);
3180     else
3181         RETPUSHUNDEF;
3182     if (PerlLIO_isatty(fd))
3183         RETPUSHYES;
3184     RETPUSHNO;
3185 }
3186
3187 #if defined(atarist) /* this will work with atariST. Configure will
3188                         make guesses for other systems. */
3189 # define FILE_base(f) ((f)->_base)
3190 # define FILE_ptr(f) ((f)->_ptr)
3191 # define FILE_cnt(f) ((f)->_cnt)
3192 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3193 #endif
3194
3195 PP(pp_fttext)
3196 {
3197     dSP;
3198     I32 i;
3199     I32 len;
3200     I32 odd = 0;
3201     STDCHAR tbuf[512];
3202     register STDCHAR *s;
3203     register IO *io;
3204     register SV *sv;
3205     GV *gv;
3206     STRLEN n_a;
3207     PerlIO *fp;
3208
3209     if (PL_op->op_flags & OPf_REF)
3210         gv = cGVOP_gv;
3211     else if (isGV(TOPs))
3212         gv = (GV*)POPs;
3213     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3214         gv = (GV*)SvRV(POPs);
3215     else
3216         gv = Nullgv;
3217
3218     if (gv) {
3219         EXTEND(SP, 1);
3220         if (gv == PL_defgv) {
3221             if (PL_statgv)
3222                 io = GvIO(PL_statgv);
3223             else {
3224                 sv = PL_statname;
3225                 goto really_filename;
3226             }
3227         }
3228         else {
3229             PL_statgv = gv;
3230             PL_laststatval = -1;
3231             sv_setpv(PL_statname, "");
3232             io = GvIO(PL_statgv);
3233         }
3234         if (io && IoIFP(io)) {
3235             if (! PerlIO_has_base(IoIFP(io)))
3236                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3237             PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3238             if (PL_laststatval < 0)
3239                 RETPUSHUNDEF;
3240             if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3241                 if (PL_op->op_type == OP_FTTEXT)
3242                     RETPUSHNO;
3243                 else
3244                     RETPUSHYES;
3245             }
3246             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3247                 i = PerlIO_getc(IoIFP(io));
3248                 if (i != EOF)
3249                     (void)PerlIO_ungetc(IoIFP(io),i);
3250             }
3251             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3252                 RETPUSHYES;
3253             len = PerlIO_get_bufsiz(IoIFP(io));
3254             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3255             /* sfio can have large buffers - limit to 512 */
3256             if (len > 512)
3257                 len = 512;
3258         }
3259         else {
3260             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3261                 gv = cGVOP_gv;
3262                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3263             }
3264             SETERRNO(EBADF,RMS$_IFI);
3265             RETPUSHUNDEF;
3266         }
3267     }
3268     else {
3269         sv = POPs;
3270       really_filename:
3271         PL_statgv = Nullgv;
3272         PL_laststatval = -1;
3273         sv_setpv(PL_statname, SvPV(sv, n_a));
3274         if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
3275             if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
3276                 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
3277             RETPUSHUNDEF;
3278         }
3279         PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3280         if (PL_laststatval < 0) {
3281             (void)PerlIO_close(fp);
3282             RETPUSHUNDEF;
3283         }
3284         PerlIO_binmode(aTHX_ fp, '<', O_BINARY, Nullch);
3285         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3286         (void)PerlIO_close(fp);
3287         if (len <= 0) {
3288             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3289                 RETPUSHNO;              /* special case NFS directories */
3290             RETPUSHYES;         /* null file is anything */
3291         }
3292         s = tbuf;
3293     }
3294
3295     /* now scan s to look for textiness */
3296     /*   XXX ASCII dependent code */
3297
3298 #if defined(DOSISH) || defined(USEMYBINMODE)
3299     /* ignore trailing ^Z on short files */
3300     if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3301         --len;
3302 #endif
3303
3304     for (i = 0; i < len; i++, s++) {
3305         if (!*s) {                      /* null never allowed in text */
3306             odd += len;
3307             break;
3308         }
3309 #ifdef EBCDIC
3310         else if (!(isPRINT(*s) || isSPACE(*s)))
3311             odd++;
3312 #else
3313         else if (*s & 128) {
3314 #ifdef USE_LOCALE
3315             if ((PL_op->op_private & OPpLOCALE) && isALPHA_LC(*s))
3316                 continue;
3317 #endif
3318             /* utf8 characters don't count as odd */
3319             if (UTF8_IS_START(*s)) {
3320                 int ulen = UTF8SKIP(s);
3321                 if (ulen < len - i) {
3322                     int j;
3323                     for (j = 1; j < ulen; j++) {
3324                         if (!UTF8_IS_CONTINUATION(s[j]))
3325                             goto not_utf8;
3326                     }
3327                     --ulen;     /* loop does extra increment */
3328                     s += ulen;
3329                     i += ulen;
3330                     continue;
3331                 }
3332             }
3333           not_utf8:
3334             odd++;
3335         }
3336         else if (*s < 32 &&
3337           *s != '\n' && *s != '\r' && *s != '\b' &&
3338           *s != '\t' && *s != '\f' && *s != 27)
3339             odd++;
3340 #endif
3341     }
3342
3343     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3344         RETPUSHNO;
3345     else
3346         RETPUSHYES;
3347 }
3348
3349 PP(pp_ftbinary)
3350 {
3351     return pp_fttext();
3352 }
3353
3354 /* File calls. */
3355
3356 PP(pp_chdir)
3357 {
3358     dSP; dTARGET;
3359     char *tmps;
3360     SV **svp;
3361     STRLEN n_a;
3362
3363     if (MAXARG < 1)
3364         tmps = Nullch;
3365     else
3366         tmps = POPpx;
3367     if (!tmps || !*tmps) {
3368         svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
3369         if (svp)
3370             tmps = SvPV(*svp, n_a);
3371     }
3372     if (!tmps || !*tmps) {
3373         svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
3374         if (svp)
3375             tmps = SvPV(*svp, n_a);
3376     }
3377 #ifdef VMS
3378     if (!tmps || !*tmps) {
3379        svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
3380        if (svp)
3381            tmps = SvPV(*svp, n_a);
3382     }
3383 #endif
3384     TAINT_PROPER("chdir");
3385     PUSHi( PerlDir_chdir(tmps) >= 0 );
3386 #ifdef VMS
3387     /* Clear the DEFAULT element of ENV so we'll get the new value
3388      * in the future. */
3389     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3390 #endif
3391     RETURN;
3392 }
3393
3394 PP(pp_chown)
3395 {
3396     dSP; dMARK; dTARGET;
3397     I32 value;
3398 #ifdef HAS_CHOWN
3399     value = (I32)apply(PL_op->op_type, MARK, SP);
3400     SP = MARK;
3401     PUSHi(value);
3402     RETURN;
3403 #else
3404     DIE(aTHX_ PL_no_func, "Unsupported function chown");
3405 #endif
3406 }
3407
3408 PP(pp_chroot)
3409 {
3410     dSP; dTARGET;
3411     char *tmps;
3412 #ifdef HAS_CHROOT
3413     STRLEN n_a;
3414     tmps = POPpx;
3415     TAINT_PROPER("chroot");
3416     PUSHi( chroot(tmps) >= 0 );
3417     RETURN;
3418 #else
3419     DIE(aTHX_ PL_no_func, "chroot");
3420 #endif
3421 }
3422
3423 PP(pp_unlink)
3424 {
3425     dSP; dMARK; dTARGET;
3426     I32 value;
3427     value = (I32)apply(PL_op->op_type, MARK, SP);
3428     SP = MARK;
3429     PUSHi(value);
3430     RETURN;
3431 }
3432
3433 PP(pp_chmod)
3434 {
3435     dSP; dMARK; dTARGET;
3436     I32 value;
3437     value = (I32)apply(PL_op->op_type, MARK, SP);
3438     SP = MARK;
3439     PUSHi(value);
3440     RETURN;
3441 }
3442
3443 PP(pp_utime)
3444 {
3445     dSP; dMARK; dTARGET;
3446     I32 value;
3447     value = (I32)apply(PL_op->op_type, MARK, SP);
3448     SP = MARK;
3449     PUSHi(value);
3450     RETURN;
3451 }
3452
3453 PP(pp_rename)
3454 {
3455     dSP; dTARGET;
3456     int anum;
3457     STRLEN n_a;
3458
3459     char *tmps2 = POPpx;
3460     char *tmps = SvPV(TOPs, n_a);
3461     TAINT_PROPER("rename");
3462 #ifdef HAS_RENAME
3463     anum = PerlLIO_rename(tmps, tmps2);
3464 #else
3465     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3466         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3467             anum = 1;
3468         else {
3469             if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3470                 (void)UNLINK(tmps2);
3471             if (!(anum = link(tmps, tmps2)))
3472                 anum = UNLINK(tmps);
3473         }
3474     }
3475 #endif
3476     SETi( anum >= 0 );
3477     RETURN;
3478 }
3479
3480 PP(pp_link)
3481 {
3482     dSP; dTARGET;
3483 #ifdef HAS_LINK
3484     STRLEN n_a;
3485     char *tmps2 = POPpx;
3486     char *tmps = SvPV(TOPs, n_a);
3487     TAINT_PROPER("link");
3488     SETi( PerlLIO_link(tmps, tmps2) >= 0 );
3489 #else
3490     DIE(aTHX_ PL_no_func, "Unsupported function link");
3491 #endif
3492     RETURN;
3493 }
3494
3495 PP(pp_symlink)
3496 {
3497     dSP; dTARGET;
3498 #ifdef HAS_SYMLINK
3499     STRLEN n_a;
3500     char *tmps2 = POPpx;
3501     char *tmps = SvPV(TOPs, n_a);
3502     TAINT_PROPER("symlink");
3503     SETi( symlink(tmps, tmps2) >= 0 );
3504     RETURN;
3505 #else
3506     DIE(aTHX_ PL_no_func, "symlink");
3507 #endif
3508 }
3509
3510 PP(pp_readlink)
3511 {
3512     dSP; dTARGET;
3513 #ifdef HAS_SYMLINK
3514     char *tmps;
3515     char buf[MAXPATHLEN];
3516     int len;
3517     STRLEN n_a;
3518
3519 #ifndef INCOMPLETE_TAINTS
3520     TAINT;
3521 #endif
3522     tmps = POPpx;
3523     len = readlink(tmps, buf, sizeof buf);
3524     EXTEND(SP, 1);
3525     if (len < 0)
3526         RETPUSHUNDEF;
3527     PUSHp(buf, len);
3528     RETURN;
3529 #else
3530     EXTEND(SP, 1);
3531     RETSETUNDEF;                /* just pretend it's a normal file */
3532 #endif
3533 }
3534
3535 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3536 STATIC int
3537 S_dooneliner(pTHX_ char *cmd, char *filename)
3538 {
3539     char *save_filename = filename;
3540     char *cmdline;
3541     char *s;
3542     PerlIO *myfp;
3543     int anum = 1;
3544
3545     New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3546     strcpy(cmdline, cmd);
3547     strcat(cmdline, " ");
3548     for (s = cmdline + strlen(cmdline); *filename; ) {
3549         *s++ = '\\';
3550         *s++ = *filename++;
3551     }
3552     strcpy(s, " 2>&1");
3553     myfp = PerlProc_popen(cmdline, "r");
3554     Safefree(cmdline);
3555
3556     if (myfp) {
3557         SV *tmpsv = sv_newmortal();
3558         /* Need to save/restore 'PL_rs' ?? */
3559         s = sv_gets(tmpsv, myfp, 0);
3560         (void)PerlProc_pclose(myfp);
3561         if (s != Nullch) {
3562             int e;
3563             for (e = 1;
3564 #ifdef HAS_SYS_ERRLIST
3565                  e <= sys_nerr
3566 #endif
3567                  ; e++)
3568             {
3569                 /* you don't see this */
3570                 char *errmsg =
3571 #ifdef HAS_SYS_ERRLIST
3572                     sys_errlist[e]
3573 #else
3574                     strerror(e)
3575 #endif
3576                     ;
3577                 if (!errmsg)
3578                     break;
3579                 if (instr(s, errmsg)) {
3580                     SETERRNO(e,0);
3581                     return 0;
3582                 }
3583             }
3584             SETERRNO(0,0);
3585 #ifndef EACCES
3586 #define EACCES EPERM
3587 #endif
3588             if (instr(s, "cannot make"))
3589                 SETERRNO(EEXIST,RMS$_FEX);
3590             else if (instr(s, "existing file"))
3591                 SETERRNO(EEXIST,RMS$_FEX);
3592             else if (instr(s, "ile exists"))
3593                 SETERRNO(EEXIST,RMS$_FEX);
3594             else if (instr(s, "non-exist"))
3595                 SETERRNO(ENOENT,RMS$_FNF);
3596             else if (instr(s, "does not exist"))
3597                 SETERRNO(ENOENT,RMS$_FNF);
3598             else if (instr(s, "not empty"))
3599                 SETERRNO(EBUSY,SS$_DEVOFFLINE);
3600             else if (instr(s, "cannot access"))
3601                 SETERRNO(EACCES,RMS$_PRV);
3602             else
3603                 SETERRNO(EPERM,RMS$_PRV);
3604             return 0;
3605         }
3606         else {  /* some mkdirs return no failure indication */
3607             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3608             if (PL_op->op_type == OP_RMDIR)
3609                 anum = !anum;
3610             if (anum)
3611                 SETERRNO(0,0);
3612             else
3613                 SETERRNO(EACCES,RMS$_PRV);      /* a guess */
3614         }
3615         return anum;
3616     }
3617     else
3618         return 0;
3619 }
3620 #endif
3621
3622 PP(pp_mkdir)
3623 {
3624     dSP; dTARGET;
3625     int mode;
3626 #ifndef HAS_MKDIR
3627     int oldumask;
3628 #endif
3629     STRLEN len;
3630     char *tmps;
3631     bool copy = FALSE;
3632
3633     if (MAXARG > 1)
3634         mode = POPi;
3635     else
3636         mode = 0777;
3637
3638     tmps = SvPV(TOPs, len);
3639     /* Different operating and file systems take differently to
3640      * trailing slashes.  According to POSIX 1003.1 1996 Edition
3641      * any number of trailing slashes should be allowed.
3642      * Thusly we snip them away so that even non-conforming
3643      * systems are happy. */
3644     /* We should probably do this "filtering" for all
3645      * the functions that expect (potentially) directory names:
3646      * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3647      * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3648     if (len > 1 && tmps[len-1] == '/') {
3649         while (tmps[len] == '/' && len > 1)
3650             len--;
3651         tmps = savepvn(tmps, len);
3652         copy = TRUE;
3653     }
3654
3655     TAINT_PROPER("mkdir");
3656 #ifdef HAS_MKDIR
3657     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3658 #else
3659     SETi( dooneliner("mkdir", tmps) );
3660     oldumask = PerlLIO_umask(0);
3661     PerlLIO_umask(oldumask);
3662     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3663 #endif
3664     if (copy)
3665         Safefree(tmps);
3666     RETURN;
3667 }
3668
3669 PP(pp_rmdir)
3670 {
3671     dSP; dTARGET;
3672     char *tmps;
3673     STRLEN n_a;
3674
3675     tmps = POPpx;
3676     TAINT_PROPER("rmdir");
3677 #ifdef HAS_RMDIR
3678     XPUSHi( PerlDir_rmdir(tmps) >= 0 );
3679 #else
3680     XPUSHi( dooneliner("rmdir", tmps) );
3681 #endif
3682     RETURN;
3683 }
3684
3685 /* Directory calls. */
3686
3687 PP(pp_open_dir)
3688 {
3689     dSP;
3690 #if defined(Direntry_t) && defined(HAS_READDIR)
3691     STRLEN n_a;
3692     char *dirname = POPpx;
3693     GV *gv = (GV*)POPs;
3694     register IO *io = GvIOn(gv);
3695
3696     if (!io)
3697         goto nope;
3698
3699     if (IoDIRP(io))
3700         PerlDir_close(IoDIRP(io));
3701     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3702         goto nope;
3703
3704     RETPUSHYES;
3705 nope:
3706     if (!errno)
3707         SETERRNO(EBADF,RMS$_DIR);
3708     RETPUSHUNDEF;
3709 #else
3710     DIE(aTHX_ PL_no_dir_func, "opendir");
3711 #endif
3712 }
3713
3714 PP(pp_readdir)
3715 {
3716     dSP;
3717 #if defined(Direntry_t) && defined(HAS_READDIR)
3718 #ifndef I_DIRENT
3719     Direntry_t *readdir (DIR *);
3720 #endif
3721     register Direntry_t *dp;
3722     GV *gv = (GV*)POPs;
3723     register IO *io = GvIOn(gv);
3724     SV *sv;
3725
3726     if (!io || !IoDIRP(io))
3727         goto nope;
3728
3729     if (GIMME == G_ARRAY) {
3730         /*SUPPRESS 560*/
3731         while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
3732 #ifdef DIRNAMLEN
3733             sv = newSVpvn(dp->d_name, dp->d_namlen);
3734 #else
3735             sv = newSVpv(dp->d_name, 0);
3736 #endif
3737 #ifndef INCOMPLETE_TAINTS
3738             if (!(IoFLAGS(io) & IOf_UNTAINT))
3739                 SvTAINTED_on(sv);
3740 #endif
3741             XPUSHs(sv_2mortal(sv));
3742         }
3743     }
3744     else {
3745         if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
3746             goto nope;
3747 #ifdef DIRNAMLEN
3748         sv = newSVpvn(dp->d_name, dp->d_namlen);
3749 #else
3750         sv = newSVpv(dp->d_name, 0);
3751 #endif
3752 #ifndef INCOMPLETE_TAINTS
3753         if (!(IoFLAGS(io) & IOf_UNTAINT))
3754             SvTAINTED_on(sv);
3755 #endif
3756         XPUSHs(sv_2mortal(sv));
3757     }
3758     RETURN;
3759
3760 nope:
3761     if (!errno)
3762         SETERRNO(EBADF,RMS$_ISI);
3763     if (GIMME == G_ARRAY)
3764         RETURN;
3765     else
3766         RETPUSHUNDEF;
3767 #else
3768     DIE(aTHX_ PL_no_dir_func, "readdir");
3769 #endif
3770 }
3771
3772 PP(pp_telldir)
3773 {
3774     dSP; dTARGET;
3775 #if defined(HAS_TELLDIR) || defined(telldir)
3776  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3777  /* XXX netbsd still seemed to.
3778     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3779     --JHI 1999-Feb-02 */
3780 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3781     long telldir (DIR *);
3782 # endif
3783     GV *gv = (GV*)POPs;
3784     register IO *io = GvIOn(gv);
3785
3786     if (!io || !IoDIRP(io))
3787         goto nope;
3788
3789     PUSHi( PerlDir_tell(IoDIRP(io)) );
3790     RETURN;
3791 nope:
3792     if (!errno)
3793         SETERRNO(EBADF,RMS$_ISI);
3794     RETPUSHUNDEF;
3795 #else
3796     DIE(aTHX_ PL_no_dir_func, "telldir");
3797 #endif
3798 }
3799
3800 PP(pp_seekdir)
3801 {
3802     dSP;
3803 #if defined(HAS_SEEKDIR) || defined(seekdir)
3804     long along = POPl;
3805     GV *gv = (GV*)POPs;
3806     register IO *io = GvIOn(gv);
3807
3808     if (!io || !IoDIRP(io))
3809         goto nope;
3810
3811     (void)PerlDir_seek(IoDIRP(io), along);
3812
3813     RETPUSHYES;
3814 nope:
3815     if (!errno)
3816         SETERRNO(EBADF,RMS$_ISI);
3817     RETPUSHUNDEF;
3818 #else
3819     DIE(aTHX_ PL_no_dir_func, "seekdir");
3820 #endif
3821 }
3822
3823 PP(pp_rewinddir)
3824 {
3825     dSP;
3826 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3827     GV *gv = (GV*)POPs;
3828     register IO *io = GvIOn(gv);
3829
3830     if (!io || !IoDIRP(io))
3831         goto nope;
3832
3833     (void)PerlDir_rewind(IoDIRP(io));
3834     RETPUSHYES;
3835 nope:
3836     if (!errno)
3837         SETERRNO(EBADF,RMS$_ISI);
3838     RETPUSHUNDEF;
3839 #else
3840     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3841 #endif
3842 }
3843
3844 PP(pp_closedir)
3845 {
3846     dSP;
3847 #if defined(Direntry_t) && defined(HAS_READDIR)
3848     GV *gv = (GV*)POPs;
3849     register IO *io = GvIOn(gv);
3850
3851     if (!io || !IoDIRP(io))
3852         goto nope;
3853
3854 #ifdef VOID_CLOSEDIR
3855     PerlDir_close(IoDIRP(io));
3856 #else
3857     if (PerlDir_close(IoDIRP(io)) < 0) {
3858         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3859         goto nope;
3860     }
3861 #endif
3862     IoDIRP(io) = 0;
3863
3864     RETPUSHYES;
3865 nope:
3866     if (!errno)
3867         SETERRNO(EBADF,RMS$_IFI);
3868     RETPUSHUNDEF;
3869 #else
3870     DIE(aTHX_ PL_no_dir_func, "closedir");
3871 #endif
3872 }
3873
3874 /* Process control. */
3875
3876 PP(pp_fork)
3877 {
3878 #ifdef HAS_FORK
3879     dSP; dTARGET;
3880     Pid_t childpid;
3881     GV *tmpgv;
3882
3883     EXTEND(SP, 1);
3884     PERL_FLUSHALL_FOR_CHILD;
3885     childpid = fork();
3886     if (childpid < 0)
3887         RETSETUNDEF;
3888     if (!childpid) {
3889         /*SUPPRESS 560*/
3890         if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
3891             sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3892         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3893     }
3894     PUSHi(childpid);
3895     RETURN;
3896 #else
3897 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3898     dSP; dTARGET;
3899     Pid_t childpid;
3900
3901     EXTEND(SP, 1);
3902     PERL_FLUSHALL_FOR_CHILD;
3903     childpid = PerlProc_fork();
3904     if (childpid == -1)
3905         RETSETUNDEF;
3906     PUSHi(childpid);
3907     RETURN;
3908 #  else
3909     DIE(aTHX_ PL_no_func, "Unsupported function fork");
3910 #  endif
3911 #endif
3912 }
3913
3914 PP(pp_wait)
3915 {
3916 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3917     dSP; dTARGET;
3918     Pid_t childpid;
3919     int argflags;
3920
3921     childpid = wait4pid(-1, &argflags, 0);
3922 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3923     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3924     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3925 #  else
3926     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3927 #  endif
3928     XPUSHi(childpid);
3929     RETURN;
3930 #else
3931     DIE(aTHX_ PL_no_func, "Unsupported function wait");
3932 #endif
3933 }
3934
3935 PP(pp_waitpid)
3936 {
3937 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3938     dSP; dTARGET;
3939     Pid_t childpid;
3940     int optype;
3941     int argflags;
3942
3943     optype = POPi;
3944     childpid = TOPi;
3945     childpid = wait4pid(childpid, &argflags, optype);
3946 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3947     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3948     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3949 #  else
3950     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3951 #  endif
3952     SETi(childpid);
3953     RETURN;
3954 #else
3955     DIE(aTHX_ PL_no_func, "Unsupported function waitpid");
3956 #endif
3957 }
3958
3959 PP(pp_system)
3960 {
3961     dSP; dMARK; dORIGMARK; dTARGET;
3962     I32 value;
3963     Pid_t childpid;
3964     int result;
3965     int status;
3966     Sigsave_t ihand,qhand;     /* place to save signals during system() */
3967     STRLEN n_a;
3968     I32 did_pipes = 0;
3969     int pp[2];
3970
3971     if (SP - MARK == 1) {
3972         if (PL_tainting) {
3973             char *junk = SvPV(TOPs, n_a);
3974             TAINT_ENV();
3975             TAINT_PROPER("system");
3976         }
3977     }
3978     PERL_FLUSHALL_FOR_CHILD;
3979 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) && !defined(__CYGWIN__) || defined(PERL_MICRO)
3980     if (PerlProc_pipe(pp) >= 0)
3981         did_pipes = 1;
3982     while ((childpid = vfork()) == -1) {
3983         if (errno != EAGAIN) {
3984             value = -1;
3985             SP = ORIGMARK;
3986             PUSHi(value);
3987             if (did_pipes) {
3988                 PerlLIO_close(pp[0]);
3989                 PerlLIO_close(pp[1]);
3990             }
3991             RETURN;
3992         }
3993         sleep(5);
3994     }
3995     if (childpid > 0) {
3996         if (did_pipes)
3997             PerlLIO_close(pp[1]);
3998 #ifndef PERL_MICRO
3999         rsignal_save(SIGINT, SIG_IGN, &ihand);
4000         rsignal_save(SIGQUIT, SIG_IGN, &qhand);
4001 #endif
4002         do {
4003             result = wait4pid(childpid, &status, 0);
4004         } while (result == -1 && errno == EINTR);
4005 #ifndef PERL_MICRO
4006         (void)rsignal_restore(SIGINT, &ihand);
4007         (void)rsignal_restore(SIGQUIT, &qhand);
4008 #endif
4009         STATUS_NATIVE_SET(result == -1 ? -1 : status);
4010         do_execfree();  /* free any memory child malloced on vfork */
4011         SP = ORIGMARK;
4012         if (did_pipes) {
4013             int errkid;
4014             int n = 0, n1;
4015
4016             while (n < sizeof(int)) {
4017                 n1 = PerlLIO_read(pp[0],
4018                                   (void*)(((char*)&errkid)+n),
4019                                   (sizeof(int)) - n);
4020                 if (n1 <= 0)
4021                     break;
4022                 n += n1;
4023             }
4024             PerlLIO_close(pp[0]);
4025             if (n) {                    /* Error */
4026                 if (n != sizeof(int))
4027                     DIE(aTHX_ "panic: kid popen errno read");
4028                 errno = errkid;         /* Propagate errno from kid */
4029                 STATUS_CURRENT = -1;
4030             }
4031         }
4032         PUSHi(STATUS_CURRENT);
4033         RETURN;
4034     }
4035     if (did_pipes) {
4036         PerlLIO_close(pp[0]);
4037 #if defined(HAS_FCNTL) && defined(F_SETFD)
4038         fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4039 #endif
4040     }
4041     if (PL_op->op_flags & OPf_STACKED) {
4042         SV *really = *++MARK;
4043         value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4044     }
4045     else if (SP - MARK != 1)
4046         value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
4047     else {
4048         value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
4049     }
4050     PerlProc__exit(-1);
4051 #else /* ! FORK or VMS or OS/2 */
4052     PL_statusvalue = 0;
4053     result = 0;
4054     if (PL_op->op_flags & OPf_STACKED) {
4055         SV *really = *++MARK;
4056         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4057     }
4058     else if (SP - MARK != 1)
4059         value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
4060     else {
4061         value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
4062     }
4063     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4064         result = 1;
4065     STATUS_NATIVE_SET(value);
4066     do_execfree();
4067     SP = ORIGMARK;
4068     PUSHi(result ? value : STATUS_CURRENT);
4069 #endif /* !FORK or VMS */
4070     RETURN;
4071 }
4072
4073 PP(pp_exec)
4074 {
4075     dSP; dMARK; dORIGMARK; dTARGET;
4076     I32 value;
4077     STRLEN n_a;
4078
4079     PERL_FLUSHALL_FOR_CHILD;
4080     if (PL_op->op_flags & OPf_STACKED) {
4081         SV *really = *++MARK;
4082         value = (I32)do_aexec(really, MARK, SP);
4083     }
4084     else if (SP - MARK != 1)
4085 #ifdef VMS
4086         value = (I32)vms_do_aexec(Nullsv, MARK, SP);
4087 #else
4088 #  ifdef __OPEN_VM
4089         {
4090            (void ) do_aspawn(Nullsv, MARK, SP);
4091            value = 0;
4092         }
4093 #  else
4094         value = (I32)do_aexec(Nullsv, MARK, SP);
4095 #  endif
4096 #endif
4097     else {
4098         if (PL_tainting) {
4099             char *junk = SvPV(*SP, n_a);
4100             TAINT_ENV();
4101             TAINT_PROPER("exec");
4102         }
4103 #ifdef VMS
4104         value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
4105 #else
4106 #  ifdef __OPEN_VM
4107         (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
4108         value = 0;
4109 #  else
4110         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
4111 #  endif
4112 #endif
4113     }
4114
4115 #if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4116     if (value >= 0)
4117         my_exit(value);
4118 #endif
4119
4120     SP = ORIGMARK;
4121     PUSHi(value);
4122     RETURN;
4123 }
4124
4125 PP(pp_kill)
4126 {
4127     dSP; dMARK; dTARGET;
4128     I32 value;
4129 #ifdef HAS_KILL
4130     value = (I32)apply(PL_op->op_type, MARK, SP);
4131     SP = MARK;
4132     PUSHi(value);
4133     RETURN;
4134 #else
4135     DIE(aTHX_ PL_no_func, "Unsupported function kill");
4136 #endif
4137 }
4138
4139 PP(pp_getppid)
4140 {
4141 #ifdef HAS_GETPPID
4142     dSP; dTARGET;
4143     XPUSHi( getppid() );
4144     RETURN;
4145 #else
4146     DIE(aTHX_ PL_no_func, "getppid");
4147 #endif
4148 }
4149
4150 PP(pp_getpgrp)
4151 {
4152 #ifdef HAS_GETPGRP
4153     dSP; dTARGET;
4154     Pid_t pid;
4155     Pid_t pgrp;
4156
4157     if (MAXARG < 1)
4158         pid = 0;
4159     else
4160         pid = SvIVx(POPs);
4161 #ifdef BSD_GETPGRP
4162     pgrp = (I32)BSD_GETPGRP(pid);
4163 #else
4164     if (pid != 0 && pid != PerlProc_getpid())
4165         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4166     pgrp = getpgrp();
4167 #endif
4168     XPUSHi(pgrp);
4169     RETURN;
4170 #else
4171     DIE(aTHX_ PL_no_func, "getpgrp()");
4172 #endif
4173 }
4174
4175 PP(pp_setpgrp)
4176 {
4177 #ifdef HAS_SETPGRP
4178     dSP; dTARGET;
4179     Pid_t pgrp;
4180     Pid_t pid;
4181     if (MAXARG < 2) {
4182         pgrp = 0;
4183         pid = 0;
4184     }
4185     else {
4186         pgrp = POPi;
4187         pid = TOPi;
4188     }
4189
4190     TAINT_PROPER("setpgrp");
4191 #ifdef BSD_SETPGRP
4192     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4193 #else
4194     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4195         || (pid != 0 && pid != PerlProc_getpid()))
4196     {
4197         DIE(aTHX_ "setpgrp can't take arguments");
4198     }
4199     SETi( setpgrp() >= 0 );
4200 #endif /* USE_BSDPGRP */
4201     RETURN;
4202 #else
4203     DIE(aTHX_ PL_no_func, "setpgrp()");
4204 #endif
4205 }
4206
4207 PP(pp_getpriority)
4208 {
4209     dSP; dTARGET;
4210     int which;
4211     int who;
4212 #ifdef HAS_GETPRIORITY
4213     who = POPi;
4214     which = TOPi;
4215     SETi( getpriority(which, who) );
4216     RETURN;
4217 #else
4218     DIE(aTHX_ PL_no_func, "getpriority()");
4219 #endif
4220 }
4221
4222 PP(pp_setpriority)
4223 {
4224     dSP; dTARGET;
4225     int which;
4226     int who;
4227     int niceval;
4228 #ifdef HAS_SETPRIORITY
4229     niceval = POPi;
4230     who = POPi;
4231     which = TOPi;
4232     TAINT_PROPER("setpriority");
4233     SETi( setpriority(which, who, niceval) >= 0 );
4234     RETURN;
4235 #else
4236     DIE(aTHX_ PL_no_func, "setpriority()");
4237 #endif
4238 }
4239
4240 /* Time calls. */
4241
4242 PP(pp_time)
4243 {
4244     dSP; dTARGET;
4245 #ifdef BIG_TIME
4246     XPUSHn( time(Null(Time_t*)) );
4247 #else
4248     XPUSHi( time(Null(Time_t*)) );
4249 #endif
4250     RETURN;
4251 }
4252
4253 /* XXX The POSIX name is CLK_TCK; it is to be preferred
4254    to HZ.  Probably.  For now, assume that if the system
4255    defines HZ, it does so correctly.  (Will this break
4256    on VMS?)
4257    Probably we ought to use _sysconf(_SC_CLK_TCK), if
4258    it's supported.    --AD  9/96.
4259 */
4260
4261 #ifndef HZ
4262 #  ifdef CLK_TCK
4263 #    define HZ CLK_TCK
4264 #  else
4265 #    define HZ 60
4266 #  endif
4267 #endif
4268
4269 PP(pp_tms)
4270 {
4271     dSP;
4272
4273 #ifndef HAS_TIMES
4274     DIE(aTHX_ "times not implemented");
4275 #else
4276     EXTEND(SP, 4);
4277
4278 #ifndef VMS
4279     (void)PerlProc_times(&PL_timesbuf);
4280 #else
4281     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4282                                                    /* struct tms, though same data   */
4283                                                    /* is returned.                   */
4284 #endif
4285
4286     PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
4287     if (GIMME == G_ARRAY) {
4288         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4289         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4290         PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
4291     }
4292     RETURN;
4293 #endif /* HAS_TIMES */
4294 }
4295
4296 PP(pp_localtime)
4297 {
4298     return pp_gmtime();
4299 }
4300
4301 PP(pp_gmtime)
4302 {
4303     dSP;
4304     Time_t when;
4305     struct tm *tmbuf;
4306     static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4307     static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4308                               "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4309
4310     if (MAXARG < 1)
4311         (void)time(&when);
4312     else
4313 #ifdef BIG_TIME
4314         when = (Time_t)SvNVx(POPs);
4315 #else
4316         when = (Time_t)SvIVx(POPs);
4317 #endif
4318
4319     if (PL_op->op_type == OP_LOCALTIME)
4320         tmbuf = localtime(&when);
4321     else
4322         tmbuf = gmtime(&when);
4323
4324     EXTEND(SP, 9);
4325     EXTEND_MORTAL(9);
4326     if (GIMME != G_ARRAY) {
4327         SV *tsv;
4328         if (!tmbuf)
4329             RETPUSHUNDEF;
4330         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4331                             dayname[tmbuf->tm_wday],
4332                             monname[tmbuf->tm_mon],
4333                             tmbuf->tm_mday,
4334                             tmbuf->tm_hour,
4335                             tmbuf->tm_min,
4336                             tmbuf->tm_sec,
4337                             tmbuf->tm_year + 1900);
4338         PUSHs(sv_2mortal(tsv));
4339     }
4340     else if (tmbuf) {
4341         PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4342         PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4343         PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4344         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4345         PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4346         PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4347         PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4348         PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4349         PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4350     }
4351     RETURN;
4352 }
4353
4354 PP(pp_alarm)
4355 {
4356     dSP; dTARGET;
4357     int anum;
4358 #ifdef HAS_ALARM
4359     anum = POPi;
4360     anum = alarm((unsigned int)anum);
4361     EXTEND(SP, 1);
4362     if (anum < 0)
4363         RETPUSHUNDEF;
4364     PUSHi(anum);
4365     RETURN;
4366 #else
4367     DIE(aTHX_ PL_no_func, "Unsupported function alarm");
4368 #endif
4369 }
4370
4371 PP(pp_sleep)
4372 {
4373     dSP; dTARGET;
4374     I32 duration;
4375     Time_t lasttime;
4376     Time_t when;
4377
4378     (void)time(&lasttime);
4379     if (MAXARG < 1)
4380         PerlProc_pause();
4381     else {
4382         duration = POPi;
4383         PerlProc_sleep((unsigned int)duration);
4384     }
4385     (void)time(&when);
4386     XPUSHi(when - lasttime);
4387     RETURN;
4388 }
4389
4390 /* Shared memory. */
4391
4392 PP(pp_shmget)
4393 {
4394     return pp_semget();
4395 }
4396
4397 PP(pp_shmctl)
4398 {
4399     return pp_semctl();
4400 }
4401
4402 PP(pp_shmread)
4403 {
4404     return pp_shmwrite();
4405 }
4406
4407 PP(pp_shmwrite)
4408 {
4409 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4410     dSP; dMARK; dTARGET;
4411     I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
4412     SP = MARK;
4413     PUSHi(value);
4414     RETURN;
4415 #else
4416     return pp_semget();
4417 #endif
4418 }
4419
4420 /* Message passing. */
4421
4422 PP(pp_msgget)
4423 {
4424     return pp_semget();
4425 }
4426
4427 PP(pp_msgctl)
4428 {
4429     return pp_semctl();
4430 }
4431
4432 PP(pp_msgsnd)
4433 {
4434 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4435     dSP; dMARK; dTARGET;
4436     I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4437     SP = MARK;
4438     PUSHi(value);
4439     RETURN;
4440 #else
4441     return pp_semget();
4442 #endif
4443 }
4444
4445 PP(pp_msgrcv)
4446 {
4447 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4448     dSP; dMARK; dTARGET;
4449     I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4450     SP = MARK;
4451     PUSHi(value);
4452     RETURN;
4453 #else
4454     return pp_semget();
4455 #endif
4456 }
4457
4458 /* Semaphores. */
4459
4460 PP(pp_semget)
4461 {
4462 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4463     dSP; dMARK; dTARGET;
4464     int anum = do_ipcget(PL_op->op_type, MARK, SP);
4465     SP = MARK;
4466     if (anum == -1)
4467         RETPUSHUNDEF;
4468     PUSHi(anum);
4469     RETURN;
4470 #else
4471     DIE(aTHX_ "System V IPC is not implemented on this machine");
4472 #endif
4473 }
4474
4475 PP(pp_semctl)
4476 {
4477 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4478     dSP; dMARK; dTARGET;
4479     int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4480     SP = MARK;
4481     if (anum == -1)
4482         RETSETUNDEF;
4483     if (anum != 0) {
4484         PUSHi(anum);
4485     }
4486     else {
4487         PUSHp(zero_but_true, ZBTLEN);
4488     }
4489     RETURN;
4490 #else
4491     return pp_semget();
4492 #endif
4493 }
4494
4495 PP(pp_semop)
4496 {
4497 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4498     dSP; dMARK; dTARGET;
4499     I32 value = (I32)(do_semop(MARK, SP) >= 0);
4500     SP = MARK;
4501     PUSHi(value);
4502     RETURN;
4503 #else
4504     return pp_semget();
4505 #endif
4506 }
4507
4508 /* Get system info. */
4509
4510 PP(pp_ghbyname)
4511 {
4512 #ifdef HAS_GETHOSTBYNAME
4513     return pp_ghostent();
4514 #else
4515     DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4516 #endif
4517 }
4518
4519 PP(pp_ghbyaddr)
4520 {
4521 #ifdef HAS_GETHOSTBYADDR
4522     return pp_ghostent();
4523 #else
4524     DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4525 #endif
4526 }
4527
4528 PP(pp_ghostent)
4529 {
4530     dSP;
4531 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4532     I32 which = PL_op->op_type;
4533     register char **elem;
4534     register SV *sv;
4535 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4536     struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4537     struct hostent *PerlSock_gethostbyname(Netdb_name_t);
4538     struct hostent *PerlSock_gethostent(void);
4539 #endif
4540     struct hostent *hent;
4541     unsigned long len;
4542     STRLEN n_a;
4543
4544     EXTEND(SP, 10);
4545     if (which == OP_GHBYNAME)
4546 #ifdef HAS_GETHOSTBYNAME
4547         hent = PerlSock_gethostbyname(POPpbytex);
4548 #else
4549         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4550 #endif
4551     else if (which == OP_GHBYADDR) {
4552 #ifdef HAS_GETHOSTBYADDR
4553         int addrtype = POPi;
4554         SV *addrsv = POPs;
4555         STRLEN addrlen;
4556         Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
4557
4558         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4559 #else
4560         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4561 #endif
4562     }
4563     else
4564 #ifdef HAS_GETHOSTENT
4565         hent = PerlSock_gethostent();
4566 #else
4567         DIE(aTHX_ PL_no_sock_func, "gethostent");
4568 #endif
4569
4570 #ifdef HOST_NOT_FOUND
4571     if (!hent)
4572         STATUS_NATIVE_SET(h_errno);
4573 #endif
4574
4575     if (GIMME != G_ARRAY) {
4576         PUSHs(sv = sv_newmortal());
4577         if (hent) {
4578             if (which == OP_GHBYNAME) {
4579                 if (hent->h_addr)
4580                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4581             }
4582             else
4583                 sv_setpv(sv, (char*)hent->h_name);
4584         }
4585         RETURN;
4586     }
4587
4588     if (hent) {
4589         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4590         sv_setpv(sv, (char*)hent->h_name);
4591         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4592         for (elem = hent->h_aliases; elem && *elem; elem++) {
4593             sv_catpv(sv, *elem);
4594             if (elem[1])
4595                 sv_catpvn(sv, " ", 1);
4596         }
4597         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4598         sv_setiv(sv, (IV)hent->h_addrtype);
4599         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4600         len = hent->h_length;
4601         sv_setiv(sv, (IV)len);
4602 #ifdef h_addr
4603         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4604             XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
4605             sv_setpvn(sv, *elem, len);
4606         }
4607 #else
4608         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4609         if (hent->h_addr)
4610             sv_setpvn(sv, hent->h_addr, len);
4611 #endif /* h_addr */
4612     }
4613     RETURN;
4614 #else
4615     DIE(aTHX_ PL_no_sock_func, "gethostent");
4616 #endif
4617 }
4618
4619 PP(pp_gnbyname)
4620 {
4621 #ifdef HAS_GETNETBYNAME
4622     return pp_gnetent();
4623 #else
4624     DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4625 #endif
4626 }
4627
4628 PP(pp_gnbyaddr)
4629 {
4630 #ifdef HAS_GETNETBYADDR
4631     return pp_gnetent();
4632 #else
4633     DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4634 #endif
4635 }
4636
4637 PP(pp_gnetent)
4638 {
4639     dSP;
4640 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4641     I32 which = PL_op->op_type;
4642     register char **elem;
4643     register SV *sv;
4644 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4645     struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4646     struct netent *PerlSock_getnetbyname(Netdb_name_t);
4647     struct netent *PerlSock_getnetent(void);
4648 #endif
4649     struct netent *nent;
4650     STRLEN n_a;
4651
4652     if (which == OP_GNBYNAME)
4653 #ifdef HAS_GETNETBYNAME
4654         nent = PerlSock_getnetbyname(POPpbytex);
4655 #else
4656         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4657 #endif
4658     else if (which == OP_GNBYADDR) {
4659 #ifdef HAS_GETNETBYADDR
4660         int addrtype = POPi;
4661         Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
4662         nent = PerlSock_getnetbyaddr(addr, addrtype);
4663 #else
4664         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4665 #endif
4666     }
4667     else
4668 #ifdef HAS_GETNETENT
4669         nent = PerlSock_getnetent();
4670 #else
4671         DIE(aTHX_ PL_no_sock_func, "getnetent");
4672 #endif
4673
4674     EXTEND(SP, 4);
4675     if (GIMME != G_ARRAY) {
4676         PUSHs(sv = sv_newmortal());
4677         if (nent) {
4678             if (which == OP_GNBYNAME)
4679                 sv_setiv(sv, (IV)nent->n_net);
4680             else
4681                 sv_setpv(sv, nent->n_name);
4682         }
4683         RETURN;
4684     }
4685
4686     if (nent) {
4687         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4688         sv_setpv(sv, nent->n_name);
4689         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4690         for (elem = nent->n_aliases; elem && *elem; elem++) {
4691             sv_catpv(sv, *elem);
4692             if (elem[1])
4693                 sv_catpvn(sv, " ", 1);
4694         }
4695         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4696         sv_setiv(sv, (IV)nent->n_addrtype);
4697         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4698         sv_setiv(sv, (IV)nent->n_net);
4699     }
4700
4701     RETURN;
4702 #else
4703     DIE(aTHX_ PL_no_sock_func, "getnetent");
4704 #endif
4705 }
4706
4707 PP(pp_gpbyname)
4708 {
4709 #ifdef HAS_GETPROTOBYNAME
4710     return pp_gprotoent();
4711 #else
4712     DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4713 #endif
4714 }
4715
4716 PP(pp_gpbynumber)
4717 {
4718 #ifdef HAS_GETPROTOBYNUMBER
4719     return pp_gprotoent();
4720 #else
4721     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4722 #endif
4723 }
4724
4725 PP(pp_gprotoent)
4726 {
4727     dSP;
4728 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4729     I32 which = PL_op->op_type;
4730     register char **elem;
4731     register SV *sv;
4732 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4733     struct protoent *PerlSock_getprotobyname(Netdb_name_t);
4734     struct protoent *PerlSock_getprotobynumber(int);
4735     struct protoent *PerlSock_getprotoent(void);
4736 #endif
4737     struct protoent *pent;
4738     STRLEN n_a;
4739
4740     if (which == OP_GPBYNAME)
4741 #ifdef HAS_GETPROTOBYNAME
4742         pent = PerlSock_getprotobyname(POPpbytex);
4743 #else
4744         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4745 #endif
4746     else if (which == OP_GPBYNUMBER)
4747 #ifdef HAS_GETPROTOBYNUMBER
4748         pent = PerlSock_getprotobynumber(POPi);
4749 #else
4750     DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4751 #endif
4752     else
4753 #ifdef HAS_GETPROTOENT
4754         pent = PerlSock_getprotoent();
4755 #else
4756         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4757 #endif
4758
4759     EXTEND(SP, 3);
4760     if (GIMME != G_ARRAY) {
4761         PUSHs(sv = sv_newmortal());
4762         if (pent) {
4763             if (which == OP_GPBYNAME)
4764                 sv_setiv(sv, (IV)pent->p_proto);
4765             else
4766                 sv_setpv(sv, pent->p_name);
4767         }
4768         RETURN;
4769     }
4770
4771     if (pent) {
4772         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4773         sv_setpv(sv, pent->p_name);
4774         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4775         for (elem = pent->p_aliases; elem && *elem; elem++) {
4776             sv_catpv(sv, *elem);
4777             if (elem[1])
4778                 sv_catpvn(sv, " ", 1);
4779         }
4780         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4781         sv_setiv(sv, (IV)pent->p_proto);
4782     }
4783
4784     RETURN;
4785 #else
4786     DIE(aTHX_ PL_no_sock_func, "getprotoent");
4787 #endif
4788 }
4789
4790 PP(pp_gsbyname)
4791 {
4792 #ifdef HAS_GETSERVBYNAME
4793     return pp_gservent();
4794 #else
4795     DIE(aTHX_ PL_no_sock_func, "getservbyname");
4796 #endif
4797 }
4798
4799 PP(pp_gsbyport)
4800 {
4801 #ifdef HAS_GETSERVBYPORT
4802     return pp_gservent();
4803 #else
4804     DIE(aTHX_ PL_no_sock_func, "getservbyport");
4805 #endif
4806 }
4807
4808 PP(pp_gservent)
4809 {
4810     dSP;
4811 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4812     I32 which = PL_op->op_type;
4813     register char **elem;
4814     register SV *sv;
4815 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4816     struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4817     struct servent *PerlSock_getservbyport(int, Netdb_name_t);
4818     struct servent *PerlSock_getservent(void);
4819 #endif
4820     struct servent *sent;
4821     STRLEN n_a;
4822
4823     if (which == OP_GSBYNAME) {
4824 #ifdef HAS_GETSERVBYNAME
4825         char *proto = POPpbytex;
4826         char *name = POPpbytex;
4827
4828         if (proto && !*proto)
4829             proto = Nullch;
4830
4831         sent = PerlSock_getservbyname(name, proto);
4832 #else
4833         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4834 #endif
4835     }
4836     else if (which == OP_GSBYPORT) {
4837 #ifdef HAS_GETSERVBYPORT
4838         char *proto = POPpbytex;
4839         unsigned short port = POPu;
4840
4841 #ifdef HAS_HTONS
4842         port = PerlSock_htons(port);
4843 #endif
4844         sent = PerlSock_getservbyport(port, proto);
4845 #else
4846         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4847 #endif
4848     }
4849     else
4850 #ifdef HAS_GETSERVENT
4851         sent = PerlSock_getservent();
4852 #else
4853         DIE(aTHX_ PL_no_sock_func, "getservent");
4854 #endif
4855
4856     EXTEND(SP, 4);
4857     if (GIMME != G_ARRAY) {
4858         PUSHs(sv = sv_newmortal());
4859         if (sent) {
4860             if (which == OP_GSBYNAME) {
4861 #ifdef HAS_NTOHS
4862                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4863 #else
4864                 sv_setiv(sv, (IV)(sent->s_port));
4865 #endif
4866             }
4867             else
4868                 sv_setpv(sv, sent->s_name);
4869         }
4870         RETURN;
4871     }
4872
4873     if (sent) {
4874         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4875         sv_setpv(sv, sent->s_name);
4876         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4877         for (elem = sent->s_aliases; elem && *elem; elem++) {
4878             sv_catpv(sv, *elem);
4879             if (elem[1])
4880                 sv_catpvn(sv, " ", 1);
4881         }
4882         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4883 #ifdef HAS_NTOHS
4884         sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4885 #else
4886         sv_setiv(sv, (IV)(sent->s_port));
4887 #endif
4888         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4889         sv_setpv(sv, sent->s_proto);
4890     }
4891
4892     RETURN;
4893 #else
4894     DIE(aTHX_ PL_no_sock_func, "getservent");
4895 #endif
4896 }
4897
4898 PP(pp_shostent)
4899 {
4900     dSP;
4901 #ifdef HAS_SETHOSTENT
4902     PerlSock_sethostent(TOPi);
4903     RETSETYES;
4904 #else
4905     DIE(aTHX_ PL_no_sock_func, "sethostent");
4906 #endif
4907 }
4908
4909 PP(pp_snetent)
4910 {
4911     dSP;
4912 #ifdef HAS_SETNETENT
4913     PerlSock_setnetent(TOPi);
4914     RETSETYES;
4915 #else
4916     DIE(aTHX_ PL_no_sock_func, "setnetent");
4917 #endif
4918 }
4919
4920 PP(pp_sprotoent)
4921 {
4922     dSP;
4923 #ifdef HAS_SETPROTOENT
4924     PerlSock_setprotoent(TOPi);
4925     RETSETYES;
4926 #else
4927     DIE(aTHX_ PL_no_sock_func, "setprotoent");
4928 #endif
4929 }
4930
4931 PP(pp_sservent)
4932 {
4933     dSP;
4934 #ifdef HAS_SETSERVENT
4935     PerlSock_setservent(TOPi);
4936     RETSETYES;
4937 #else
4938     DIE(aTHX_ PL_no_sock_func, "setservent");
4939 #endif
4940 }
4941
4942 PP(pp_ehostent)
4943 {
4944     dSP;
4945 #ifdef HAS_ENDHOSTENT
4946     PerlSock_endhostent();
4947     EXTEND(SP,1);
4948     RETPUSHYES;
4949 #else
4950     DIE(aTHX_ PL_no_sock_func, "endhostent");
4951 #endif
4952 }
4953
4954 PP(pp_enetent)
4955 {
4956     dSP;
4957 #ifdef HAS_ENDNETENT
4958     PerlSock_endnetent();
4959     EXTEND(SP,1);
4960     RETPUSHYES;
4961 #else
4962     DIE(aTHX_ PL_no_sock_func, "endnetent");
4963 #endif
4964 }
4965
4966 PP(pp_eprotoent)
4967 {
4968     dSP;
4969 #ifdef HAS_ENDPROTOENT
4970     PerlSock_endprotoent();
4971     EXTEND(SP,1);
4972     RETPUSHYES;
4973 #else
4974     DIE(aTHX_ PL_no_sock_func, "endprotoent");
4975 #endif
4976 }
4977
4978 PP(pp_eservent)
4979 {
4980     dSP;
4981 #ifdef HAS_ENDSERVENT
4982     PerlSock_endservent();
4983     EXTEND(SP,1);
4984     RETPUSHYES;
4985 #else
4986     DIE(aTHX_ PL_no_sock_func, "endservent");
4987 #endif
4988 }
4989
4990 PP(pp_gpwnam)
4991 {
4992 #ifdef HAS_PASSWD
4993     return pp_gpwent();
4994 #else
4995     DIE(aTHX_ PL_no_func, "getpwnam");
4996 #endif
4997 }
4998
4999 PP(pp_gpwuid)
5000 {
5001 #ifdef HAS_PASSWD
5002     return pp_gpwent();
5003 #else
5004     DIE(aTHX_ PL_no_func, "getpwuid");
5005 #endif
5006 }
5007
5008 PP(pp_gpwent)
5009 {
5010     dSP;
5011 #ifdef HAS_PASSWD
5012     I32 which = PL_op->op_type;
5013     register SV *sv;
5014     STRLEN n_a;
5015     struct passwd *pwent  = NULL;
5016     /*
5017      * We currently support only the SysV getsp* shadow password interface.
5018      * The interface is declared in <shadow.h> and often one needs to link
5019      * with -lsecurity or some such.
5020      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5021      * (and SCO?)
5022      *
5023      * AIX getpwnam() is clever enough to return the encrypted password
5024      * only if the caller (euid?) is root.
5025      *
5026      * There are at least two other shadow password APIs.  Many platforms
5027      * seem to contain more than one interface for accessing the shadow
5028      * password databases, possibly for compatibility reasons.
5029      * The getsp*() is by far he simplest one, the other two interfaces
5030      * are much more complicated, but also very similar to each other.
5031      *
5032      * <sys/types.h>
5033      * <sys/security.h>
5034      * <prot.h>
5035      * struct pr_passwd *getprpw*();
5036      * The password is in
5037      * char getprpw*(...).ufld.fd_encrypt[]
5038      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5039      *
5040      * <sys/types.h>
5041      * <sys/security.h>
5042      * <prot.h>
5043      * struct es_passwd *getespw*();
5044      * The password is in
5045      * char *(getespw*(...).ufld.fd_encrypt)
5046      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5047      *
5048      * Mention I_PROT here so that Configure probes for it.
5049      *
5050      * In HP-UX for getprpw*() the manual page claims that one should include
5051      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5052      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5053      * and pp_sys.c already includes <shadow.h> if there is such.
5054      *
5055      * Note that <sys/security.h> is already probed for, but currently
5056      * it is only included in special cases.
5057      *
5058      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5059      * be preferred interface, even though also the getprpw*() interface
5060      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5061      * One also needs to call set_auth_parameters() in main() before
5062      * doing anything else, whether one is using getespw*() or getprpw*().
5063      *
5064      * Note that accessing the shadow databases can be magnitudes
5065      * slower than accessing the standard databases.
5066      *
5067      * --jhi
5068      */
5069
5070     switch (which) {
5071     case OP_GPWNAM:
5072         pwent  = getpwnam(POPpbytex);
5073         break;
5074     case OP_GPWUID:
5075         pwent = getpwuid((Uid_t)POPi);
5076         break;
5077     case OP_GPWENT:
5078 #   ifdef HAS_GETPWENT
5079         pwent  = getpwent();
5080 #   else
5081         DIE(aTHX_ PL_no_func, "getpwent");
5082 #   endif
5083         break;
5084     }
5085
5086     EXTEND(SP, 10);
5087     if (GIMME != G_ARRAY) {
5088         PUSHs(sv = sv_newmortal());
5089         if (pwent) {
5090             if (which == OP_GPWNAM)
5091 #   if Uid_t_sign <= 0
5092                 sv_setiv(sv, (IV)pwent->pw_uid);
5093 #   else
5094                 sv_setuv(sv, (UV)pwent->pw_uid);
5095 #   endif
5096             else
5097                 sv_setpv(sv, pwent->pw_name);
5098         }
5099         RETURN;
5100     }
5101
5102     if (pwent) {
5103         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5104         sv_setpv(sv, pwent->pw_name);
5105
5106         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5107         SvPOK_off(sv);
5108         /* If we have getspnam(), we try to dig up the shadow
5109          * password.  If we are underprivileged, the shadow
5110          * interface will set the errno to EACCES or similar,
5111          * and return a null pointer.  If this happens, we will
5112          * use the dummy password (usually "*" or "x") from the
5113          * standard password database.
5114          *
5115          * In theory we could skip the shadow call completely
5116          * if euid != 0 but in practice we cannot know which
5117          * security measures are guarding the shadow databases
5118          * on a random platform.
5119          *
5120          * Resist the urge to use additional shadow interfaces.
5121          * Divert the urge to writing an extension instead.
5122          *
5123          * --jhi */
5124 #   ifdef HAS_GETSPNAM
5125         {
5126             struct spwd *spwent;
5127             int saverrno; /* Save and restore errno so that
5128                            * underprivileged attempts seem
5129                            * to have never made the unsccessful
5130                            * attempt to retrieve the shadow password. */
5131
5132             saverrno = errno;
5133             spwent = getspnam(pwent->pw_name);
5134             errno = saverrno;
5135             if (spwent && spwent->sp_pwdp)
5136                 sv_setpv(sv, spwent->sp_pwdp);
5137         }
5138 #   endif
5139 #   ifdef PWPASSWD
5140         if (!SvPOK(sv)) /* Use the standard password, then. */
5141             sv_setpv(sv, pwent->pw_passwd);
5142 #   endif
5143
5144 #   ifndef INCOMPLETE_TAINTS
5145         /* passwd is tainted because user himself can diddle with it.
5146          * admittedly not much and in a very limited way, but nevertheless. */
5147         SvTAINTED_on(sv);
5148 #   endif
5149
5150         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5151 #   if Uid_t_sign <= 0
5152         sv_setiv(sv, (IV)pwent->pw_uid);
5153 #   else
5154         sv_setuv(sv, (UV)pwent->pw_uid);
5155 #   endif
5156
5157         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5158 #   if Uid_t_sign <= 0
5159         sv_setiv(sv, (IV)pwent->pw_gid);
5160 #   else
5161         sv_setuv(sv, (UV)pwent->pw_gid);
5162 #   endif
5163         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5164          * because of the poor interface of the Perl getpw*(),
5165          * not because there's some standard/convention saying so.
5166          * A better interface would have been to return a hash,
5167          * but we are accursed by our history, alas. --jhi.  */
5168         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5169 #   ifdef PWCHANGE
5170         sv_setiv(sv, (IV)pwent->pw_change);
5171 #   else
5172 #       ifdef PWQUOTA
5173         sv_setiv(sv, (IV)pwent->pw_quota);
5174 #       else
5175 #           ifdef PWAGE
5176         sv_setpv(sv, pwent->pw_age);
5177 #           endif
5178 #       endif
5179 #   endif
5180
5181         /* pw_class and pw_comment are mutually exclusive--.
5182          * see the above note for pw_change, pw_quota, and pw_age. */
5183         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5184 #   ifdef PWCLASS
5185         sv_setpv(sv, pwent->pw_class);
5186 #   else
5187 #       ifdef PWCOMMENT
5188         sv_setpv(sv, pwent->pw_comment);
5189 #       endif
5190 #   endif
5191
5192         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5193 #   ifdef PWGECOS
5194         sv_setpv(sv, pwent->pw_gecos);
5195 #   endif
5196 #   ifndef INCOMPLETE_TAINTS
5197         /* pw_gecos is tainted because user himself can diddle with it. */
5198         SvTAINTED_on(sv);
5199 #   endif
5200
5201         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5202         sv_setpv(sv, pwent->pw_dir);
5203
5204         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5205         sv_setpv(sv, pwent->pw_shell);
5206 #   ifndef INCOMPLETE_TAINTS
5207         /* pw_shell is tainted because user himself can diddle with it. */
5208         SvTAINTED_on(sv);
5209 #   endif
5210
5211 #   ifdef PWEXPIRE
5212         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5213         sv_setiv(sv, (IV)pwent->pw_expire);
5214 #   endif
5215     }
5216     RETURN;
5217 #else
5218     DIE(aTHX_ PL_no_func, "getpwent");
5219 #endif
5220 }
5221
5222 PP(pp_spwent)
5223 {
5224     dSP;
5225 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5226     setpwent();
5227     RETPUSHYES;
5228 #else
5229     DIE(aTHX_ PL_no_func, "setpwent");
5230 #endif
5231 }
5232
5233 PP(pp_epwent)
5234 {
5235     dSP;
5236 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5237     endpwent();
5238     RETPUSHYES;
5239 #else
5240     DIE(aTHX_ PL_no_func, "endpwent");
5241 #endif
5242 }
5243
5244 PP(pp_ggrnam)
5245 {
5246 #ifdef HAS_GROUP
5247     return pp_ggrent();
5248 #else
5249     DIE(aTHX_ PL_no_func, "getgrnam");
5250 #endif
5251 }
5252
5253 PP(pp_ggrgid)
5254 {
5255 #ifdef HAS_GROUP
5256     return pp_ggrent();
5257 #else
5258     DIE(aTHX_ PL_no_func, "getgrgid");
5259 #endif
5260 }
5261
5262 PP(pp_ggrent)
5263 {
5264     dSP;
5265 #ifdef HAS_GROUP
5266     I32 which = PL_op->op_type;
5267     register char **elem;
5268     register SV *sv;
5269     struct group *grent;
5270     STRLEN n_a;
5271
5272     if (which == OP_GGRNAM)
5273         grent = (struct group *)getgrnam(POPpbytex);
5274     else if (which == OP_GGRGID)
5275         grent = (struct group *)getgrgid(POPi);
5276     else
5277 #ifdef HAS_GETGRENT
5278         grent = (struct group *)getgrent();
5279 #else
5280         DIE(aTHX_ PL_no_func, "getgrent");
5281 #endif
5282
5283     EXTEND(SP, 4);
5284     if (GIMME != G_ARRAY) {
5285         PUSHs(sv = sv_newmortal());
5286         if (grent) {
5287             if (which == OP_GGRNAM)
5288                 sv_setiv(sv, (IV)grent->gr_gid);
5289             else
5290                 sv_setpv(sv, grent->gr_name);
5291         }
5292         RETURN;
5293     }
5294
5295     if (grent) {
5296         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5297         sv_setpv(sv, grent->gr_name);
5298
5299         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5300 #ifdef GRPASSWD
5301         sv_setpv(sv, grent->gr_passwd);
5302 #endif
5303
5304         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5305         sv_setiv(sv, (IV)grent->gr_gid);
5306
5307         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5308         for (elem = grent->gr_mem; elem && *elem; elem++) {
5309             sv_catpv(sv, *elem);
5310             if (elem[1])
5311                 sv_catpvn(sv, " ", 1);
5312         }
5313     }
5314
5315     RETURN;
5316 #else
5317     DIE(aTHX_ PL_no_func, "getgrent");
5318 #endif
5319 }
5320
5321 PP(pp_sgrent)
5322 {
5323     dSP;
5324 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5325     setgrent();
5326     RETPUSHYES;
5327 #else
5328     DIE(aTHX_ PL_no_func, "setgrent");
5329 #endif
5330 }
5331
5332 PP(pp_egrent)
5333 {
5334     dSP;
5335 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5336     endgrent();
5337     RETPUSHYES;
5338 #else
5339     DIE(aTHX_ PL_no_func, "endgrent");
5340 #endif
5341 }
5342
5343 PP(pp_getlogin)
5344 {
5345     dSP; dTARGET;
5346 #ifdef HAS_GETLOGIN
5347     char *tmps;
5348     EXTEND(SP, 1);
5349     if (!(tmps = PerlProc_getlogin()))
5350         RETPUSHUNDEF;
5351     PUSHp(tmps, strlen(tmps));
5352     RETURN;
5353 #else
5354     DIE(aTHX_ PL_no_func, "getlogin");
5355 #endif
5356 }
5357
5358 /* Miscellaneous. */
5359
5360 PP(pp_syscall)
5361 {
5362 #ifdef HAS_SYSCALL
5363     dSP; dMARK; dORIGMARK; dTARGET;
5364     register I32 items = SP - MARK;
5365     unsigned long a[20];
5366     register I32 i = 0;
5367     I32 retval = -1;
5368     STRLEN n_a;
5369
5370     if (PL_tainting) {
5371         while (++MARK <= SP) {
5372             if (SvTAINTED(*MARK)) {
5373                 TAINT;
5374                 break;
5375             }
5376         }
5377         MARK = ORIGMARK;
5378         TAINT_PROPER("syscall");
5379     }
5380
5381     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5382      * or where sizeof(long) != sizeof(char*).  But such machines will
5383      * not likely have syscall implemented either, so who cares?
5384      */
5385     while (++MARK <= SP) {
5386         if (SvNIOK(*MARK) || !i)
5387             a[i++] = SvIV(*MARK);
5388         else if (*MARK == &PL_sv_undef)
5389             a[i++] = 0;
5390         else
5391             a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
5392         if (i > 15)
5393             break;
5394     }
5395     switch (items) {
5396     default:
5397         DIE(aTHX_ "Too many args to syscall");
5398     case 0:
5399         DIE(aTHX_ "Too few args to syscall");
5400     case 1:
5401         retval = syscall(a[0]);
5402         break;
5403     case 2:
5404         retval = syscall(a[0],a[1]);
5405         break;
5406     case 3:
5407         retval = syscall(a[0],a[1],a[2]);
5408         break;
5409     case 4:
5410         retval = syscall(a[0],a[1],a[2],a[3]);
5411         break;
5412     case 5:
5413         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5414         break;
5415     case 6:
5416         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5417         break;
5418     case 7:
5419         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5420         break;
5421     case 8:
5422         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5423         break;
5424 #ifdef atarist
5425     case 9:
5426         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5427         break;
5428     case 10:
5429         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5430         break;
5431     case 11:
5432         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5433           a[10]);
5434         break;
5435     case 12:
5436         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5437           a[10],a[11]);
5438         break;
5439     case 13:
5440         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5441           a[10],a[11],a[12]);
5442         break;
5443     case 14:
5444         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5445           a[10],a[11],a[12],a[13]);
5446         break;
5447 #endif /* atarist */
5448     }
5449     SP = ORIGMARK;
5450     PUSHi(retval);
5451     RETURN;
5452 #else
5453     DIE(aTHX_ PL_no_func, "syscall");
5454 #endif
5455 }
5456
5457 #ifdef FCNTL_EMULATE_FLOCK
5458
5459 /*  XXX Emulate flock() with fcntl().
5460     What's really needed is a good file locking module.
5461 */
5462
5463 static int
5464 fcntl_emulate_flock(int fd, int operation)
5465 {
5466     struct flock flock;
5467
5468     switch (operation & ~LOCK_NB) {
5469     case LOCK_SH:
5470         flock.l_type = F_RDLCK;
5471         break;
5472     case LOCK_EX:
5473         flock.l_type = F_WRLCK;
5474         break;
5475     case LOCK_UN:
5476         flock.l_type = F_UNLCK;
5477         break;
5478     default:
5479         errno = EINVAL;
5480         return -1;
5481     }
5482     flock.l_whence = SEEK_SET;
5483     flock.l_start = flock.l_len = (Off_t)0;
5484
5485     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5486 }
5487
5488 #endif /* FCNTL_EMULATE_FLOCK */
5489
5490 #ifdef LOCKF_EMULATE_FLOCK
5491
5492 /*  XXX Emulate flock() with lockf().  This is just to increase
5493     portability of scripts.  The calls are not completely
5494     interchangeable.  What's really needed is a good file
5495     locking module.
5496 */
5497
5498 /*  The lockf() constants might have been defined in <unistd.h>.
5499     Unfortunately, <unistd.h> causes troubles on some mixed
5500     (BSD/POSIX) systems, such as SunOS 4.1.3.
5501
5502    Further, the lockf() constants aren't POSIX, so they might not be
5503    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5504    just stick in the SVID values and be done with it.  Sigh.
5505 */
5506
5507 # ifndef F_ULOCK
5508 #  define F_ULOCK       0       /* Unlock a previously locked region */
5509 # endif
5510 # ifndef F_LOCK
5511 #  define F_LOCK        1       /* Lock a region for exclusive use */
5512 # endif
5513 # ifndef F_TLOCK
5514 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5515 # endif
5516 # ifndef F_TEST
5517 #  define F_TEST        3       /* Test a region for other processes locks */
5518 # endif
5519
5520 static int
5521 lockf_emulate_flock(int fd, int operation)
5522 {
5523     int i;
5524     int save_errno;
5525     Off_t pos;
5526
5527     /* flock locks entire file so for lockf we need to do the same      */
5528     save_errno = errno;
5529     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5530     if (pos > 0)        /* is seekable and needs to be repositioned     */
5531         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5532             pos = -1;   /* seek failed, so don't seek back afterwards   */
5533     errno = save_errno;
5534
5535     switch (operation) {
5536
5537         /* LOCK_SH - get a shared lock */
5538         case LOCK_SH:
5539         /* LOCK_EX - get an exclusive lock */
5540         case LOCK_EX:
5541             i = lockf (fd, F_LOCK, 0);
5542             break;
5543
5544         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5545         case LOCK_SH|LOCK_NB:
5546         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5547         case LOCK_EX|LOCK_NB:
5548             i = lockf (fd, F_TLOCK, 0);
5549             if (i == -1)
5550                 if ((errno == EAGAIN) || (errno == EACCES))
5551                     errno = EWOULDBLOCK;
5552             break;
5553
5554         /* LOCK_UN - unlock (non-blocking is a no-op) */
5555         case LOCK_UN:
5556         case LOCK_UN|LOCK_NB:
5557             i = lockf (fd, F_ULOCK, 0);
5558             break;
5559
5560         /* Default - can't decipher operation */
5561         default:
5562             i = -1;
5563             errno = EINVAL;
5564             break;
5565     }
5566
5567     if (pos > 0)      /* need to restore position of the handle */
5568         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5569
5570     return (i);
5571 }
5572
5573 #endif /* LOCKF_EMULATE_FLOCK */