pp_sys.c

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