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