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