pp_sys.c

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