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