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