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