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         bufsize = sizeof namebuf;
1247         buffer = SvGROW(bufsv, length+1);
1248         /* 'offset' means 'flags' here */
1249         length = recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1250                           (struct sockaddr *)namebuf, &bufsize);
1251         if (length < 0)
1252             RETPUSHUNDEF;
1253         SvCUR_set(bufsv, length);
1254         *SvEND(bufsv) = '\0';
1255         (void)SvPOK_only(bufsv);
1256         SvSETMAGIC(bufsv);
1257         /* This should not be marked tainted if the fp is marked clean */
1258         if (!(IoFLAGS(io) & IOf_UNTAINT))
1259             SvTAINTED_on(bufsv);
1260         SP = ORIGMARK;
1261         sv_setpvn(TARG, namebuf, bufsize);
1262         PUSHs(TARG);
1263         RETURN;
1264     }
1265 #else
1266     if (op->op_type == OP_RECV)
1267         DIE(no_sock_func, "recv");
1268 #endif
1269     if (offset < 0) {
1270         if (-offset > blen)
1271             DIE("Offset outside string");
1272         offset += blen;
1273     }
1274     bufsize = SvCUR(bufsv);
1275     buffer = SvGROW(bufsv, length+offset+1);
1276     if (offset > bufsize) { /* Zero any newly allocated space */
1277         Zero(buffer+bufsize, offset-bufsize, char);
1278     }
1279     if (op->op_type == OP_SYSREAD) {
1280         length = read(PerlIO_fileno(IoIFP(io)), buffer+offset, length);
1281     }
1282     else
1283 #ifdef HAS_SOCKET__bad_code_maybe
1284     if (IoTYPE(io) == 's') {
1285         char namebuf[MAXPATHLEN];
1286         bufsize = sizeof namebuf;
1287         length = recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
1288                           (struct sockaddr *)namebuf, &bufsize);
1289     }
1290     else
1291 #endif
1292         length = PerlIO_read(IoIFP(io), buffer+offset, length);
1293     if (length < 0)
1294         goto say_undef;
1295     SvCUR_set(bufsv, length+offset);
1296     *SvEND(bufsv) = '\0';
1297     (void)SvPOK_only(bufsv);
1298     SvSETMAGIC(bufsv);
1299     /* This should not be marked tainted if the fp is marked clean */
1300     if (!(IoFLAGS(io) & IOf_UNTAINT))
1301         SvTAINTED_on(bufsv);
1302     SP = ORIGMARK;
1303     PUSHi(length);
1304     RETURN;
1305
1306   say_undef:
1307     SP = ORIGMARK;
1308     RETPUSHUNDEF;
1309 }
1310
1311 PP(pp_syswrite)
1312 {
1313     return pp_send(ARGS);
1314 }
1315
1316 PP(pp_send)
1317 {
1318     dSP; dMARK; dORIGMARK; dTARGET;
1319     GV *gv;
1320     IO *io;
1321     int offset;
1322     SV *bufsv;
1323     char *buffer;
1324     int length;
1325     STRLEN blen;
1326
1327     gv = (GV*)*++MARK;
1328     if (!gv)
1329         goto say_undef;
1330     bufsv = *++MARK;
1331     buffer = SvPV(bufsv, blen);
1332     length = SvIVx(*++MARK);
1333     if (length < 0)
1334         DIE("Negative length");
1335     SETERRNO(0,0);
1336     io = GvIO(gv);
1337     if (!io || !IoIFP(io)) {
1338         length = -1;
1339         if (dowarn) {
1340             if (op->op_type == OP_SYSWRITE)
1341                 warn("Syswrite on closed filehandle");
1342             else
1343                 warn("Send on closed socket");
1344         }
1345     }
1346     else if (op->op_type == OP_SYSWRITE) {
1347         if (MARK < SP) {
1348             offset = SvIVx(*++MARK);
1349             if (offset < 0) {
1350                 if (-offset > blen)
1351                     DIE("Offset outside string");
1352                 offset += blen;
1353             } else if (offset >= blen)
1354                 DIE("Offset outside string");
1355         } else
1356             offset = 0;
1357         if (length > blen - offset)
1358             length = blen - offset;
1359         length = write(PerlIO_fileno(IoIFP(io)), buffer+offset, length);
1360     }
1361 #ifdef HAS_SOCKET
1362     else if (SP > MARK) {
1363         char *sockbuf;
1364         STRLEN mlen;
1365         sockbuf = SvPVx(*++MARK, mlen);
1366         length = sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
1367                                 (struct sockaddr *)sockbuf, mlen);
1368     }
1369     else
1370         length = send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
1371 #else
1372     else
1373         DIE(no_sock_func, "send");
1374 #endif
1375     if (length < 0)
1376         goto say_undef;
1377     SP = ORIGMARK;
1378     PUSHi(length);
1379     RETURN;
1380
1381   say_undef:
1382     SP = ORIGMARK;
1383     RETPUSHUNDEF;
1384 }
1385
1386 PP(pp_recv)
1387 {
1388     return pp_sysread(ARGS);
1389 }
1390
1391 PP(pp_eof)
1392 {
1393     dSP;
1394     GV *gv;
1395
1396     if (MAXARG <= 0)
1397         gv = last_in_gv;
1398     else
1399         gv = last_in_gv = (GV*)POPs;
1400     PUSHs(boolSV(!gv || do_eof(gv)));
1401     RETURN;
1402 }
1403
1404 PP(pp_tell)
1405 {
1406     dSP; dTARGET;
1407     GV *gv;
1408
1409     if (MAXARG <= 0)
1410         gv = last_in_gv;
1411     else
1412         gv = last_in_gv = (GV*)POPs;
1413     PUSHi( do_tell(gv) );
1414     RETURN;
1415 }
1416
1417 PP(pp_seek)
1418 {
1419     return pp_sysseek(ARGS);
1420 }
1421
1422 PP(pp_sysseek)
1423 {
1424     dSP;
1425     GV *gv;
1426     int whence = POPi;
1427     long offset = POPl;
1428
1429     gv = last_in_gv = (GV*)POPs;
1430     if (op->op_type == OP_SEEK)
1431         PUSHs(boolSV(do_seek(gv, offset, whence)));
1432     else {
1433         long n = do_sysseek(gv, offset, whence);
1434         PUSHs((n < 0) ? &sv_undef
1435               : sv_2mortal(n ? newSViv((IV)n)
1436                            : newSVpv(zero_but_true, ZBTLEN)));
1437     }
1438     RETURN;
1439 }
1440
1441 PP(pp_truncate)
1442 {
1443     dSP;
1444     Off_t len = (Off_t)POPn;
1445     int result = 1;
1446     GV *tmpgv;
1447
1448     SETERRNO(0,0);
1449 #if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
1450     if (op->op_flags & OPf_SPECIAL) {
1451         tmpgv = gv_fetchpv(POPp, FALSE, SVt_PVIO);
1452     do_ftruncate:
1453         TAINT_PROPER("truncate");
1454         if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
1455 #ifdef HAS_TRUNCATE
1456           ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
1457 #else
1458           my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
1459 #endif
1460             result = 0;
1461     }
1462     else {
1463         SV *sv = POPs;
1464         char *name;
1465
1466         if (SvTYPE(sv) == SVt_PVGV) {
1467             tmpgv = (GV*)sv;            /* *main::FRED for example */
1468             goto do_ftruncate;
1469         }
1470         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1471             tmpgv = (GV*) SvRV(sv);     /* \*main::FRED for example */
1472             goto do_ftruncate;
1473         }
1474
1475         name = SvPV(sv, na);
1476         TAINT_PROPER("truncate");
1477 #ifdef HAS_TRUNCATE
1478         if (truncate(name, len) < 0)
1479             result = 0;
1480 #else
1481         {
1482             int tmpfd;
1483             if ((tmpfd = open(name, O_RDWR)) < 0)
1484                 result = 0;
1485             else {
1486                 if (my_chsize(tmpfd, len) < 0)
1487                     result = 0;
1488                 close(tmpfd);
1489             }
1490         }
1491 #endif
1492     }
1493
1494     if (result)
1495         RETPUSHYES;
1496     if (!errno)
1497         SETERRNO(EBADF,RMS$_IFI);
1498     RETPUSHUNDEF;
1499 #else
1500     DIE("truncate not implemented");
1501 #endif
1502 }
1503
1504 PP(pp_fcntl)
1505 {
1506     return pp_ioctl(ARGS);
1507 }
1508
1509 PP(pp_ioctl)
1510 {
1511     dSP; dTARGET;
1512     SV *argsv = POPs;
1513     unsigned int func = U_I(POPn);
1514     int optype = op->op_type;
1515     char *s;
1516     IV retval;
1517     GV *gv = (GV*)POPs;
1518     IO *io = GvIOn(gv);
1519
1520     if (!io || !argsv || !IoIFP(io)) {
1521         SETERRNO(EBADF,RMS$_IFI);       /* well, sort of... */
1522         RETPUSHUNDEF;
1523     }
1524
1525     if (SvPOK(argsv) || !SvNIOK(argsv)) {
1526         STRLEN len;
1527         STRLEN need;
1528         s = SvPV_force(argsv, len);
1529         need = IOCPARM_LEN(func);
1530         if (len < need) {
1531             s = Sv_Grow(argsv, need + 1);
1532             SvCUR_set(argsv, need);
1533         }
1534
1535         s[SvCUR(argsv)] = 17;   /* a little sanity check here */
1536     }
1537     else {
1538         retval = SvIV(argsv);
1539         s = (char*)retval;              /* ouch */
1540     }
1541
1542     TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
1543
1544     if (optype == OP_IOCTL)
1545 #ifdef HAS_IOCTL
1546         retval = ioctl(PerlIO_fileno(IoIFP(io)), func, s);
1547 #else
1548         DIE("ioctl is not implemented");
1549 #endif
1550     else
1551 #ifdef HAS_FCNTL
1552 #if defined(OS2) && defined(__EMX__)
1553         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
1554 #else
1555         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
1556 #endif
1557 #else
1558         DIE("fcntl is not implemented");
1559 #endif
1560
1561     if (SvPOK(argsv)) {
1562         if (s[SvCUR(argsv)] != 17)
1563             DIE("Possible memory corruption: %s overflowed 3rd argument",
1564                 op_name[optype]);
1565         s[SvCUR(argsv)] = 0;            /* put our null back */
1566         SvSETMAGIC(argsv);              /* Assume it has changed */
1567     }
1568
1569     if (retval == -1)
1570         RETPUSHUNDEF;
1571     if (retval != 0) {
1572         PUSHi(retval);
1573     }
1574     else {
1575         PUSHp(zero_but_true, ZBTLEN);
1576     }
1577     RETURN;
1578 }
1579
1580 PP(pp_flock)
1581 {
1582     dSP; dTARGET;
1583     I32 value;
1584     int argtype;
1585     GV *gv;
1586     PerlIO *fp;
1587
1588 #ifdef FLOCK
1589     argtype = POPi;
1590     if (MAXARG <= 0)
1591         gv = last_in_gv;
1592     else
1593         gv = (GV*)POPs;
1594     if (gv && GvIO(gv))
1595         fp = IoIFP(GvIOp(gv));
1596     else
1597         fp = Nullfp;
1598     if (fp) {
1599         (void)PerlIO_flush(fp);
1600         value = (I32)(FLOCK(PerlIO_fileno(fp), argtype) >= 0);
1601     }
1602     else
1603         value = 0;
1604     PUSHi(value);
1605     RETURN;
1606 #else
1607     DIE(no_func, "flock()");
1608 #endif
1609 }
1610
1611 /* Sockets. */
1612
1613 PP(pp_socket)
1614 {
1615     dSP;
1616 #ifdef HAS_SOCKET
1617     GV *gv;
1618     register IO *io;
1619     int protocol = POPi;
1620     int type = POPi;
1621     int domain = POPi;
1622     int fd;
1623
1624     gv = (GV*)POPs;
1625
1626     if (!gv) {
1627         SETERRNO(EBADF,LIB$_INVARG);
1628         RETPUSHUNDEF;
1629     }
1630
1631     io = GvIOn(gv);
1632     if (IoIFP(io))
1633         do_close(gv, FALSE);
1634
1635     TAINT_PROPER("socket");
1636     fd = socket(domain, type, protocol);
1637     if (fd < 0)
1638         RETPUSHUNDEF;
1639     IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
1640     IoOFP(io) = PerlIO_fdopen(fd, "w");
1641     IoTYPE(io) = 's';
1642     if (!IoIFP(io) || !IoOFP(io)) {
1643         if (IoIFP(io)) PerlIO_close(IoIFP(io));
1644         if (IoOFP(io)) PerlIO_close(IoOFP(io));
1645         if (!IoIFP(io) && !IoOFP(io)) close(fd);
1646         RETPUSHUNDEF;
1647     }
1648
1649     RETPUSHYES;
1650 #else
1651     DIE(no_sock_func, "socket");
1652 #endif
1653 }
1654
1655 PP(pp_sockpair)
1656 {
1657     dSP;
1658 #ifdef HAS_SOCKETPAIR
1659     GV *gv1;
1660     GV *gv2;
1661     register IO *io1;
1662     register IO *io2;
1663     int protocol = POPi;
1664     int type = POPi;
1665     int domain = POPi;
1666     int fd[2];
1667
1668     gv2 = (GV*)POPs;
1669     gv1 = (GV*)POPs;
1670     if (!gv1 || !gv2)
1671         RETPUSHUNDEF;
1672
1673     io1 = GvIOn(gv1);
1674     io2 = GvIOn(gv2);
1675     if (IoIFP(io1))
1676         do_close(gv1, FALSE);
1677     if (IoIFP(io2))
1678         do_close(gv2, FALSE);
1679
1680     TAINT_PROPER("socketpair");
1681     if (socketpair(domain, type, protocol, fd) < 0)
1682         RETPUSHUNDEF;
1683     IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
1684     IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
1685     IoTYPE(io1) = 's';
1686     IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
1687     IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
1688     IoTYPE(io2) = 's';
1689     if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
1690         if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
1691         if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
1692         if (!IoIFP(io1) && !IoOFP(io1)) close(fd[0]);
1693         if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
1694         if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
1695         if (!IoIFP(io2) && !IoOFP(io2)) close(fd[1]);
1696         RETPUSHUNDEF;
1697     }
1698
1699     RETPUSHYES;
1700 #else
1701     DIE(no_sock_func, "socketpair");
1702 #endif
1703 }
1704
1705 PP(pp_bind)
1706 {
1707     dSP;
1708 #ifdef HAS_SOCKET
1709     SV *addrsv = POPs;
1710     char *addr;
1711     GV *gv = (GV*)POPs;
1712     register IO *io = GvIOn(gv);
1713     STRLEN len;
1714
1715     if (!io || !IoIFP(io))
1716         goto nuts;
1717
1718     addr = SvPV(addrsv, len);
1719     TAINT_PROPER("bind");
1720     if (bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
1721         RETPUSHYES;
1722     else
1723         RETPUSHUNDEF;
1724
1725 nuts:
1726     if (dowarn)
1727         warn("bind() on closed fd");
1728     SETERRNO(EBADF,SS$_IVCHAN);
1729     RETPUSHUNDEF;
1730 #else
1731     DIE(no_sock_func, "bind");
1732 #endif
1733 }
1734
1735 PP(pp_connect)
1736 {
1737     dSP;
1738 #ifdef HAS_SOCKET
1739     SV *addrsv = POPs;
1740     char *addr;
1741     GV *gv = (GV*)POPs;
1742     register IO *io = GvIOn(gv);
1743     STRLEN len;
1744
1745     if (!io || !IoIFP(io))
1746         goto nuts;
1747
1748     addr = SvPV(addrsv, len);
1749     TAINT_PROPER("connect");
1750     if (connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
1751         RETPUSHYES;
1752     else
1753         RETPUSHUNDEF;
1754
1755 nuts:
1756     if (dowarn)
1757         warn("connect() on closed fd");
1758     SETERRNO(EBADF,SS$_IVCHAN);
1759     RETPUSHUNDEF;
1760 #else
1761     DIE(no_sock_func, "connect");
1762 #endif
1763 }
1764
1765 PP(pp_listen)
1766 {
1767     dSP;
1768 #ifdef HAS_SOCKET
1769     int backlog = POPi;
1770     GV *gv = (GV*)POPs;
1771     register IO *io = GvIOn(gv);
1772
1773     if (!io || !IoIFP(io))
1774         goto nuts;
1775
1776     if (listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
1777         RETPUSHYES;
1778     else
1779         RETPUSHUNDEF;
1780
1781 nuts:
1782     if (dowarn)
1783         warn("listen() on closed fd");
1784     SETERRNO(EBADF,SS$_IVCHAN);
1785     RETPUSHUNDEF;
1786 #else
1787     DIE(no_sock_func, "listen");
1788 #endif
1789 }
1790
1791 PP(pp_accept)
1792 {
1793     dSP; dTARGET;
1794 #ifdef HAS_SOCKET
1795     GV *ngv;
1796     GV *ggv;
1797     register IO *nstio;
1798     register IO *gstio;
1799     struct sockaddr saddr;      /* use a struct to avoid alignment problems */
1800     Sock_size_t len = sizeof saddr;
1801     int fd;
1802
1803     ggv = (GV*)POPs;
1804     ngv = (GV*)POPs;
1805
1806     if (!ngv)
1807         goto badexit;
1808     if (!ggv)
1809         goto nuts;
1810
1811     gstio = GvIO(ggv);
1812     if (!gstio || !IoIFP(gstio))
1813         goto nuts;
1814
1815     nstio = GvIOn(ngv);
1816     if (IoIFP(nstio))
1817         do_close(ngv, FALSE);
1818
1819     fd = accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
1820     if (fd < 0)
1821         goto badexit;
1822     IoIFP(nstio) = PerlIO_fdopen(fd, "r");
1823     IoOFP(nstio) = PerlIO_fdopen(fd, "w");
1824     IoTYPE(nstio) = 's';
1825     if (!IoIFP(nstio) || !IoOFP(nstio)) {
1826         if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
1827         if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
1828         if (!IoIFP(nstio) && !IoOFP(nstio)) close(fd);
1829         goto badexit;
1830     }
1831
1832     PUSHp((char *)&saddr, len);
1833     RETURN;
1834
1835 nuts:
1836     if (dowarn)
1837         warn("accept() on closed fd");
1838     SETERRNO(EBADF,SS$_IVCHAN);
1839
1840 badexit:
1841     RETPUSHUNDEF;
1842
1843 #else
1844     DIE(no_sock_func, "accept");
1845 #endif
1846 }
1847
1848 PP(pp_shutdown)
1849 {
1850     dSP; dTARGET;
1851 #ifdef HAS_SOCKET
1852     int how = POPi;
1853     GV *gv = (GV*)POPs;
1854     register IO *io = GvIOn(gv);
1855
1856     if (!io || !IoIFP(io))
1857         goto nuts;
1858
1859     PUSHi( shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
1860     RETURN;
1861
1862 nuts:
1863     if (dowarn)
1864         warn("shutdown() on closed fd");
1865     SETERRNO(EBADF,SS$_IVCHAN);
1866     RETPUSHUNDEF;
1867 #else
1868     DIE(no_sock_func, "shutdown");
1869 #endif
1870 }
1871
1872 PP(pp_gsockopt)
1873 {
1874 #ifdef HAS_SOCKET
1875     return pp_ssockopt(ARGS);
1876 #else
1877     DIE(no_sock_func, "getsockopt");
1878 #endif
1879 }
1880
1881 PP(pp_ssockopt)
1882 {
1883     dSP;
1884 #ifdef HAS_SOCKET
1885     int optype = op->op_type;
1886     SV *sv;
1887     int fd;
1888     unsigned int optname;
1889     unsigned int lvl;
1890     GV *gv;
1891     register IO *io;
1892     Sock_size_t len;
1893
1894     if (optype == OP_GSOCKOPT)
1895         sv = sv_2mortal(NEWSV(22, 257));
1896     else
1897         sv = POPs;
1898     optname = (unsigned int) POPi;
1899     lvl = (unsigned int) POPi;
1900
1901     gv = (GV*)POPs;
1902     io = GvIOn(gv);
1903     if (!io || !IoIFP(io))
1904         goto nuts;
1905
1906     fd = PerlIO_fileno(IoIFP(io));
1907     switch (optype) {
1908     case OP_GSOCKOPT:
1909         SvGROW(sv, 257);
1910         (void)SvPOK_only(sv);
1911         SvCUR_set(sv,256);
1912         *SvEND(sv) ='\0';
1913         len = SvCUR(sv);
1914         if (getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
1915             goto nuts2;
1916         SvCUR_set(sv, len);
1917         *SvEND(sv) ='\0';
1918         PUSHs(sv);
1919         break;
1920     case OP_SSOCKOPT: {
1921             char *buf;
1922             int aint;
1923             if (SvPOKp(sv)) {
1924                 buf = SvPV(sv, na);
1925                 len = na;
1926             }
1927             else if (SvOK(sv)) {
1928                 aint = (int)SvIV(sv);
1929                 buf = (char*)&aint;
1930                 len = sizeof(int);
1931             }
1932             if (setsockopt(fd, lvl, optname, buf, len) < 0)
1933                 goto nuts2;
1934             PUSHs(&sv_yes);
1935         }
1936         break;
1937     }
1938     RETURN;
1939
1940 nuts:
1941     if (dowarn)
1942         warn("[gs]etsockopt() on closed fd");
1943     SETERRNO(EBADF,SS$_IVCHAN);
1944 nuts2:
1945     RETPUSHUNDEF;
1946
1947 #else
1948     DIE(no_sock_func, "setsockopt");
1949 #endif
1950 }
1951
1952 PP(pp_getsockname)
1953 {
1954 #ifdef HAS_SOCKET
1955     return pp_getpeername(ARGS);
1956 #else
1957     DIE(no_sock_func, "getsockname");
1958 #endif
1959 }
1960
1961 PP(pp_getpeername)
1962 {
1963     dSP;
1964 #ifdef HAS_SOCKET
1965     int optype = op->op_type;
1966     SV *sv;
1967     int fd;
1968     GV *gv = (GV*)POPs;
1969     register IO *io = GvIOn(gv);
1970     Sock_size_t len;
1971
1972     if (!io || !IoIFP(io))
1973         goto nuts;
1974
1975     sv = sv_2mortal(NEWSV(22, 257));
1976     (void)SvPOK_only(sv);
1977     len = 256;
1978     SvCUR_set(sv, len);
1979     *SvEND(sv) ='\0';
1980     fd = PerlIO_fileno(IoIFP(io));
1981     switch (optype) {
1982     case OP_GETSOCKNAME:
1983         if (getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
1984             goto nuts2;
1985         break;
1986     case OP_GETPEERNAME:
1987         if (getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
1988             goto nuts2;
1989         break;
1990     }
1991 #ifdef BOGUS_GETNAME_RETURN
1992     /* Interactive Unix, getpeername() and getsockname()
1993       does not return valid namelen */
1994     if (len == BOGUS_GETNAME_RETURN)
1995         len = sizeof(struct sockaddr);
1996 #endif
1997     SvCUR_set(sv, len);
1998     *SvEND(sv) ='\0';
1999     PUSHs(sv);
2000     RETURN;
2001
2002 nuts:
2003     if (dowarn)
2004         warn("get{sock, peer}name() on closed fd");
2005     SETERRNO(EBADF,SS$_IVCHAN);
2006 nuts2:
2007     RETPUSHUNDEF;
2008
2009 #else
2010     DIE(no_sock_func, "getpeername");
2011 #endif
2012 }
2013
2014 /* Stat calls. */
2015
2016 PP(pp_lstat)
2017 {
2018     return pp_stat(ARGS);
2019 }
2020
2021 PP(pp_stat)
2022 {
2023     dSP;
2024     GV *tmpgv;
2025     I32 gimme;
2026     I32 max = 13;
2027
2028     if (op->op_flags & OPf_REF) {
2029         tmpgv = cGVOP->op_gv;
2030       do_fstat:
2031         if (tmpgv != defgv) {
2032             laststype = OP_STAT;
2033             statgv = tmpgv;
2034             sv_setpv(statname, "");
2035             laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
2036                 ? Fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &statcache) : -1);
2037         }
2038         if (laststatval < 0)
2039             max = 0;
2040     }
2041     else {
2042         SV* sv = POPs;
2043         if (SvTYPE(sv) == SVt_PVGV) {
2044             tmpgv = (GV*)sv;
2045             goto do_fstat;
2046         }
2047         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2048             tmpgv = (GV*)SvRV(sv);
2049             goto do_fstat;
2050         }
2051         sv_setpv(statname, SvPV(sv,na));
2052         statgv = Nullgv;
2053 #ifdef HAS_LSTAT
2054         laststype = op->op_type;
2055         if (op->op_type == OP_LSTAT)
2056             laststatval = lstat(SvPV(statname, na), &statcache);
2057         else
2058 #endif
2059             laststatval = Stat(SvPV(statname, na), &statcache);
2060         if (laststatval < 0) {
2061             if (dowarn && strchr(SvPV(statname, na), '\n'))
2062                 warn(warn_nl, "stat");
2063             max = 0;
2064         }
2065     }
2066
2067     gimme = GIMME_V;
2068     if (gimme != G_ARRAY) {
2069         if (gimme != G_VOID)
2070             XPUSHs(boolSV(max));
2071         RETURN;
2072     }
2073     if (max) {
2074         EXTEND(SP, max);
2075         EXTEND_MORTAL(max);
2076         PUSHs(sv_2mortal(newSViv((I32)statcache.st_dev)));
2077         PUSHs(sv_2mortal(newSViv((I32)statcache.st_ino)));
2078         PUSHs(sv_2mortal(newSViv((I32)statcache.st_mode)));
2079         PUSHs(sv_2mortal(newSViv((I32)statcache.st_nlink)));
2080         PUSHs(sv_2mortal(newSViv((I32)statcache.st_uid)));
2081         PUSHs(sv_2mortal(newSViv((I32)statcache.st_gid)));
2082 #ifdef USE_STAT_RDEV
2083         PUSHs(sv_2mortal(newSViv((I32)statcache.st_rdev)));
2084 #else
2085         PUSHs(sv_2mortal(newSVpv("", 0)));
2086 #endif
2087         PUSHs(sv_2mortal(newSViv((I32)statcache.st_size)));
2088 #ifdef BIG_TIME
2089         PUSHs(sv_2mortal(newSVnv((U32)statcache.st_atime)));
2090         PUSHs(sv_2mortal(newSVnv((U32)statcache.st_mtime)));
2091         PUSHs(sv_2mortal(newSVnv((U32)statcache.st_ctime)));
2092 #else
2093         PUSHs(sv_2mortal(newSViv((I32)statcache.st_atime)));
2094         PUSHs(sv_2mortal(newSViv((I32)statcache.st_mtime)));
2095         PUSHs(sv_2mortal(newSViv((I32)statcache.st_ctime)));
2096 #endif
2097 #ifdef USE_STAT_BLOCKS
2098         PUSHs(sv_2mortal(newSViv((I32)statcache.st_blksize)));
2099         PUSHs(sv_2mortal(newSViv((I32)statcache.st_blocks)));
2100 #else
2101         PUSHs(sv_2mortal(newSVpv("", 0)));
2102         PUSHs(sv_2mortal(newSVpv("", 0)));
2103 #endif
2104     }
2105     RETURN;
2106 }
2107
2108 PP(pp_ftrread)
2109 {
2110     I32 result = my_stat(ARGS);
2111     dSP;
2112     if (result < 0)
2113         RETPUSHUNDEF;
2114     if (cando(S_IRUSR, 0, &statcache))
2115         RETPUSHYES;
2116     RETPUSHNO;
2117 }
2118
2119 PP(pp_ftrwrite)
2120 {
2121     I32 result = my_stat(ARGS);
2122     dSP;
2123     if (result < 0)
2124         RETPUSHUNDEF;
2125     if (cando(S_IWUSR, 0, &statcache))
2126         RETPUSHYES;
2127     RETPUSHNO;
2128 }
2129
2130 PP(pp_ftrexec)
2131 {
2132     I32 result = my_stat(ARGS);
2133     dSP;
2134     if (result < 0)
2135         RETPUSHUNDEF;
2136     if (cando(S_IXUSR, 0, &statcache))
2137         RETPUSHYES;
2138     RETPUSHNO;
2139 }
2140
2141 PP(pp_fteread)
2142 {
2143     I32 result = my_stat(ARGS);
2144     dSP;
2145     if (result < 0)
2146         RETPUSHUNDEF;
2147     if (cando(S_IRUSR, 1, &statcache))
2148         RETPUSHYES;
2149     RETPUSHNO;
2150 }
2151
2152 PP(pp_ftewrite)
2153 {
2154     I32 result = my_stat(ARGS);
2155     dSP;
2156     if (result < 0)
2157         RETPUSHUNDEF;
2158     if (cando(S_IWUSR, 1, &statcache))
2159         RETPUSHYES;
2160     RETPUSHNO;
2161 }
2162
2163 PP(pp_fteexec)
2164 {
2165     I32 result = my_stat(ARGS);
2166     dSP;
2167     if (result < 0)
2168         RETPUSHUNDEF;
2169     if (cando(S_IXUSR, 1, &statcache))
2170         RETPUSHYES;
2171     RETPUSHNO;
2172 }
2173
2174 PP(pp_ftis)
2175 {
2176     I32 result = my_stat(ARGS);
2177     dSP;
2178     if (result < 0)
2179         RETPUSHUNDEF;
2180     RETPUSHYES;
2181 }
2182
2183 PP(pp_fteowned)
2184 {
2185     return pp_ftrowned(ARGS);
2186 }
2187
2188 PP(pp_ftrowned)
2189 {
2190     I32 result = my_stat(ARGS);
2191     dSP;
2192     if (result < 0)
2193         RETPUSHUNDEF;
2194     if (statcache.st_uid == (op->op_type == OP_FTEOWNED ? euid : uid) )
2195         RETPUSHYES;
2196     RETPUSHNO;
2197 }
2198
2199 PP(pp_ftzero)
2200 {
2201     I32 result = my_stat(ARGS);
2202     dSP;
2203     if (result < 0)
2204         RETPUSHUNDEF;
2205     if (!statcache.st_size)
2206         RETPUSHYES;
2207     RETPUSHNO;
2208 }
2209
2210 PP(pp_ftsize)
2211 {
2212     I32 result = my_stat(ARGS);
2213     dSP; dTARGET;
2214     if (result < 0)
2215         RETPUSHUNDEF;
2216     PUSHi(statcache.st_size);
2217     RETURN;
2218 }
2219
2220 PP(pp_ftmtime)
2221 {
2222     I32 result = my_stat(ARGS);
2223     dSP; dTARGET;
2224     if (result < 0)
2225         RETPUSHUNDEF;
2226     PUSHn( ((I32)basetime - (I32)statcache.st_mtime) / 86400.0 );
2227     RETURN;
2228 }
2229
2230 PP(pp_ftatime)
2231 {
2232     I32 result = my_stat(ARGS);
2233     dSP; dTARGET;
2234     if (result < 0)
2235         RETPUSHUNDEF;
2236     PUSHn( ((I32)basetime - (I32)statcache.st_atime) / 86400.0 );
2237     RETURN;
2238 }
2239
2240 PP(pp_ftctime)
2241 {
2242     I32 result = my_stat(ARGS);
2243     dSP; dTARGET;
2244     if (result < 0)
2245         RETPUSHUNDEF;
2246     PUSHn( ((I32)basetime - (I32)statcache.st_ctime) / 86400.0 );
2247     RETURN;
2248 }
2249
2250 PP(pp_ftsock)
2251 {
2252     I32 result = my_stat(ARGS);
2253     dSP;
2254     if (result < 0)
2255         RETPUSHUNDEF;
2256     if (S_ISSOCK(statcache.st_mode))
2257         RETPUSHYES;
2258     RETPUSHNO;
2259 }
2260
2261 PP(pp_ftchr)
2262 {
2263     I32 result = my_stat(ARGS);
2264     dSP;
2265     if (result < 0)
2266         RETPUSHUNDEF;
2267     if (S_ISCHR(statcache.st_mode))
2268         RETPUSHYES;
2269     RETPUSHNO;
2270 }
2271
2272 PP(pp_ftblk)
2273 {
2274     I32 result = my_stat(ARGS);
2275     dSP;
2276     if (result < 0)
2277         RETPUSHUNDEF;
2278     if (S_ISBLK(statcache.st_mode))
2279         RETPUSHYES;
2280     RETPUSHNO;
2281 }
2282
2283 PP(pp_ftfile)
2284 {
2285     I32 result = my_stat(ARGS);
2286     dSP;
2287     if (result < 0)
2288         RETPUSHUNDEF;
2289     if (S_ISREG(statcache.st_mode))
2290         RETPUSHYES;
2291     RETPUSHNO;
2292 }
2293
2294 PP(pp_ftdir)
2295 {
2296     I32 result = my_stat(ARGS);
2297     dSP;
2298     if (result < 0)
2299         RETPUSHUNDEF;
2300     if (S_ISDIR(statcache.st_mode))
2301         RETPUSHYES;
2302     RETPUSHNO;
2303 }
2304
2305 PP(pp_ftpipe)
2306 {
2307     I32 result = my_stat(ARGS);
2308     dSP;
2309     if (result < 0)
2310         RETPUSHUNDEF;
2311     if (S_ISFIFO(statcache.st_mode))
2312         RETPUSHYES;
2313     RETPUSHNO;
2314 }
2315
2316 PP(pp_ftlink)
2317 {
2318     I32 result = my_lstat(ARGS);
2319     dSP;
2320     if (result < 0)
2321         RETPUSHUNDEF;
2322     if (S_ISLNK(statcache.st_mode))
2323         RETPUSHYES;
2324     RETPUSHNO;
2325 }
2326
2327 PP(pp_ftsuid)
2328 {
2329     dSP;
2330 #ifdef S_ISUID
2331     I32 result = my_stat(ARGS);
2332     SPAGAIN;
2333     if (result < 0)
2334         RETPUSHUNDEF;
2335     if (statcache.st_mode & S_ISUID)
2336         RETPUSHYES;
2337 #endif
2338     RETPUSHNO;
2339 }
2340
2341 PP(pp_ftsgid)
2342 {
2343     dSP;
2344 #ifdef S_ISGID
2345     I32 result = my_stat(ARGS);
2346     SPAGAIN;
2347     if (result < 0)
2348         RETPUSHUNDEF;
2349     if (statcache.st_mode & S_ISGID)
2350         RETPUSHYES;
2351 #endif
2352     RETPUSHNO;
2353 }
2354
2355 PP(pp_ftsvtx)
2356 {
2357     dSP;
2358 #ifdef S_ISVTX
2359     I32 result = my_stat(ARGS);
2360     SPAGAIN;
2361     if (result < 0)
2362         RETPUSHUNDEF;
2363     if (statcache.st_mode & S_ISVTX)
2364         RETPUSHYES;
2365 #endif
2366     RETPUSHNO;
2367 }
2368
2369 PP(pp_fttty)
2370 {
2371     dSP;
2372     int fd;
2373     GV *gv;
2374     char *tmps;
2375     if (op->op_flags & OPf_REF) {
2376         gv = cGVOP->op_gv;
2377         tmps = "";
2378     }
2379     else
2380         gv = gv_fetchpv(tmps = POPp, FALSE, SVt_PVIO);
2381     if (GvIO(gv) && IoIFP(GvIOp(gv)))
2382         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
2383     else if (isDIGIT(*tmps))
2384         fd = atoi(tmps);
2385     else
2386         RETPUSHUNDEF;
2387     if (isatty(fd))
2388         RETPUSHYES;
2389     RETPUSHNO;
2390 }
2391
2392 #if defined(atarist) /* this will work with atariST. Configure will
2393                         make guesses for other systems. */
2394 # define FILE_base(f) ((f)->_base)
2395 # define FILE_ptr(f) ((f)->_ptr)
2396 # define FILE_cnt(f) ((f)->_cnt)
2397 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
2398 #endif
2399
2400 PP(pp_fttext)
2401 {
2402     dSP;
2403     I32 i;
2404     I32 len;
2405     I32 odd = 0;
2406     STDCHAR tbuf[512];
2407     register STDCHAR *s;
2408     register IO *io;
2409     register SV *sv;
2410     GV *gv;
2411
2412     if (op->op_flags & OPf_REF)
2413         gv = cGVOP->op_gv;
2414     else if (isGV(TOPs))
2415         gv = (GV*)POPs;
2416     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2417         gv = (GV*)SvRV(POPs);
2418     else
2419         gv = Nullgv;
2420
2421     if (gv) {
2422         EXTEND(SP, 1);
2423         if (gv == defgv) {
2424             if (statgv)
2425                 io = GvIO(statgv);
2426             else {
2427                 sv = statname;
2428                 goto really_filename;
2429             }
2430         }
2431         else {
2432             statgv = gv;
2433             laststatval = -1;
2434             sv_setpv(statname, "");
2435             io = GvIO(statgv);
2436         }
2437         if (io && IoIFP(io)) {
2438             if (! PerlIO_has_base(IoIFP(io)))
2439                 DIE("-T and -B not implemented on filehandles");
2440             laststatval = Fstat(PerlIO_fileno(IoIFP(io)), &statcache);
2441             if (laststatval < 0)
2442                 RETPUSHUNDEF;
2443             if (S_ISDIR(statcache.st_mode))     /* handle NFS glitch */
2444                 if (op->op_type == OP_FTTEXT)
2445                     RETPUSHNO;
2446                 else
2447                     RETPUSHYES;
2448             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
2449                 i = PerlIO_getc(IoIFP(io));
2450                 if (i != EOF)
2451                     (void)PerlIO_ungetc(IoIFP(io),i);
2452             }
2453             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
2454                 RETPUSHYES;
2455             len = PerlIO_get_bufsiz(IoIFP(io));
2456             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
2457             /* sfio can have large buffers - limit to 512 */
2458             if (len > 512)
2459                 len = 512;
2460         }
2461         else {
2462             if (dowarn)
2463                 warn("Test on unopened file <%s>",
2464                   GvENAME(cGVOP->op_gv));
2465             SETERRNO(EBADF,RMS$_IFI);
2466             RETPUSHUNDEF;
2467         }
2468     }
2469     else {
2470         sv = POPs;
2471       really_filename:
2472         statgv = Nullgv;
2473         laststatval = -1;
2474         sv_setpv(statname, SvPV(sv, na));
2475 #ifdef HAS_OPEN3
2476         i = open(SvPV(sv, na), O_RDONLY, 0);
2477 #else
2478         i = open(SvPV(sv, na), 0);
2479 #endif
2480         if (i < 0) {
2481             if (dowarn && strchr(SvPV(sv, na), '\n'))
2482                 warn(warn_nl, "open");
2483             RETPUSHUNDEF;
2484         }
2485         laststatval = Fstat(i, &statcache);
2486         if (laststatval < 0)
2487             RETPUSHUNDEF;
2488         len = read(i, tbuf, 512);
2489         (void)close(i);
2490         if (len <= 0) {
2491             if (S_ISDIR(statcache.st_mode) && op->op_type == OP_FTTEXT)
2492                 RETPUSHNO;              /* special case NFS directories */
2493             RETPUSHYES;         /* null file is anything */
2494         }
2495         s = tbuf;
2496     }
2497
2498     /* now scan s to look for textiness */
2499     /*   XXX ASCII dependent code */
2500
2501     for (i = 0; i < len; i++, s++) {
2502         if (!*s) {                      /* null never allowed in text */
2503             odd += len;
2504             break;
2505         }
2506         else if (*s & 128)
2507             odd++;
2508         else if (*s < 32 &&
2509           *s != '\n' && *s != '\r' && *s != '\b' &&
2510           *s != '\t' && *s != '\f' && *s != 27)
2511             odd++;
2512     }
2513
2514     if ((odd * 3 > len) == (op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
2515         RETPUSHNO;
2516     else
2517         RETPUSHYES;
2518 }
2519
2520 PP(pp_ftbinary)
2521 {
2522     return pp_fttext(ARGS);
2523 }
2524
2525 /* File calls. */
2526
2527 PP(pp_chdir)
2528 {
2529     dSP; dTARGET;
2530     char *tmps;
2531     SV **svp;
2532
2533     if (MAXARG < 1)
2534         tmps = Nullch;
2535     else
2536         tmps = POPp;
2537     if (!tmps || !*tmps) {
2538         svp = hv_fetch(GvHVn(envgv), "HOME", 4, FALSE);
2539         if (svp)
2540             tmps = SvPV(*svp, na);
2541     }
2542     if (!tmps || !*tmps) {
2543         svp = hv_fetch(GvHVn(envgv), "LOGDIR", 6, FALSE);
2544         if (svp)
2545             tmps = SvPV(*svp, na);
2546     }
2547     TAINT_PROPER("chdir");
2548     PUSHi( chdir(tmps) >= 0 );
2549 #ifdef VMS
2550     /* Clear the DEFAULT element of ENV so we'll get the new value
2551      * in the future. */
2552     hv_delete(GvHVn(envgv),"DEFAULT",7,G_DISCARD);
2553 #endif
2554     RETURN;
2555 }
2556
2557 PP(pp_chown)
2558 {
2559     dSP; dMARK; dTARGET;
2560     I32 value;
2561 #ifdef HAS_CHOWN
2562     value = (I32)apply(op->op_type, MARK, SP);
2563     SP = MARK;
2564     PUSHi(value);
2565     RETURN;
2566 #else
2567     DIE(no_func, "Unsupported function chown");
2568 #endif
2569 }
2570
2571 PP(pp_chroot)
2572 {
2573     dSP; dTARGET;
2574     char *tmps;
2575 #ifdef HAS_CHROOT
2576     tmps = POPp;
2577     TAINT_PROPER("chroot");
2578     PUSHi( chroot(tmps) >= 0 );
2579     RETURN;
2580 #else
2581     DIE(no_func, "chroot");
2582 #endif
2583 }
2584
2585 PP(pp_unlink)
2586 {
2587     dSP; dMARK; dTARGET;
2588     I32 value;
2589     value = (I32)apply(op->op_type, MARK, SP);
2590     SP = MARK;
2591     PUSHi(value);
2592     RETURN;
2593 }
2594
2595 PP(pp_chmod)
2596 {
2597     dSP; dMARK; dTARGET;
2598     I32 value;
2599     value = (I32)apply(op->op_type, MARK, SP);
2600     SP = MARK;
2601     PUSHi(value);
2602     RETURN;
2603 }
2604
2605 PP(pp_utime)
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_rename)
2616 {
2617     dSP; dTARGET;
2618     int anum;
2619
2620     char *tmps2 = POPp;
2621     char *tmps = SvPV(TOPs, na);
2622     TAINT_PROPER("rename");
2623 #ifdef HAS_RENAME
2624     anum = rename(tmps, tmps2);
2625 #else
2626     if (!(anum = Stat(tmps, &statbuf))) {
2627         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
2628             anum = 1;
2629         else {
2630             if (euid || Stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
2631                 (void)UNLINK(tmps2);
2632             if (!(anum = link(tmps, tmps2)))
2633                 anum = UNLINK(tmps);
2634         }
2635     }
2636 #endif
2637     SETi( anum >= 0 );
2638     RETURN;
2639 }
2640
2641 PP(pp_link)
2642 {
2643     dSP; dTARGET;
2644 #ifdef HAS_LINK
2645     char *tmps2 = POPp;
2646     char *tmps = SvPV(TOPs, na);
2647     TAINT_PROPER("link");
2648     SETi( link(tmps, tmps2) >= 0 );
2649 #else
2650     DIE(no_func, "Unsupported function link");
2651 #endif
2652     RETURN;
2653 }
2654
2655 PP(pp_symlink)
2656 {
2657     dSP; dTARGET;
2658 #ifdef HAS_SYMLINK
2659     char *tmps2 = POPp;
2660     char *tmps = SvPV(TOPs, na);
2661     TAINT_PROPER("symlink");
2662     SETi( symlink(tmps, tmps2) >= 0 );
2663     RETURN;
2664 #else
2665     DIE(no_func, "symlink");
2666 #endif
2667 }
2668
2669 PP(pp_readlink)
2670 {
2671     dSP; dTARGET;
2672 #ifdef HAS_SYMLINK
2673     char *tmps;
2674     char buf[MAXPATHLEN];
2675     int len;
2676
2677     tmps = POPp;
2678     len = readlink(tmps, buf, sizeof buf);
2679     EXTEND(SP, 1);
2680     if (len < 0)
2681         RETPUSHUNDEF;
2682     PUSHp(buf, len);
2683     RETURN;
2684 #else
2685     EXTEND(SP, 1);
2686     RETSETUNDEF;                /* just pretend it's a normal file */
2687 #endif
2688 }
2689
2690 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
2691 static int
2692 dooneliner(cmd, filename)
2693 char *cmd;
2694 char *filename;
2695 {
2696     char *save_filename = filename;
2697     char *cmdline;
2698     char *s;
2699     PerlIO *myfp;
2700     int anum = 1;
2701
2702     New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
2703     strcpy(cmdline, cmd);
2704     strcat(cmdline, " ");
2705     for (s = cmdline + strlen(cmdline); *filename; ) {
2706         *s++ = '\\';
2707         *s++ = *filename++;
2708     }
2709     strcpy(s, " 2>&1");
2710     myfp = my_popen(cmdline, "r");
2711     Safefree(cmdline);
2712
2713     if (myfp) {
2714         SV *tmpsv = sv_newmortal();
2715         /* Need to save/restore 'rs' ?? */
2716         s = sv_gets(tmpsv, myfp, 0);
2717         (void)my_pclose(myfp);
2718         if (s != Nullch) {
2719             int e;
2720             for (e = 1;
2721 #ifdef HAS_SYS_ERRLIST
2722                  e <= sys_nerr
2723 #endif
2724                  ; e++)
2725             {
2726                 /* you don't see this */
2727                 char *errmsg =
2728 #ifdef HAS_SYS_ERRLIST
2729                     sys_errlist[e]
2730 #else
2731                     strerror(e)
2732 #endif
2733                     ;
2734                 if (!errmsg)
2735                     break;
2736                 if (instr(s, errmsg)) {
2737                     SETERRNO(e,0);
2738                     return 0;
2739                 }
2740             }
2741             SETERRNO(0,0);
2742 #ifndef EACCES
2743 #define EACCES EPERM
2744 #endif
2745             if (instr(s, "cannot make"))
2746                 SETERRNO(EEXIST,RMS$_FEX);
2747             else if (instr(s, "existing file"))
2748                 SETERRNO(EEXIST,RMS$_FEX);
2749             else if (instr(s, "ile exists"))
2750                 SETERRNO(EEXIST,RMS$_FEX);
2751             else if (instr(s, "non-exist"))
2752                 SETERRNO(ENOENT,RMS$_FNF);
2753             else if (instr(s, "does not exist"))
2754                 SETERRNO(ENOENT,RMS$_FNF);
2755             else if (instr(s, "not empty"))
2756                 SETERRNO(EBUSY,SS$_DEVOFFLINE);
2757             else if (instr(s, "cannot access"))
2758                 SETERRNO(EACCES,RMS$_PRV);
2759             else
2760                 SETERRNO(EPERM,RMS$_PRV);
2761             return 0;
2762         }
2763         else {  /* some mkdirs return no failure indication */
2764             anum = (Stat(save_filename, &statbuf) >= 0);
2765             if (op->op_type == OP_RMDIR)
2766                 anum = !anum;
2767             if (anum)
2768                 SETERRNO(0,0);
2769             else
2770                 SETERRNO(EACCES,RMS$_PRV);      /* a guess */
2771         }
2772         return anum;
2773     }
2774     else
2775         return 0;
2776 }
2777 #endif
2778
2779 PP(pp_mkdir)
2780 {
2781     dSP; dTARGET;
2782     int mode = POPi;
2783 #ifndef HAS_MKDIR
2784     int oldumask;
2785 #endif
2786     char *tmps = SvPV(TOPs, na);
2787
2788     TAINT_PROPER("mkdir");
2789 #ifdef HAS_MKDIR
2790     SETi( Mkdir(tmps, mode) >= 0 );
2791 #else
2792     SETi( dooneliner("mkdir", tmps) );
2793     oldumask = umask(0);
2794     umask(oldumask);
2795     chmod(tmps, (mode & ~oldumask) & 0777);
2796 #endif
2797     RETURN;
2798 }
2799
2800 PP(pp_rmdir)
2801 {
2802     dSP; dTARGET;
2803     char *tmps;
2804
2805     tmps = POPp;
2806     TAINT_PROPER("rmdir");
2807 #ifdef HAS_RMDIR
2808     XPUSHi( rmdir(tmps) >= 0 );
2809 #else
2810     XPUSHi( dooneliner("rmdir", tmps) );
2811 #endif
2812     RETURN;
2813 }
2814
2815 /* Directory calls. */
2816
2817 PP(pp_open_dir)
2818 {
2819     dSP;
2820 #if defined(Direntry_t) && defined(HAS_READDIR)
2821     char *dirname = POPp;
2822     GV *gv = (GV*)POPs;
2823     register IO *io = GvIOn(gv);
2824
2825     if (!io)
2826         goto nope;
2827
2828     if (IoDIRP(io))
2829         closedir(IoDIRP(io));
2830     if (!(IoDIRP(io) = opendir(dirname)))
2831         goto nope;
2832
2833     RETPUSHYES;
2834 nope:
2835     if (!errno)
2836         SETERRNO(EBADF,RMS$_DIR);
2837     RETPUSHUNDEF;
2838 #else
2839     DIE(no_dir_func, "opendir");
2840 #endif
2841 }
2842
2843 PP(pp_readdir)
2844 {
2845     dSP;
2846 #if defined(Direntry_t) && defined(HAS_READDIR)
2847 #ifndef I_DIRENT
2848     Direntry_t *readdir _((DIR *));
2849 #endif
2850     register Direntry_t *dp;
2851     GV *gv = (GV*)POPs;
2852     register IO *io = GvIOn(gv);
2853
2854     if (!io || !IoDIRP(io))
2855         goto nope;
2856
2857     if (GIMME == G_ARRAY) {
2858         /*SUPPRESS 560*/
2859         while (dp = (Direntry_t *)readdir(IoDIRP(io))) {
2860 #ifdef DIRNAMLEN
2861             XPUSHs(sv_2mortal(newSVpv(dp->d_name, dp->d_namlen)));
2862 #else
2863             XPUSHs(sv_2mortal(newSVpv(dp->d_name, 0)));
2864 #endif
2865         }
2866     }
2867     else {
2868         if (!(dp = (Direntry_t *)readdir(IoDIRP(io))))
2869             goto nope;
2870 #ifdef DIRNAMLEN
2871         XPUSHs(sv_2mortal(newSVpv(dp->d_name, dp->d_namlen)));
2872 #else
2873         XPUSHs(sv_2mortal(newSVpv(dp->d_name, 0)));
2874 #endif
2875     }
2876     RETURN;
2877
2878 nope:
2879     if (!errno)
2880         SETERRNO(EBADF,RMS$_ISI);
2881     if (GIMME == G_ARRAY)
2882         RETURN;
2883     else
2884         RETPUSHUNDEF;
2885 #else
2886     DIE(no_dir_func, "readdir");
2887 #endif
2888 }
2889
2890 PP(pp_telldir)
2891 {
2892     dSP; dTARGET;
2893 #if defined(HAS_TELLDIR) || defined(telldir)
2894 #if !defined(telldir) && !defined(HAS_TELLDIR_PROTOTYPE)
2895     long telldir _((DIR *));
2896 #endif
2897     GV *gv = (GV*)POPs;
2898     register IO *io = GvIOn(gv);
2899
2900     if (!io || !IoDIRP(io))
2901         goto nope;
2902
2903     PUSHi( telldir(IoDIRP(io)) );
2904     RETURN;
2905 nope:
2906     if (!errno)
2907         SETERRNO(EBADF,RMS$_ISI);
2908     RETPUSHUNDEF;
2909 #else
2910     DIE(no_dir_func, "telldir");
2911 #endif
2912 }
2913
2914 PP(pp_seekdir)
2915 {
2916     dSP;
2917 #if defined(HAS_SEEKDIR) || defined(seekdir)
2918     long along = POPl;
2919     GV *gv = (GV*)POPs;
2920     register IO *io = GvIOn(gv);
2921
2922     if (!io || !IoDIRP(io))
2923         goto nope;
2924
2925     (void)seekdir(IoDIRP(io), along);
2926
2927     RETPUSHYES;
2928 nope:
2929     if (!errno)
2930         SETERRNO(EBADF,RMS$_ISI);
2931     RETPUSHUNDEF;
2932 #else
2933     DIE(no_dir_func, "seekdir");
2934 #endif
2935 }
2936
2937 PP(pp_rewinddir)
2938 {
2939     dSP;
2940 #if defined(HAS_REWINDDIR) || defined(rewinddir)
2941     GV *gv = (GV*)POPs;
2942     register IO *io = GvIOn(gv);
2943
2944     if (!io || !IoDIRP(io))
2945         goto nope;
2946
2947     (void)rewinddir(IoDIRP(io));
2948     RETPUSHYES;
2949 nope:
2950     if (!errno)
2951         SETERRNO(EBADF,RMS$_ISI);
2952     RETPUSHUNDEF;
2953 #else
2954     DIE(no_dir_func, "rewinddir");
2955 #endif
2956 }
2957
2958 PP(pp_closedir)
2959 {
2960     dSP;
2961 #if defined(Direntry_t) && defined(HAS_READDIR)
2962     GV *gv = (GV*)POPs;
2963     register IO *io = GvIOn(gv);
2964
2965     if (!io || !IoDIRP(io))
2966         goto nope;
2967
2968 #ifdef VOID_CLOSEDIR
2969     closedir(IoDIRP(io));
2970 #else
2971     if (closedir(IoDIRP(io)) < 0) {
2972         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
2973         goto nope;
2974     }
2975 #endif
2976     IoDIRP(io) = 0;
2977
2978     RETPUSHYES;
2979 nope:
2980     if (!errno)
2981         SETERRNO(EBADF,RMS$_IFI);
2982     RETPUSHUNDEF;
2983 #else
2984     DIE(no_dir_func, "closedir");
2985 #endif
2986 }
2987
2988 /* Process control. */
2989
2990 PP(pp_fork)
2991 {
2992 #ifdef HAS_FORK
2993     dSP; dTARGET;
2994     int childpid;
2995     GV *tmpgv;
2996
2997     EXTEND(SP, 1);
2998     childpid = fork();
2999     if (childpid < 0)
3000         RETSETUNDEF;
3001     if (!childpid) {
3002         /*SUPPRESS 560*/
3003         if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
3004             sv_setiv(GvSV(tmpgv), (IV)getpid());
3005         hv_clear(pidstatus);    /* no kids, so don't wait for 'em */
3006     }
3007     PUSHi(childpid);
3008     RETURN;
3009 #else
3010     DIE(no_func, "Unsupported function fork");
3011 #endif
3012 }
3013
3014 PP(pp_wait)
3015 {
3016 #if !defined(DOSISH) || defined(OS2)
3017     dSP; dTARGET;
3018     int childpid;
3019     int argflags;
3020
3021     childpid = wait4pid(-1, &argflags, 0);
3022     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3023     XPUSHi(childpid);
3024     RETURN;
3025 #else
3026     DIE(no_func, "Unsupported function wait");
3027 #endif
3028 }
3029
3030 PP(pp_waitpid)
3031 {
3032 #if !defined(DOSISH) || defined(OS2)
3033     dSP; dTARGET;
3034     int childpid;
3035     int optype;
3036     int argflags;
3037
3038     optype = POPi;
3039     childpid = TOPi;
3040     childpid = wait4pid(childpid, &argflags, optype);
3041     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3042     SETi(childpid);
3043     RETURN;
3044 #else
3045     DIE(no_func, "Unsupported function wait");
3046 #endif
3047 }
3048
3049 PP(pp_system)
3050 {
3051     dSP; dMARK; dORIGMARK; dTARGET;
3052     I32 value;
3053     int childpid;
3054     int result;
3055     int status;
3056     Sigsave_t ihand,qhand;     /* place to save signals during system() */
3057
3058     if (SP - MARK == 1) {
3059         if (tainting) {
3060             char *junk = SvPV(TOPs, na);
3061             TAINT_ENV();
3062             TAINT_PROPER("system");
3063         }
3064     }
3065 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
3066     while ((childpid = vfork()) == -1) {
3067         if (errno != EAGAIN) {
3068             value = -1;
3069             SP = ORIGMARK;
3070             PUSHi(value);
3071             RETURN;
3072         }
3073         sleep(5);
3074     }
3075     if (childpid > 0) {
3076         rsignal_save(SIGINT, SIG_IGN, &ihand);
3077         rsignal_save(SIGQUIT, SIG_IGN, &qhand);
3078         do {
3079             result = wait4pid(childpid, &status, 0);
3080         } while (result == -1 && errno == EINTR);
3081         (void)rsignal_restore(SIGINT, &ihand);
3082         (void)rsignal_restore(SIGQUIT, &qhand);
3083         STATUS_NATIVE_SET(result == -1 ? -1 : status);
3084         do_execfree();  /* free any memory child malloced on vfork */
3085         SP = ORIGMARK;
3086         PUSHi(STATUS_CURRENT);
3087         RETURN;
3088     }
3089     if (op->op_flags & OPf_STACKED) {
3090         SV *really = *++MARK;
3091         value = (I32)do_aexec(really, MARK, SP);
3092     }
3093     else if (SP - MARK != 1)
3094         value = (I32)do_aexec(Nullsv, MARK, SP);
3095     else {
3096         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na));
3097     }
3098     _exit(-1);
3099 #else /* ! FORK or VMS or OS/2 */
3100     if (op->op_flags & OPf_STACKED) {
3101         SV *really = *++MARK;
3102         value = (I32)do_aspawn(really, MARK, SP);
3103     }
3104     else if (SP - MARK != 1)
3105         value = (I32)do_aspawn(Nullsv, MARK, SP);
3106     else {
3107         value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), na));
3108     }
3109     STATUS_NATIVE_SET(value);
3110     do_execfree();
3111     SP = ORIGMARK;
3112     PUSHi(STATUS_CURRENT);
3113 #endif /* !FORK or VMS */
3114     RETURN;
3115 }
3116
3117 PP(pp_exec)
3118 {
3119     dSP; dMARK; dORIGMARK; dTARGET;
3120     I32 value;
3121
3122     if (op->op_flags & OPf_STACKED) {
3123         SV *really = *++MARK;
3124         value = (I32)do_aexec(really, MARK, SP);
3125     }
3126     else if (SP - MARK != 1)
3127 #ifdef VMS
3128         value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3129 #else
3130         value = (I32)do_aexec(Nullsv, MARK, SP);
3131 #endif
3132     else {
3133         if (tainting) {
3134             char *junk = SvPV(*SP, na);
3135             TAINT_ENV();
3136             TAINT_PROPER("exec");
3137         }
3138 #ifdef VMS
3139         value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), na));
3140 #else
3141         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na));
3142 #endif
3143     }
3144     SP = ORIGMARK;
3145     PUSHi(value);
3146     RETURN;
3147 }
3148
3149 PP(pp_kill)
3150 {
3151     dSP; dMARK; dTARGET;
3152     I32 value;
3153 #ifdef HAS_KILL
3154     value = (I32)apply(op->op_type, MARK, SP);
3155     SP = MARK;
3156     PUSHi(value);
3157     RETURN;
3158 #else
3159     DIE(no_func, "Unsupported function kill");
3160 #endif
3161 }
3162
3163 PP(pp_getppid)
3164 {
3165 #ifdef HAS_GETPPID
3166     dSP; dTARGET;
3167     XPUSHi( getppid() );
3168     RETURN;
3169 #else
3170     DIE(no_func, "getppid");
3171 #endif
3172 }
3173
3174 PP(pp_getpgrp)
3175 {
3176 #ifdef HAS_GETPGRP
3177     dSP; dTARGET;
3178     int pid;
3179     I32 value;
3180
3181     if (MAXARG < 1)
3182         pid = 0;
3183     else
3184         pid = SvIVx(POPs);
3185 #ifdef BSD_GETPGRP
3186     value = (I32)BSD_GETPGRP(pid);
3187 #else
3188     if (pid != 0 && pid != getpid())
3189         DIE("POSIX getpgrp can't take an argument");
3190     value = (I32)getpgrp();
3191 #endif
3192     XPUSHi(value);
3193     RETURN;
3194 #else
3195     DIE(no_func, "getpgrp()");
3196 #endif
3197 }
3198
3199 PP(pp_setpgrp)
3200 {
3201 #ifdef HAS_SETPGRP
3202     dSP; dTARGET;
3203     int pgrp;
3204     int pid;
3205     if (MAXARG < 2) {
3206         pgrp = 0;
3207         pid = 0;
3208     }
3209     else {
3210         pgrp = POPi;
3211         pid = TOPi;
3212     }
3213
3214     TAINT_PROPER("setpgrp");
3215 #ifdef BSD_SETPGRP
3216     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
3217 #else
3218     if ((pgrp != 0 && pgrp != getpid()) || (pid != 0 && pid != getpid()))
3219         DIE("POSIX setpgrp can't take an argument");
3220     SETi( setpgrp() >= 0 );
3221 #endif /* USE_BSDPGRP */
3222     RETURN;
3223 #else
3224     DIE(no_func, "setpgrp()");
3225 #endif
3226 }
3227
3228 PP(pp_getpriority)
3229 {
3230     dSP; dTARGET;
3231     int which;
3232     int who;
3233 #ifdef HAS_GETPRIORITY
3234     who = POPi;
3235     which = TOPi;
3236     SETi( getpriority(which, who) );
3237     RETURN;
3238 #else
3239     DIE(no_func, "getpriority()");
3240 #endif
3241 }
3242
3243 PP(pp_setpriority)
3244 {
3245     dSP; dTARGET;
3246     int which;
3247     int who;
3248     int niceval;
3249 #ifdef HAS_SETPRIORITY
3250     niceval = POPi;
3251     who = POPi;
3252     which = TOPi;
3253     TAINT_PROPER("setpriority");
3254     SETi( setpriority(which, who, niceval) >= 0 );
3255     RETURN;
3256 #else
3257     DIE(no_func, "setpriority()");
3258 #endif
3259 }
3260
3261 /* Time calls. */
3262
3263 PP(pp_time)
3264 {
3265     dSP; dTARGET;
3266 #ifdef BIG_TIME
3267     XPUSHn( time(Null(Time_t*)) );
3268 #else
3269     XPUSHi( time(Null(Time_t*)) );
3270 #endif
3271     RETURN;
3272 }
3273
3274 /* XXX The POSIX name is CLK_TCK; it is to be preferred
3275    to HZ.  Probably.  For now, assume that if the system
3276    defines HZ, it does so correctly.  (Will this break
3277    on VMS?)
3278    Probably we ought to use _sysconf(_SC_CLK_TCK), if
3279    it's supported.    --AD  9/96.
3280 */
3281
3282 #ifndef HZ
3283 #  ifdef CLK_TCK
3284 #    define HZ CLK_TCK
3285 #  else
3286 #    define HZ 60
3287 #  endif
3288 #endif
3289
3290 PP(pp_tms)
3291 {
3292     dSP;
3293
3294 #ifndef HAS_TIMES
3295     DIE("times not implemented");
3296 #else
3297     EXTEND(SP, 4);
3298
3299 #ifndef VMS
3300     (void)times(&timesbuf);
3301 #else
3302     (void)times((tbuffer_t *)&timesbuf);  /* time.h uses different name for */
3303                                           /* struct tms, though same data   */
3304                                           /* is returned.                   */
3305 #endif
3306
3307     PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_utime)/HZ)));
3308     if (GIMME == G_ARRAY) {
3309         PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_stime)/HZ)));
3310         PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cutime)/HZ)));
3311         PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cstime)/HZ)));
3312     }
3313     RETURN;
3314 #endif /* HAS_TIMES */
3315 }
3316
3317 PP(pp_localtime)
3318 {
3319     return pp_gmtime(ARGS);
3320 }
3321
3322 PP(pp_gmtime)
3323 {
3324     dSP;
3325     Time_t when;
3326     struct tm *tmbuf;
3327     static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
3328     static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
3329                               "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
3330
3331     if (MAXARG < 1)
3332         (void)time(&when);
3333     else
3334 #ifdef BIG_TIME
3335         when = (Time_t)SvNVx(POPs);
3336 #else
3337         when = (Time_t)SvIVx(POPs);
3338 #endif
3339
3340     if (op->op_type == OP_LOCALTIME)
3341         tmbuf = localtime(&when);
3342     else
3343         tmbuf = gmtime(&when);
3344
3345     EXTEND(SP, 9);
3346     EXTEND_MORTAL(9);
3347     if (GIMME != G_ARRAY) {
3348         dTARGET;
3349         SV *tsv;
3350         if (!tmbuf)
3351             RETPUSHUNDEF;
3352         tsv = newSVpvf("%s %s %2d %02d:%02d:%02d %d",
3353                        dayname[tmbuf->tm_wday],
3354                        monname[tmbuf->tm_mon],
3355                        tmbuf->tm_mday,
3356                        tmbuf->tm_hour,
3357                        tmbuf->tm_min,
3358                        tmbuf->tm_sec,
3359                        tmbuf->tm_year + 1900);
3360         PUSHs(sv_2mortal(tsv));
3361     }
3362     else if (tmbuf) {
3363         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_sec)));
3364         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_min)));
3365         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_hour)));
3366         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mday)));
3367         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mon)));
3368         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_year)));
3369         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_wday)));
3370         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_yday)));
3371         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_isdst)));
3372     }
3373     RETURN;
3374 }
3375
3376 PP(pp_alarm)
3377 {
3378     dSP; dTARGET;
3379     int anum;
3380 #ifdef HAS_ALARM
3381     anum = POPi;
3382     anum = alarm((unsigned int)anum);
3383     EXTEND(SP, 1);
3384     if (anum < 0)
3385         RETPUSHUNDEF;
3386     PUSHi((I32)anum);
3387     RETURN;
3388 #else
3389     DIE(no_func, "Unsupported function alarm");
3390 #endif
3391 }
3392
3393 PP(pp_sleep)
3394 {
3395     dSP; dTARGET;
3396     I32 duration;
3397     Time_t lasttime;
3398     Time_t when;
3399
3400     (void)time(&lasttime);
3401     if (MAXARG < 1)
3402         Pause();
3403     else {
3404         duration = POPi;
3405         sleep((unsigned int)duration);
3406     }
3407     (void)time(&when);
3408     XPUSHi(when - lasttime);
3409     RETURN;
3410 }
3411
3412 /* Shared memory. */
3413
3414 PP(pp_shmget)
3415 {
3416     return pp_semget(ARGS);
3417 }
3418
3419 PP(pp_shmctl)
3420 {
3421     return pp_semctl(ARGS);
3422 }
3423
3424 PP(pp_shmread)
3425 {
3426     return pp_shmwrite(ARGS);
3427 }
3428
3429 PP(pp_shmwrite)
3430 {
3431 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3432     dSP; dMARK; dTARGET;
3433     I32 value = (I32)(do_shmio(op->op_type, MARK, SP) >= 0);
3434     SP = MARK;
3435     PUSHi(value);
3436     RETURN;
3437 #else
3438     return pp_semget(ARGS);
3439 #endif
3440 }
3441
3442 /* Message passing. */
3443
3444 PP(pp_msgget)
3445 {
3446     return pp_semget(ARGS);
3447 }
3448
3449 PP(pp_msgctl)
3450 {
3451     return pp_semctl(ARGS);
3452 }
3453
3454 PP(pp_msgsnd)
3455 {
3456 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3457     dSP; dMARK; dTARGET;
3458     I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
3459     SP = MARK;
3460     PUSHi(value);
3461     RETURN;
3462 #else
3463     return pp_semget(ARGS);
3464 #endif
3465 }
3466
3467 PP(pp_msgrcv)
3468 {
3469 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3470     dSP; dMARK; dTARGET;
3471     I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
3472     SP = MARK;
3473     PUSHi(value);
3474     RETURN;
3475 #else
3476     return pp_semget(ARGS);
3477 #endif
3478 }
3479
3480 /* Semaphores. */
3481
3482 PP(pp_semget)
3483 {
3484 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3485     dSP; dMARK; dTARGET;
3486     int anum = do_ipcget(op->op_type, MARK, SP);
3487     SP = MARK;
3488     if (anum == -1)
3489         RETPUSHUNDEF;
3490     PUSHi(anum);
3491     RETURN;
3492 #else
3493     DIE("System V IPC is not implemented on this machine");
3494 #endif
3495 }
3496
3497 PP(pp_semctl)
3498 {
3499 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3500     dSP; dMARK; dTARGET;
3501     int anum = do_ipcctl(op->op_type, MARK, SP);
3502     SP = MARK;
3503     if (anum == -1)
3504         RETSETUNDEF;
3505     if (anum != 0) {
3506         PUSHi(anum);
3507     }
3508     else {
3509         PUSHp(zero_but_true, ZBTLEN);
3510     }
3511     RETURN;
3512 #else
3513     return pp_semget(ARGS);
3514 #endif
3515 }
3516
3517 PP(pp_semop)
3518 {
3519 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3520     dSP; dMARK; dTARGET;
3521     I32 value = (I32)(do_semop(MARK, SP) >= 0);
3522     SP = MARK;
3523     PUSHi(value);
3524     RETURN;
3525 #else
3526     return pp_semget(ARGS);
3527 #endif
3528 }
3529
3530 /* Get system info. */
3531
3532 PP(pp_ghbyname)
3533 {
3534 #ifdef HAS_SOCKET
3535     return pp_ghostent(ARGS);
3536 #else
3537     DIE(no_sock_func, "gethostbyname");
3538 #endif
3539 }
3540
3541 PP(pp_ghbyaddr)
3542 {
3543 #ifdef HAS_SOCKET
3544     return pp_ghostent(ARGS);
3545 #else
3546     DIE(no_sock_func, "gethostbyaddr");
3547 #endif
3548 }
3549
3550 PP(pp_ghostent)
3551 {
3552     dSP;
3553 #ifdef HAS_SOCKET
3554     I32 which = op->op_type;
3555     register char **elem;
3556     register SV *sv;
3557     struct hostent *gethostbyname();
3558     struct hostent *gethostbyaddr();
3559 #ifdef HAS_GETHOSTENT
3560     struct hostent *gethostent();
3561 #endif
3562     struct hostent *hent;
3563     unsigned long len;
3564
3565     EXTEND(SP, 10);
3566     if (which == OP_GHBYNAME) {
3567         hent = gethostbyname(POPp);
3568     }
3569     else if (which == OP_GHBYADDR) {
3570         int addrtype = POPi;
3571         SV *addrsv = POPs;
3572         STRLEN addrlen;
3573         char *addr = SvPV(addrsv, addrlen);
3574
3575         hent = gethostbyaddr(addr, addrlen, addrtype);
3576     }
3577     else
3578 #ifdef HAS_GETHOSTENT
3579         hent = gethostent();
3580 #else
3581         DIE("gethostent not implemented");
3582 #endif
3583
3584 #ifdef HOST_NOT_FOUND
3585     if (!hent)
3586         STATUS_NATIVE_SET(h_errno);
3587 #endif
3588
3589     if (GIMME != G_ARRAY) {
3590         PUSHs(sv = sv_newmortal());
3591         if (hent) {
3592             if (which == OP_GHBYNAME) {
3593                 if (hent->h_addr)
3594                     sv_setpvn(sv, hent->h_addr, hent->h_length);
3595             }
3596             else
3597                 sv_setpv(sv, (char*)hent->h_name);
3598         }
3599         RETURN;
3600     }
3601
3602     if (hent) {
3603         PUSHs(sv = sv_mortalcopy(&sv_no));
3604         sv_setpv(sv, (char*)hent->h_name);
3605         PUSHs(sv = sv_mortalcopy(&sv_no));
3606         for (elem = hent->h_aliases; elem && *elem; elem++) {
3607             sv_catpv(sv, *elem);
3608             if (elem[1])
3609                 sv_catpvn(sv, " ", 1);
3610         }
3611         PUSHs(sv = sv_mortalcopy(&sv_no));
3612         sv_setiv(sv, (IV)hent->h_addrtype);
3613         PUSHs(sv = sv_mortalcopy(&sv_no));
3614         len = hent->h_length;
3615         sv_setiv(sv, (IV)len);
3616 #ifdef h_addr
3617         for (elem = hent->h_addr_list; elem && *elem; elem++) {
3618             XPUSHs(sv = sv_mortalcopy(&sv_no));
3619             sv_setpvn(sv, *elem, len);
3620         }
3621 #else
3622         PUSHs(sv = sv_mortalcopy(&sv_no));
3623         if (hent->h_addr)
3624             sv_setpvn(sv, hent->h_addr, len);
3625 #endif /* h_addr */
3626     }
3627     RETURN;
3628 #else
3629     DIE(no_sock_func, "gethostent");
3630 #endif
3631 }
3632
3633 PP(pp_gnbyname)
3634 {
3635 #ifdef HAS_SOCKET
3636     return pp_gnetent(ARGS);
3637 #else
3638     DIE(no_sock_func, "getnetbyname");
3639 #endif
3640 }
3641
3642 PP(pp_gnbyaddr)
3643 {
3644 #ifdef HAS_SOCKET
3645     return pp_gnetent(ARGS);
3646 #else
3647     DIE(no_sock_func, "getnetbyaddr");
3648 #endif
3649 }
3650
3651 PP(pp_gnetent)
3652 {
3653     dSP;
3654 #ifdef HAS_SOCKET
3655     I32 which = op->op_type;
3656     register char **elem;
3657     register SV *sv;
3658     struct netent *getnetbyname();
3659     struct netent *getnetbyaddr();
3660     struct netent *getnetent();
3661     struct netent *nent;
3662
3663     if (which == OP_GNBYNAME)
3664         nent = getnetbyname(POPp);
3665     else if (which == OP_GNBYADDR) {
3666         int addrtype = POPi;
3667         unsigned long addr = U_L(POPn);
3668         nent = getnetbyaddr((long)addr, addrtype);
3669     }
3670     else
3671         nent = getnetent();
3672
3673     EXTEND(SP, 4);
3674     if (GIMME != G_ARRAY) {
3675         PUSHs(sv = sv_newmortal());
3676         if (nent) {
3677             if (which == OP_GNBYNAME)
3678                 sv_setiv(sv, (IV)nent->n_net);
3679             else
3680                 sv_setpv(sv, nent->n_name);
3681         }
3682         RETURN;
3683     }
3684
3685     if (nent) {
3686         PUSHs(sv = sv_mortalcopy(&sv_no));
3687         sv_setpv(sv, nent->n_name);
3688         PUSHs(sv = sv_mortalcopy(&sv_no));
3689         for (elem = nent->n_aliases; elem && *elem; elem++) {
3690             sv_catpv(sv, *elem);
3691             if (elem[1])
3692                 sv_catpvn(sv, " ", 1);
3693         }
3694         PUSHs(sv = sv_mortalcopy(&sv_no));
3695         sv_setiv(sv, (IV)nent->n_addrtype);
3696         PUSHs(sv = sv_mortalcopy(&sv_no));
3697         sv_setiv(sv, (IV)nent->n_net);
3698     }
3699
3700     RETURN;
3701 #else
3702     DIE(no_sock_func, "getnetent");
3703 #endif
3704 }
3705
3706 PP(pp_gpbyname)
3707 {
3708 #ifdef HAS_SOCKET
3709     return pp_gprotoent(ARGS);
3710 #else
3711     DIE(no_sock_func, "getprotobyname");
3712 #endif
3713 }
3714
3715 PP(pp_gpbynumber)
3716 {
3717 #ifdef HAS_SOCKET
3718     return pp_gprotoent(ARGS);
3719 #else
3720     DIE(no_sock_func, "getprotobynumber");
3721 #endif
3722 }
3723
3724 PP(pp_gprotoent)
3725 {
3726     dSP;
3727 #ifdef HAS_SOCKET
3728     I32 which = op->op_type;
3729     register char **elem;
3730     register SV *sv;
3731     struct protoent *getprotobyname();
3732     struct protoent *getprotobynumber();
3733     struct protoent *getprotoent();
3734     struct protoent *pent;
3735
3736     if (which == OP_GPBYNAME)
3737         pent = getprotobyname(POPp);
3738     else if (which == OP_GPBYNUMBER)
3739         pent = getprotobynumber(POPi);
3740     else
3741         pent = getprotoent();
3742
3743     EXTEND(SP, 3);
3744     if (GIMME != G_ARRAY) {
3745         PUSHs(sv = sv_newmortal());
3746         if (pent) {
3747             if (which == OP_GPBYNAME)
3748                 sv_setiv(sv, (IV)pent->p_proto);
3749             else
3750                 sv_setpv(sv, pent->p_name);
3751         }
3752         RETURN;
3753     }
3754
3755     if (pent) {
3756         PUSHs(sv = sv_mortalcopy(&sv_no));
3757         sv_setpv(sv, pent->p_name);
3758         PUSHs(sv = sv_mortalcopy(&sv_no));
3759         for (elem = pent->p_aliases; elem && *elem; elem++) {
3760             sv_catpv(sv, *elem);
3761             if (elem[1])
3762                 sv_catpvn(sv, " ", 1);
3763         }
3764         PUSHs(sv = sv_mortalcopy(&sv_no));
3765         sv_setiv(sv, (IV)pent->p_proto);
3766     }
3767
3768     RETURN;
3769 #else
3770     DIE(no_sock_func, "getprotoent");
3771 #endif
3772 }
3773
3774 PP(pp_gsbyname)
3775 {
3776 #ifdef HAS_SOCKET
3777     return pp_gservent(ARGS);
3778 #else
3779     DIE(no_sock_func, "getservbyname");
3780 #endif
3781 }
3782
3783 PP(pp_gsbyport)
3784 {
3785 #ifdef HAS_SOCKET
3786     return pp_gservent(ARGS);
3787 #else
3788     DIE(no_sock_func, "getservbyport");
3789 #endif
3790 }
3791
3792 PP(pp_gservent)
3793 {
3794     dSP;
3795 #ifdef HAS_SOCKET
3796     I32 which = op->op_type;
3797     register char **elem;
3798     register SV *sv;
3799     struct servent *getservbyname();
3800     struct servent *getservbynumber();
3801     struct servent *getservent();
3802     struct servent *sent;
3803
3804     if (which == OP_GSBYNAME) {
3805         char *proto = POPp;
3806         char *name = POPp;
3807
3808         if (proto && !*proto)
3809             proto = Nullch;
3810
3811         sent = getservbyname(name, proto);
3812     }
3813     else if (which == OP_GSBYPORT) {
3814         char *proto = POPp;
3815         unsigned short port = POPu;
3816
3817 #ifdef HAS_HTONS
3818         port = htons(port);
3819 #endif
3820         sent = getservbyport(port, proto);
3821     }
3822     else
3823         sent = getservent();
3824
3825     EXTEND(SP, 4);
3826     if (GIMME != G_ARRAY) {
3827         PUSHs(sv = sv_newmortal());
3828         if (sent) {
3829             if (which == OP_GSBYNAME) {
3830 #ifdef HAS_NTOHS
3831                 sv_setiv(sv, (IV)ntohs(sent->s_port));
3832 #else
3833                 sv_setiv(sv, (IV)(sent->s_port));
3834 #endif
3835             }
3836             else
3837                 sv_setpv(sv, sent->s_name);
3838         }
3839         RETURN;
3840     }
3841
3842     if (sent) {
3843         PUSHs(sv = sv_mortalcopy(&sv_no));
3844         sv_setpv(sv, sent->s_name);
3845         PUSHs(sv = sv_mortalcopy(&sv_no));
3846         for (elem = sent->s_aliases; elem && *elem; elem++) {
3847             sv_catpv(sv, *elem);
3848             if (elem[1])
3849                 sv_catpvn(sv, " ", 1);
3850         }
3851         PUSHs(sv = sv_mortalcopy(&sv_no));
3852 #ifdef HAS_NTOHS
3853         sv_setiv(sv, (IV)ntohs(sent->s_port));
3854 #else
3855         sv_setiv(sv, (IV)(sent->s_port));
3856 #endif
3857         PUSHs(sv = sv_mortalcopy(&sv_no));
3858         sv_setpv(sv, sent->s_proto);
3859     }
3860
3861     RETURN;
3862 #else
3863     DIE(no_sock_func, "getservent");
3864 #endif
3865 }
3866
3867 PP(pp_shostent)
3868 {
3869     dSP;
3870 #ifdef HAS_SOCKET
3871     sethostent(TOPi);
3872     RETSETYES;
3873 #else
3874     DIE(no_sock_func, "sethostent");
3875 #endif
3876 }
3877
3878 PP(pp_snetent)
3879 {
3880     dSP;
3881 #ifdef HAS_SOCKET
3882     setnetent(TOPi);
3883     RETSETYES;
3884 #else
3885     DIE(no_sock_func, "setnetent");
3886 #endif
3887 }
3888
3889 PP(pp_sprotoent)
3890 {
3891     dSP;
3892 #ifdef HAS_SOCKET
3893     setprotoent(TOPi);
3894     RETSETYES;
3895 #else
3896     DIE(no_sock_func, "setprotoent");
3897 #endif
3898 }
3899
3900 PP(pp_sservent)
3901 {
3902     dSP;
3903 #ifdef HAS_SOCKET
3904     setservent(TOPi);
3905     RETSETYES;
3906 #else
3907     DIE(no_sock_func, "setservent");
3908 #endif
3909 }
3910
3911 PP(pp_ehostent)
3912 {
3913     dSP;
3914 #ifdef HAS_SOCKET
3915     endhostent();
3916     EXTEND(sp,1);
3917     RETPUSHYES;
3918 #else
3919     DIE(no_sock_func, "endhostent");
3920 #endif
3921 }
3922
3923 PP(pp_enetent)
3924 {
3925     dSP;
3926 #ifdef HAS_SOCKET
3927     endnetent();
3928     EXTEND(sp,1);
3929     RETPUSHYES;
3930 #else
3931     DIE(no_sock_func, "endnetent");
3932 #endif
3933 }
3934
3935 PP(pp_eprotoent)
3936 {
3937     dSP;
3938 #ifdef HAS_SOCKET
3939     endprotoent();
3940     EXTEND(sp,1);
3941     RETPUSHYES;
3942 #else
3943     DIE(no_sock_func, "endprotoent");
3944 #endif
3945 }
3946
3947 PP(pp_eservent)
3948 {
3949     dSP;
3950 #ifdef HAS_SOCKET
3951     endservent();
3952     EXTEND(sp,1);
3953     RETPUSHYES;
3954 #else
3955     DIE(no_sock_func, "endservent");
3956 #endif
3957 }
3958
3959 PP(pp_gpwnam)
3960 {
3961 #ifdef HAS_PASSWD
3962     return pp_gpwent(ARGS);
3963 #else
3964     DIE(no_func, "getpwnam");
3965 #endif
3966 }
3967
3968 PP(pp_gpwuid)
3969 {
3970 #ifdef HAS_PASSWD
3971     return pp_gpwent(ARGS);
3972 #else
3973     DIE(no_func, "getpwuid");
3974 #endif
3975 }
3976
3977 PP(pp_gpwent)
3978 {
3979     dSP;
3980 #ifdef HAS_PASSWD
3981     I32 which = op->op_type;
3982     register SV *sv;
3983     struct passwd *pwent;
3984
3985     if (which == OP_GPWNAM)
3986         pwent = getpwnam(POPp);
3987     else if (which == OP_GPWUID)
3988         pwent = getpwuid(POPi);
3989     else
3990         pwent = (struct passwd *)getpwent();
3991
3992     EXTEND(SP, 10);
3993     if (GIMME != G_ARRAY) {
3994         PUSHs(sv = sv_newmortal());
3995         if (pwent) {
3996             if (which == OP_GPWNAM)
3997                 sv_setiv(sv, (IV)pwent->pw_uid);
3998             else
3999                 sv_setpv(sv, pwent->pw_name);
4000         }
4001         RETURN;
4002     }
4003
4004     if (pwent) {
4005         PUSHs(sv = sv_mortalcopy(&sv_no));
4006         sv_setpv(sv, pwent->pw_name);
4007         PUSHs(sv = sv_mortalcopy(&sv_no));
4008         sv_setpv(sv, pwent->pw_passwd);
4009         PUSHs(sv = sv_mortalcopy(&sv_no));
4010         sv_setiv(sv, (IV)pwent->pw_uid);
4011         PUSHs(sv = sv_mortalcopy(&sv_no));
4012         sv_setiv(sv, (IV)pwent->pw_gid);
4013         PUSHs(sv = sv_mortalcopy(&sv_no));
4014 #ifdef PWCHANGE
4015         sv_setiv(sv, (IV)pwent->pw_change);
4016 #else
4017 #ifdef PWQUOTA
4018         sv_setiv(sv, (IV)pwent->pw_quota);
4019 #else
4020 #ifdef PWAGE
4021         sv_setpv(sv, pwent->pw_age);
4022 #endif
4023 #endif
4024 #endif
4025         PUSHs(sv = sv_mortalcopy(&sv_no));
4026 #ifdef PWCLASS
4027         sv_setpv(sv, pwent->pw_class);
4028 #else
4029 #ifdef PWCOMMENT
4030         sv_setpv(sv, pwent->pw_comment);
4031 #endif
4032 #endif
4033         PUSHs(sv = sv_mortalcopy(&sv_no));
4034         sv_setpv(sv, pwent->pw_gecos);
4035         PUSHs(sv = sv_mortalcopy(&sv_no));
4036         sv_setpv(sv, pwent->pw_dir);
4037         PUSHs(sv = sv_mortalcopy(&sv_no));
4038         sv_setpv(sv, pwent->pw_shell);
4039 #ifdef PWEXPIRE
4040         PUSHs(sv = sv_mortalcopy(&sv_no));
4041         sv_setiv(sv, (IV)pwent->pw_expire);
4042 #endif
4043     }
4044     RETURN;
4045 #else
4046     DIE(no_func, "getpwent");
4047 #endif
4048 }
4049
4050 PP(pp_spwent)
4051 {
4052     dSP;
4053 #if defined(HAS_PASSWD) && !defined(CYGWIN32)
4054     setpwent();
4055     RETPUSHYES;
4056 #else
4057     DIE(no_func, "setpwent");
4058 #endif
4059 }
4060
4061 PP(pp_epwent)
4062 {
4063     dSP;
4064 #ifdef HAS_PASSWD
4065     endpwent();
4066     RETPUSHYES;
4067 #else
4068     DIE(no_func, "endpwent");
4069 #endif
4070 }
4071
4072 PP(pp_ggrnam)
4073 {
4074 #ifdef HAS_GROUP
4075     return pp_ggrent(ARGS);
4076 #else
4077     DIE(no_func, "getgrnam");
4078 #endif
4079 }
4080
4081 PP(pp_ggrgid)
4082 {
4083 #ifdef HAS_GROUP
4084     return pp_ggrent(ARGS);
4085 #else
4086     DIE(no_func, "getgrgid");
4087 #endif
4088 }
4089
4090 PP(pp_ggrent)
4091 {
4092     dSP;
4093 #ifdef HAS_GROUP
4094     I32 which = op->op_type;
4095     register char **elem;
4096     register SV *sv;
4097     struct group *grent;
4098
4099     if (which == OP_GGRNAM)
4100         grent = (struct group *)getgrnam(POPp);
4101     else if (which == OP_GGRGID)
4102         grent = (struct group *)getgrgid(POPi);
4103     else
4104         grent = (struct group *)getgrent();
4105
4106     EXTEND(SP, 4);
4107     if (GIMME != G_ARRAY) {
4108         PUSHs(sv = sv_newmortal());
4109         if (grent) {
4110             if (which == OP_GGRNAM)
4111                 sv_setiv(sv, (IV)grent->gr_gid);
4112             else
4113                 sv_setpv(sv, grent->gr_name);
4114         }
4115         RETURN;
4116     }
4117
4118     if (grent) {
4119         PUSHs(sv = sv_mortalcopy(&sv_no));
4120         sv_setpv(sv, grent->gr_name);
4121         PUSHs(sv = sv_mortalcopy(&sv_no));
4122         sv_setpv(sv, grent->gr_passwd);
4123         PUSHs(sv = sv_mortalcopy(&sv_no));
4124         sv_setiv(sv, (IV)grent->gr_gid);
4125         PUSHs(sv = sv_mortalcopy(&sv_no));
4126         for (elem = grent->gr_mem; elem && *elem; elem++) {
4127             sv_catpv(sv, *elem);
4128             if (elem[1])
4129                 sv_catpvn(sv, " ", 1);
4130         }
4131     }
4132
4133     RETURN;
4134 #else
4135     DIE(no_func, "getgrent");
4136 #endif
4137 }
4138
4139 PP(pp_sgrent)
4140 {
4141     dSP;
4142 #ifdef HAS_GROUP
4143     setgrent();
4144     RETPUSHYES;
4145 #else
4146     DIE(no_func, "setgrent");
4147 #endif
4148 }
4149
4150 PP(pp_egrent)
4151 {
4152     dSP;
4153 #ifdef HAS_GROUP
4154     endgrent();
4155     RETPUSHYES;
4156 #else
4157     DIE(no_func, "endgrent");
4158 #endif
4159 }
4160
4161 PP(pp_getlogin)
4162 {
4163     dSP; dTARGET;
4164 #ifdef HAS_GETLOGIN
4165     char *tmps;
4166     EXTEND(SP, 1);
4167     if (!(tmps = getlogin()))
4168         RETPUSHUNDEF;
4169     PUSHp(tmps, strlen(tmps));
4170     RETURN;
4171 #else
4172     DIE(no_func, "getlogin");
4173 #endif
4174 }
4175
4176 /* Miscellaneous. */
4177
4178 PP(pp_syscall)
4179 {
4180 #ifdef HAS_SYSCALL
4181     dSP; dMARK; dORIGMARK; dTARGET;
4182     register I32 items = SP - MARK;
4183     unsigned long a[20];
4184     register I32 i = 0;
4185     I32 retval = -1;
4186     MAGIC *mg;
4187
4188     if (tainting) {
4189         while (++MARK <= SP) {
4190             if (SvTAINTED(*MARK)) {
4191                 TAINT;
4192                 break;
4193             }
4194         }
4195         MARK = ORIGMARK;
4196         TAINT_PROPER("syscall");
4197     }
4198
4199     /* This probably won't work on machines where sizeof(long) != sizeof(int)
4200      * or where sizeof(long) != sizeof(char*).  But such machines will
4201      * not likely have syscall implemented either, so who cares?
4202      */
4203     while (++MARK <= SP) {
4204         if (SvNIOK(*MARK) || !i)
4205             a[i++] = SvIV(*MARK);
4206         else if (*MARK == &sv_undef)
4207             a[i++] = 0;
4208         else
4209             a[i++] = (unsigned long)SvPV_force(*MARK, na);
4210         if (i > 15)
4211             break;
4212     }
4213     switch (items) {
4214     default:
4215         DIE("Too many args to syscall");
4216     case 0:
4217         DIE("Too few args to syscall");
4218     case 1:
4219         retval = syscall(a[0]);
4220         break;
4221     case 2:
4222         retval = syscall(a[0],a[1]);
4223         break;
4224     case 3:
4225         retval = syscall(a[0],a[1],a[2]);
4226         break;
4227     case 4:
4228         retval = syscall(a[0],a[1],a[2],a[3]);
4229         break;
4230     case 5:
4231         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
4232         break;
4233     case 6:
4234         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
4235         break;
4236     case 7:
4237         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
4238         break;
4239     case 8:
4240         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
4241         break;
4242 #ifdef atarist
4243     case 9:
4244         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
4245         break;
4246     case 10:
4247         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
4248         break;
4249     case 11:
4250         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4251           a[10]);
4252         break;
4253     case 12:
4254         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4255           a[10],a[11]);
4256         break;
4257     case 13:
4258         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4259           a[10],a[11],a[12]);
4260         break;
4261     case 14:
4262         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4263           a[10],a[11],a[12],a[13]);
4264         break;
4265 #endif /* atarist */
4266     }
4267     SP = ORIGMARK;
4268     PUSHi(retval);
4269     RETURN;
4270 #else
4271     DIE(no_func, "syscall");
4272 #endif
4273 }
4274
4275 #ifdef FCNTL_EMULATE_FLOCK
4276
4277 /*  XXX Emulate flock() with fcntl().
4278     What's really needed is a good file locking module.
4279 */
4280
4281 static int
4282 fcntl_emulate_flock(fd, operation)
4283 int fd;
4284 int operation;
4285 {
4286     struct flock flock;
4287
4288     switch (operation & ~LOCK_NB) {
4289     case LOCK_SH:
4290         flock.l_type = F_RDLCK;
4291         break;
4292     case LOCK_EX:
4293         flock.l_type = F_WRLCK;
4294         break;
4295     case LOCK_UN:
4296         flock.l_type = F_UNLCK;
4297         break;
4298     default:
4299         errno = EINVAL;
4300         return -1;
4301     }
4302     flock.l_whence = SEEK_SET;
4303     flock.l_start = flock.l_len = 0L;
4304
4305     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
4306 }
4307
4308 #endif /* FCNTL_EMULATE_FLOCK */
4309
4310 #ifdef LOCKF_EMULATE_FLOCK
4311
4312 /*  XXX Emulate flock() with lockf().  This is just to increase
4313     portability of scripts.  The calls are not completely
4314     interchangeable.  What's really needed is a good file
4315     locking module.
4316 */
4317
4318 /*  The lockf() constants might have been defined in <unistd.h>.
4319     Unfortunately, <unistd.h> causes troubles on some mixed
4320     (BSD/POSIX) systems, such as SunOS 4.1.3.
4321
4322    Further, the lockf() constants aren't POSIX, so they might not be
4323    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
4324    just stick in the SVID values and be done with it.  Sigh.
4325 */
4326
4327 # ifndef F_ULOCK
4328 #  define F_ULOCK       0       /* Unlock a previously locked region */
4329 # endif
4330 # ifndef F_LOCK
4331 #  define F_LOCK        1       /* Lock a region for exclusive use */
4332 # endif
4333 # ifndef F_TLOCK
4334 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
4335 # endif
4336 # ifndef F_TEST
4337 #  define F_TEST        3       /* Test a region for other processes locks */
4338 # endif
4339
4340 static int
4341 lockf_emulate_flock (fd, operation)
4342 int fd;
4343 int operation;
4344 {
4345     int i;
4346     switch (operation) {
4347
4348         /* LOCK_SH - get a shared lock */
4349         case LOCK_SH:
4350         /* LOCK_EX - get an exclusive lock */
4351         case LOCK_EX:
4352             i = lockf (fd, F_LOCK, 0);
4353             break;
4354
4355         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
4356         case LOCK_SH|LOCK_NB:
4357         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
4358         case LOCK_EX|LOCK_NB:
4359             i = lockf (fd, F_TLOCK, 0);
4360             if (i == -1)
4361                 if ((errno == EAGAIN) || (errno == EACCES))
4362                     errno = EWOULDBLOCK;
4363             break;
4364
4365         /* LOCK_UN - unlock (non-blocking is a no-op) */
4366         case LOCK_UN:
4367         case LOCK_UN|LOCK_NB:
4368             i = lockf (fd, F_ULOCK, 0);
4369             break;
4370
4371         /* Default - can't decipher operation */
4372         default:
4373             i = -1;
4374             errno = EINVAL;
4375             break;
4376     }
4377     return (i);
4378 }
4379
4380 #endif /* LOCKF_EMULATE_FLOCK */