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