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