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