pp_sys.c

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