pp_sys.c

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