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