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         length = PerlLIO_read(PerlIO_fileno(IoIFP(io)), buffer+offset, length);
1426     }
1427     else
1428 #ifdef HAS_SOCKET__bad_code_maybe
1429     if (IoTYPE(io) == 's') {
1430         char namebuf[MAXPATHLEN];
1431 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1432         bufsize = sizeof (struct sockaddr_in);
1433 #else
1434         bufsize = sizeof namebuf;
1435 #endif
1436         length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
1437                           (struct sockaddr *)namebuf, &bufsize);
1438     }
1439     else
1440 #endif
1441     {
1442         length = PerlIO_read(IoIFP(io), buffer+offset, length);
1443         /* fread() returns 0 on both error and EOF */
1444         if (length == 0 && PerlIO_error(IoIFP(io)))
1445             length = -1;
1446     }
1447     if (length < 0)
1448         goto say_undef;
1449     SvCUR_set(bufsv, length+offset);
1450     *SvEND(bufsv) = '\0';
1451     (void)SvPOK_only(bufsv);
1452     SvSETMAGIC(bufsv);
1453     /* This should not be marked tainted if the fp is marked clean */
1454     if (!(IoFLAGS(io) & IOf_UNTAINT))
1455         SvTAINTED_on(bufsv);
1456     SP = ORIGMARK;
1457     PUSHi(length);
1458     RETURN;
1459
1460   say_undef:
1461     SP = ORIGMARK;
1462     RETPUSHUNDEF;
1463 }
1464
1465 PP(pp_syswrite)
1466 {
1467     djSP;
1468     int items = (SP - PL_stack_base) - TOPMARK;
1469     if (items == 2) {
1470         SV *sv;
1471         EXTEND(SP, 1);
1472         sv = sv_2mortal(newSViv(sv_len(*SP)));
1473         PUSHs(sv);
1474         PUTBACK;
1475     }
1476     return pp_send(ARGS);
1477 }
1478
1479 PP(pp_send)
1480 {
1481     djSP; dMARK; dORIGMARK; dTARGET;
1482     GV *gv;
1483     IO *io;
1484     int offset;
1485     SV *bufsv;
1486     char *buffer;
1487     int length;
1488     STRLEN blen;
1489     MAGIC *mg;
1490
1491     gv = (GV*)*++MARK;
1492     if (PL_op->op_type == OP_SYSWRITE && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1493         SV *sv;
1494
1495         PUSHMARK(MARK-1);
1496         *MARK = SvTIED_obj((SV*)gv, mg);
1497         ENTER;
1498         perl_call_method("WRITE", G_SCALAR);
1499         LEAVE;
1500         SPAGAIN;
1501         sv = POPs;
1502         SP = ORIGMARK;
1503         PUSHs(sv);
1504         RETURN;
1505     }
1506     if (!gv)
1507         goto say_undef;
1508     bufsv = *++MARK;
1509     buffer = SvPV(bufsv, blen);
1510     length = SvIVx(*++MARK);
1511     if (length < 0)
1512         DIE("Negative length");
1513     SETERRNO(0,0);
1514     io = GvIO(gv);
1515     if (!io || !IoIFP(io)) {
1516         length = -1;
1517         if (ckWARN(WARN_CLOSED)) {
1518             if (PL_op->op_type == OP_SYSWRITE)
1519                 warner(WARN_CLOSED, "Syswrite on closed filehandle");
1520             else
1521                 warner(WARN_CLOSED, "Send on closed socket");
1522         }
1523     }
1524     else if (PL_op->op_type == OP_SYSWRITE) {
1525         if (MARK < SP) {
1526             offset = SvIVx(*++MARK);
1527             if (offset < 0) {
1528                 if (-offset > blen)
1529                     DIE("Offset outside string");
1530                 offset += blen;
1531             } else if (offset >= blen && blen > 0)
1532                 DIE("Offset outside string");
1533         } else
1534             offset = 0;
1535         if (length > blen - offset)
1536             length = blen - offset;
1537         length = PerlLIO_write(PerlIO_fileno(IoIFP(io)), buffer+offset, length);
1538     }
1539 #ifdef HAS_SOCKET
1540     else if (SP > MARK) {
1541         char *sockbuf;
1542         STRLEN mlen;
1543         sockbuf = SvPVx(*++MARK, mlen);
1544         length = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
1545                                 (struct sockaddr *)sockbuf, mlen);
1546     }
1547     else
1548         length = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
1549
1550 #else
1551     else
1552         DIE(PL_no_sock_func, "send");
1553 #endif
1554     if (length < 0)
1555         goto say_undef;
1556     SP = ORIGMARK;
1557     PUSHi(length);
1558     RETURN;
1559
1560   say_undef:
1561     SP = ORIGMARK;
1562     RETPUSHUNDEF;
1563 }
1564
1565 PP(pp_recv)
1566 {
1567     return pp_sysread(ARGS);
1568 }
1569
1570 PP(pp_eof)
1571 {
1572     djSP;
1573     GV *gv;
1574
1575     if (MAXARG <= 0)
1576         gv = PL_last_in_gv;
1577     else
1578         gv = PL_last_in_gv = (GV*)POPs;
1579     PUSHs(boolSV(!gv || do_eof(gv)));
1580     RETURN;
1581 }
1582
1583 PP(pp_tell)
1584 {
1585     djSP; dTARGET;
1586     GV *gv;
1587
1588     if (MAXARG <= 0)
1589         gv = PL_last_in_gv;
1590     else
1591         gv = PL_last_in_gv = (GV*)POPs;
1592     PUSHi( do_tell(gv) );
1593     RETURN;
1594 }
1595
1596 PP(pp_seek)
1597 {
1598     return pp_sysseek(ARGS);
1599 }
1600
1601 PP(pp_sysseek)
1602 {
1603     djSP;
1604     GV *gv;
1605     int whence = POPi;
1606     Off_t offset = POPl;
1607
1608     gv = PL_last_in_gv = (GV*)POPs;
1609     if (PL_op->op_type == OP_SEEK)
1610         PUSHs(boolSV(do_seek(gv, offset, whence)));
1611     else {
1612         Off_t n = do_sysseek(gv, offset, whence);
1613         PUSHs((n < 0) ? &PL_sv_undef
1614               : sv_2mortal(n ? newSViv((IV)n)
1615                            : newSVpv(zero_but_true, ZBTLEN)));
1616     }
1617     RETURN;
1618 }
1619
1620 PP(pp_truncate)
1621 {
1622     djSP;
1623     Off_t len = (Off_t)POPn;
1624     int result = 1;
1625     GV *tmpgv;
1626
1627     SETERRNO(0,0);
1628 #if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
1629     if (PL_op->op_flags & OPf_SPECIAL) {
1630         tmpgv = gv_fetchpv(POPp, FALSE, SVt_PVIO);
1631     do_ftruncate:
1632         TAINT_PROPER("truncate");
1633         if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
1634 #ifdef HAS_TRUNCATE
1635           ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
1636 #else
1637           my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
1638 #endif
1639             result = 0;
1640     }
1641     else {
1642         SV *sv = POPs;
1643         char *name;
1644
1645         if (SvTYPE(sv) == SVt_PVGV) {
1646             tmpgv = (GV*)sv;            /* *main::FRED for example */
1647             goto do_ftruncate;
1648         }
1649         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1650             tmpgv = (GV*) SvRV(sv);     /* \*main::FRED for example */
1651             goto do_ftruncate;
1652         }
1653
1654         name = SvPV(sv, PL_na);
1655         TAINT_PROPER("truncate");
1656 #ifdef HAS_TRUNCATE
1657         if (truncate(name, len) < 0)
1658             result = 0;
1659 #else
1660         {
1661             int tmpfd;
1662             if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
1663                 result = 0;
1664             else {
1665                 if (my_chsize(tmpfd, len) < 0)
1666                     result = 0;
1667                 PerlLIO_close(tmpfd);
1668             }
1669         }
1670 #endif
1671     }
1672
1673     if (result)
1674         RETPUSHYES;
1675     if (!errno)
1676         SETERRNO(EBADF,RMS$_IFI);
1677     RETPUSHUNDEF;
1678 #else
1679     DIE("truncate not implemented");
1680 #endif
1681 }
1682
1683 PP(pp_fcntl)
1684 {
1685     return pp_ioctl(ARGS);
1686 }
1687
1688 PP(pp_ioctl)
1689 {
1690     djSP; dTARGET;
1691     SV *argsv = POPs;
1692     unsigned int func = U_I(POPn);
1693     int optype = PL_op->op_type;
1694     char *s;
1695     IV retval;
1696     GV *gv = (GV*)POPs;
1697     IO *io = GvIOn(gv);
1698
1699     if (!io || !argsv || !IoIFP(io)) {
1700         SETERRNO(EBADF,RMS$_IFI);       /* well, sort of... */
1701         RETPUSHUNDEF;
1702     }
1703
1704     if (SvPOK(argsv) || !SvNIOK(argsv)) {
1705         STRLEN len;
1706         STRLEN need;
1707         s = SvPV_force(argsv, len);
1708         need = IOCPARM_LEN(func);
1709         if (len < need) {
1710             s = Sv_Grow(argsv, need + 1);
1711             SvCUR_set(argsv, need);
1712         }
1713
1714         s[SvCUR(argsv)] = 17;   /* a little sanity check here */
1715     }
1716     else {
1717         retval = SvIV(argsv);
1718         s = (char*)retval;              /* ouch */
1719     }
1720
1721     TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
1722
1723     if (optype == OP_IOCTL)
1724 #ifdef HAS_IOCTL
1725         retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
1726 #else
1727         DIE("ioctl is not implemented");
1728 #endif
1729     else
1730 #ifdef HAS_FCNTL
1731 #if defined(OS2) && defined(__EMX__)
1732         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
1733 #else
1734         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
1735 #endif
1736 #else
1737         DIE("fcntl is not implemented");
1738 #endif
1739
1740     if (SvPOK(argsv)) {
1741         if (s[SvCUR(argsv)] != 17)
1742             DIE("Possible memory corruption: %s overflowed 3rd argument",
1743                 PL_op_name[optype]);
1744         s[SvCUR(argsv)] = 0;            /* put our null back */
1745         SvSETMAGIC(argsv);              /* Assume it has changed */
1746     }
1747
1748     if (retval == -1)
1749         RETPUSHUNDEF;
1750     if (retval != 0) {
1751         PUSHi(retval);
1752     }
1753     else {
1754         PUSHp(zero_but_true, ZBTLEN);
1755     }
1756     RETURN;
1757 }
1758
1759 PP(pp_flock)
1760 {
1761     djSP; dTARGET;
1762     I32 value;
1763     int argtype;
1764     GV *gv;
1765     PerlIO *fp;
1766
1767 #ifdef FLOCK
1768     argtype = POPi;
1769     if (MAXARG <= 0)
1770         gv = PL_last_in_gv;
1771     else
1772         gv = (GV*)POPs;
1773     if (gv && GvIO(gv))
1774         fp = IoIFP(GvIOp(gv));
1775     else
1776         fp = Nullfp;
1777     if (fp) {
1778         (void)PerlIO_flush(fp);
1779         value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
1780     }
1781     else
1782         value = 0;
1783     PUSHi(value);
1784     RETURN;
1785 #else
1786     DIE(PL_no_func, "flock()");
1787 #endif
1788 }
1789
1790 /* Sockets. */
1791
1792 PP(pp_socket)
1793 {
1794     djSP;
1795 #ifdef HAS_SOCKET
1796     GV *gv;
1797     register IO *io;
1798     int protocol = POPi;
1799     int type = POPi;
1800     int domain = POPi;
1801     int fd;
1802
1803     gv = (GV*)POPs;
1804
1805     if (!gv) {
1806         SETERRNO(EBADF,LIB$_INVARG);
1807         RETPUSHUNDEF;
1808     }
1809
1810     io = GvIOn(gv);
1811     if (IoIFP(io))
1812         do_close(gv, FALSE);
1813
1814     TAINT_PROPER("socket");
1815     fd = PerlSock_socket(domain, type, protocol);
1816     if (fd < 0)
1817         RETPUSHUNDEF;
1818     IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
1819     IoOFP(io) = PerlIO_fdopen(fd, "w");
1820     IoTYPE(io) = 's';
1821     if (!IoIFP(io) || !IoOFP(io)) {
1822         if (IoIFP(io)) PerlIO_close(IoIFP(io));
1823         if (IoOFP(io)) PerlIO_close(IoOFP(io));
1824         if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
1825         RETPUSHUNDEF;
1826     }
1827
1828     RETPUSHYES;
1829 #else
1830     DIE(PL_no_sock_func, "socket");
1831 #endif
1832 }
1833
1834 PP(pp_sockpair)
1835 {
1836     djSP;
1837 #ifdef HAS_SOCKETPAIR
1838     GV *gv1;
1839     GV *gv2;
1840     register IO *io1;
1841     register IO *io2;
1842     int protocol = POPi;
1843     int type = POPi;
1844     int domain = POPi;
1845     int fd[2];
1846
1847     gv2 = (GV*)POPs;
1848     gv1 = (GV*)POPs;
1849     if (!gv1 || !gv2)
1850         RETPUSHUNDEF;
1851
1852     io1 = GvIOn(gv1);
1853     io2 = GvIOn(gv2);
1854     if (IoIFP(io1))
1855         do_close(gv1, FALSE);
1856     if (IoIFP(io2))
1857         do_close(gv2, FALSE);
1858
1859     TAINT_PROPER("socketpair");
1860     if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
1861         RETPUSHUNDEF;
1862     IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
1863     IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
1864     IoTYPE(io1) = 's';
1865     IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
1866     IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
1867     IoTYPE(io2) = 's';
1868     if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
1869         if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
1870         if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
1871         if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
1872         if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
1873         if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
1874         if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
1875         RETPUSHUNDEF;
1876     }
1877
1878     RETPUSHYES;
1879 #else
1880     DIE(PL_no_sock_func, "socketpair");
1881 #endif
1882 }
1883
1884 PP(pp_bind)
1885 {
1886     djSP;
1887 #ifdef HAS_SOCKET
1888 #ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
1889     extern GETPRIVMODE();
1890     extern GETUSERMODE();
1891 #endif
1892     SV *addrsv = POPs;
1893     char *addr;
1894     GV *gv = (GV*)POPs;
1895     register IO *io = GvIOn(gv);
1896     STRLEN len;
1897     int bind_ok = 0;
1898 #ifdef MPE
1899     int mpeprivmode = 0;
1900 #endif
1901
1902     if (!io || !IoIFP(io))
1903         goto nuts;
1904
1905     addr = SvPV(addrsv, len);
1906     TAINT_PROPER("bind");
1907 #ifdef MPE /* Deal with MPE bind() peculiarities */
1908     if (((struct sockaddr *)addr)->sa_family == AF_INET) {
1909         /* The address *MUST* stupidly be zero. */
1910         ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
1911         /* PRIV mode is required to bind() to ports < 1024. */
1912         if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
1913             ((struct sockaddr_in *)addr)->sin_port > 0) {
1914             GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
1915             mpeprivmode = 1;
1916         }
1917     }
1918 #endif /* MPE */
1919     if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
1920                       (struct sockaddr *)addr, len) >= 0)
1921         bind_ok = 1;
1922
1923 #ifdef MPE /* Switch back to USER mode */
1924     if (mpeprivmode)
1925         GETUSERMODE();
1926 #endif /* MPE */
1927
1928     if (bind_ok)
1929         RETPUSHYES;
1930     else
1931         RETPUSHUNDEF;
1932
1933 nuts:
1934     if (ckWARN(WARN_CLOSED))
1935         warner(WARN_CLOSED, "bind() on closed fd");
1936     SETERRNO(EBADF,SS$_IVCHAN);
1937     RETPUSHUNDEF;
1938 #else
1939     DIE(PL_no_sock_func, "bind");
1940 #endif
1941 }
1942
1943 PP(pp_connect)
1944 {
1945     djSP;
1946 #ifdef HAS_SOCKET
1947     SV *addrsv = POPs;
1948     char *addr;
1949     GV *gv = (GV*)POPs;
1950     register IO *io = GvIOn(gv);
1951     STRLEN len;
1952
1953     if (!io || !IoIFP(io))
1954         goto nuts;
1955
1956     addr = SvPV(addrsv, len);
1957     TAINT_PROPER("connect");
1958     if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
1959         RETPUSHYES;
1960     else
1961         RETPUSHUNDEF;
1962
1963 nuts:
1964     if (ckWARN(WARN_CLOSED))
1965         warner(WARN_CLOSED, "connect() on closed fd");
1966     SETERRNO(EBADF,SS$_IVCHAN);
1967     RETPUSHUNDEF;
1968 #else
1969     DIE(PL_no_sock_func, "connect");
1970 #endif
1971 }
1972
1973 PP(pp_listen)
1974 {
1975     djSP;
1976 #ifdef HAS_SOCKET
1977     int backlog = POPi;
1978     GV *gv = (GV*)POPs;
1979     register IO *io = GvIOn(gv);
1980
1981     if (!io || !IoIFP(io))
1982         goto nuts;
1983
1984     if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
1985         RETPUSHYES;
1986     else
1987         RETPUSHUNDEF;
1988
1989 nuts:
1990     if (ckWARN(WARN_CLOSED))
1991         warner(WARN_CLOSED, "listen() on closed fd");
1992     SETERRNO(EBADF,SS$_IVCHAN);
1993     RETPUSHUNDEF;
1994 #else
1995     DIE(PL_no_sock_func, "listen");
1996 #endif
1997 }
1998
1999 PP(pp_accept)
2000 {
2001     djSP; dTARGET;
2002 #ifdef HAS_SOCKET
2003     GV *ngv;
2004     GV *ggv;
2005     register IO *nstio;
2006     register IO *gstio;
2007     struct sockaddr saddr;      /* use a struct to avoid alignment problems */
2008     Sock_size_t len = sizeof saddr;
2009     int fd;
2010
2011     ggv = (GV*)POPs;
2012     ngv = (GV*)POPs;
2013
2014     if (!ngv)
2015         goto badexit;
2016     if (!ggv)
2017         goto nuts;
2018
2019     gstio = GvIO(ggv);
2020     if (!gstio || !IoIFP(gstio))
2021         goto nuts;
2022
2023     nstio = GvIOn(ngv);
2024     if (IoIFP(nstio))
2025         do_close(ngv, FALSE);
2026
2027     fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
2028     if (fd < 0)
2029         goto badexit;
2030     IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2031     IoOFP(nstio) = PerlIO_fdopen(fd, "w");
2032     IoTYPE(nstio) = 's';
2033     if (!IoIFP(nstio) || !IoOFP(nstio)) {
2034         if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2035         if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2036         if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2037         goto badexit;
2038     }
2039
2040     PUSHp((char *)&saddr, len);
2041     RETURN;
2042
2043 nuts:
2044     if (ckWARN(WARN_CLOSED))
2045         warner(WARN_CLOSED, "accept() on closed fd");
2046     SETERRNO(EBADF,SS$_IVCHAN);
2047
2048 badexit:
2049     RETPUSHUNDEF;
2050
2051 #else
2052     DIE(PL_no_sock_func, "accept");
2053 #endif
2054 }
2055
2056 PP(pp_shutdown)
2057 {
2058     djSP; dTARGET;
2059 #ifdef HAS_SOCKET
2060     int how = POPi;
2061     GV *gv = (GV*)POPs;
2062     register IO *io = GvIOn(gv);
2063
2064     if (!io || !IoIFP(io))
2065         goto nuts;
2066
2067     PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2068     RETURN;
2069
2070 nuts:
2071     if (ckWARN(WARN_CLOSED))
2072         warner(WARN_CLOSED, "shutdown() on closed fd");
2073     SETERRNO(EBADF,SS$_IVCHAN);
2074     RETPUSHUNDEF;
2075 #else
2076     DIE(PL_no_sock_func, "shutdown");
2077 #endif
2078 }
2079
2080 PP(pp_gsockopt)
2081 {
2082 #ifdef HAS_SOCKET
2083     return pp_ssockopt(ARGS);
2084 #else
2085     DIE(PL_no_sock_func, "getsockopt");
2086 #endif
2087 }
2088
2089 PP(pp_ssockopt)
2090 {
2091     djSP;
2092 #ifdef HAS_SOCKET
2093     int optype = PL_op->op_type;
2094     SV *sv;
2095     int fd;
2096     unsigned int optname;
2097     unsigned int lvl;
2098     GV *gv;
2099     register IO *io;
2100     Sock_size_t len;
2101
2102     if (optype == OP_GSOCKOPT)
2103         sv = sv_2mortal(NEWSV(22, 257));
2104     else
2105         sv = POPs;
2106     optname = (unsigned int) POPi;
2107     lvl = (unsigned int) POPi;
2108
2109     gv = (GV*)POPs;
2110     io = GvIOn(gv);
2111     if (!io || !IoIFP(io))
2112         goto nuts;
2113
2114     fd = PerlIO_fileno(IoIFP(io));
2115     switch (optype) {
2116     case OP_GSOCKOPT:
2117         SvGROW(sv, 257);
2118         (void)SvPOK_only(sv);
2119         SvCUR_set(sv,256);
2120         *SvEND(sv) ='\0';
2121         len = SvCUR(sv);
2122         if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2123             goto nuts2;
2124         SvCUR_set(sv, len);
2125         *SvEND(sv) ='\0';
2126         PUSHs(sv);
2127         break;
2128     case OP_SSOCKOPT: {
2129             char *buf;
2130             int aint;
2131             if (SvPOKp(sv)) {
2132                 buf = SvPV(sv, PL_na);
2133                 len = PL_na;
2134             }
2135             else {
2136                 aint = (int)SvIV(sv);
2137                 buf = (char*)&aint;
2138                 len = sizeof(int);
2139             }
2140             if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2141                 goto nuts2;
2142             PUSHs(&PL_sv_yes);
2143         }
2144         break;
2145     }
2146     RETURN;
2147
2148 nuts:
2149     if (ckWARN(WARN_CLOSED))
2150         warner(WARN_CLOSED, "[gs]etsockopt() on closed fd");
2151     SETERRNO(EBADF,SS$_IVCHAN);
2152 nuts2:
2153     RETPUSHUNDEF;
2154
2155 #else
2156     DIE(PL_no_sock_func, "setsockopt");
2157 #endif
2158 }
2159
2160 PP(pp_getsockname)
2161 {
2162 #ifdef HAS_SOCKET
2163     return pp_getpeername(ARGS);
2164 #else
2165     DIE(PL_no_sock_func, "getsockname");
2166 #endif
2167 }
2168
2169 PP(pp_getpeername)
2170 {
2171     djSP;
2172 #ifdef HAS_SOCKET
2173     int optype = PL_op->op_type;
2174     SV *sv;
2175     int fd;
2176     GV *gv = (GV*)POPs;
2177     register IO *io = GvIOn(gv);
2178     Sock_size_t len;
2179
2180     if (!io || !IoIFP(io))
2181         goto nuts;
2182
2183     sv = sv_2mortal(NEWSV(22, 257));
2184     (void)SvPOK_only(sv);
2185     len = 256;
2186     SvCUR_set(sv, len);
2187     *SvEND(sv) ='\0';
2188     fd = PerlIO_fileno(IoIFP(io));
2189     switch (optype) {
2190     case OP_GETSOCKNAME:
2191         if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2192             goto nuts2;
2193         break;
2194     case OP_GETPEERNAME:
2195         if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2196             goto nuts2;
2197 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2198         {
2199             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";
2200             /* If the call succeeded, make sure we don't have a zeroed port/addr */
2201             if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2202                 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2203                         sizeof(u_short) + sizeof(struct in_addr))) {
2204                 goto nuts2;
2205             }
2206         }
2207 #endif
2208         break;
2209     }
2210 #ifdef BOGUS_GETNAME_RETURN
2211     /* Interactive Unix, getpeername() and getsockname()
2212       does not return valid namelen */
2213     if (len == BOGUS_GETNAME_RETURN)
2214         len = sizeof(struct sockaddr);
2215 #endif
2216     SvCUR_set(sv, len);
2217     *SvEND(sv) ='\0';
2218     PUSHs(sv);
2219     RETURN;
2220
2221 nuts:
2222     if (ckWARN(WARN_CLOSED))
2223         warner(WARN_CLOSED, "get{sock, peer}name() on closed fd");
2224     SETERRNO(EBADF,SS$_IVCHAN);
2225 nuts2:
2226     RETPUSHUNDEF;
2227
2228 #else
2229     DIE(PL_no_sock_func, "getpeername");
2230 #endif
2231 }
2232
2233 /* Stat calls. */
2234
2235 PP(pp_lstat)
2236 {
2237     return pp_stat(ARGS);
2238 }
2239
2240 PP(pp_stat)
2241 {
2242     djSP;
2243     GV *tmpgv;
2244     I32 gimme;
2245     I32 max = 13;
2246
2247     if (PL_op->op_flags & OPf_REF) {
2248         tmpgv = cGVOP->op_gv;
2249       do_fstat:
2250         if (tmpgv != PL_defgv) {
2251             PL_laststype = OP_STAT;
2252             PL_statgv = tmpgv;
2253             sv_setpv(PL_statname, "");
2254             PL_laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
2255                 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &PL_statcache) : -1);
2256         }
2257         if (PL_laststatval < 0)
2258             max = 0;
2259     }
2260     else {
2261         SV* sv = POPs;
2262         if (SvTYPE(sv) == SVt_PVGV) {
2263             tmpgv = (GV*)sv;
2264             goto do_fstat;
2265         }
2266         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2267             tmpgv = (GV*)SvRV(sv);
2268             goto do_fstat;
2269         }
2270         sv_setpv(PL_statname, SvPV(sv,PL_na));
2271         PL_statgv = Nullgv;
2272 #ifdef HAS_LSTAT
2273         PL_laststype = PL_op->op_type;
2274         if (PL_op->op_type == OP_LSTAT)
2275             PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, PL_na), &PL_statcache);
2276         else
2277 #endif
2278             PL_laststatval = PerlLIO_stat(SvPV(PL_statname, PL_na), &PL_statcache);
2279         if (PL_laststatval < 0) {
2280             if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, PL_na), '\n'))
2281                 warner(WARN_NEWLINE, PL_warn_nl, "stat");
2282             max = 0;
2283         }
2284     }
2285
2286     gimme = GIMME_V;
2287     if (gimme != G_ARRAY) {
2288         if (gimme != G_VOID)
2289             XPUSHs(boolSV(max));
2290         RETURN;
2291     }
2292     if (max) {
2293         EXTEND(SP, max);
2294         EXTEND_MORTAL(max);
2295         PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_dev)));
2296         PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_ino)));
2297         PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_mode)));
2298         PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_nlink)));
2299         PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_uid)));
2300         PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_gid)));
2301 #ifdef USE_STAT_RDEV
2302         PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_rdev)));
2303 #else
2304         PUSHs(sv_2mortal(newSVpv("", 0)));
2305 #endif
2306         PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_size)));
2307 #ifdef BIG_TIME
2308         PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_atime)));
2309         PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_mtime)));
2310         PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_ctime)));
2311 #else
2312         PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_atime)));
2313         PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_mtime)));
2314         PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_ctime)));
2315 #endif
2316 #ifdef USE_STAT_BLOCKS
2317         PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_blksize)));
2318         PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_blocks)));
2319 #else
2320         PUSHs(sv_2mortal(newSVpv("", 0)));
2321         PUSHs(sv_2mortal(newSVpv("", 0)));
2322 #endif
2323     }
2324     RETURN;
2325 }
2326
2327 PP(pp_ftrread)
2328 {
2329     I32 result;
2330     djSP;
2331 #if defined(HAS_ACCESS) && defined(R_OK)
2332     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2333         result = access(TOPp, R_OK);
2334         if (result == 0)
2335             RETPUSHYES;
2336         if (result < 0)
2337             RETPUSHUNDEF;
2338         RETPUSHNO;
2339     }
2340     else
2341         result = my_stat(ARGS);
2342 #else
2343     result = my_stat(ARGS);
2344 #endif
2345     SPAGAIN;
2346     if (result < 0)
2347         RETPUSHUNDEF;
2348     if (cando(S_IRUSR, 0, &PL_statcache))
2349         RETPUSHYES;
2350     RETPUSHNO;
2351 }
2352
2353 PP(pp_ftrwrite)
2354 {
2355     I32 result;
2356     djSP;
2357 #if defined(HAS_ACCESS) && defined(W_OK)
2358     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2359         result = access(TOPp, W_OK);
2360         if (result == 0)
2361             RETPUSHYES;
2362         if (result < 0)
2363             RETPUSHUNDEF;
2364         RETPUSHNO;
2365     }
2366     else
2367         result = my_stat(ARGS);
2368 #else
2369     result = my_stat(ARGS);
2370 #endif
2371     SPAGAIN;
2372     if (result < 0)
2373         RETPUSHUNDEF;
2374     if (cando(S_IWUSR, 0, &PL_statcache))
2375         RETPUSHYES;
2376     RETPUSHNO;
2377 }
2378
2379 PP(pp_ftrexec)
2380 {
2381     I32 result;
2382     djSP;
2383 #if defined(HAS_ACCESS) && defined(X_OK)
2384     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2385         result = access(TOPp, X_OK);
2386         if (result == 0)
2387             RETPUSHYES;
2388         if (result < 0)
2389             RETPUSHUNDEF;
2390         RETPUSHNO;
2391     }
2392     else
2393         result = my_stat(ARGS);
2394 #else
2395     result = my_stat(ARGS);
2396 #endif
2397     SPAGAIN;
2398     if (result < 0)
2399         RETPUSHUNDEF;
2400     if (cando(S_IXUSR, 0, &PL_statcache))
2401         RETPUSHYES;
2402     RETPUSHNO;
2403 }
2404
2405 PP(pp_fteread)
2406 {
2407     I32 result;
2408     djSP;
2409 #ifdef PERL_EFF_ACCESS_R_OK
2410     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2411         result = PERL_EFF_ACCESS_R_OK(TOPp);
2412         if (result == 0)
2413             RETPUSHYES;
2414         if (result < 0)
2415             RETPUSHUNDEF;
2416         RETPUSHNO;
2417     }
2418     else
2419         result = my_stat(ARGS);
2420 #else
2421     result = my_stat(ARGS);
2422 #endif
2423     SPAGAIN;
2424     if (result < 0)
2425         RETPUSHUNDEF;
2426     if (cando(S_IRUSR, 1, &PL_statcache))
2427         RETPUSHYES;
2428     RETPUSHNO;
2429 }
2430
2431 PP(pp_ftewrite)
2432 {
2433     I32 result;
2434     djSP;
2435 #ifdef PERL_EFF_ACCESS_W_OK
2436     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2437         result = PERL_EFF_ACCESS_W_OK(TOPp);
2438         if (result == 0)
2439             RETPUSHYES;
2440         if (result < 0)
2441             RETPUSHUNDEF;
2442         RETPUSHNO;
2443     }
2444     else
2445         result = my_stat(ARGS);
2446 #else
2447     result = my_stat(ARGS);
2448 #endif
2449     SPAGAIN;
2450     if (result < 0)
2451         RETPUSHUNDEF;
2452     if (cando(S_IWUSR, 1, &PL_statcache))
2453         RETPUSHYES;
2454     RETPUSHNO;
2455 }
2456
2457 PP(pp_fteexec)
2458 {
2459     I32 result;
2460     djSP;
2461 #ifdef PERL_EFF_ACCESS_X_OK
2462     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2463         result = PERL_EFF_ACCESS_X_OK(TOPp);
2464         if (result == 0)
2465             RETPUSHYES;
2466         if (result < 0)
2467             RETPUSHUNDEF;
2468         RETPUSHNO;
2469     }
2470     else
2471         result = my_stat(ARGS);
2472 #else
2473     result = my_stat(ARGS);
2474 #endif
2475     SPAGAIN;
2476     if (result < 0)
2477         RETPUSHUNDEF;
2478     if (cando(S_IXUSR, 1, &PL_statcache))
2479         RETPUSHYES;
2480     RETPUSHNO;
2481 }
2482
2483 PP(pp_ftis)
2484 {
2485     I32 result = my_stat(ARGS);
2486     djSP;
2487     if (result < 0)
2488         RETPUSHUNDEF;
2489     RETPUSHYES;
2490 }
2491
2492 PP(pp_fteowned)
2493 {
2494     return pp_ftrowned(ARGS);
2495 }
2496
2497 PP(pp_ftrowned)
2498 {
2499     I32 result = my_stat(ARGS);
2500     djSP;
2501     if (result < 0)
2502         RETPUSHUNDEF;
2503     if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ? PL_euid : PL_uid) )
2504         RETPUSHYES;
2505     RETPUSHNO;
2506 }
2507
2508 PP(pp_ftzero)
2509 {
2510     I32 result = my_stat(ARGS);
2511     djSP;
2512     if (result < 0)
2513         RETPUSHUNDEF;
2514     if (!PL_statcache.st_size)
2515         RETPUSHYES;
2516     RETPUSHNO;
2517 }
2518
2519 PP(pp_ftsize)
2520 {
2521     I32 result = my_stat(ARGS);
2522     djSP; dTARGET;
2523     if (result < 0)
2524         RETPUSHUNDEF;
2525     PUSHi(PL_statcache.st_size);
2526     RETURN;
2527 }
2528
2529 PP(pp_ftmtime)
2530 {
2531     I32 result = my_stat(ARGS);
2532     djSP; dTARGET;
2533     if (result < 0)
2534         RETPUSHUNDEF;
2535     PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_mtime) / 86400.0 );
2536     RETURN;
2537 }
2538
2539 PP(pp_ftatime)
2540 {
2541     I32 result = my_stat(ARGS);
2542     djSP; dTARGET;
2543     if (result < 0)
2544         RETPUSHUNDEF;
2545     PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_atime) / 86400.0 );
2546     RETURN;
2547 }
2548
2549 PP(pp_ftctime)
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_ctime) / 86400.0 );
2556     RETURN;
2557 }
2558
2559 PP(pp_ftsock)
2560 {
2561     I32 result = my_stat(ARGS);
2562     djSP;
2563     if (result < 0)
2564         RETPUSHUNDEF;
2565     if (S_ISSOCK(PL_statcache.st_mode))
2566         RETPUSHYES;
2567     RETPUSHNO;
2568 }
2569
2570 PP(pp_ftchr)
2571 {
2572     I32 result = my_stat(ARGS);
2573     djSP;
2574     if (result < 0)
2575         RETPUSHUNDEF;
2576     if (S_ISCHR(PL_statcache.st_mode))
2577         RETPUSHYES;
2578     RETPUSHNO;
2579 }
2580
2581 PP(pp_ftblk)
2582 {
2583     I32 result = my_stat(ARGS);
2584     djSP;
2585     if (result < 0)
2586         RETPUSHUNDEF;
2587     if (S_ISBLK(PL_statcache.st_mode))
2588         RETPUSHYES;
2589     RETPUSHNO;
2590 }
2591
2592 PP(pp_ftfile)
2593 {
2594     I32 result = my_stat(ARGS);
2595     djSP;
2596     if (result < 0)
2597         RETPUSHUNDEF;
2598     if (S_ISREG(PL_statcache.st_mode))
2599         RETPUSHYES;
2600     RETPUSHNO;
2601 }
2602
2603 PP(pp_ftdir)
2604 {
2605     I32 result = my_stat(ARGS);
2606     djSP;
2607     if (result < 0)
2608         RETPUSHUNDEF;
2609     if (S_ISDIR(PL_statcache.st_mode))
2610         RETPUSHYES;
2611     RETPUSHNO;
2612 }
2613
2614 PP(pp_ftpipe)
2615 {
2616     I32 result = my_stat(ARGS);
2617     djSP;
2618     if (result < 0)
2619         RETPUSHUNDEF;
2620     if (S_ISFIFO(PL_statcache.st_mode))
2621         RETPUSHYES;
2622     RETPUSHNO;
2623 }
2624
2625 PP(pp_ftlink)
2626 {
2627     I32 result = my_lstat(ARGS);
2628     djSP;
2629     if (result < 0)
2630         RETPUSHUNDEF;
2631     if (S_ISLNK(PL_statcache.st_mode))
2632         RETPUSHYES;
2633     RETPUSHNO;
2634 }
2635
2636 PP(pp_ftsuid)
2637 {
2638     djSP;
2639 #ifdef S_ISUID
2640     I32 result = my_stat(ARGS);
2641     SPAGAIN;
2642     if (result < 0)
2643         RETPUSHUNDEF;
2644     if (PL_statcache.st_mode & S_ISUID)
2645         RETPUSHYES;
2646 #endif
2647     RETPUSHNO;
2648 }
2649
2650 PP(pp_ftsgid)
2651 {
2652     djSP;
2653 #ifdef S_ISGID
2654     I32 result = my_stat(ARGS);
2655     SPAGAIN;
2656     if (result < 0)
2657         RETPUSHUNDEF;
2658     if (PL_statcache.st_mode & S_ISGID)
2659         RETPUSHYES;
2660 #endif
2661     RETPUSHNO;
2662 }
2663
2664 PP(pp_ftsvtx)
2665 {
2666     djSP;
2667 #ifdef S_ISVTX
2668     I32 result = my_stat(ARGS);
2669     SPAGAIN;
2670     if (result < 0)
2671         RETPUSHUNDEF;
2672     if (PL_statcache.st_mode & S_ISVTX)
2673         RETPUSHYES;
2674 #endif
2675     RETPUSHNO;
2676 }
2677
2678 PP(pp_fttty)
2679 {
2680     djSP;
2681     int fd;
2682     GV *gv;
2683     char *tmps = Nullch;
2684
2685     if (PL_op->op_flags & OPf_REF)
2686         gv = cGVOP->op_gv;
2687     else if (isGV(TOPs))
2688         gv = (GV*)POPs;
2689     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2690         gv = (GV*)SvRV(POPs);
2691     else
2692         gv = gv_fetchpv(tmps = POPp, FALSE, SVt_PVIO);
2693
2694     if (GvIO(gv) && IoIFP(GvIOp(gv)))
2695         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
2696     else if (tmps && isDIGIT(*tmps))
2697         fd = atoi(tmps);
2698     else
2699         RETPUSHUNDEF;
2700     if (PerlLIO_isatty(fd))
2701         RETPUSHYES;
2702     RETPUSHNO;
2703 }
2704
2705 #if defined(atarist) /* this will work with atariST. Configure will
2706                         make guesses for other systems. */
2707 # define FILE_base(f) ((f)->_base)
2708 # define FILE_ptr(f) ((f)->_ptr)
2709 # define FILE_cnt(f) ((f)->_cnt)
2710 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
2711 #endif
2712
2713 PP(pp_fttext)
2714 {
2715     djSP;
2716     I32 i;
2717     I32 len;
2718     I32 odd = 0;
2719     STDCHAR tbuf[512];
2720     register STDCHAR *s;
2721     register IO *io;
2722     register SV *sv;
2723     GV *gv;
2724
2725     if (PL_op->op_flags & OPf_REF)
2726         gv = cGVOP->op_gv;
2727     else if (isGV(TOPs))
2728         gv = (GV*)POPs;
2729     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2730         gv = (GV*)SvRV(POPs);
2731     else
2732         gv = Nullgv;
2733
2734     if (gv) {
2735         EXTEND(SP, 1);
2736         if (gv == PL_defgv) {
2737             if (PL_statgv)
2738                 io = GvIO(PL_statgv);
2739             else {
2740                 sv = PL_statname;
2741                 goto really_filename;
2742             }
2743         }
2744         else {
2745             PL_statgv = gv;
2746             PL_laststatval = -1;
2747             sv_setpv(PL_statname, "");
2748             io = GvIO(PL_statgv);
2749         }
2750         if (io && IoIFP(io)) {
2751             if (! PerlIO_has_base(IoIFP(io)))
2752                 DIE("-T and -B not implemented on filehandles");
2753             PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2754             if (PL_laststatval < 0)
2755                 RETPUSHUNDEF;
2756             if (S_ISDIR(PL_statcache.st_mode))  /* handle NFS glitch */
2757                 if (PL_op->op_type == OP_FTTEXT)
2758                     RETPUSHNO;
2759                 else
2760                     RETPUSHYES;
2761             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
2762                 i = PerlIO_getc(IoIFP(io));
2763                 if (i != EOF)
2764                     (void)PerlIO_ungetc(IoIFP(io),i);
2765             }
2766             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
2767                 RETPUSHYES;
2768             len = PerlIO_get_bufsiz(IoIFP(io));
2769             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
2770             /* sfio can have large buffers - limit to 512 */
2771             if (len > 512)
2772                 len = 512;
2773         }
2774         else {
2775             if (ckWARN(WARN_UNOPENED))
2776                 warner(WARN_UNOPENED, "Test on unopened file <%s>",
2777                   GvENAME(cGVOP->op_gv));
2778             SETERRNO(EBADF,RMS$_IFI);
2779             RETPUSHUNDEF;
2780         }
2781     }
2782     else {
2783         sv = POPs;
2784       really_filename:
2785         PL_statgv = Nullgv;
2786         PL_laststatval = -1;
2787         sv_setpv(PL_statname, SvPV(sv, PL_na));
2788 #ifdef HAS_OPEN3
2789         i = PerlLIO_open3(SvPV(sv, PL_na), O_RDONLY, 0);
2790 #else
2791         i = PerlLIO_open(SvPV(sv, PL_na), 0);
2792 #endif
2793         if (i < 0) {
2794             if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, PL_na), '\n'))
2795                 warner(WARN_NEWLINE, PL_warn_nl, "open");
2796             RETPUSHUNDEF;
2797         }
2798         PL_laststatval = PerlLIO_fstat(i, &PL_statcache);
2799         if (PL_laststatval < 0)
2800             RETPUSHUNDEF;
2801         len = PerlLIO_read(i, tbuf, 512);
2802         (void)PerlLIO_close(i);
2803         if (len <= 0) {
2804             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
2805                 RETPUSHNO;              /* special case NFS directories */
2806             RETPUSHYES;         /* null file is anything */
2807         }
2808         s = tbuf;
2809     }
2810
2811     /* now scan s to look for textiness */
2812     /*   XXX ASCII dependent code */
2813
2814     for (i = 0; i < len; i++, s++) {
2815         if (!*s) {                      /* null never allowed in text */
2816             odd += len;
2817             break;
2818         }
2819 #ifdef EBCDIC
2820         else if (!(isPRINT(*s) || isSPACE(*s)))
2821             odd++;
2822 #else
2823         else if (*s & 128)
2824             odd++;
2825         else if (*s < 32 &&
2826           *s != '\n' && *s != '\r' && *s != '\b' &&
2827           *s != '\t' && *s != '\f' && *s != 27)
2828             odd++;
2829 #endif
2830     }
2831
2832     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
2833         RETPUSHNO;
2834     else
2835         RETPUSHYES;
2836 }
2837
2838 PP(pp_ftbinary)
2839 {
2840     return pp_fttext(ARGS);
2841 }
2842
2843 /* File calls. */
2844
2845 PP(pp_chdir)
2846 {
2847     djSP; dTARGET;
2848     char *tmps;
2849     SV **svp;
2850
2851     if (MAXARG < 1)
2852         tmps = Nullch;
2853     else
2854         tmps = POPp;
2855     if (!tmps || !*tmps) {
2856         svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
2857         if (svp)
2858             tmps = SvPV(*svp, PL_na);
2859     }
2860     if (!tmps || !*tmps) {
2861         svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
2862         if (svp)
2863             tmps = SvPV(*svp, PL_na);
2864     }
2865 #ifdef VMS
2866     if (!tmps || !*tmps) {
2867        svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
2868        if (svp)
2869            tmps = SvPV(*svp, PL_na);
2870     }
2871 #endif
2872     TAINT_PROPER("chdir");
2873     PUSHi( PerlDir_chdir(tmps) >= 0 );
2874 #ifdef VMS
2875     /* Clear the DEFAULT element of ENV so we'll get the new value
2876      * in the future. */
2877     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
2878 #endif
2879     RETURN;
2880 }
2881
2882 PP(pp_chown)
2883 {
2884     djSP; dMARK; dTARGET;
2885     I32 value;
2886 #ifdef HAS_CHOWN
2887     value = (I32)apply(PL_op->op_type, MARK, SP);
2888     SP = MARK;
2889     PUSHi(value);
2890     RETURN;
2891 #else
2892     DIE(PL_no_func, "Unsupported function chown");
2893 #endif
2894 }
2895
2896 PP(pp_chroot)
2897 {
2898     djSP; dTARGET;
2899     char *tmps;
2900 #ifdef HAS_CHROOT
2901     tmps = POPp;
2902     TAINT_PROPER("chroot");
2903     PUSHi( chroot(tmps) >= 0 );
2904     RETURN;
2905 #else
2906     DIE(PL_no_func, "chroot");
2907 #endif
2908 }
2909
2910 PP(pp_unlink)
2911 {
2912     djSP; dMARK; dTARGET;
2913     I32 value;
2914     value = (I32)apply(PL_op->op_type, MARK, SP);
2915     SP = MARK;
2916     PUSHi(value);
2917     RETURN;
2918 }
2919
2920 PP(pp_chmod)
2921 {
2922     djSP; dMARK; dTARGET;
2923     I32 value;
2924     value = (I32)apply(PL_op->op_type, MARK, SP);
2925     SP = MARK;
2926     PUSHi(value);
2927     RETURN;
2928 }
2929
2930 PP(pp_utime)
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_rename)
2941 {
2942     djSP; dTARGET;
2943     int anum;
2944
2945     char *tmps2 = POPp;
2946     char *tmps = SvPV(TOPs, PL_na);
2947     TAINT_PROPER("rename");
2948 #ifdef HAS_RENAME
2949     anum = PerlLIO_rename(tmps, tmps2);
2950 #else
2951     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
2952         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
2953             anum = 1;
2954         else {
2955             if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
2956                 (void)UNLINK(tmps2);
2957             if (!(anum = link(tmps, tmps2)))
2958                 anum = UNLINK(tmps);
2959         }
2960     }
2961 #endif
2962     SETi( anum >= 0 );
2963     RETURN;
2964 }
2965
2966 PP(pp_link)
2967 {
2968     djSP; dTARGET;
2969 #ifdef HAS_LINK
2970     char *tmps2 = POPp;
2971     char *tmps = SvPV(TOPs, PL_na);
2972     TAINT_PROPER("link");
2973     SETi( link(tmps, tmps2) >= 0 );
2974 #else
2975     DIE(PL_no_func, "Unsupported function link");
2976 #endif
2977     RETURN;
2978 }
2979
2980 PP(pp_symlink)
2981 {
2982     djSP; dTARGET;
2983 #ifdef HAS_SYMLINK
2984     char *tmps2 = POPp;
2985     char *tmps = SvPV(TOPs, PL_na);
2986     TAINT_PROPER("symlink");
2987     SETi( symlink(tmps, tmps2) >= 0 );
2988     RETURN;
2989 #else
2990     DIE(PL_no_func, "symlink");
2991 #endif
2992 }
2993
2994 PP(pp_readlink)
2995 {
2996     djSP; dTARGET;
2997 #ifdef HAS_SYMLINK
2998     char *tmps;
2999     char buf[MAXPATHLEN];
3000     int len;
3001
3002 #ifndef INCOMPLETE_TAINTS
3003     TAINT;
3004 #endif
3005     tmps = POPp;
3006     len = readlink(tmps, buf, sizeof buf);
3007     EXTEND(SP, 1);
3008     if (len < 0)
3009         RETPUSHUNDEF;
3010     PUSHp(buf, len);
3011     RETURN;
3012 #else
3013     EXTEND(SP, 1);
3014     RETSETUNDEF;                /* just pretend it's a normal file */
3015 #endif
3016 }
3017
3018 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3019 static int
3020 dooneliner(cmd, filename)
3021 char *cmd;
3022 char *filename;
3023 {
3024     char *save_filename = filename;
3025     char *cmdline;
3026     char *s;
3027     PerlIO *myfp;
3028     int anum = 1;
3029
3030     New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3031     strcpy(cmdline, cmd);
3032     strcat(cmdline, " ");
3033     for (s = cmdline + strlen(cmdline); *filename; ) {
3034         *s++ = '\\';
3035         *s++ = *filename++;
3036     }
3037     strcpy(s, " 2>&1");
3038     myfp = PerlProc_popen(cmdline, "r");
3039     Safefree(cmdline);
3040
3041     if (myfp) {
3042         SV *tmpsv = sv_newmortal();
3043         /* Need to save/restore 'PL_rs' ?? */
3044         s = sv_gets(tmpsv, myfp, 0);
3045         (void)PerlProc_pclose(myfp);
3046         if (s != Nullch) {
3047             int e;
3048             for (e = 1;
3049 #ifdef HAS_SYS_ERRLIST
3050                  e <= sys_nerr
3051 #endif
3052                  ; e++)
3053             {
3054                 /* you don't see this */
3055                 char *errmsg =
3056 #ifdef HAS_SYS_ERRLIST
3057                     sys_errlist[e]
3058 #else
3059                     strerror(e)
3060 #endif
3061                     ;
3062                 if (!errmsg)
3063                     break;
3064                 if (instr(s, errmsg)) {
3065                     SETERRNO(e,0);
3066                     return 0;
3067                 }
3068             }
3069             SETERRNO(0,0);
3070 #ifndef EACCES
3071 #define EACCES EPERM
3072 #endif
3073             if (instr(s, "cannot make"))
3074                 SETERRNO(EEXIST,RMS$_FEX);
3075             else if (instr(s, "existing file"))
3076                 SETERRNO(EEXIST,RMS$_FEX);
3077             else if (instr(s, "ile exists"))
3078                 SETERRNO(EEXIST,RMS$_FEX);
3079             else if (instr(s, "non-exist"))
3080                 SETERRNO(ENOENT,RMS$_FNF);
3081             else if (instr(s, "does not exist"))
3082                 SETERRNO(ENOENT,RMS$_FNF);
3083             else if (instr(s, "not empty"))
3084                 SETERRNO(EBUSY,SS$_DEVOFFLINE);
3085             else if (instr(s, "cannot access"))
3086                 SETERRNO(EACCES,RMS$_PRV);
3087             else
3088                 SETERRNO(EPERM,RMS$_PRV);
3089             return 0;
3090         }
3091         else {  /* some mkdirs return no failure indication */
3092             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3093             if (PL_op->op_type == OP_RMDIR)
3094                 anum = !anum;
3095             if (anum)
3096                 SETERRNO(0,0);
3097             else
3098                 SETERRNO(EACCES,RMS$_PRV);      /* a guess */
3099         }
3100         return anum;
3101     }
3102     else
3103         return 0;
3104 }
3105 #endif
3106
3107 PP(pp_mkdir)
3108 {
3109     djSP; dTARGET;
3110     int mode = POPi;
3111 #ifndef HAS_MKDIR
3112     int oldumask;
3113 #endif
3114     char *tmps = SvPV(TOPs, PL_na);
3115
3116     TAINT_PROPER("mkdir");
3117 #ifdef HAS_MKDIR
3118     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3119 #else
3120     SETi( dooneliner("mkdir", tmps) );
3121     oldumask = PerlLIO_umask(0);
3122     PerlLIO_umask(oldumask);
3123     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3124 #endif
3125     RETURN;
3126 }
3127
3128 PP(pp_rmdir)
3129 {
3130     djSP; dTARGET;
3131     char *tmps;
3132
3133     tmps = POPp;
3134     TAINT_PROPER("rmdir");
3135 #ifdef HAS_RMDIR
3136     XPUSHi( PerlDir_rmdir(tmps) >= 0 );
3137 #else
3138     XPUSHi( dooneliner("rmdir", tmps) );
3139 #endif
3140     RETURN;
3141 }
3142
3143 /* Directory calls. */
3144
3145 PP(pp_open_dir)
3146 {
3147     djSP;
3148 #if defined(Direntry_t) && defined(HAS_READDIR)
3149     char *dirname = POPp;
3150     GV *gv = (GV*)POPs;
3151     register IO *io = GvIOn(gv);
3152
3153     if (!io)
3154         goto nope;
3155
3156     if (IoDIRP(io))
3157         PerlDir_close(IoDIRP(io));
3158     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3159         goto nope;
3160
3161     RETPUSHYES;
3162 nope:
3163     if (!errno)
3164         SETERRNO(EBADF,RMS$_DIR);
3165     RETPUSHUNDEF;
3166 #else
3167     DIE(PL_no_dir_func, "opendir");
3168 #endif
3169 }
3170
3171 PP(pp_readdir)
3172 {
3173     djSP;
3174 #if defined(Direntry_t) && defined(HAS_READDIR)
3175 #ifndef I_DIRENT
3176     Direntry_t *readdir _((DIR *));
3177 #endif
3178     register Direntry_t *dp;
3179     GV *gv = (GV*)POPs;
3180     register IO *io = GvIOn(gv);
3181     SV *sv;
3182
3183     if (!io || !IoDIRP(io))
3184         goto nope;
3185
3186     if (GIMME == G_ARRAY) {
3187         /*SUPPRESS 560*/
3188         while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
3189 #ifdef DIRNAMLEN
3190             sv = newSVpv(dp->d_name, dp->d_namlen);
3191 #else
3192             sv = newSVpv(dp->d_name, 0);
3193 #endif
3194 #ifndef INCOMPLETE_TAINTS
3195             SvTAINTED_on(sv);
3196 #endif
3197             XPUSHs(sv_2mortal(sv));
3198         }
3199     }
3200     else {
3201         if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
3202             goto nope;
3203 #ifdef DIRNAMLEN
3204         sv = newSVpv(dp->d_name, dp->d_namlen);
3205 #else
3206         sv = newSVpv(dp->d_name, 0);
3207 #endif
3208 #ifndef INCOMPLETE_TAINTS
3209         SvTAINTED_on(sv);
3210 #endif
3211         XPUSHs(sv_2mortal(sv));
3212     }
3213     RETURN;
3214
3215 nope:
3216     if (!errno)
3217         SETERRNO(EBADF,RMS$_ISI);
3218     if (GIMME == G_ARRAY)
3219         RETURN;
3220     else
3221         RETPUSHUNDEF;
3222 #else
3223     DIE(PL_no_dir_func, "readdir");
3224 #endif
3225 }
3226
3227 PP(pp_telldir)
3228 {
3229     djSP; dTARGET;
3230 #if defined(HAS_TELLDIR) || defined(telldir)
3231 # ifdef NEED_TELLDIR_PROTO /* XXX does _anyone_ need this? --AD 2/20/1998 */
3232     long telldir _((DIR *));
3233 # endif
3234     GV *gv = (GV*)POPs;
3235     register IO *io = GvIOn(gv);
3236
3237     if (!io || !IoDIRP(io))
3238         goto nope;
3239
3240     PUSHi( PerlDir_tell(IoDIRP(io)) );
3241     RETURN;
3242 nope:
3243     if (!errno)
3244         SETERRNO(EBADF,RMS$_ISI);
3245     RETPUSHUNDEF;
3246 #else
3247     DIE(PL_no_dir_func, "telldir");
3248 #endif
3249 }
3250
3251 PP(pp_seekdir)
3252 {
3253     djSP;
3254 #if defined(HAS_SEEKDIR) || defined(seekdir)
3255     long along = POPl;
3256     GV *gv = (GV*)POPs;
3257     register IO *io = GvIOn(gv);
3258
3259     if (!io || !IoDIRP(io))
3260         goto nope;
3261
3262     (void)PerlDir_seek(IoDIRP(io), along);
3263
3264     RETPUSHYES;
3265 nope:
3266     if (!errno)
3267         SETERRNO(EBADF,RMS$_ISI);
3268     RETPUSHUNDEF;
3269 #else
3270     DIE(PL_no_dir_func, "seekdir");
3271 #endif
3272 }
3273
3274 PP(pp_rewinddir)
3275 {
3276     djSP;
3277 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3278     GV *gv = (GV*)POPs;
3279     register IO *io = GvIOn(gv);
3280
3281     if (!io || !IoDIRP(io))
3282         goto nope;
3283
3284     (void)PerlDir_rewind(IoDIRP(io));
3285     RETPUSHYES;
3286 nope:
3287     if (!errno)
3288         SETERRNO(EBADF,RMS$_ISI);
3289     RETPUSHUNDEF;
3290 #else
3291     DIE(PL_no_dir_func, "rewinddir");
3292 #endif
3293 }
3294
3295 PP(pp_closedir)
3296 {
3297     djSP;
3298 #if defined(Direntry_t) && defined(HAS_READDIR)
3299     GV *gv = (GV*)POPs;
3300     register IO *io = GvIOn(gv);
3301
3302     if (!io || !IoDIRP(io))
3303         goto nope;
3304
3305 #ifdef VOID_CLOSEDIR
3306     PerlDir_close(IoDIRP(io));
3307 #else
3308     if (PerlDir_close(IoDIRP(io)) < 0) {
3309         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3310         goto nope;
3311     }
3312 #endif
3313     IoDIRP(io) = 0;
3314
3315     RETPUSHYES;
3316 nope:
3317     if (!errno)
3318         SETERRNO(EBADF,RMS$_IFI);
3319     RETPUSHUNDEF;
3320 #else
3321     DIE(PL_no_dir_func, "closedir");
3322 #endif
3323 }
3324
3325 /* Process control. */
3326
3327 PP(pp_fork)
3328 {
3329 #ifdef HAS_FORK
3330     djSP; dTARGET;
3331     int childpid;
3332     GV *tmpgv;
3333
3334     EXTEND(SP, 1);
3335     childpid = fork();
3336     if (childpid < 0)
3337         RETSETUNDEF;
3338     if (!childpid) {
3339         /*SUPPRESS 560*/
3340         if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
3341             sv_setiv(GvSV(tmpgv), (IV)getpid());
3342         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3343     }
3344     PUSHi(childpid);
3345     RETURN;
3346 #else
3347     DIE(PL_no_func, "Unsupported function fork");
3348 #endif
3349 }
3350
3351 PP(pp_wait)
3352 {
3353 #if !defined(DOSISH) || defined(OS2) || defined(WIN32)
3354     djSP; dTARGET;
3355     int childpid;
3356     int argflags;
3357
3358     childpid = wait4pid(-1, &argflags, 0);
3359     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3360     XPUSHi(childpid);
3361     RETURN;
3362 #else
3363     DIE(PL_no_func, "Unsupported function wait");
3364 #endif
3365 }
3366
3367 PP(pp_waitpid)
3368 {
3369 #if !defined(DOSISH) || defined(OS2) || defined(WIN32)
3370     djSP; dTARGET;
3371     int childpid;
3372     int optype;
3373     int argflags;
3374
3375     optype = POPi;
3376     childpid = TOPi;
3377     childpid = wait4pid(childpid, &argflags, optype);
3378     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3379     SETi(childpid);
3380     RETURN;
3381 #else
3382     DIE(PL_no_func, "Unsupported function waitpid");
3383 #endif
3384 }
3385
3386 PP(pp_system)
3387 {
3388     djSP; dMARK; dORIGMARK; dTARGET;
3389     I32 value;
3390     int childpid;
3391     int result;
3392     int status;
3393     Sigsave_t ihand,qhand;     /* place to save signals during system() */
3394
3395     if (SP - MARK == 1) {
3396         if (PL_tainting) {
3397             char *junk = SvPV(TOPs, PL_na);
3398             TAINT_ENV();
3399             TAINT_PROPER("system");
3400         }
3401     }
3402 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
3403     while ((childpid = vfork()) == -1) {
3404         if (errno != EAGAIN) {
3405             value = -1;
3406             SP = ORIGMARK;
3407             PUSHi(value);
3408             RETURN;
3409         }
3410         sleep(5);
3411     }
3412     if (childpid > 0) {
3413         rsignal_save(SIGINT, SIG_IGN, &ihand);
3414         rsignal_save(SIGQUIT, SIG_IGN, &qhand);
3415         do {
3416             result = wait4pid(childpid, &status, 0);
3417         } while (result == -1 && errno == EINTR);
3418         (void)rsignal_restore(SIGINT, &ihand);
3419         (void)rsignal_restore(SIGQUIT, &qhand);
3420         STATUS_NATIVE_SET(result == -1 ? -1 : status);
3421         do_execfree();  /* free any memory child malloced on vfork */
3422         SP = ORIGMARK;
3423         PUSHi(STATUS_CURRENT);
3424         RETURN;
3425     }
3426     if (PL_op->op_flags & OPf_STACKED) {
3427         SV *really = *++MARK;
3428         value = (I32)do_aexec(really, MARK, SP);
3429     }
3430     else if (SP - MARK != 1)
3431         value = (I32)do_aexec(Nullsv, MARK, SP);
3432     else {
3433         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), PL_na));
3434     }
3435     PerlProc__exit(-1);
3436 #else /* ! FORK or VMS or OS/2 */
3437     if (PL_op->op_flags & OPf_STACKED) {
3438         SV *really = *++MARK;
3439         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
3440     }
3441     else if (SP - MARK != 1)
3442         value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
3443     else {
3444         value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), PL_na));
3445     }
3446     STATUS_NATIVE_SET(value);
3447     do_execfree();
3448     SP = ORIGMARK;
3449     PUSHi(STATUS_CURRENT);
3450 #endif /* !FORK or VMS */
3451     RETURN;
3452 }
3453
3454 PP(pp_exec)
3455 {
3456     djSP; dMARK; dORIGMARK; dTARGET;
3457     I32 value;
3458
3459     if (PL_op->op_flags & OPf_STACKED) {
3460         SV *really = *++MARK;
3461         value = (I32)do_aexec(really, MARK, SP);
3462     }
3463     else if (SP - MARK != 1)
3464 #ifdef VMS
3465         value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3466 #else
3467 #  ifdef __OPEN_VM
3468         {
3469            (void ) do_aspawn(Nullsv, MARK, SP);
3470            value = 0;
3471         }
3472 #  else
3473         value = (I32)do_aexec(Nullsv, MARK, SP);
3474 #  endif
3475 #endif
3476     else {
3477         if (PL_tainting) {
3478             char *junk = SvPV(*SP, PL_na);
3479             TAINT_ENV();
3480             TAINT_PROPER("exec");
3481         }
3482 #ifdef VMS
3483         value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), PL_na));
3484 #else
3485 #  ifdef __OPEN_VM
3486         (void) do_spawn(SvPVx(sv_mortalcopy(*SP), PL_na));
3487         value = 0;
3488 #  else
3489         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), PL_na));
3490 #  endif
3491 #endif
3492     }
3493     SP = ORIGMARK;
3494     PUSHi(value);
3495     RETURN;
3496 }
3497
3498 PP(pp_kill)
3499 {
3500     djSP; dMARK; dTARGET;
3501     I32 value;
3502 #ifdef HAS_KILL
3503     value = (I32)apply(PL_op->op_type, MARK, SP);
3504     SP = MARK;
3505     PUSHi(value);
3506     RETURN;
3507 #else
3508     DIE(PL_no_func, "Unsupported function kill");
3509 #endif
3510 }
3511
3512 PP(pp_getppid)
3513 {
3514 #ifdef HAS_GETPPID
3515     djSP; dTARGET;
3516     XPUSHi( getppid() );
3517     RETURN;
3518 #else
3519     DIE(PL_no_func, "getppid");
3520 #endif
3521 }
3522
3523 PP(pp_getpgrp)
3524 {
3525 #ifdef HAS_GETPGRP
3526     djSP; dTARGET;
3527     int pid;
3528     I32 value;
3529
3530     if (MAXARG < 1)
3531         pid = 0;
3532     else
3533         pid = SvIVx(POPs);
3534 #ifdef BSD_GETPGRP
3535     value = (I32)BSD_GETPGRP(pid);
3536 #else
3537     if (pid != 0 && pid != getpid())
3538         DIE("POSIX getpgrp can't take an argument");
3539     value = (I32)getpgrp();
3540 #endif
3541     XPUSHi(value);
3542     RETURN;
3543 #else
3544     DIE(PL_no_func, "getpgrp()");
3545 #endif
3546 }
3547
3548 PP(pp_setpgrp)
3549 {
3550 #ifdef HAS_SETPGRP
3551     djSP; dTARGET;
3552     int pgrp;
3553     int pid;
3554     if (MAXARG < 2) {
3555         pgrp = 0;
3556         pid = 0;
3557     }
3558     else {
3559         pgrp = POPi;
3560         pid = TOPi;
3561     }
3562
3563     TAINT_PROPER("setpgrp");
3564 #ifdef BSD_SETPGRP
3565     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
3566 #else
3567     if ((pgrp != 0 && pgrp != getpid()) || (pid != 0 && pid != getpid()))
3568         DIE("POSIX setpgrp can't take an argument");
3569     SETi( setpgrp() >= 0 );
3570 #endif /* USE_BSDPGRP */
3571     RETURN;
3572 #else
3573     DIE(PL_no_func, "setpgrp()");
3574 #endif
3575 }
3576
3577 PP(pp_getpriority)
3578 {
3579     djSP; dTARGET;
3580     int which;
3581     int who;
3582 #ifdef HAS_GETPRIORITY
3583     who = POPi;
3584     which = TOPi;
3585     SETi( getpriority(which, who) );
3586     RETURN;
3587 #else
3588     DIE(PL_no_func, "getpriority()");
3589 #endif
3590 }
3591
3592 PP(pp_setpriority)
3593 {
3594     djSP; dTARGET;
3595     int which;
3596     int who;
3597     int niceval;
3598 #ifdef HAS_SETPRIORITY
3599     niceval = POPi;
3600     who = POPi;
3601     which = TOPi;
3602     TAINT_PROPER("setpriority");
3603     SETi( setpriority(which, who, niceval) >= 0 );
3604     RETURN;
3605 #else
3606     DIE(PL_no_func, "setpriority()");
3607 #endif
3608 }
3609
3610 /* Time calls. */
3611
3612 PP(pp_time)
3613 {
3614     djSP; dTARGET;
3615 #ifdef BIG_TIME
3616     XPUSHn( time(Null(Time_t*)) );
3617 #else
3618     XPUSHi( time(Null(Time_t*)) );
3619 #endif
3620     RETURN;
3621 }
3622
3623 /* XXX The POSIX name is CLK_TCK; it is to be preferred
3624    to HZ.  Probably.  For now, assume that if the system
3625    defines HZ, it does so correctly.  (Will this break
3626    on VMS?)
3627    Probably we ought to use _sysconf(_SC_CLK_TCK), if
3628    it's supported.    --AD  9/96.
3629 */
3630
3631 #ifndef HZ
3632 #  ifdef CLK_TCK
3633 #    define HZ CLK_TCK
3634 #  else
3635 #    define HZ 60
3636 #  endif
3637 #endif
3638
3639 PP(pp_tms)
3640 {
3641     djSP;
3642
3643 #ifndef HAS_TIMES
3644     DIE("times not implemented");
3645 #else
3646     EXTEND(SP, 4);
3647
3648 #ifndef VMS
3649     (void)PerlProc_times(&PL_timesbuf);
3650 #else
3651     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
3652                                                    /* struct tms, though same data   */
3653                                                    /* is returned.                   */
3654 #endif
3655
3656     PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_utime)/HZ)));
3657     if (GIMME == G_ARRAY) {
3658         PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_stime)/HZ)));
3659         PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_cutime)/HZ)));
3660         PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_cstime)/HZ)));
3661     }
3662     RETURN;
3663 #endif /* HAS_TIMES */
3664 }
3665
3666 PP(pp_localtime)
3667 {
3668     return pp_gmtime(ARGS);
3669 }
3670
3671 PP(pp_gmtime)
3672 {
3673     djSP;
3674     Time_t when;
3675     struct tm *tmbuf;
3676     static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
3677     static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
3678                               "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
3679
3680     if (MAXARG < 1)
3681         (void)time(&when);
3682     else
3683 #ifdef BIG_TIME
3684         when = (Time_t)SvNVx(POPs);
3685 #else
3686         when = (Time_t)SvIVx(POPs);
3687 #endif
3688
3689     if (PL_op->op_type == OP_LOCALTIME)
3690         tmbuf = localtime(&when);
3691     else
3692         tmbuf = gmtime(&when);
3693
3694     EXTEND(SP, 9);
3695     EXTEND_MORTAL(9);
3696     if (GIMME != G_ARRAY) {
3697         dTARGET;
3698         SV *tsv;
3699         if (!tmbuf)
3700             RETPUSHUNDEF;
3701         tsv = newSVpvf("%s %s %2d %02d:%02d:%02d %d",
3702                        dayname[tmbuf->tm_wday],
3703                        monname[tmbuf->tm_mon],
3704                        tmbuf->tm_mday,
3705                        tmbuf->tm_hour,
3706                        tmbuf->tm_min,
3707                        tmbuf->tm_sec,
3708                        tmbuf->tm_year + 1900);
3709         PUSHs(sv_2mortal(tsv));
3710     }
3711     else if (tmbuf) {
3712         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_sec)));
3713         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_min)));
3714         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_hour)));
3715         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mday)));
3716         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mon)));
3717         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_year)));
3718         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_wday)));
3719         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_yday)));
3720         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_isdst)));
3721     }
3722     RETURN;
3723 }
3724
3725 PP(pp_alarm)
3726 {
3727     djSP; dTARGET;
3728     int anum;
3729 #ifdef HAS_ALARM
3730     anum = POPi;
3731     anum = alarm((unsigned int)anum);
3732     EXTEND(SP, 1);
3733     if (anum < 0)
3734         RETPUSHUNDEF;
3735     PUSHi((I32)anum);
3736     RETURN;
3737 #else
3738     DIE(PL_no_func, "Unsupported function alarm");
3739 #endif
3740 }
3741
3742 PP(pp_sleep)
3743 {
3744     djSP; dTARGET;
3745     I32 duration;
3746     Time_t lasttime;
3747     Time_t when;
3748
3749     (void)time(&lasttime);
3750     if (MAXARG < 1)
3751         PerlProc_pause();
3752     else {
3753         duration = POPi;
3754         PerlProc_sleep((unsigned int)duration);
3755     }
3756     (void)time(&when);
3757     XPUSHi(when - lasttime);
3758     RETURN;
3759 }
3760
3761 /* Shared memory. */
3762
3763 PP(pp_shmget)
3764 {
3765     return pp_semget(ARGS);
3766 }
3767
3768 PP(pp_shmctl)
3769 {
3770     return pp_semctl(ARGS);
3771 }
3772
3773 PP(pp_shmread)
3774 {
3775     return pp_shmwrite(ARGS);
3776 }
3777
3778 PP(pp_shmwrite)
3779 {
3780 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3781     djSP; dMARK; dTARGET;
3782     I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
3783     SP = MARK;
3784     PUSHi(value);
3785     RETURN;
3786 #else
3787     return pp_semget(ARGS);
3788 #endif
3789 }
3790
3791 /* Message passing. */
3792
3793 PP(pp_msgget)
3794 {
3795     return pp_semget(ARGS);
3796 }
3797
3798 PP(pp_msgctl)
3799 {
3800     return pp_semctl(ARGS);
3801 }
3802
3803 PP(pp_msgsnd)
3804 {
3805 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3806     djSP; dMARK; dTARGET;
3807     I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
3808     SP = MARK;
3809     PUSHi(value);
3810     RETURN;
3811 #else
3812     return pp_semget(ARGS);
3813 #endif
3814 }
3815
3816 PP(pp_msgrcv)
3817 {
3818 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3819     djSP; dMARK; dTARGET;
3820     I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
3821     SP = MARK;
3822     PUSHi(value);
3823     RETURN;
3824 #else
3825     return pp_semget(ARGS);
3826 #endif
3827 }
3828
3829 /* Semaphores. */
3830
3831 PP(pp_semget)
3832 {
3833 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3834     djSP; dMARK; dTARGET;
3835     int anum = do_ipcget(PL_op->op_type, MARK, SP);
3836     SP = MARK;
3837     if (anum == -1)
3838         RETPUSHUNDEF;
3839     PUSHi(anum);
3840     RETURN;
3841 #else
3842     DIE("System V IPC is not implemented on this machine");
3843 #endif
3844 }
3845
3846 PP(pp_semctl)
3847 {
3848 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3849     djSP; dMARK; dTARGET;
3850     int anum = do_ipcctl(PL_op->op_type, MARK, SP);
3851     SP = MARK;
3852     if (anum == -1)
3853         RETSETUNDEF;
3854     if (anum != 0) {
3855         PUSHi(anum);
3856     }
3857     else {
3858         PUSHp(zero_but_true, ZBTLEN);
3859     }
3860     RETURN;
3861 #else
3862     return pp_semget(ARGS);
3863 #endif
3864 }
3865
3866 PP(pp_semop)
3867 {
3868 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3869     djSP; dMARK; dTARGET;
3870     I32 value = (I32)(do_semop(MARK, SP) >= 0);
3871     SP = MARK;
3872     PUSHi(value);
3873     RETURN;
3874 #else
3875     return pp_semget(ARGS);
3876 #endif
3877 }
3878
3879 /* Get system info. */
3880
3881 PP(pp_ghbyname)
3882 {
3883 #ifdef HAS_GETHOSTBYNAME
3884     return pp_ghostent(ARGS);
3885 #else
3886     DIE(PL_no_sock_func, "gethostbyname");
3887 #endif
3888 }
3889
3890 PP(pp_ghbyaddr)
3891 {
3892 #ifdef HAS_GETHOSTBYADDR
3893     return pp_ghostent(ARGS);
3894 #else
3895     DIE(PL_no_sock_func, "gethostbyaddr");
3896 #endif
3897 }
3898
3899 PP(pp_ghostent)
3900 {
3901     djSP;
3902 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
3903     I32 which = PL_op->op_type;
3904     register char **elem;
3905     register SV *sv;
3906 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
3907     struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
3908     struct hostent *PerlSock_gethostbyname(Netdb_name_t);
3909     struct hostent *PerlSock_gethostent(void);
3910 #endif
3911     struct hostent *hent;
3912     unsigned long len;
3913
3914     EXTEND(SP, 10);
3915     if (which == OP_GHBYNAME)
3916 #ifdef HAS_GETHOSTBYNAME
3917         hent = PerlSock_gethostbyname(POPp);
3918 #else
3919         DIE(PL_no_sock_func, "gethostbyname");
3920 #endif
3921     else if (which == OP_GHBYADDR) {
3922 #ifdef HAS_GETHOSTBYADDR
3923         int addrtype = POPi;
3924         SV *addrsv = POPs;
3925         STRLEN addrlen;
3926         Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen);
3927
3928         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
3929 #else
3930         DIE(PL_no_sock_func, "gethostbyaddr");
3931 #endif
3932     }
3933     else
3934 #ifdef HAS_GETHOSTENT
3935         hent = PerlSock_gethostent();
3936 #else
3937         DIE(PL_no_sock_func, "gethostent");
3938 #endif
3939
3940 #ifdef HOST_NOT_FOUND
3941     if (!hent)
3942         STATUS_NATIVE_SET(h_errno);
3943 #endif
3944
3945     if (GIMME != G_ARRAY) {
3946         PUSHs(sv = sv_newmortal());
3947         if (hent) {
3948             if (which == OP_GHBYNAME) {
3949                 if (hent->h_addr)
3950                     sv_setpvn(sv, hent->h_addr, hent->h_length);
3951             }
3952             else
3953                 sv_setpv(sv, (char*)hent->h_name);
3954         }
3955         RETURN;
3956     }
3957
3958     if (hent) {
3959         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3960         sv_setpv(sv, (char*)hent->h_name);
3961         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3962         for (elem = hent->h_aliases; elem && *elem; elem++) {
3963             sv_catpv(sv, *elem);
3964             if (elem[1])
3965                 sv_catpvn(sv, " ", 1);
3966         }
3967         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3968         sv_setiv(sv, (IV)hent->h_addrtype);
3969         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3970         len = hent->h_length;
3971         sv_setiv(sv, (IV)len);
3972 #ifdef h_addr
3973         for (elem = hent->h_addr_list; elem && *elem; elem++) {
3974             XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
3975             sv_setpvn(sv, *elem, len);
3976         }
3977 #else
3978         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3979         if (hent->h_addr)
3980             sv_setpvn(sv, hent->h_addr, len);
3981 #endif /* h_addr */
3982     }
3983     RETURN;
3984 #else
3985     DIE(PL_no_sock_func, "gethostent");
3986 #endif
3987 }
3988
3989 PP(pp_gnbyname)
3990 {
3991 #ifdef HAS_GETNETBYNAME
3992     return pp_gnetent(ARGS);
3993 #else
3994     DIE(PL_no_sock_func, "getnetbyname");
3995 #endif
3996 }
3997
3998 PP(pp_gnbyaddr)
3999 {
4000 #ifdef HAS_GETNETBYADDR
4001     return pp_gnetent(ARGS);
4002 #else
4003     DIE(PL_no_sock_func, "getnetbyaddr");
4004 #endif
4005 }
4006
4007 PP(pp_gnetent)
4008 {
4009     djSP;
4010 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4011     I32 which = PL_op->op_type;
4012     register char **elem;
4013     register SV *sv;
4014 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4015     struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4016     struct netent *PerlSock_getnetbyname(Netdb_name_t);
4017     struct netent *PerlSock_getnetent(void);
4018 #endif
4019     struct netent *nent;
4020
4021     if (which == OP_GNBYNAME)
4022 #ifdef HAS_GETNETBYNAME
4023         nent = PerlSock_getnetbyname(POPp);
4024 #else
4025         DIE(PL_no_sock_func, "getnetbyname");
4026 #endif
4027     else if (which == OP_GNBYADDR) {
4028 #ifdef HAS_GETNETBYADDR
4029         int addrtype = POPi;
4030         Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
4031         nent = PerlSock_getnetbyaddr(addr, addrtype);
4032 #else
4033         DIE(PL_no_sock_func, "getnetbyaddr");
4034 #endif
4035     }
4036     else
4037 #ifdef HAS_GETNETENT
4038         nent = PerlSock_getnetent();
4039 #else
4040         DIE(PL_no_sock_func, "getnetent");
4041 #endif
4042
4043     EXTEND(SP, 4);
4044     if (GIMME != G_ARRAY) {
4045         PUSHs(sv = sv_newmortal());
4046         if (nent) {
4047             if (which == OP_GNBYNAME)
4048                 sv_setiv(sv, (IV)nent->n_net);
4049             else
4050                 sv_setpv(sv, nent->n_name);
4051         }
4052         RETURN;
4053     }
4054
4055     if (nent) {
4056         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4057         sv_setpv(sv, nent->n_name);
4058         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4059         for (elem = nent->n_aliases; elem && *elem; elem++) {
4060             sv_catpv(sv, *elem);
4061             if (elem[1])
4062                 sv_catpvn(sv, " ", 1);
4063         }
4064         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4065         sv_setiv(sv, (IV)nent->n_addrtype);
4066         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4067         sv_setiv(sv, (IV)nent->n_net);
4068     }
4069
4070     RETURN;
4071 #else
4072     DIE(PL_no_sock_func, "getnetent");
4073 #endif
4074 }
4075
4076 PP(pp_gpbyname)
4077 {
4078 #ifdef HAS_GETPROTOBYNAME
4079     return pp_gprotoent(ARGS);
4080 #else
4081     DIE(PL_no_sock_func, "getprotobyname");
4082 #endif
4083 }
4084
4085 PP(pp_gpbynumber)
4086 {
4087 #ifdef HAS_GETPROTOBYNUMBER
4088     return pp_gprotoent(ARGS);
4089 #else
4090     DIE(PL_no_sock_func, "getprotobynumber");
4091 #endif
4092 }
4093
4094 PP(pp_gprotoent)
4095 {
4096     djSP;
4097 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4098     I32 which = PL_op->op_type;
4099     register char **elem;
4100     register SV *sv;
4101 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4102     struct protoent *PerlSock_getprotobyname(Netdb_name_t);
4103     struct protoent *PerlSock_getprotobynumber(int);
4104     struct protoent *PerlSock_getprotoent(void);
4105 #endif
4106     struct protoent *pent;
4107
4108     if (which == OP_GPBYNAME)
4109 #ifdef HAS_GETPROTOBYNAME
4110         pent = PerlSock_getprotobyname(POPp);
4111 #else
4112         DIE(PL_no_sock_func, "getprotobyname");
4113 #endif
4114     else if (which == OP_GPBYNUMBER)
4115 #ifdef HAS_GETPROTOBYNUMBER
4116         pent = PerlSock_getprotobynumber(POPi);
4117 #else
4118     DIE(PL_no_sock_func, "getprotobynumber");
4119 #endif
4120     else
4121 #ifdef HAS_GETPROTOENT
4122         pent = PerlSock_getprotoent();
4123 #else
4124         DIE(PL_no_sock_func, "getprotoent");
4125 #endif
4126
4127     EXTEND(SP, 3);
4128     if (GIMME != G_ARRAY) {
4129         PUSHs(sv = sv_newmortal());
4130         if (pent) {
4131             if (which == OP_GPBYNAME)
4132                 sv_setiv(sv, (IV)pent->p_proto);
4133             else
4134                 sv_setpv(sv, pent->p_name);
4135         }
4136         RETURN;
4137     }
4138
4139     if (pent) {
4140         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4141         sv_setpv(sv, pent->p_name);
4142         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4143         for (elem = pent->p_aliases; elem && *elem; elem++) {
4144             sv_catpv(sv, *elem);
4145             if (elem[1])
4146                 sv_catpvn(sv, " ", 1);
4147         }
4148         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4149         sv_setiv(sv, (IV)pent->p_proto);
4150     }
4151
4152     RETURN;
4153 #else
4154     DIE(PL_no_sock_func, "getprotoent");
4155 #endif
4156 }
4157
4158 PP(pp_gsbyname)
4159 {
4160 #ifdef HAS_GETSERVBYNAME
4161     return pp_gservent(ARGS);
4162 #else
4163     DIE(PL_no_sock_func, "getservbyname");
4164 #endif
4165 }
4166
4167 PP(pp_gsbyport)
4168 {
4169 #ifdef HAS_GETSERVBYPORT
4170     return pp_gservent(ARGS);
4171 #else
4172     DIE(PL_no_sock_func, "getservbyport");
4173 #endif
4174 }
4175
4176 PP(pp_gservent)
4177 {
4178     djSP;
4179 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4180     I32 which = PL_op->op_type;
4181     register char **elem;
4182     register SV *sv;
4183 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4184     struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4185     struct servent *PerlSock_getservbyport(int, Netdb_name_t);
4186     struct servent *PerlSock_getservent(void);
4187 #endif
4188     struct servent *sent;
4189
4190     if (which == OP_GSBYNAME) {
4191 #ifdef HAS_GETSERVBYNAME
4192         char *proto = POPp;
4193         char *name = POPp;
4194
4195         if (proto && !*proto)
4196             proto = Nullch;
4197
4198         sent = PerlSock_getservbyname(name, proto);
4199 #else
4200         DIE(PL_no_sock_func, "getservbyname");
4201 #endif
4202     }
4203     else if (which == OP_GSBYPORT) {
4204 #ifdef HAS_GETSERVBYPORT
4205         char *proto = POPp;
4206         unsigned short port = POPu;
4207
4208 #ifdef HAS_HTONS
4209         port = PerlSock_htons(port);
4210 #endif
4211         sent = PerlSock_getservbyport(port, proto);
4212 #else
4213         DIE(PL_no_sock_func, "getservbyport");
4214 #endif
4215     }
4216     else
4217 #ifdef HAS_GETSERVENT
4218         sent = PerlSock_getservent();
4219 #else
4220         DIE(PL_no_sock_func, "getservent");
4221 #endif
4222
4223     EXTEND(SP, 4);
4224     if (GIMME != G_ARRAY) {
4225         PUSHs(sv = sv_newmortal());
4226         if (sent) {
4227             if (which == OP_GSBYNAME) {
4228 #ifdef HAS_NTOHS
4229                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4230 #else
4231                 sv_setiv(sv, (IV)(sent->s_port));
4232 #endif
4233             }
4234             else
4235                 sv_setpv(sv, sent->s_name);
4236         }
4237         RETURN;
4238     }
4239
4240     if (sent) {
4241         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4242         sv_setpv(sv, sent->s_name);
4243         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4244         for (elem = sent->s_aliases; elem && *elem; elem++) {
4245             sv_catpv(sv, *elem);
4246             if (elem[1])
4247                 sv_catpvn(sv, " ", 1);
4248         }
4249         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4250 #ifdef HAS_NTOHS
4251         sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4252 #else
4253         sv_setiv(sv, (IV)(sent->s_port));
4254 #endif
4255         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4256         sv_setpv(sv, sent->s_proto);
4257     }
4258
4259     RETURN;
4260 #else
4261     DIE(PL_no_sock_func, "getservent");
4262 #endif
4263 }
4264
4265 PP(pp_shostent)
4266 {
4267     djSP;
4268 #ifdef HAS_SETHOSTENT
4269     PerlSock_sethostent(TOPi);
4270     RETSETYES;
4271 #else
4272     DIE(PL_no_sock_func, "sethostent");
4273 #endif
4274 }
4275
4276 PP(pp_snetent)
4277 {
4278     djSP;
4279 #ifdef HAS_SETNETENT
4280     PerlSock_setnetent(TOPi);
4281     RETSETYES;
4282 #else
4283     DIE(PL_no_sock_func, "setnetent");
4284 #endif
4285 }
4286
4287 PP(pp_sprotoent)
4288 {
4289     djSP;
4290 #ifdef HAS_SETPROTOENT
4291     PerlSock_setprotoent(TOPi);
4292     RETSETYES;
4293 #else
4294     DIE(PL_no_sock_func, "setprotoent");
4295 #endif
4296 }
4297
4298 PP(pp_sservent)
4299 {
4300     djSP;
4301 #ifdef HAS_SETSERVENT
4302     PerlSock_setservent(TOPi);
4303     RETSETYES;
4304 #else
4305     DIE(PL_no_sock_func, "setservent");
4306 #endif
4307 }
4308
4309 PP(pp_ehostent)
4310 {
4311     djSP;
4312 #ifdef HAS_ENDHOSTENT
4313     PerlSock_endhostent();
4314     EXTEND(SP,1);
4315     RETPUSHYES;
4316 #else
4317     DIE(PL_no_sock_func, "endhostent");
4318 #endif
4319 }
4320
4321 PP(pp_enetent)
4322 {
4323     djSP;
4324 #ifdef HAS_ENDNETENT
4325     PerlSock_endnetent();
4326     EXTEND(SP,1);
4327     RETPUSHYES;
4328 #else
4329     DIE(PL_no_sock_func, "endnetent");
4330 #endif
4331 }
4332
4333 PP(pp_eprotoent)
4334 {
4335     djSP;
4336 #ifdef HAS_ENDPROTOENT
4337     PerlSock_endprotoent();
4338     EXTEND(SP,1);
4339     RETPUSHYES;
4340 #else
4341     DIE(PL_no_sock_func, "endprotoent");
4342 #endif
4343 }
4344
4345 PP(pp_eservent)
4346 {
4347     djSP;
4348 #ifdef HAS_ENDSERVENT
4349     PerlSock_endservent();
4350     EXTEND(SP,1);
4351     RETPUSHYES;
4352 #else
4353     DIE(PL_no_sock_func, "endservent");
4354 #endif
4355 }
4356
4357 PP(pp_gpwnam)
4358 {
4359 #ifdef HAS_PASSWD
4360     return pp_gpwent(ARGS);
4361 #else
4362     DIE(PL_no_func, "getpwnam");
4363 #endif
4364 }
4365
4366 PP(pp_gpwuid)
4367 {
4368 #ifdef HAS_PASSWD
4369     return pp_gpwent(ARGS);
4370 #else
4371     DIE(PL_no_func, "getpwuid");
4372 #endif
4373 }
4374
4375 PP(pp_gpwent)
4376 {
4377     djSP;
4378 #if defined(HAS_PASSWD) && defined(HAS_GETPWENT)
4379     I32 which = PL_op->op_type;
4380     register SV *sv;
4381     struct passwd *pwent;
4382
4383     if (which == OP_GPWNAM)
4384         pwent = getpwnam(POPp);
4385     else if (which == OP_GPWUID)
4386         pwent = getpwuid(POPi);
4387     else
4388         pwent = (struct passwd *)getpwent();
4389
4390     EXTEND(SP, 10);
4391     if (GIMME != G_ARRAY) {
4392         PUSHs(sv = sv_newmortal());
4393         if (pwent) {
4394             if (which == OP_GPWNAM)
4395                 sv_setiv(sv, (IV)pwent->pw_uid);
4396             else
4397                 sv_setpv(sv, pwent->pw_name);
4398         }
4399         RETURN;
4400     }
4401
4402     if (pwent) {
4403         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4404         sv_setpv(sv, pwent->pw_name);
4405
4406         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4407 #ifdef PWPASSWD
4408         sv_setpv(sv, pwent->pw_passwd);
4409 #endif
4410
4411         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4412         sv_setiv(sv, (IV)pwent->pw_uid);
4413
4414         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4415         sv_setiv(sv, (IV)pwent->pw_gid);
4416
4417         /* pw_change, pw_quota, and pw_age are mutually exclusive. */
4418         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4419 #ifdef PWCHANGE
4420         sv_setiv(sv, (IV)pwent->pw_change);
4421 #else
4422 #   ifdef PWQUOTA
4423         sv_setiv(sv, (IV)pwent->pw_quota);
4424 #   else
4425 #       ifdef PWAGE
4426         sv_setpv(sv, pwent->pw_age);
4427 #       endif
4428 #   endif
4429 #endif
4430
4431         /* pw_class and pw_comment are mutually exclusive. */
4432         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4433 #ifdef PWCLASS
4434         sv_setpv(sv, pwent->pw_class);
4435 #else
4436 #   ifdef PWCOMMENT
4437         sv_setpv(sv, pwent->pw_comment);
4438 #   endif
4439 #endif
4440
4441         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4442 #ifdef PWGECOS
4443         sv_setpv(sv, pwent->pw_gecos);
4444 #endif
4445 #ifndef INCOMPLETE_TAINTS
4446         /* pw_gecos is tainted because user himself can diddle with it. */
4447         SvTAINTED_on(sv);
4448 #endif
4449
4450         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4451         sv_setpv(sv, pwent->pw_dir);
4452
4453         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4454         sv_setpv(sv, pwent->pw_shell);
4455
4456 #ifdef PWEXPIRE
4457         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4458         sv_setiv(sv, (IV)pwent->pw_expire);
4459 #endif
4460     }
4461     RETURN;
4462 #else
4463     DIE(PL_no_func, "getpwent");
4464 #endif
4465 }
4466
4467 PP(pp_spwent)
4468 {
4469     djSP;
4470 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT) && !defined(CYGWIN32)
4471     setpwent();
4472     RETPUSHYES;
4473 #else
4474     DIE(PL_no_func, "setpwent");
4475 #endif
4476 }
4477
4478 PP(pp_epwent)
4479 {
4480     djSP;
4481 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
4482     endpwent();
4483     RETPUSHYES;
4484 #else
4485     DIE(PL_no_func, "endpwent");
4486 #endif
4487 }
4488
4489 PP(pp_ggrnam)
4490 {
4491 #ifdef HAS_GROUP
4492     return pp_ggrent(ARGS);
4493 #else
4494     DIE(PL_no_func, "getgrnam");
4495 #endif
4496 }
4497
4498 PP(pp_ggrgid)
4499 {
4500 #ifdef HAS_GROUP
4501     return pp_ggrent(ARGS);
4502 #else
4503     DIE(PL_no_func, "getgrgid");
4504 #endif
4505 }
4506
4507 PP(pp_ggrent)
4508 {
4509     djSP;
4510 #if defined(HAS_GROUP) && defined(HAS_GETGRENT)
4511     I32 which = PL_op->op_type;
4512     register char **elem;
4513     register SV *sv;
4514     struct group *grent;
4515
4516     if (which == OP_GGRNAM)
4517         grent = (struct group *)getgrnam(POPp);
4518     else if (which == OP_GGRGID)
4519         grent = (struct group *)getgrgid(POPi);
4520     else
4521         grent = (struct group *)getgrent();
4522
4523     EXTEND(SP, 4);
4524     if (GIMME != G_ARRAY) {
4525         PUSHs(sv = sv_newmortal());
4526         if (grent) {
4527             if (which == OP_GGRNAM)
4528                 sv_setiv(sv, (IV)grent->gr_gid);
4529             else
4530                 sv_setpv(sv, grent->gr_name);
4531         }
4532         RETURN;
4533     }
4534
4535     if (grent) {
4536         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4537         sv_setpv(sv, grent->gr_name);
4538
4539         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4540 #ifdef GRPASSWD
4541         sv_setpv(sv, grent->gr_passwd);
4542 #endif
4543
4544         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4545         sv_setiv(sv, (IV)grent->gr_gid);
4546
4547         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4548         for (elem = grent->gr_mem; elem && *elem; elem++) {
4549             sv_catpv(sv, *elem);
4550             if (elem[1])
4551                 sv_catpvn(sv, " ", 1);
4552         }
4553     }
4554
4555     RETURN;
4556 #else
4557     DIE(PL_no_func, "getgrent");
4558 #endif
4559 }
4560
4561 PP(pp_sgrent)
4562 {
4563     djSP;
4564 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
4565     setgrent();
4566     RETPUSHYES;
4567 #else
4568     DIE(PL_no_func, "setgrent");
4569 #endif
4570 }
4571
4572 PP(pp_egrent)
4573 {
4574     djSP;
4575 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
4576     endgrent();
4577     RETPUSHYES;
4578 #else
4579     DIE(PL_no_func, "endgrent");
4580 #endif
4581 }
4582
4583 PP(pp_getlogin)
4584 {
4585     djSP; dTARGET;
4586 #ifdef HAS_GETLOGIN
4587     char *tmps;
4588     EXTEND(SP, 1);
4589     if (!(tmps = PerlProc_getlogin()))
4590         RETPUSHUNDEF;
4591     PUSHp(tmps, strlen(tmps));
4592     RETURN;
4593 #else
4594     DIE(PL_no_func, "getlogin");
4595 #endif
4596 }
4597
4598 /* Miscellaneous. */
4599
4600 PP(pp_syscall)
4601 {
4602 #ifdef HAS_SYSCALL
4603     djSP; dMARK; dORIGMARK; dTARGET;
4604     register I32 items = SP - MARK;
4605     unsigned long a[20];
4606     register I32 i = 0;
4607     I32 retval = -1;
4608     MAGIC *mg;
4609
4610     if (PL_tainting) {
4611         while (++MARK <= SP) {
4612             if (SvTAINTED(*MARK)) {
4613                 TAINT;
4614                 break;
4615             }
4616         }
4617         MARK = ORIGMARK;
4618         TAINT_PROPER("syscall");
4619     }
4620
4621     /* This probably won't work on machines where sizeof(long) != sizeof(int)
4622      * or where sizeof(long) != sizeof(char*).  But such machines will
4623      * not likely have syscall implemented either, so who cares?
4624      */
4625     while (++MARK <= SP) {
4626         if (SvNIOK(*MARK) || !i)
4627             a[i++] = SvIV(*MARK);
4628         else if (*MARK == &PL_sv_undef)
4629             a[i++] = 0;
4630         else
4631             a[i++] = (unsigned long)SvPV_force(*MARK, PL_na);
4632         if (i > 15)
4633             break;
4634     }
4635     switch (items) {
4636     default:
4637         DIE("Too many args to syscall");
4638     case 0:
4639         DIE("Too few args to syscall");
4640     case 1:
4641         retval = syscall(a[0]);
4642         break;
4643     case 2:
4644         retval = syscall(a[0],a[1]);
4645         break;
4646     case 3:
4647         retval = syscall(a[0],a[1],a[2]);
4648         break;
4649     case 4:
4650         retval = syscall(a[0],a[1],a[2],a[3]);
4651         break;
4652     case 5:
4653         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
4654         break;
4655     case 6:
4656         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
4657         break;
4658     case 7:
4659         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
4660         break;
4661     case 8:
4662         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
4663         break;
4664 #ifdef atarist
4665     case 9:
4666         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
4667         break;
4668     case 10:
4669         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
4670         break;
4671     case 11:
4672         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4673           a[10]);
4674         break;
4675     case 12:
4676         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4677           a[10],a[11]);
4678         break;
4679     case 13:
4680         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4681           a[10],a[11],a[12]);
4682         break;
4683     case 14:
4684         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4685           a[10],a[11],a[12],a[13]);
4686         break;
4687 #endif /* atarist */
4688     }
4689     SP = ORIGMARK;
4690     PUSHi(retval);
4691     RETURN;
4692 #else
4693     DIE(PL_no_func, "syscall");
4694 #endif
4695 }
4696
4697 #ifdef FCNTL_EMULATE_FLOCK
4698
4699 /*  XXX Emulate flock() with fcntl().
4700     What's really needed is a good file locking module.
4701 */
4702
4703 static int
4704 fcntl_emulate_flock(int fd, int operation)
4705 {
4706     struct flock flock;
4707
4708     switch (operation & ~LOCK_NB) {
4709     case LOCK_SH:
4710         flock.l_type = F_RDLCK;
4711         break;
4712     case LOCK_EX:
4713         flock.l_type = F_WRLCK;
4714         break;
4715     case LOCK_UN:
4716         flock.l_type = F_UNLCK;
4717         break;
4718     default:
4719         errno = EINVAL;
4720         return -1;
4721     }
4722     flock.l_whence = SEEK_SET;
4723     flock.l_start = flock.l_len = 0L;
4724
4725     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
4726 }
4727
4728 #endif /* FCNTL_EMULATE_FLOCK */
4729
4730 #ifdef LOCKF_EMULATE_FLOCK
4731
4732 /*  XXX Emulate flock() with lockf().  This is just to increase
4733     portability of scripts.  The calls are not completely
4734     interchangeable.  What's really needed is a good file
4735     locking module.
4736 */
4737
4738 /*  The lockf() constants might have been defined in <unistd.h>.
4739     Unfortunately, <unistd.h> causes troubles on some mixed
4740     (BSD/POSIX) systems, such as SunOS 4.1.3.
4741
4742    Further, the lockf() constants aren't POSIX, so they might not be
4743    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
4744    just stick in the SVID values and be done with it.  Sigh.
4745 */
4746
4747 # ifndef F_ULOCK
4748 #  define F_ULOCK       0       /* Unlock a previously locked region */
4749 # endif
4750 # ifndef F_LOCK
4751 #  define F_LOCK        1       /* Lock a region for exclusive use */
4752 # endif
4753 # ifndef F_TLOCK
4754 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
4755 # endif
4756 # ifndef F_TEST
4757 #  define F_TEST        3       /* Test a region for other processes locks */
4758 # endif
4759
4760 static int
4761 lockf_emulate_flock (fd, operation)
4762 int fd;
4763 int operation;
4764 {
4765     int i;
4766     int save_errno;
4767     Off_t pos;
4768
4769     /* flock locks entire file so for lockf we need to do the same      */
4770     save_errno = errno;
4771     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
4772     if (pos > 0)        /* is seekable and needs to be repositioned     */
4773         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
4774             pos = -1;   /* seek failed, so don't seek back afterwards   */
4775     errno = save_errno;
4776
4777     switch (operation) {
4778
4779         /* LOCK_SH - get a shared lock */
4780         case LOCK_SH:
4781         /* LOCK_EX - get an exclusive lock */
4782         case LOCK_EX:
4783             i = lockf (fd, F_LOCK, 0);
4784             break;
4785
4786         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
4787         case LOCK_SH|LOCK_NB:
4788         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
4789         case LOCK_EX|LOCK_NB:
4790             i = lockf (fd, F_TLOCK, 0);
4791             if (i == -1)
4792                 if ((errno == EAGAIN) || (errno == EACCES))
4793                     errno = EWOULDBLOCK;
4794             break;
4795
4796         /* LOCK_UN - unlock (non-blocking is a no-op) */
4797         case LOCK_UN:
4798         case LOCK_UN|LOCK_NB:
4799             i = lockf (fd, F_ULOCK, 0);
4800             break;
4801
4802         /* Default - can't decipher operation */
4803         default:
4804             i = -1;
4805             errno = EINVAL;
4806             break;
4807     }
4808
4809     if (pos > 0)      /* need to restore position of the handle */
4810         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
4811
4812     return (i);
4813 }
4814
4815 #endif /* LOCKF_EMULATE_FLOCK */