pp_sys.c

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