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