pp_sys.c

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