dist/IO/IO.xs

   1 /*
   2  * Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
   3  * This program is free software; you can redistribute it and/or
   4  * modify it under the same terms as Perl itself.
   5  */
   6
   7 #define PERL_EXT_IO
   8
   9 #define PERL_NO_GET_CONTEXT
  10 #include "EXTERN.h"
  11 #define PERLIO_NOT_STDIO 1
  12 #include "perl.h"
  13 #include "XSUB.h"
  14 #include "poll.h"
  15 #ifdef I_UNISTD
  16 #  include <unistd.h>
  17 #endif
  18 #if defined(I_FCNTL) || defined(HAS_FCNTL)
  19 #  include <fcntl.h>
  20 #endif
  21
  22 #ifndef SIOCATMARK
  23 #   ifdef I_SYS_SOCKIO
  24 #       include <sys/sockio.h>
  25 #   endif
  26 #endif
  27
  28 #ifdef PerlIO
  29 #if defined(MACOS_TRADITIONAL) && defined(USE_SFIO)
  30 #define PERLIO_IS_STDIO 1
  31 #undef setbuf
  32 #undef setvbuf
  33 #define setvbuf         _stdsetvbuf
  34 #define setbuf(f,b)     ( __sf_setbuf(f,b) )
  35 #endif
  36 typedef int SysRet;
  37 typedef PerlIO * InputStream;
  38 typedef PerlIO * OutputStream;
  39 #else
  40 #define PERLIO_IS_STDIO 1
  41 typedef int SysRet;
  42 typedef FILE * InputStream;
  43 typedef FILE * OutputStream;
  44 #endif
  45
  46 #define MY_start_subparse(fmt,flags) start_subparse(fmt,flags)
  47
  48 #ifndef gv_stashpvn
  49 #define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
  50 #endif
  51
  52 #ifndef __attribute__noreturn__
  53 #  define __attribute__noreturn__
  54 #endif
  55
  56 #ifndef NORETURN_FUNCTION_END
  57 # define NORETURN_FUNCTION_END /* NOT REACHED */ return 0
  58 #endif
  59
  60 #ifndef dVAR
  61 #  define dVAR dNOOP
  62 #endif
  63
  64 #ifndef OpSIBLING
  65 #  define OpSIBLING(o) (o)->op_sibling
  66 #endif
  67
  68 static int not_here(const char *s) __attribute__noreturn__;
  69 static int
  70 not_here(const char *s)
  71 {
  72     croak("%s not implemented on this architecture", s);
  73     NORETURN_FUNCTION_END;
  74 }
  75
  76 #ifndef UVCHR_IS_INVARIANT   /* For use with Perls without this macro */
  77 #   if ('A' == 65)
  78 #       define UVCHR_IS_INVARIANT(cp) ((cp) < 128)
  79 #   elif (defined(NATIVE_IS_INVARIANT)) /* EBCDIC on old Perl */
  80 #       define UVCHR_IS_INVARIANT(cp) ((cp) < 256 && NATIVE_IS_INVARIANT(cp))
  81 #   elif defined(isASCII)    /* EBCDIC on very old Perl */
  82         /* In EBCDIC, the invariants are the code points corresponding to ASCII,
  83          * plus all the controls.  All but one EBCDIC control is below SPACE; it
  84          * varies depending on the code page, determined by the ord of '^' */
  85 #       define UVCHR_IS_INVARIANT(cp) (isASCII(cp)                            \
  86                                        || (cp) < ' '                          \
  87                                        || (('^' == 106)    /* POSIX-BC */     \
  88                                           ? (cp) == 95                        \
  89                                           : (cp) == 0xFF)) /* 1047 or 037 */
  90 #   else    /* EBCDIC on very very old Perl */
  91         /* This assumes isascii() is available, but that could be fixed by
  92          * having the macro test for each printable ASCII char */
  93 #       define UVCHR_IS_INVARIANT(cp) (isascii(cp)                            \
  94                                        || (cp) < ' '                          \
  95                                        || (('^' == 106)    /* POSIX-BC */     \
  96                                           ? (cp) == 95                        \
  97                                           : (cp) == 0xFF)) /* 1047 or 037 */
  98 #   endif
  99 #endif
 100
 101
 102 #ifndef PerlIO
 103 #define PerlIO_fileno(f) fileno(f)
 104 #endif
 105
 106 static int
 107 io_blocking(pTHX_ InputStream f, int block)
 108 {
 109     int fd = -1;
 110 #if defined(HAS_FCNTL)
 111     int RETVAL;
 112     if (!f) {
 113         errno = EBADF;
 114         return -1;
 115     }
 116     fd = PerlIO_fileno(f);
 117     if (fd < 0) {
 118       errno = EBADF;
 119       return -1;
 120     }
 121     RETVAL = fcntl(fd, F_GETFL, 0);
 122     if (RETVAL >= 0) {
 123         int mode = RETVAL;
 124         int newmode = mode;
 125 #ifdef O_NONBLOCK
 126         /* POSIX style */
 127
 128 # ifndef O_NDELAY
 129 #  define O_NDELAY O_NONBLOCK
 130 # endif
 131         /* Note: UNICOS and UNICOS/mk a F_GETFL returns an O_NDELAY
 132          * after a successful F_SETFL of an O_NONBLOCK. */
 133         RETVAL = RETVAL & (O_NONBLOCK | O_NDELAY) ? 0 : 1;
 134
 135         if (block == 0) {
 136             newmode &= ~O_NDELAY;
 137             newmode |= O_NONBLOCK;
 138         } else if (block > 0) {
 139             newmode &= ~(O_NDELAY|O_NONBLOCK);
 140         }
 141 #else
 142         /* Not POSIX - better have O_NDELAY or we can't cope.
 143          * for BSD-ish machines this is an acceptable alternative
 144          * for SysV we can't tell "would block" from EOF but that is
 145          * the way SysV is...
 146          */
 147         RETVAL = RETVAL & O_NDELAY ? 0 : 1;
 148
 149         if (block == 0) {
 150             newmode |= O_NDELAY;
 151         } else if (block > 0) {
 152             newmode &= ~O_NDELAY;
 153         }
 154 #endif
 155         if (newmode != mode) {
 156             const int ret = fcntl(fd, F_SETFL, newmode);
 157             if (ret < 0)
 158                 RETVAL = ret;
 159         }
 160     }
 161     return RETVAL;
 162 #else
 163 #   ifdef WIN32
 164     if (block >= 0) {
 165         unsigned long flags = !block;
 166         /* ioctl claims to take char* but really needs a u_long sized buffer */
 167         const int ret = ioctl(fd, FIONBIO, (char*)&flags);
 168         if (ret != 0)
 169             return -1;
 170         /* Win32 has no way to get the current blocking status of a socket.
 171          * However, we don't want to just return undef, because there's no way
 172          * to tell that the ioctl succeeded.
 173          */
 174         return flags;
 175     }
 176     /* TODO: Perhaps set $! to ENOTSUP? */
 177     return -1;
 178 #   else
 179     return -1;
 180 #   endif
 181 #endif
 182 }
 183
 184 static OP *
 185 io_pp_nextstate(pTHX)
 186 {
 187     dVAR;
 188     COP *old_curcop = PL_curcop;
 189     OP *next = PL_ppaddr[PL_op->op_type](aTHX);
 190     PL_curcop = old_curcop;
 191     return next;
 192 }
 193
 194 static OP *
 195 io_ck_lineseq(pTHX_ OP *o)
 196 {
 197     OP *kid = cBINOPo->op_first;
 198     for (; kid; kid = OpSIBLING(kid))
 199         if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
 200             kid->op_ppaddr = io_pp_nextstate;
 201     return o;
 202 }
 203
 204
 205 MODULE = IO     PACKAGE = IO::Seekable  PREFIX = f
 206
 207 void
 208 fgetpos(handle)
 209         InputStream     handle
 210     CODE:
 211         if (handle) {
 212 #ifdef PerlIO
 213 #if PERL_VERSION < 8
 214             Fpos_t pos;
 215             ST(0) = sv_newmortal();
 216             if (PerlIO_getpos(handle, &pos) != 0) {
 217                 ST(0) = &PL_sv_undef;
 218             }
 219             else {
 220                 sv_setpvn(ST(0), (char *)&pos, sizeof(Fpos_t));
 221             }
 222 #else
 223             ST(0) = sv_newmortal();
 224             if (PerlIO_getpos(handle, ST(0)) != 0) {
 225                 ST(0) = &PL_sv_undef;
 226             }
 227 #endif
 228 #else
 229             Fpos_t pos;
 230             if (fgetpos(handle, &pos)) {
 231                 ST(0) = &PL_sv_undef;
 232             } else {
 233 #  if PERL_VERSION >= 11
 234                 ST(0) = newSVpvn_flags((char*)&pos, sizeof(Fpos_t), SVs_TEMP);
 235 #  else
 236                 ST(0) = sv_2mortal(newSVpvn((char*)&pos, sizeof(Fpos_t)));
 237 #  endif
 238             }
 239 #endif
 240         }
 241         else {
 242             errno = EINVAL;
 243             ST(0) = &PL_sv_undef;
 244         }
 245
 246 SysRet
 247 fsetpos(handle, pos)
 248         InputStream     handle
 249         SV *            pos
 250     CODE:
 251         if (handle) {
 252 #ifdef PerlIO
 253 #if PERL_VERSION < 8
 254             char *p;
 255             STRLEN len;
 256             if (SvOK(pos) && (p = SvPV(pos,len)) && len == sizeof(Fpos_t)) {
 257                 RETVAL = PerlIO_setpos(handle, (Fpos_t*)p);
 258             }
 259             else {
 260                 RETVAL = -1;
 261                 errno = EINVAL;
 262             }
 263 #else
 264             RETVAL = PerlIO_setpos(handle, pos);
 265 #endif
 266 #else
 267             char *p;
 268             STRLEN len;
 269             if ((p = SvPV(pos,len)) && len == sizeof(Fpos_t)) {
 270                 RETVAL = fsetpos(handle, (Fpos_t*)p);
 271             }
 272             else {
 273                 RETVAL = -1;
 274                 errno = EINVAL;
 275             }
 276 #endif
 277         }
 278         else {
 279             RETVAL = -1;
 280             errno = EINVAL;
 281         }
 282     OUTPUT:
 283         RETVAL
 284
 285 MODULE = IO     PACKAGE = IO::File      PREFIX = f
 286
 287 void
 288 new_tmpfile(packname = "IO::File")
 289     const char * packname
 290     PREINIT:
 291         OutputStream fp;
 292         GV *gv;
 293     CODE:
 294 #ifdef PerlIO
 295         fp = PerlIO_tmpfile();
 296 #else
 297         fp = tmpfile();
 298 #endif
 299         gv = (GV*)SvREFCNT_inc(newGVgen(packname));
 300         if (gv)
 301             (void) hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD);
 302         if (gv && do_open(gv, "+>&", 3, FALSE, 0, 0, fp)) {
 303             ST(0) = sv_2mortal(newRV((SV*)gv));
 304             sv_bless(ST(0), gv_stashpv(packname, TRUE));
 305             SvREFCNT_dec(gv);   /* undo increment in newRV() */
 306         }
 307         else {
 308             ST(0) = &PL_sv_undef;
 309             SvREFCNT_dec(gv);
 310         }
 311
 312 MODULE = IO     PACKAGE = IO::Poll
 313
 314 void
 315 _poll(timeout,...)
 316         int timeout;
 317 PPCODE:
 318 {
 319 #ifdef HAS_POLL
 320     const int nfd = (items - 1) / 2;
 321     SV *tmpsv = NEWSV(999,nfd * sizeof(struct pollfd));
 322     /* We should pass _some_ valid pointer even if nfd is zero, but it
 323      * doesn't matter what it is, since we're telling it to not check any fds.
 324      */
 325     struct pollfd *fds = nfd ? (struct pollfd *)SvPVX(tmpsv) : (struct pollfd *)tmpsv;
 326     int i,j,ret;
 327     for(i=1, j=0  ; j < nfd ; j++) {
 328         fds[j].fd = SvIV(ST(i));
 329         i++;
 330         fds[j].events = (short)SvIV(ST(i));
 331         i++;
 332         fds[j].revents = 0;
 333     }
 334     if((ret = poll(fds,nfd,timeout)) >= 0) {
 335         for(i=1, j=0 ; j < nfd ; j++) {
 336             sv_setiv(ST(i), fds[j].fd); i++;
 337             sv_setiv(ST(i), fds[j].revents); i++;
 338         }
 339     }
 340     SvREFCNT_dec(tmpsv);
 341     XSRETURN_IV(ret);
 342 #else
 343         not_here("IO::Poll::poll");
 344 #endif
 345 }
 346
 347 MODULE = IO     PACKAGE = IO::Handle    PREFIX = io_
 348
 349 void
 350 io_blocking(handle,blk=-1)
 351         InputStream     handle
 352         int             blk
 353 PROTOTYPE: $;$
 354 CODE:
 355 {
 356     const int ret = io_blocking(aTHX_ handle, items == 1 ? -1 : blk ? 1 : 0);
 357     if(ret >= 0)
 358         XSRETURN_IV(ret);
 359     else
 360         XSRETURN_UNDEF;
 361 }
 362
 363 MODULE = IO     PACKAGE = IO::Handle    PREFIX = f
 364
 365 int
 366 ungetc(handle, c)
 367         InputStream     handle
 368         SV *            c
 369     CODE:
 370         if (handle) {
 371 #ifdef PerlIO
 372             UV v;
 373
 374             if ((SvIOK_notUV(c) && SvIV(c) < 0) || (SvNOK(c) && SvNV(c) < 0.0))
 375                 croak("Negative character number in ungetc()");
 376
 377             v = SvUV(c);
 378             if (UVCHR_IS_INVARIANT(v) || (v <= 0xFF && !PerlIO_isutf8(handle)))
 379                 RETVAL = PerlIO_ungetc(handle, (int)v);
 380             else {
 381                 U8 buf[UTF8_MAXBYTES + 1], *end;
 382                 Size_t len;
 383
 384                 if (!PerlIO_isutf8(handle))
 385                     croak("Wide character number in ungetc()");
 386
 387                 /* This doesn't warn for non-chars, surrogate, and
 388                  * above-Unicodes */
 389                 end = uvchr_to_utf8_flags(buf, v, 0);
 390                 len = end - buf;
 391                 if ((Size_t)PerlIO_unread(handle, &buf, len) == len)
 392                     XSRETURN_UV(v);
 393                 else
 394                     RETVAL = EOF;
 395             }
 396 #else
 397             RETVAL = ungetc((int)SvIV(c), handle);
 398 #endif
 399         }
 400         else {
 401             RETVAL = -1;
 402             errno = EINVAL;
 403         }
 404     OUTPUT:
 405         RETVAL
 406
 407 int
 408 ferror(handle)
 409         InputStream     handle
 410     CODE:
 411         if (handle)
 412 #ifdef PerlIO
 413             RETVAL = PerlIO_error(handle);
 414 #else
 415             RETVAL = ferror(handle);
 416 #endif
 417         else {
 418             RETVAL = -1;
 419             errno = EINVAL;
 420         }
 421     OUTPUT:
 422         RETVAL
 423
 424 int
 425 clearerr(handle)
 426         InputStream     handle
 427     CODE:
 428         if (handle) {
 429 #ifdef PerlIO
 430             PerlIO_clearerr(handle);
 431 #else
 432             clearerr(handle);
 433 #endif
 434             RETVAL = 0;
 435         }
 436         else {
 437             RETVAL = -1;
 438             errno = EINVAL;
 439         }
 440     OUTPUT:
 441         RETVAL
 442
 443 int
 444 untaint(handle)
 445        SV *     handle
 446     CODE:
 447 #ifdef IOf_UNTAINT
 448         IO * io;
 449         io = sv_2io(handle);
 450         if (io) {
 451             IoFLAGS(io) |= IOf_UNTAINT;
 452             RETVAL = 0;
 453         }
 454         else {
 455 #endif
 456             RETVAL = -1;
 457             errno = EINVAL;
 458 #ifdef IOf_UNTAINT
 459         }
 460 #endif
 461     OUTPUT:
 462         RETVAL
 463
 464 SysRet
 465 fflush(handle)
 466         OutputStream    handle
 467     CODE:
 468         if (handle)
 469 #ifdef PerlIO
 470             RETVAL = PerlIO_flush(handle);
 471 #else
 472             RETVAL = Fflush(handle);
 473 #endif
 474         else {
 475             RETVAL = -1;
 476             errno = EINVAL;
 477         }
 478     OUTPUT:
 479         RETVAL
 480
 481 void
 482 setbuf(handle, ...)
 483         OutputStream    handle
 484     CODE:
 485         if (handle)
 486 #ifdef PERLIO_IS_STDIO
 487         {
 488             char *buf = items == 2 && SvPOK(ST(1)) ?
 489               sv_grow(ST(1), BUFSIZ) : 0;
 490             setbuf(handle, buf);
 491         }
 492 #else
 493             not_here("IO::Handle::setbuf");
 494 #endif
 495
 496 SysRet
 497 setvbuf(...)
 498     CODE:
 499         if (items != 4)
 500             Perl_croak(aTHX_ "Usage: IO::Handle::setvbuf(handle, buf, type, size)");
 501 #if defined(PERLIO_IS_STDIO) && defined(_IOFBF) && defined(HAS_SETVBUF)
 502     {
 503         OutputStream    handle = 0;
 504         char *          buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
 505         int             type;
 506         int             size;
 507
 508         if (items == 4) {
 509             handle = IoOFP(sv_2io(ST(0)));
 510             buf    = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
 511             type   = (int)SvIV(ST(2));
 512             size   = (int)SvIV(ST(3));
 513         }
 514         if (!handle)                    /* Try input stream. */
 515             handle = IoIFP(sv_2io(ST(0)));
 516         if (items == 4 && handle)
 517             RETVAL = setvbuf(handle, buf, type, size);
 518         else {
 519             RETVAL = -1;
 520             errno = EINVAL;
 521         }
 522     }
 523 #else
 524         RETVAL = (SysRet) not_here("IO::Handle::setvbuf");
 525 #endif
 526     OUTPUT:
 527         RETVAL
 528
 529
 530 SysRet
 531 fsync(arg)
 532         SV * arg
 533     PREINIT:
 534         OutputStream handle = NULL;
 535     CODE:
 536 #ifdef HAS_FSYNC
 537         handle = IoOFP(sv_2io(arg));
 538         if (!handle)
 539             handle = IoIFP(sv_2io(arg));
 540         if (handle) {
 541             int fd = PerlIO_fileno(handle);
 542             if (fd >= 0) {
 543                 RETVAL = fsync(fd);
 544             } else {
 545                 RETVAL = -1;
 546                 errno = EBADF;
 547             }
 548         } else {
 549             RETVAL = -1;
 550             errno = EINVAL;
 551         }
 552 #else
 553         RETVAL = (SysRet) not_here("IO::Handle::sync");
 554 #endif
 555     OUTPUT:
 556         RETVAL
 557
 558 SV *
 559 _create_getline_subs(const char *code)
 560     CODE:
 561         OP *(*io_old_ck_lineseq)(pTHX_ OP *) = PL_check[OP_LINESEQ];
 562         PL_check[OP_LINESEQ] = io_ck_lineseq;
 563         RETVAL = SvREFCNT_inc(eval_pv(code,FALSE));
 564         PL_check[OP_LINESEQ] = io_old_ck_lineseq;
 565     OUTPUT:
 566         RETVAL
 567
 568
 569 MODULE = IO     PACKAGE = IO::Socket
 570
 571 SysRet
 572 sockatmark (sock)
 573    InputStream sock
 574    PROTOTYPE: $
 575    PREINIT:
 576      int fd;
 577    CODE:
 578      fd = PerlIO_fileno(sock);
 579      if (fd < 0) {
 580        errno = EBADF;
 581        RETVAL = -1;
 582      }
 583 #ifdef HAS_SOCKATMARK
 584      else {
 585        RETVAL = sockatmark(fd);
 586      }
 587 #else
 588      else {
 589        int flag = 0;
 590 #   ifdef SIOCATMARK
 591 #     if defined(NETWARE) || defined(WIN32)
 592        if (ioctl(fd, SIOCATMARK, (char*)&flag) != 0)
 593 #     else
 594        if (ioctl(fd, SIOCATMARK, &flag) != 0)
 595 #     endif
 596          XSRETURN_UNDEF;
 597 #   else
 598        not_here("IO::Socket::atmark");
 599 #   endif
 600        RETVAL = flag;
 601      }
 602 #endif
 603    OUTPUT:
 604      RETVAL
 605
 606 BOOT:
 607 {
 608     HV *stash;
 609     /*
 610      * constant subs for IO::Poll
 611      */
 612     stash = gv_stashpvn("IO::Poll", 8, TRUE);
 613 #ifdef  POLLIN
 614         newCONSTSUB(stash,"POLLIN",newSViv(POLLIN));
 615 #endif
 616 #ifdef  POLLPRI
 617         newCONSTSUB(stash,"POLLPRI", newSViv(POLLPRI));
 618 #endif
 619 #ifdef  POLLOUT
 620         newCONSTSUB(stash,"POLLOUT", newSViv(POLLOUT));
 621 #endif
 622 #ifdef  POLLRDNORM
 623         newCONSTSUB(stash,"POLLRDNORM", newSViv(POLLRDNORM));
 624 #endif
 625 #ifdef  POLLWRNORM
 626         newCONSTSUB(stash,"POLLWRNORM", newSViv(POLLWRNORM));
 627 #endif
 628 #ifdef  POLLRDBAND
 629         newCONSTSUB(stash,"POLLRDBAND", newSViv(POLLRDBAND));
 630 #endif
 631 #ifdef  POLLWRBAND
 632         newCONSTSUB(stash,"POLLWRBAND", newSViv(POLLWRBAND));
 633 #endif
 634 #ifdef  POLLNORM
 635         newCONSTSUB(stash,"POLLNORM", newSViv(POLLNORM));
 636 #endif
 637 #ifdef  POLLERR
 638         newCONSTSUB(stash,"POLLERR", newSViv(POLLERR));
 639 #endif
 640 #ifdef  POLLHUP
 641         newCONSTSUB(stash,"POLLHUP", newSViv(POLLHUP));
 642 #endif
 643 #ifdef  POLLNVAL
 644         newCONSTSUB(stash,"POLLNVAL", newSViv(POLLNVAL));
 645 #endif
 646     /*
 647      * constant subs for IO::Handle
 648      */
 649     stash = gv_stashpvn("IO::Handle", 10, TRUE);
 650 #ifdef _IOFBF
 651         newCONSTSUB(stash,"_IOFBF", newSViv(_IOFBF));
 652 #endif
 653 #ifdef _IOLBF
 654         newCONSTSUB(stash,"_IOLBF", newSViv(_IOLBF));
 655 #endif
 656 #ifdef _IONBF
 657         newCONSTSUB(stash,"_IONBF", newSViv(_IONBF));
 658 #endif
 659 #ifdef SEEK_SET
 660         newCONSTSUB(stash,"SEEK_SET", newSViv(SEEK_SET));
 661 #endif
 662 #ifdef SEEK_CUR
 663         newCONSTSUB(stash,"SEEK_CUR", newSViv(SEEK_CUR));
 664 #endif
 665 #ifdef SEEK_END
 666         newCONSTSUB(stash,"SEEK_END", newSViv(SEEK_END));
 667 #endif
 668 }
 669