pp_sys.c

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