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