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