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