pp_sys.c

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