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, 0, 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__)
 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         else if (*s & 128)
2612             odd++;
2613         else if (*s < 32 &&
2614           *s != '\n' && *s != '\r' && *s != '\b' &&
2615           *s != '\t' && *s != '\f' && *s != 27)
2616             odd++;
2617     }
2618
2619     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
2620         RETPUSHNO;
2621     else
2622         RETPUSHYES;
2623 }
2624
2625 PP(pp_ftbinary)
2626 {
2627     return pp_fttext(ARGS);
2628 }
2629
2630 /* File calls. */
2631
2632 PP(pp_chdir)
2633 {
2634     djSP; dTARGET;
2635     char *tmps;
2636     SV **svp;
2637
2638     if (MAXARG < 1)
2639         tmps = Nullch;
2640     else
2641         tmps = POPp;
2642     if (!tmps || !*tmps) {
2643         svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
2644         if (svp)
2645             tmps = SvPV(*svp, PL_na);
2646     }
2647     if (!tmps || !*tmps) {
2648         svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
2649         if (svp)
2650             tmps = SvPV(*svp, PL_na);
2651     }
2652 #ifdef VMS
2653     if (!tmps || !*tmps) {
2654        svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
2655        if (svp)
2656            tmps = SvPV(*svp, PL_na);
2657     }
2658 #endif
2659     TAINT_PROPER("chdir");
2660     PUSHi( PerlDir_chdir(tmps) >= 0 );
2661 #ifdef VMS
2662     /* Clear the DEFAULT element of ENV so we'll get the new value
2663      * in the future. */
2664     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
2665 #endif
2666     RETURN;
2667 }
2668
2669 PP(pp_chown)
2670 {
2671     djSP; dMARK; dTARGET;
2672     I32 value;
2673 #ifdef HAS_CHOWN
2674     value = (I32)apply(PL_op->op_type, MARK, SP);
2675     SP = MARK;
2676     PUSHi(value);
2677     RETURN;
2678 #else
2679     DIE(no_func, "Unsupported function chown");
2680 #endif
2681 }
2682
2683 PP(pp_chroot)
2684 {
2685     djSP; dTARGET;
2686     char *tmps;
2687 #ifdef HAS_CHROOT
2688     tmps = POPp;
2689     TAINT_PROPER("chroot");
2690     PUSHi( chroot(tmps) >= 0 );
2691     RETURN;
2692 #else
2693     DIE(no_func, "chroot");
2694 #endif
2695 }
2696
2697 PP(pp_unlink)
2698 {
2699     djSP; dMARK; dTARGET;
2700     I32 value;
2701     value = (I32)apply(PL_op->op_type, MARK, SP);
2702     SP = MARK;
2703     PUSHi(value);
2704     RETURN;
2705 }
2706
2707 PP(pp_chmod)
2708 {
2709     djSP; dMARK; dTARGET;
2710     I32 value;
2711     value = (I32)apply(PL_op->op_type, MARK, SP);
2712     SP = MARK;
2713     PUSHi(value);
2714     RETURN;
2715 }
2716
2717 PP(pp_utime)
2718 {
2719     djSP; dMARK; dTARGET;
2720     I32 value;
2721     value = (I32)apply(PL_op->op_type, MARK, SP);
2722     SP = MARK;
2723     PUSHi(value);
2724     RETURN;
2725 }
2726
2727 PP(pp_rename)
2728 {
2729     djSP; dTARGET;
2730     int anum;
2731
2732     char *tmps2 = POPp;
2733     char *tmps = SvPV(TOPs, PL_na);
2734     TAINT_PROPER("rename");
2735 #ifdef HAS_RENAME
2736     anum = PerlLIO_rename(tmps, tmps2);
2737 #else
2738     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
2739         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
2740             anum = 1;
2741         else {
2742             if (euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
2743                 (void)UNLINK(tmps2);
2744             if (!(anum = link(tmps, tmps2)))
2745                 anum = UNLINK(tmps);
2746         }
2747     }
2748 #endif
2749     SETi( anum >= 0 );
2750     RETURN;
2751 }
2752
2753 PP(pp_link)
2754 {
2755     djSP; dTARGET;
2756 #ifdef HAS_LINK
2757     char *tmps2 = POPp;
2758     char *tmps = SvPV(TOPs, PL_na);
2759     TAINT_PROPER("link");
2760     SETi( link(tmps, tmps2) >= 0 );
2761 #else
2762     DIE(no_func, "Unsupported function link");
2763 #endif
2764     RETURN;
2765 }
2766
2767 PP(pp_symlink)
2768 {
2769     djSP; dTARGET;
2770 #ifdef HAS_SYMLINK
2771     char *tmps2 = POPp;
2772     char *tmps = SvPV(TOPs, PL_na);
2773     TAINT_PROPER("symlink");
2774     SETi( symlink(tmps, tmps2) >= 0 );
2775     RETURN;
2776 #else
2777     DIE(no_func, "symlink");
2778 #endif
2779 }
2780
2781 PP(pp_readlink)
2782 {
2783     djSP; dTARGET;
2784 #ifdef HAS_SYMLINK
2785     char *tmps;
2786     char buf[MAXPATHLEN];
2787     int len;
2788
2789 #ifndef INCOMPLETE_TAINTS
2790     TAINT;
2791 #endif
2792     tmps = POPp;
2793     len = readlink(tmps, buf, sizeof buf);
2794     EXTEND(SP, 1);
2795     if (len < 0)
2796         RETPUSHUNDEF;
2797     PUSHp(buf, len);
2798     RETURN;
2799 #else
2800     EXTEND(SP, 1);
2801     RETSETUNDEF;                /* just pretend it's a normal file */
2802 #endif
2803 }
2804
2805 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
2806 static int
2807 dooneliner(cmd, filename)
2808 char *cmd;
2809 char *filename;
2810 {
2811     char *save_filename = filename;
2812     char *cmdline;
2813     char *s;
2814     PerlIO *myfp;
2815     int anum = 1;
2816
2817     New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
2818     strcpy(cmdline, cmd);
2819     strcat(cmdline, " ");
2820     for (s = cmdline + strlen(cmdline); *filename; ) {
2821         *s++ = '\\';
2822         *s++ = *filename++;
2823     }
2824     strcpy(s, " 2>&1");
2825     myfp = PerlProc_popen(cmdline, "r");
2826     Safefree(cmdline);
2827
2828     if (myfp) {
2829         SV *tmpsv = sv_newmortal();
2830         /* Need to save/restore 'PL_rs' ?? */
2831         s = sv_gets(tmpsv, myfp, 0);
2832         (void)PerlProc_pclose(myfp);
2833         if (s != Nullch) {
2834             int e;
2835             for (e = 1;
2836 #ifdef HAS_SYS_ERRLIST
2837                  e <= sys_nerr
2838 #endif
2839                  ; e++)
2840             {
2841                 /* you don't see this */
2842                 char *errmsg =
2843 #ifdef HAS_SYS_ERRLIST
2844                     sys_errlist[e]
2845 #else
2846                     strerror(e)
2847 #endif
2848                     ;
2849                 if (!errmsg)
2850                     break;
2851                 if (instr(s, errmsg)) {
2852                     SETERRNO(e,0);
2853                     return 0;
2854                 }
2855             }
2856             SETERRNO(0,0);
2857 #ifndef EACCES
2858 #define EACCES EPERM
2859 #endif
2860             if (instr(s, "cannot make"))
2861                 SETERRNO(EEXIST,RMS$_FEX);
2862             else if (instr(s, "existing file"))
2863                 SETERRNO(EEXIST,RMS$_FEX);
2864             else if (instr(s, "ile exists"))
2865                 SETERRNO(EEXIST,RMS$_FEX);
2866             else if (instr(s, "non-exist"))
2867                 SETERRNO(ENOENT,RMS$_FNF);
2868             else if (instr(s, "does not exist"))
2869                 SETERRNO(ENOENT,RMS$_FNF);
2870             else if (instr(s, "not empty"))
2871                 SETERRNO(EBUSY,SS$_DEVOFFLINE);
2872             else if (instr(s, "cannot access"))
2873                 SETERRNO(EACCES,RMS$_PRV);
2874             else
2875                 SETERRNO(EPERM,RMS$_PRV);
2876             return 0;
2877         }
2878         else {  /* some mkdirs return no failure indication */
2879             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
2880             if (PL_op->op_type == OP_RMDIR)
2881                 anum = !anum;
2882             if (anum)
2883                 SETERRNO(0,0);
2884             else
2885                 SETERRNO(EACCES,RMS$_PRV);      /* a guess */
2886         }
2887         return anum;
2888     }
2889     else
2890         return 0;
2891 }
2892 #endif
2893
2894 PP(pp_mkdir)
2895 {
2896     djSP; dTARGET;
2897     int mode = POPi;
2898 #ifndef HAS_MKDIR
2899     int oldumask;
2900 #endif
2901     char *tmps = SvPV(TOPs, PL_na);
2902
2903     TAINT_PROPER("mkdir");
2904 #ifdef HAS_MKDIR
2905     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
2906 #else
2907     SETi( dooneliner("mkdir", tmps) );
2908     oldumask = PerlLIO_umask(0);
2909     PerlLIO_umask(oldumask);
2910     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
2911 #endif
2912     RETURN;
2913 }
2914
2915 PP(pp_rmdir)
2916 {
2917     djSP; dTARGET;
2918     char *tmps;
2919
2920     tmps = POPp;
2921     TAINT_PROPER("rmdir");
2922 #ifdef HAS_RMDIR
2923     XPUSHi( PerlDir_rmdir(tmps) >= 0 );
2924 #else
2925     XPUSHi( dooneliner("rmdir", tmps) );
2926 #endif
2927     RETURN;
2928 }
2929
2930 /* Directory calls. */
2931
2932 PP(pp_open_dir)
2933 {
2934     djSP;
2935 #if defined(Direntry_t) && defined(HAS_READDIR)
2936     char *dirname = POPp;
2937     GV *gv = (GV*)POPs;
2938     register IO *io = GvIOn(gv);
2939
2940     if (!io)
2941         goto nope;
2942
2943     if (IoDIRP(io))
2944         PerlDir_close(IoDIRP(io));
2945     if (!(IoDIRP(io) = PerlDir_open(dirname)))
2946         goto nope;
2947
2948     RETPUSHYES;
2949 nope:
2950     if (!errno)
2951         SETERRNO(EBADF,RMS$_DIR);
2952     RETPUSHUNDEF;
2953 #else
2954     DIE(no_dir_func, "opendir");
2955 #endif
2956 }
2957
2958 PP(pp_readdir)
2959 {
2960     djSP;
2961 #if defined(Direntry_t) && defined(HAS_READDIR)
2962 #ifndef I_DIRENT
2963     Direntry_t *readdir _((DIR *));
2964 #endif
2965     register Direntry_t *dp;
2966     GV *gv = (GV*)POPs;
2967     register IO *io = GvIOn(gv);
2968     SV *sv;
2969
2970     if (!io || !IoDIRP(io))
2971         goto nope;
2972
2973     if (GIMME == G_ARRAY) {
2974         /*SUPPRESS 560*/
2975         while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
2976 #ifdef DIRNAMLEN
2977             sv = newSVpv(dp->d_name, dp->d_namlen);
2978 #else
2979             sv = newSVpv(dp->d_name, 0);
2980 #endif
2981 #ifndef INCOMPLETE_TAINTS
2982             SvTAINTED_on(sv);
2983 #endif
2984             XPUSHs(sv_2mortal(sv));
2985         }
2986     }
2987     else {
2988         if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
2989             goto nope;
2990 #ifdef DIRNAMLEN
2991         sv = newSVpv(dp->d_name, dp->d_namlen);
2992 #else
2993         sv = newSVpv(dp->d_name, 0);
2994 #endif
2995 #ifndef INCOMPLETE_TAINTS
2996         SvTAINTED_on(sv);
2997 #endif
2998         XPUSHs(sv_2mortal(sv));
2999     }
3000     RETURN;
3001
3002 nope:
3003     if (!errno)
3004         SETERRNO(EBADF,RMS$_ISI);
3005     if (GIMME == G_ARRAY)
3006         RETURN;
3007     else
3008         RETPUSHUNDEF;
3009 #else
3010     DIE(no_dir_func, "readdir");
3011 #endif
3012 }
3013
3014 PP(pp_telldir)
3015 {
3016     djSP; dTARGET;
3017 #if defined(HAS_TELLDIR) || defined(telldir)
3018 # ifdef NEED_TELLDIR_PROTO /* XXX does _anyone_ need this? --AD 2/20/1998 */
3019     long telldir _((DIR *));
3020 # endif
3021     GV *gv = (GV*)POPs;
3022     register IO *io = GvIOn(gv);
3023
3024     if (!io || !IoDIRP(io))
3025         goto nope;
3026
3027     PUSHi( PerlDir_tell(IoDIRP(io)) );
3028     RETURN;
3029 nope:
3030     if (!errno)
3031         SETERRNO(EBADF,RMS$_ISI);
3032     RETPUSHUNDEF;
3033 #else
3034     DIE(no_dir_func, "telldir");
3035 #endif
3036 }
3037
3038 PP(pp_seekdir)
3039 {
3040     djSP;
3041 #if defined(HAS_SEEKDIR) || defined(seekdir)
3042     long along = POPl;
3043     GV *gv = (GV*)POPs;
3044     register IO *io = GvIOn(gv);
3045
3046     if (!io || !IoDIRP(io))
3047         goto nope;
3048
3049     (void)PerlDir_seek(IoDIRP(io), along);
3050
3051     RETPUSHYES;
3052 nope:
3053     if (!errno)
3054         SETERRNO(EBADF,RMS$_ISI);
3055     RETPUSHUNDEF;
3056 #else
3057     DIE(no_dir_func, "seekdir");
3058 #endif
3059 }
3060
3061 PP(pp_rewinddir)
3062 {
3063     djSP;
3064 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3065     GV *gv = (GV*)POPs;
3066     register IO *io = GvIOn(gv);
3067
3068     if (!io || !IoDIRP(io))
3069         goto nope;
3070
3071     (void)PerlDir_rewind(IoDIRP(io));
3072     RETPUSHYES;
3073 nope:
3074     if (!errno)
3075         SETERRNO(EBADF,RMS$_ISI);
3076     RETPUSHUNDEF;
3077 #else
3078     DIE(no_dir_func, "rewinddir");
3079 #endif
3080 }
3081
3082 PP(pp_closedir)
3083 {
3084     djSP;
3085 #if defined(Direntry_t) && defined(HAS_READDIR)
3086     GV *gv = (GV*)POPs;
3087     register IO *io = GvIOn(gv);
3088
3089     if (!io || !IoDIRP(io))
3090         goto nope;
3091
3092 #ifdef VOID_CLOSEDIR
3093     PerlDir_close(IoDIRP(io));
3094 #else
3095     if (PerlDir_close(IoDIRP(io)) < 0) {
3096         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3097         goto nope;
3098     }
3099 #endif
3100     IoDIRP(io) = 0;
3101
3102     RETPUSHYES;
3103 nope:
3104     if (!errno)
3105         SETERRNO(EBADF,RMS$_IFI);
3106     RETPUSHUNDEF;
3107 #else
3108     DIE(no_dir_func, "closedir");
3109 #endif
3110 }
3111
3112 /* Process control. */
3113
3114 PP(pp_fork)
3115 {
3116 #ifdef HAS_FORK
3117     djSP; dTARGET;
3118     int childpid;
3119     GV *tmpgv;
3120
3121     EXTEND(SP, 1);
3122     childpid = fork();
3123     if (childpid < 0)
3124         RETSETUNDEF;
3125     if (!childpid) {
3126         /*SUPPRESS 560*/
3127         if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
3128             sv_setiv(GvSV(tmpgv), (IV)getpid());
3129         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3130     }
3131     PUSHi(childpid);
3132     RETURN;
3133 #else
3134     DIE(no_func, "Unsupported function fork");
3135 #endif
3136 }
3137
3138 PP(pp_wait)
3139 {
3140 #if !defined(DOSISH) || defined(OS2) || defined(WIN32)
3141     djSP; dTARGET;
3142     int childpid;
3143     int argflags;
3144
3145     childpid = wait4pid(-1, &argflags, 0);
3146     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3147     XPUSHi(childpid);
3148     RETURN;
3149 #else
3150     DIE(no_func, "Unsupported function wait");
3151 #endif
3152 }
3153
3154 PP(pp_waitpid)
3155 {
3156 #if !defined(DOSISH) || defined(OS2) || defined(WIN32)
3157     djSP; dTARGET;
3158     int childpid;
3159     int optype;
3160     int argflags;
3161
3162     optype = POPi;
3163     childpid = TOPi;
3164     childpid = wait4pid(childpid, &argflags, optype);
3165     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3166     SETi(childpid);
3167     RETURN;
3168 #else
3169     DIE(no_func, "Unsupported function waitpid");
3170 #endif
3171 }
3172
3173 PP(pp_system)
3174 {
3175     djSP; dMARK; dORIGMARK; dTARGET;
3176     I32 value;
3177     int childpid;
3178     int result;
3179     int status;
3180     Sigsave_t ihand,qhand;     /* place to save signals during system() */
3181
3182     if (SP - MARK == 1) {
3183         if (PL_tainting) {
3184             char *junk = SvPV(TOPs, PL_na);
3185             TAINT_ENV();
3186             TAINT_PROPER("system");
3187         }
3188     }
3189 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
3190     while ((childpid = vfork()) == -1) {
3191         if (errno != EAGAIN) {
3192             value = -1;
3193             SP = ORIGMARK;
3194             PUSHi(value);
3195             RETURN;
3196         }
3197         sleep(5);
3198     }
3199     if (childpid > 0) {
3200         rsignal_save(SIGINT, SIG_IGN, &ihand);
3201         rsignal_save(SIGQUIT, SIG_IGN, &qhand);
3202         do {
3203             result = wait4pid(childpid, &status, 0);
3204         } while (result == -1 && errno == EINTR);
3205         (void)rsignal_restore(SIGINT, &ihand);
3206         (void)rsignal_restore(SIGQUIT, &qhand);
3207         STATUS_NATIVE_SET(result == -1 ? -1 : status);
3208         do_execfree();  /* free any memory child malloced on vfork */
3209         SP = ORIGMARK;
3210         PUSHi(STATUS_CURRENT);
3211         RETURN;
3212     }
3213     if (PL_op->op_flags & OPf_STACKED) {
3214         SV *really = *++MARK;
3215         value = (I32)do_aexec(really, MARK, SP);
3216     }
3217     else if (SP - MARK != 1)
3218         value = (I32)do_aexec(Nullsv, MARK, SP);
3219     else {
3220         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), PL_na));
3221     }
3222     PerlProc__exit(-1);
3223 #else /* ! FORK or VMS or OS/2 */
3224     if (PL_op->op_flags & OPf_STACKED) {
3225         SV *really = *++MARK;
3226         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
3227     }
3228     else if (SP - MARK != 1)
3229         value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
3230     else {
3231         value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), PL_na));
3232     }
3233     STATUS_NATIVE_SET(value);
3234     do_execfree();
3235     SP = ORIGMARK;
3236     PUSHi(STATUS_CURRENT);
3237 #endif /* !FORK or VMS */
3238     RETURN;
3239 }
3240
3241 PP(pp_exec)
3242 {
3243     djSP; dMARK; dORIGMARK; dTARGET;
3244     I32 value;
3245
3246     if (PL_op->op_flags & OPf_STACKED) {
3247         SV *really = *++MARK;
3248         value = (I32)do_aexec(really, MARK, SP);
3249     }
3250     else if (SP - MARK != 1)
3251 #ifdef VMS
3252         value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3253 #else
3254         value = (I32)do_aexec(Nullsv, MARK, SP);
3255 #endif
3256     else {
3257         if (PL_tainting) {
3258             char *junk = SvPV(*SP, PL_na);
3259             TAINT_ENV();
3260             TAINT_PROPER("exec");
3261         }
3262 #ifdef VMS
3263         value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), PL_na));
3264 #else
3265         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), PL_na));
3266 #endif
3267     }
3268     SP = ORIGMARK;
3269     PUSHi(value);
3270     RETURN;
3271 }
3272
3273 PP(pp_kill)
3274 {
3275     djSP; dMARK; dTARGET;
3276     I32 value;
3277 #ifdef HAS_KILL
3278     value = (I32)apply(PL_op->op_type, MARK, SP);
3279     SP = MARK;
3280     PUSHi(value);
3281     RETURN;
3282 #else
3283     DIE(no_func, "Unsupported function kill");
3284 #endif
3285 }
3286
3287 PP(pp_getppid)
3288 {
3289 #ifdef HAS_GETPPID
3290     djSP; dTARGET;
3291     XPUSHi( getppid() );
3292     RETURN;
3293 #else
3294     DIE(no_func, "getppid");
3295 #endif
3296 }
3297
3298 PP(pp_getpgrp)
3299 {
3300 #ifdef HAS_GETPGRP
3301     djSP; dTARGET;
3302     int pid;
3303     I32 value;
3304
3305     if (MAXARG < 1)
3306         pid = 0;
3307     else
3308         pid = SvIVx(POPs);
3309 #ifdef BSD_GETPGRP
3310     value = (I32)BSD_GETPGRP(pid);
3311 #else
3312     if (pid != 0 && pid != getpid())
3313         DIE("POSIX getpgrp can't take an argument");
3314     value = (I32)getpgrp();
3315 #endif
3316     XPUSHi(value);
3317     RETURN;
3318 #else
3319     DIE(no_func, "getpgrp()");
3320 #endif
3321 }
3322
3323 PP(pp_setpgrp)
3324 {
3325 #ifdef HAS_SETPGRP
3326     djSP; dTARGET;
3327     int pgrp;
3328     int pid;
3329     if (MAXARG < 2) {
3330         pgrp = 0;
3331         pid = 0;
3332     }
3333     else {
3334         pgrp = POPi;
3335         pid = TOPi;
3336     }
3337
3338     TAINT_PROPER("setpgrp");
3339 #ifdef BSD_SETPGRP
3340     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
3341 #else
3342     if ((pgrp != 0 && pgrp != getpid()) || (pid != 0 && pid != getpid()))
3343         DIE("POSIX setpgrp can't take an argument");
3344     SETi( setpgrp() >= 0 );
3345 #endif /* USE_BSDPGRP */
3346     RETURN;
3347 #else
3348     DIE(no_func, "setpgrp()");
3349 #endif
3350 }
3351
3352 PP(pp_getpriority)
3353 {
3354     djSP; dTARGET;
3355     int which;
3356     int who;
3357 #ifdef HAS_GETPRIORITY
3358     who = POPi;
3359     which = TOPi;
3360     SETi( getpriority(which, who) );
3361     RETURN;
3362 #else
3363     DIE(no_func, "getpriority()");
3364 #endif
3365 }
3366
3367 PP(pp_setpriority)
3368 {
3369     djSP; dTARGET;
3370     int which;
3371     int who;
3372     int niceval;
3373 #ifdef HAS_SETPRIORITY
3374     niceval = POPi;
3375     who = POPi;
3376     which = TOPi;
3377     TAINT_PROPER("setpriority");
3378     SETi( setpriority(which, who, niceval) >= 0 );
3379     RETURN;
3380 #else
3381     DIE(no_func, "setpriority()");
3382 #endif
3383 }
3384
3385 /* Time calls. */
3386
3387 PP(pp_time)
3388 {
3389     djSP; dTARGET;
3390 #ifdef BIG_TIME
3391     XPUSHn( time(Null(Time_t*)) );
3392 #else
3393     XPUSHi( time(Null(Time_t*)) );
3394 #endif
3395     RETURN;
3396 }
3397
3398 /* XXX The POSIX name is CLK_TCK; it is to be preferred
3399    to HZ.  Probably.  For now, assume that if the system
3400    defines HZ, it does so correctly.  (Will this break
3401    on VMS?)
3402    Probably we ought to use _sysconf(_SC_CLK_TCK), if
3403    it's supported.    --AD  9/96.
3404 */
3405
3406 #ifndef HZ
3407 #  ifdef CLK_TCK
3408 #    define HZ CLK_TCK
3409 #  else
3410 #    define HZ 60
3411 #  endif
3412 #endif
3413
3414 PP(pp_tms)
3415 {
3416     djSP;
3417
3418 #ifndef HAS_TIMES
3419     DIE("times not implemented");
3420 #else
3421     EXTEND(SP, 4);
3422
3423 #ifndef VMS
3424     (void)PerlProc_times(&PL_timesbuf);
3425 #else
3426     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
3427                                                    /* struct tms, though same data   */
3428                                                    /* is returned.                   */
3429 #endif
3430
3431     PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_utime)/HZ)));
3432     if (GIMME == G_ARRAY) {
3433         PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_stime)/HZ)));
3434         PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_cutime)/HZ)));
3435         PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_cstime)/HZ)));
3436     }
3437     RETURN;
3438 #endif /* HAS_TIMES */
3439 }
3440
3441 PP(pp_localtime)
3442 {
3443     return pp_gmtime(ARGS);
3444 }
3445
3446 PP(pp_gmtime)
3447 {
3448     djSP;
3449     Time_t when;
3450     struct tm *tmbuf;
3451     static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
3452     static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
3453                               "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
3454
3455     if (MAXARG < 1)
3456         (void)time(&when);
3457     else
3458 #ifdef BIG_TIME
3459         when = (Time_t)SvNVx(POPs);
3460 #else
3461         when = (Time_t)SvIVx(POPs);
3462 #endif
3463
3464     if (PL_op->op_type == OP_LOCALTIME)
3465         tmbuf = localtime(&when);
3466     else
3467         tmbuf = gmtime(&when);
3468
3469     EXTEND(SP, 9);
3470     EXTEND_MORTAL(9);
3471     if (GIMME != G_ARRAY) {
3472         dTARGET;
3473         SV *tsv;
3474         if (!tmbuf)
3475             RETPUSHUNDEF;
3476         tsv = newSVpvf("%s %s %2d %02d:%02d:%02d %d",
3477                        dayname[tmbuf->tm_wday],
3478                        monname[tmbuf->tm_mon],
3479                        tmbuf->tm_mday,
3480                        tmbuf->tm_hour,
3481                        tmbuf->tm_min,
3482                        tmbuf->tm_sec,
3483                        tmbuf->tm_year + 1900);
3484         PUSHs(sv_2mortal(tsv));
3485     }
3486     else if (tmbuf) {
3487         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_sec)));
3488         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_min)));
3489         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_hour)));
3490         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mday)));
3491         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mon)));
3492         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_year)));
3493         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_wday)));
3494         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_yday)));
3495         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_isdst)));
3496     }
3497     RETURN;
3498 }
3499
3500 PP(pp_alarm)
3501 {
3502     djSP; dTARGET;
3503     int anum;
3504 #ifdef HAS_ALARM
3505     anum = POPi;
3506     anum = alarm((unsigned int)anum);
3507     EXTEND(SP, 1);
3508     if (anum < 0)
3509         RETPUSHUNDEF;
3510     PUSHi((I32)anum);
3511     RETURN;
3512 #else
3513     DIE(no_func, "Unsupported function alarm");
3514 #endif
3515 }
3516
3517 PP(pp_sleep)
3518 {
3519     djSP; dTARGET;
3520     I32 duration;
3521     Time_t lasttime;
3522     Time_t when;
3523
3524     (void)time(&lasttime);
3525     if (MAXARG < 1)
3526         PerlProc_pause();
3527     else {
3528         duration = POPi;
3529         PerlProc_sleep((unsigned int)duration);
3530     }
3531     (void)time(&when);
3532     XPUSHi(when - lasttime);
3533     RETURN;
3534 }
3535
3536 /* Shared memory. */
3537
3538 PP(pp_shmget)
3539 {
3540     return pp_semget(ARGS);
3541 }
3542
3543 PP(pp_shmctl)
3544 {
3545     return pp_semctl(ARGS);
3546 }
3547
3548 PP(pp_shmread)
3549 {
3550     return pp_shmwrite(ARGS);
3551 }
3552
3553 PP(pp_shmwrite)
3554 {
3555 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3556     djSP; dMARK; dTARGET;
3557     I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
3558     SP = MARK;
3559     PUSHi(value);
3560     RETURN;
3561 #else
3562     return pp_semget(ARGS);
3563 #endif
3564 }
3565
3566 /* Message passing. */
3567
3568 PP(pp_msgget)
3569 {
3570     return pp_semget(ARGS);
3571 }
3572
3573 PP(pp_msgctl)
3574 {
3575     return pp_semctl(ARGS);
3576 }
3577
3578 PP(pp_msgsnd)
3579 {
3580 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3581     djSP; dMARK; dTARGET;
3582     I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
3583     SP = MARK;
3584     PUSHi(value);
3585     RETURN;
3586 #else
3587     return pp_semget(ARGS);
3588 #endif
3589 }
3590
3591 PP(pp_msgrcv)
3592 {
3593 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3594     djSP; dMARK; dTARGET;
3595     I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
3596     SP = MARK;
3597     PUSHi(value);
3598     RETURN;
3599 #else
3600     return pp_semget(ARGS);
3601 #endif
3602 }
3603
3604 /* Semaphores. */
3605
3606 PP(pp_semget)
3607 {
3608 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3609     djSP; dMARK; dTARGET;
3610     int anum = do_ipcget(PL_op->op_type, MARK, SP);
3611     SP = MARK;
3612     if (anum == -1)
3613         RETPUSHUNDEF;
3614     PUSHi(anum);
3615     RETURN;
3616 #else
3617     DIE("System V IPC is not implemented on this machine");
3618 #endif
3619 }
3620
3621 PP(pp_semctl)
3622 {
3623 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3624     djSP; dMARK; dTARGET;
3625     int anum = do_ipcctl(PL_op->op_type, MARK, SP);
3626     SP = MARK;
3627     if (anum == -1)
3628         RETSETUNDEF;
3629     if (anum != 0) {
3630         PUSHi(anum);
3631     }
3632     else {
3633         PUSHp(zero_but_true, ZBTLEN);
3634     }
3635     RETURN;
3636 #else
3637     return pp_semget(ARGS);
3638 #endif
3639 }
3640
3641 PP(pp_semop)
3642 {
3643 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3644     djSP; dMARK; dTARGET;
3645     I32 value = (I32)(do_semop(MARK, SP) >= 0);
3646     SP = MARK;
3647     PUSHi(value);
3648     RETURN;
3649 #else
3650     return pp_semget(ARGS);
3651 #endif
3652 }
3653
3654 /* Get system info. */
3655
3656 PP(pp_ghbyname)
3657 {
3658 #ifdef HAS_GETHOSTBYNAME
3659     return pp_ghostent(ARGS);
3660 #else
3661     DIE(no_sock_func, "gethostbyname");
3662 #endif
3663 }
3664
3665 PP(pp_ghbyaddr)
3666 {
3667 #ifdef HAS_GETHOSTBYADDR
3668     return pp_ghostent(ARGS);
3669 #else
3670     DIE(no_sock_func, "gethostbyaddr");
3671 #endif
3672 }
3673
3674 PP(pp_ghostent)
3675 {
3676     djSP;
3677 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
3678     I32 which = PL_op->op_type;
3679     register char **elem;
3680     register SV *sv;
3681 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
3682     struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
3683     struct hostent *PerlSock_gethostbyname(Netdb_name_t);
3684     struct hostent *PerlSock_gethostent(void);
3685 #endif
3686     struct hostent *hent;
3687     unsigned long len;
3688
3689     EXTEND(SP, 10);
3690     if (which == OP_GHBYNAME)
3691 #ifdef HAS_GETHOSTBYNAME
3692         hent = PerlSock_gethostbyname(POPp);
3693 #else
3694         DIE(no_sock_func, "gethostbyname");
3695 #endif
3696     else if (which == OP_GHBYADDR) {
3697 #ifdef HAS_GETHOSTBYADDR
3698         int addrtype = POPi;
3699         SV *addrsv = POPs;
3700         STRLEN addrlen;
3701         Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen);
3702
3703         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
3704 #else
3705         DIE(no_sock_func, "gethostbyaddr");
3706 #endif
3707     }
3708     else
3709 #ifdef HAS_GETHOSTENT
3710         hent = PerlSock_gethostent();
3711 #else
3712         DIE(no_sock_func, "gethostent");
3713 #endif
3714
3715 #ifdef HOST_NOT_FOUND
3716     if (!hent)
3717         STATUS_NATIVE_SET(h_errno);
3718 #endif
3719
3720     if (GIMME != G_ARRAY) {
3721         PUSHs(sv = sv_newmortal());
3722         if (hent) {
3723             if (which == OP_GHBYNAME) {
3724                 if (hent->h_addr)
3725                     sv_setpvn(sv, hent->h_addr, hent->h_length);
3726             }
3727             else
3728                 sv_setpv(sv, (char*)hent->h_name);
3729         }
3730         RETURN;
3731     }
3732
3733     if (hent) {
3734         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3735         sv_setpv(sv, (char*)hent->h_name);
3736         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3737         for (elem = hent->h_aliases; elem && *elem; elem++) {
3738             sv_catpv(sv, *elem);
3739             if (elem[1])
3740                 sv_catpvn(sv, " ", 1);
3741         }
3742         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3743         sv_setiv(sv, (IV)hent->h_addrtype);
3744         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3745         len = hent->h_length;
3746         sv_setiv(sv, (IV)len);
3747 #ifdef h_addr
3748         for (elem = hent->h_addr_list; elem && *elem; elem++) {
3749             XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
3750             sv_setpvn(sv, *elem, len);
3751         }
3752 #else
3753         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3754         if (hent->h_addr)
3755             sv_setpvn(sv, hent->h_addr, len);
3756 #endif /* h_addr */
3757     }
3758     RETURN;
3759 #else
3760     DIE(no_sock_func, "gethostent");
3761 #endif
3762 }
3763
3764 PP(pp_gnbyname)
3765 {
3766 #ifdef HAS_GETNETBYNAME
3767     return pp_gnetent(ARGS);
3768 #else
3769     DIE(no_sock_func, "getnetbyname");
3770 #endif
3771 }
3772
3773 PP(pp_gnbyaddr)
3774 {
3775 #ifdef HAS_GETNETBYADDR
3776     return pp_gnetent(ARGS);
3777 #else
3778     DIE(no_sock_func, "getnetbyaddr");
3779 #endif
3780 }
3781
3782 PP(pp_gnetent)
3783 {
3784     djSP;
3785 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
3786     I32 which = PL_op->op_type;
3787     register char **elem;
3788     register SV *sv;
3789 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
3790     struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
3791     struct netent *PerlSock_getnetbyname(Netdb_name_t);
3792     struct netent *PerlSock_getnetent(void);
3793 #endif
3794     struct netent *nent;
3795
3796     if (which == OP_GNBYNAME)
3797 #ifdef HAS_GETNETBYNAME
3798         nent = PerlSock_getnetbyname(POPp);
3799 #else
3800         DIE(no_sock_func, "getnetbyname");
3801 #endif
3802     else if (which == OP_GNBYADDR) {
3803 #ifdef HAS_GETNETBYADDR
3804         int addrtype = POPi;
3805         Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
3806         nent = PerlSock_getnetbyaddr(addr, addrtype);
3807 #else
3808         DIE(no_sock_func, "getnetbyaddr");
3809 #endif
3810     }
3811     else
3812 #ifdef HAS_GETNETENT
3813         nent = PerlSock_getnetent();
3814 #else
3815         DIE(no_sock_func, "getnetent");
3816 #endif
3817
3818     EXTEND(SP, 4);
3819     if (GIMME != G_ARRAY) {
3820         PUSHs(sv = sv_newmortal());
3821         if (nent) {
3822             if (which == OP_GNBYNAME)
3823                 sv_setiv(sv, (IV)nent->n_net);
3824             else
3825                 sv_setpv(sv, nent->n_name);
3826         }
3827         RETURN;
3828     }
3829
3830     if (nent) {
3831         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3832         sv_setpv(sv, nent->n_name);
3833         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3834         for (elem = nent->n_aliases; elem && *elem; elem++) {
3835             sv_catpv(sv, *elem);
3836             if (elem[1])
3837                 sv_catpvn(sv, " ", 1);
3838         }
3839         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3840         sv_setiv(sv, (IV)nent->n_addrtype);
3841         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3842         sv_setiv(sv, (IV)nent->n_net);
3843     }
3844
3845     RETURN;
3846 #else
3847     DIE(no_sock_func, "getnetent");
3848 #endif
3849 }
3850
3851 PP(pp_gpbyname)
3852 {
3853 #ifdef HAS_GETPROTOBYNAME
3854     return pp_gprotoent(ARGS);
3855 #else
3856     DIE(no_sock_func, "getprotobyname");
3857 #endif
3858 }
3859
3860 PP(pp_gpbynumber)
3861 {
3862 #ifdef HAS_GETPROTOBYNUMBER
3863     return pp_gprotoent(ARGS);
3864 #else
3865     DIE(no_sock_func, "getprotobynumber");
3866 #endif
3867 }
3868
3869 PP(pp_gprotoent)
3870 {
3871     djSP;
3872 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
3873     I32 which = PL_op->op_type;
3874     register char **elem;
3875     register SV *sv;
3876 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
3877     struct protoent *PerlSock_getprotobyname(Netdb_name_t);
3878     struct protoent *PerlSock_getprotobynumber(int);
3879     struct protoent *PerlSock_getprotoent(void);
3880 #endif
3881     struct protoent *pent;
3882
3883     if (which == OP_GPBYNAME)
3884 #ifdef HAS_GETPROTOBYNAME
3885         pent = PerlSock_getprotobyname(POPp);
3886 #else
3887         DIE(no_sock_func, "getprotobyname");
3888 #endif
3889     else if (which == OP_GPBYNUMBER)
3890 #ifdef HAS_GETPROTOBYNUMBER
3891         pent = PerlSock_getprotobynumber(POPi);
3892 #else
3893     DIE(no_sock_func, "getprotobynumber");
3894 #endif
3895     else
3896 #ifdef HAS_GETPROTOENT
3897         pent = PerlSock_getprotoent();
3898 #else
3899         DIE(no_sock_func, "getprotoent");
3900 #endif
3901
3902     EXTEND(SP, 3);
3903     if (GIMME != G_ARRAY) {
3904         PUSHs(sv = sv_newmortal());
3905         if (pent) {
3906             if (which == OP_GPBYNAME)
3907                 sv_setiv(sv, (IV)pent->p_proto);
3908             else
3909                 sv_setpv(sv, pent->p_name);
3910         }
3911         RETURN;
3912     }
3913
3914     if (pent) {
3915         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3916         sv_setpv(sv, pent->p_name);
3917         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3918         for (elem = pent->p_aliases; elem && *elem; elem++) {
3919             sv_catpv(sv, *elem);
3920             if (elem[1])
3921                 sv_catpvn(sv, " ", 1);
3922         }
3923         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3924         sv_setiv(sv, (IV)pent->p_proto);
3925     }
3926
3927     RETURN;
3928 #else
3929     DIE(no_sock_func, "getprotoent");
3930 #endif
3931 }
3932
3933 PP(pp_gsbyname)
3934 {
3935 #ifdef HAS_GETSERVBYNAME
3936     return pp_gservent(ARGS);
3937 #else
3938     DIE(no_sock_func, "getservbyname");
3939 #endif
3940 }
3941
3942 PP(pp_gsbyport)
3943 {
3944 #ifdef HAS_GETSERVBYPORT
3945     return pp_gservent(ARGS);
3946 #else
3947     DIE(no_sock_func, "getservbyport");
3948 #endif
3949 }
3950
3951 PP(pp_gservent)
3952 {
3953     djSP;
3954 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
3955     I32 which = PL_op->op_type;
3956     register char **elem;
3957     register SV *sv;
3958 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
3959     struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
3960     struct servent *PerlSock_getservbyport(int, Netdb_name_t);
3961     struct servent *PerlSock_getservent(void);
3962 #endif
3963     struct servent *sent;
3964
3965     if (which == OP_GSBYNAME) {
3966 #ifdef HAS_GETSERVBYNAME
3967         char *proto = POPp;
3968         char *name = POPp;
3969
3970         if (proto && !*proto)
3971             proto = Nullch;
3972
3973         sent = PerlSock_getservbyname(name, proto);
3974 #else
3975         DIE(no_sock_func, "getservbyname");
3976 #endif
3977     }
3978     else if (which == OP_GSBYPORT) {
3979 #ifdef HAS_GETSERVBYPORT
3980         char *proto = POPp;
3981         unsigned short port = POPu;
3982
3983 #ifdef HAS_HTONS
3984         port = PerlSock_htons(port);
3985 #endif
3986         sent = PerlSock_getservbyport(port, proto);
3987 #else
3988         DIE(no_sock_func, "getservbyport");
3989 #endif
3990     }
3991     else
3992 #ifdef HAS_GETSERVENT
3993         sent = PerlSock_getservent();
3994 #else
3995         DIE(no_sock_func, "getservent");
3996 #endif
3997
3998     EXTEND(SP, 4);
3999     if (GIMME != G_ARRAY) {
4000         PUSHs(sv = sv_newmortal());
4001         if (sent) {
4002             if (which == OP_GSBYNAME) {
4003 #ifdef HAS_NTOHS
4004                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4005 #else
4006                 sv_setiv(sv, (IV)(sent->s_port));
4007 #endif
4008             }
4009             else
4010                 sv_setpv(sv, sent->s_name);
4011         }
4012         RETURN;
4013     }
4014
4015     if (sent) {
4016         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4017         sv_setpv(sv, sent->s_name);
4018         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4019         for (elem = sent->s_aliases; elem && *elem; elem++) {
4020             sv_catpv(sv, *elem);
4021             if (elem[1])
4022                 sv_catpvn(sv, " ", 1);
4023         }
4024         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4025 #ifdef HAS_NTOHS
4026         sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4027 #else
4028         sv_setiv(sv, (IV)(sent->s_port));
4029 #endif
4030         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4031         sv_setpv(sv, sent->s_proto);
4032     }
4033
4034     RETURN;
4035 #else
4036     DIE(no_sock_func, "getservent");
4037 #endif
4038 }
4039
4040 PP(pp_shostent)
4041 {
4042     djSP;
4043 #ifdef HAS_SETHOSTENT
4044     PerlSock_sethostent(TOPi);
4045     RETSETYES;
4046 #else
4047     DIE(no_sock_func, "sethostent");
4048 #endif
4049 }
4050
4051 PP(pp_snetent)
4052 {
4053     djSP;
4054 #ifdef HAS_SETNETENT
4055     PerlSock_setnetent(TOPi);
4056     RETSETYES;
4057 #else
4058     DIE(no_sock_func, "setnetent");
4059 #endif
4060 }
4061
4062 PP(pp_sprotoent)
4063 {
4064     djSP;
4065 #ifdef HAS_SETPROTOENT
4066     PerlSock_setprotoent(TOPi);
4067     RETSETYES;
4068 #else
4069     DIE(no_sock_func, "setprotoent");
4070 #endif
4071 }
4072
4073 PP(pp_sservent)
4074 {
4075     djSP;
4076 #ifdef HAS_SETSERVENT
4077     PerlSock_setservent(TOPi);
4078     RETSETYES;
4079 #else
4080     DIE(no_sock_func, "setservent");
4081 #endif
4082 }
4083
4084 PP(pp_ehostent)
4085 {
4086     djSP;
4087 #ifdef HAS_ENDHOSTENT
4088     PerlSock_endhostent();
4089     EXTEND(SP,1);
4090     RETPUSHYES;
4091 #else
4092     DIE(no_sock_func, "endhostent");
4093 #endif
4094 }
4095
4096 PP(pp_enetent)
4097 {
4098     djSP;
4099 #ifdef HAS_ENDNETENT
4100     PerlSock_endnetent();
4101     EXTEND(SP,1);
4102     RETPUSHYES;
4103 #else
4104     DIE(no_sock_func, "endnetent");
4105 #endif
4106 }
4107
4108 PP(pp_eprotoent)
4109 {
4110     djSP;
4111 #ifdef HAS_ENDPROTOENT
4112     PerlSock_endprotoent();
4113     EXTEND(SP,1);
4114     RETPUSHYES;
4115 #else
4116     DIE(no_sock_func, "endprotoent");
4117 #endif
4118 }
4119
4120 PP(pp_eservent)
4121 {
4122     djSP;
4123 #ifdef HAS_ENDSERVENT
4124     PerlSock_endservent();
4125     EXTEND(SP,1);
4126     RETPUSHYES;
4127 #else
4128     DIE(no_sock_func, "endservent");
4129 #endif
4130 }
4131
4132 PP(pp_gpwnam)
4133 {
4134 #ifdef HAS_PASSWD
4135     return pp_gpwent(ARGS);
4136 #else
4137     DIE(no_func, "getpwnam");
4138 #endif
4139 }
4140
4141 PP(pp_gpwuid)
4142 {
4143 #ifdef HAS_PASSWD
4144     return pp_gpwent(ARGS);
4145 #else
4146     DIE(no_func, "getpwuid");
4147 #endif
4148 }
4149
4150 PP(pp_gpwent)
4151 {
4152     djSP;
4153 #if defined(HAS_PASSWD) && defined(HAS_GETPWENT)
4154     I32 which = PL_op->op_type;
4155     register SV *sv;
4156     struct passwd *pwent;
4157
4158     if (which == OP_GPWNAM)
4159         pwent = getpwnam(POPp);
4160     else if (which == OP_GPWUID)
4161         pwent = getpwuid(POPi);
4162     else
4163         pwent = (struct passwd *)getpwent();
4164
4165     EXTEND(SP, 10);
4166     if (GIMME != G_ARRAY) {
4167         PUSHs(sv = sv_newmortal());
4168         if (pwent) {
4169             if (which == OP_GPWNAM)
4170                 sv_setiv(sv, (IV)pwent->pw_uid);
4171             else
4172                 sv_setpv(sv, pwent->pw_name);
4173         }
4174         RETURN;
4175     }
4176
4177     if (pwent) {
4178         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4179         sv_setpv(sv, pwent->pw_name);
4180
4181         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4182 #ifdef PWPASSWD
4183         sv_setpv(sv, pwent->pw_passwd);
4184 #endif
4185
4186         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4187         sv_setiv(sv, (IV)pwent->pw_uid);
4188
4189         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4190         sv_setiv(sv, (IV)pwent->pw_gid);
4191
4192         /* pw_change, pw_quota, and pw_age are mutually exclusive. */
4193         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4194 #ifdef PWCHANGE
4195         sv_setiv(sv, (IV)pwent->pw_change);
4196 #else
4197 #   ifdef PWQUOTA
4198         sv_setiv(sv, (IV)pwent->pw_quota);
4199 #   else
4200 #       ifdef PWAGE
4201         sv_setpv(sv, pwent->pw_age);
4202 #       endif
4203 #   endif
4204 #endif
4205
4206         /* pw_class and pw_comment are mutually exclusive. */
4207         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4208 #ifdef PWCLASS
4209         sv_setpv(sv, pwent->pw_class);
4210 #else
4211 #   ifdef PWCOMMENT
4212         sv_setpv(sv, pwent->pw_comment);
4213 #   endif
4214 #endif
4215
4216         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4217 #ifdef PWGECOS
4218         sv_setpv(sv, pwent->pw_gecos);
4219 #endif
4220 #ifndef INCOMPLETE_TAINTS
4221         /* pw_gecos is tainted because user himself can diddle with it. */
4222         SvTAINTED_on(sv);
4223 #endif
4224
4225         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4226         sv_setpv(sv, pwent->pw_dir);
4227
4228         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4229         sv_setpv(sv, pwent->pw_shell);
4230
4231 #ifdef PWEXPIRE
4232         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4233         sv_setiv(sv, (IV)pwent->pw_expire);
4234 #endif
4235     }
4236     RETURN;
4237 #else
4238     DIE(no_func, "getpwent");
4239 #endif
4240 }
4241
4242 PP(pp_spwent)
4243 {
4244     djSP;
4245 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT) && !defined(CYGWIN32)
4246     setpwent();
4247     RETPUSHYES;
4248 #else
4249     DIE(no_func, "setpwent");
4250 #endif
4251 }
4252
4253 PP(pp_epwent)
4254 {
4255     djSP;
4256 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
4257     endpwent();
4258     RETPUSHYES;
4259 #else
4260     DIE(no_func, "endpwent");
4261 #endif
4262 }
4263
4264 PP(pp_ggrnam)
4265 {
4266 #ifdef HAS_GROUP
4267     return pp_ggrent(ARGS);
4268 #else
4269     DIE(no_func, "getgrnam");
4270 #endif
4271 }
4272
4273 PP(pp_ggrgid)
4274 {
4275 #ifdef HAS_GROUP
4276     return pp_ggrent(ARGS);
4277 #else
4278     DIE(no_func, "getgrgid");
4279 #endif
4280 }
4281
4282 PP(pp_ggrent)
4283 {
4284     djSP;
4285 #if defined(HAS_GROUP) && defined(HAS_GETGRENT)
4286     I32 which = PL_op->op_type;
4287     register char **elem;
4288     register SV *sv;
4289     struct group *grent;
4290
4291     if (which == OP_GGRNAM)
4292         grent = (struct group *)getgrnam(POPp);
4293     else if (which == OP_GGRGID)
4294         grent = (struct group *)getgrgid(POPi);
4295     else
4296         grent = (struct group *)getgrent();
4297
4298     EXTEND(SP, 4);
4299     if (GIMME != G_ARRAY) {
4300         PUSHs(sv = sv_newmortal());
4301         if (grent) {
4302             if (which == OP_GGRNAM)
4303                 sv_setiv(sv, (IV)grent->gr_gid);
4304             else
4305                 sv_setpv(sv, grent->gr_name);
4306         }
4307         RETURN;
4308     }
4309
4310     if (grent) {
4311         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4312         sv_setpv(sv, grent->gr_name);
4313
4314         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4315 #ifdef GRPASSWD
4316         sv_setpv(sv, grent->gr_passwd);
4317 #endif
4318
4319         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4320         sv_setiv(sv, (IV)grent->gr_gid);
4321
4322         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4323         for (elem = grent->gr_mem; elem && *elem; elem++) {
4324             sv_catpv(sv, *elem);
4325             if (elem[1])
4326                 sv_catpvn(sv, " ", 1);
4327         }
4328     }
4329
4330     RETURN;
4331 #else
4332     DIE(no_func, "getgrent");
4333 #endif
4334 }
4335
4336 PP(pp_sgrent)
4337 {
4338     djSP;
4339 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
4340     setgrent();
4341     RETPUSHYES;
4342 #else
4343     DIE(no_func, "setgrent");
4344 #endif
4345 }
4346
4347 PP(pp_egrent)
4348 {
4349     djSP;
4350 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
4351     endgrent();
4352     RETPUSHYES;
4353 #else
4354     DIE(no_func, "endgrent");
4355 #endif
4356 }
4357
4358 PP(pp_getlogin)
4359 {
4360     djSP; dTARGET;
4361 #ifdef HAS_GETLOGIN
4362     char *tmps;
4363     EXTEND(SP, 1);
4364     if (!(tmps = PerlProc_getlogin()))
4365         RETPUSHUNDEF;
4366     PUSHp(tmps, strlen(tmps));
4367     RETURN;
4368 #else
4369     DIE(no_func, "getlogin");
4370 #endif
4371 }
4372
4373 /* Miscellaneous. */
4374
4375 PP(pp_syscall)
4376 {
4377 #ifdef HAS_SYSCALL
4378     djSP; dMARK; dORIGMARK; dTARGET;
4379     register I32 items = SP - MARK;
4380     unsigned long a[20];
4381     register I32 i = 0;
4382     I32 retval = -1;
4383     MAGIC *mg;
4384
4385     if (PL_tainting) {
4386         while (++MARK <= SP) {
4387             if (SvTAINTED(*MARK)) {
4388                 TAINT;
4389                 break;
4390             }
4391         }
4392         MARK = ORIGMARK;
4393         TAINT_PROPER("syscall");
4394     }
4395
4396     /* This probably won't work on machines where sizeof(long) != sizeof(int)
4397      * or where sizeof(long) != sizeof(char*).  But such machines will
4398      * not likely have syscall implemented either, so who cares?
4399      */
4400     while (++MARK <= SP) {
4401         if (SvNIOK(*MARK) || !i)
4402             a[i++] = SvIV(*MARK);
4403         else if (*MARK == &PL_sv_undef)
4404             a[i++] = 0;
4405         else
4406             a[i++] = (unsigned long)SvPV_force(*MARK, PL_na);
4407         if (i > 15)
4408             break;
4409     }
4410     switch (items) {
4411     default:
4412         DIE("Too many args to syscall");
4413     case 0:
4414         DIE("Too few args to syscall");
4415     case 1:
4416         retval = syscall(a[0]);
4417         break;
4418     case 2:
4419         retval = syscall(a[0],a[1]);
4420         break;
4421     case 3:
4422         retval = syscall(a[0],a[1],a[2]);
4423         break;
4424     case 4:
4425         retval = syscall(a[0],a[1],a[2],a[3]);
4426         break;
4427     case 5:
4428         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
4429         break;
4430     case 6:
4431         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
4432         break;
4433     case 7:
4434         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
4435         break;
4436     case 8:
4437         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
4438         break;
4439 #ifdef atarist
4440     case 9:
4441         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
4442         break;
4443     case 10:
4444         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
4445         break;
4446     case 11:
4447         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4448           a[10]);
4449         break;
4450     case 12:
4451         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4452           a[10],a[11]);
4453         break;
4454     case 13:
4455         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4456           a[10],a[11],a[12]);
4457         break;
4458     case 14:
4459         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4460           a[10],a[11],a[12],a[13]);
4461         break;
4462 #endif /* atarist */
4463     }
4464     SP = ORIGMARK;
4465     PUSHi(retval);
4466     RETURN;
4467 #else
4468     DIE(no_func, "syscall");
4469 #endif
4470 }
4471
4472 #ifdef FCNTL_EMULATE_FLOCK
4473
4474 /*  XXX Emulate flock() with fcntl().
4475     What's really needed is a good file locking module.
4476 */
4477
4478 static int
4479 fcntl_emulate_flock(int fd, int operation)
4480 {
4481     struct flock flock;
4482
4483     switch (operation & ~LOCK_NB) {
4484     case LOCK_SH:
4485         flock.l_type = F_RDLCK;
4486         break;
4487     case LOCK_EX:
4488         flock.l_type = F_WRLCK;
4489         break;
4490     case LOCK_UN:
4491         flock.l_type = F_UNLCK;
4492         break;
4493     default:
4494         errno = EINVAL;
4495         return -1;
4496     }
4497     flock.l_whence = SEEK_SET;
4498     flock.l_start = flock.l_len = 0L;
4499
4500     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
4501 }
4502
4503 #endif /* FCNTL_EMULATE_FLOCK */
4504
4505 #ifdef LOCKF_EMULATE_FLOCK
4506
4507 /*  XXX Emulate flock() with lockf().  This is just to increase
4508     portability of scripts.  The calls are not completely
4509     interchangeable.  What's really needed is a good file
4510     locking module.
4511 */
4512
4513 /*  The lockf() constants might have been defined in <unistd.h>.
4514     Unfortunately, <unistd.h> causes troubles on some mixed
4515     (BSD/POSIX) systems, such as SunOS 4.1.3.
4516
4517    Further, the lockf() constants aren't POSIX, so they might not be
4518    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
4519    just stick in the SVID values and be done with it.  Sigh.
4520 */
4521
4522 # ifndef F_ULOCK
4523 #  define F_ULOCK       0       /* Unlock a previously locked region */
4524 # endif
4525 # ifndef F_LOCK
4526 #  define F_LOCK        1       /* Lock a region for exclusive use */
4527 # endif
4528 # ifndef F_TLOCK
4529 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
4530 # endif
4531 # ifndef F_TEST
4532 #  define F_TEST        3       /* Test a region for other processes locks */
4533 # endif
4534
4535 static int
4536 lockf_emulate_flock (fd, operation)
4537 int fd;
4538 int operation;
4539 {
4540     int i;
4541     int save_errno;
4542     Off_t pos;
4543
4544     /* flock locks entire file so for lockf we need to do the same      */
4545     save_errno = errno;
4546     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
4547     if (pos > 0)        /* is seekable and needs to be repositioned     */
4548         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
4549             pos = -1;   /* seek failed, so don't seek back afterwards   */
4550     errno = save_errno;
4551
4552     switch (operation) {
4553
4554         /* LOCK_SH - get a shared lock */
4555         case LOCK_SH:
4556         /* LOCK_EX - get an exclusive lock */
4557         case LOCK_EX:
4558             i = lockf (fd, F_LOCK, 0);
4559             break;
4560
4561         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
4562         case LOCK_SH|LOCK_NB:
4563         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
4564         case LOCK_EX|LOCK_NB:
4565             i = lockf (fd, F_TLOCK, 0);
4566             if (i == -1)
4567                 if ((errno == EAGAIN) || (errno == EACCES))
4568                     errno = EWOULDBLOCK;
4569             break;
4570
4571         /* LOCK_UN - unlock (non-blocking is a no-op) */
4572         case LOCK_UN:
4573         case LOCK_UN|LOCK_NB:
4574             i = lockf (fd, F_ULOCK, 0);
4575             break;
4576
4577         /* Default - can't decipher operation */
4578         default:
4579             i = -1;
4580             errno = EINVAL;
4581             break;
4582     }
4583
4584     if (pos > 0)      /* need to restore position of the handle */
4585         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
4586
4587     return (i);
4588 }
4589
4590 #endif /* LOCKF_EMULATE_FLOCK */