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