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 = sv_2mortal(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     XSRETURN_IV(ret);
 341 #else
 342         not_here("IO::Poll::poll");
 343 #endif
 344 }
 345
 346 MODULE = IO     PACKAGE = IO::Handle    PREFIX = io_
 347
 348 void
 349 io_blocking(handle,blk=-1)
 350         InputStream     handle
 351         int             blk
 352 PROTOTYPE: $;$
 353 CODE:
 354 {
 355     const int ret = io_blocking(aTHX_ handle, items == 1 ? -1 : blk ? 1 : 0);
 356     if(ret >= 0)
 357         XSRETURN_IV(ret);
 358     else
 359         XSRETURN_UNDEF;
 360 }
 361
 362 MODULE = IO     PACKAGE = IO::Handle    PREFIX = f
 363
 364 int
 365 ungetc(handle, c)
 366         InputStream     handle
 367         SV *            c
 368     CODE:
 369         if (handle) {
 370 #ifdef PerlIO
 371             UV v;
 372
 373             if ((SvIOK_notUV(c) && SvIV(c) < 0) || (SvNOK(c) && SvNV(c) < 0.0))
 374                 croak("Negative character number in ungetc()");
 375
 376             v = SvUV(c);
 377             if (UVCHR_IS_INVARIANT(v) || (v <= 0xFF && !PerlIO_isutf8(handle)))
 378                 RETVAL = PerlIO_ungetc(handle, (int)v);
 379             else {
 380                 U8 buf[UTF8_MAXBYTES + 1], *end;
 381                 Size_t len;
 382
 383                 if (!PerlIO_isutf8(handle))
 384                     croak("Wide character number in ungetc()");
 385
 386                 /* This doesn't warn for non-chars, surrogate, and
 387                  * above-Unicodes */
 388                 end = uvchr_to_utf8_flags(buf, v, 0);
 389                 len = end - buf;
 390                 if ((Size_t)PerlIO_unread(handle, &buf, len) == len)
 391                     XSRETURN_UV(v);
 392                 else
 393                     RETVAL = EOF;
 394             }
 395 #else
 396             RETVAL = ungetc((int)SvIV(c), handle);
 397 #endif
 398         }
 399         else {
 400             RETVAL = -1;
 401             errno = EINVAL;
 402         }
 403     OUTPUT:
 404         RETVAL
 405
 406 int
 407 ferror(handle)
 408         InputStream     handle
 409     CODE:
 410         if (handle)
 411 #ifdef PerlIO
 412             RETVAL = PerlIO_error(handle);
 413 #else
 414             RETVAL = ferror(handle);
 415 #endif
 416         else {
 417             RETVAL = -1;
 418             errno = EINVAL;
 419         }
 420     OUTPUT:
 421         RETVAL
 422
 423 int
 424 clearerr(handle)
 425         InputStream     handle
 426     CODE:
 427         if (handle) {
 428 #ifdef PerlIO
 429             PerlIO_clearerr(handle);
 430 #else
 431             clearerr(handle);
 432 #endif
 433             RETVAL = 0;
 434         }
 435         else {
 436             RETVAL = -1;
 437             errno = EINVAL;
 438         }
 439     OUTPUT:
 440         RETVAL
 441
 442 int
 443 untaint(handle)
 444        SV *     handle
 445     CODE:
 446 #ifdef IOf_UNTAINT
 447         IO * io;
 448         io = sv_2io(handle);
 449         if (io) {
 450             IoFLAGS(io) |= IOf_UNTAINT;
 451             RETVAL = 0;
 452         }
 453         else {
 454 #endif
 455             RETVAL = -1;
 456             errno = EINVAL;
 457 #ifdef IOf_UNTAINT
 458         }
 459 #endif
 460     OUTPUT:
 461         RETVAL
 462
 463 SysRet
 464 fflush(handle)
 465         OutputStream    handle
 466     CODE:
 467         if (handle)
 468 #ifdef PerlIO
 469             RETVAL = PerlIO_flush(handle);
 470 #else
 471             RETVAL = Fflush(handle);
 472 #endif
 473         else {
 474             RETVAL = -1;
 475             errno = EINVAL;
 476         }
 477     OUTPUT:
 478         RETVAL
 479
 480 void
 481 setbuf(handle, ...)
 482         OutputStream    handle
 483     CODE:
 484         if (handle)
 485 #ifdef PERLIO_IS_STDIO
 486         {
 487             char *buf = items == 2 && SvPOK(ST(1)) ?
 488               sv_grow(ST(1), BUFSIZ) : 0;
 489             setbuf(handle, buf);
 490         }
 491 #else
 492             not_here("IO::Handle::setbuf");
 493 #endif
 494
 495 SysRet
 496 setvbuf(...)
 497     CODE:
 498         if (items != 4)
 499             Perl_croak(aTHX_ "Usage: IO::Handle::setvbuf(handle, buf, type, size)");
 500 #if defined(PERLIO_IS_STDIO) && defined(_IOFBF) && defined(HAS_SETVBUF)
 501     {
 502         OutputStream    handle = 0;
 503         char *          buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
 504         int             type;
 505         int             size;
 506
 507         if (items == 4) {
 508             handle = IoOFP(sv_2io(ST(0)));
 509             buf    = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
 510             type   = (int)SvIV(ST(2));
 511             size   = (int)SvIV(ST(3));
 512         }
 513         if (!handle)                    /* Try input stream. */
 514             handle = IoIFP(sv_2io(ST(0)));
 515         if (items == 4 && handle)
 516             RETVAL = setvbuf(handle, buf, type, size);
 517         else {
 518             RETVAL = -1;
 519             errno = EINVAL;
 520         }
 521     }
 522 #else
 523         RETVAL = (SysRet) not_here("IO::Handle::setvbuf");
 524 #endif
 525     OUTPUT:
 526         RETVAL
 527
 528
 529 SysRet
 530 fsync(arg)
 531         SV * arg
 532     PREINIT:
 533         OutputStream handle = NULL;
 534     CODE:
 535 #ifdef HAS_FSYNC
 536         handle = IoOFP(sv_2io(arg));
 537         if (!handle)
 538             handle = IoIFP(sv_2io(arg));
 539         if (handle) {
 540             int fd = PerlIO_fileno(handle);
 541             if (fd >= 0) {
 542                 RETVAL = fsync(fd);
 543             } else {
 544                 RETVAL = -1;
 545                 errno = EBADF;
 546             }
 547         } else {
 548             RETVAL = -1;
 549             errno = EINVAL;
 550         }
 551 #else
 552         RETVAL = (SysRet) not_here("IO::Handle::sync");
 553 #endif
 554     OUTPUT:
 555         RETVAL
 556
 557 SV *
 558 _create_getline_subs(const char *code)
 559     CODE:
 560         OP *(*io_old_ck_lineseq)(pTHX_ OP *) = PL_check[OP_LINESEQ];
 561         PL_check[OP_LINESEQ] = io_ck_lineseq;
 562         RETVAL = SvREFCNT_inc(eval_pv(code,FALSE));
 563         PL_check[OP_LINESEQ] = io_old_ck_lineseq;
 564     OUTPUT:
 565         RETVAL
 566
 567
 568 MODULE = IO     PACKAGE = IO::Socket
 569
 570 SysRet
 571 sockatmark (sock)
 572    InputStream sock
 573    PROTOTYPE: $
 574    PREINIT:
 575      int fd;
 576    CODE:
 577      fd = PerlIO_fileno(sock);
 578      if (fd < 0) {
 579        errno = EBADF;
 580        RETVAL = -1;
 581      }
 582 #ifdef HAS_SOCKATMARK
 583      else {
 584        RETVAL = sockatmark(fd);
 585      }
 586 #else
 587      else {
 588        int flag = 0;
 589 #   ifdef SIOCATMARK
 590 #     if defined(NETWARE) || defined(WIN32)
 591        if (ioctl(fd, SIOCATMARK, (char*)&flag) != 0)
 592 #     else
 593        if (ioctl(fd, SIOCATMARK, &flag) != 0)
 594 #     endif
 595          XSRETURN_UNDEF;
 596 #   else
 597        not_here("IO::Socket::atmark");
 598 #   endif
 599        RETVAL = flag;
 600      }
 601 #endif
 602    OUTPUT:
 603      RETVAL
 604
 605 BOOT:
 606 {
 607     HV *stash;
 608     /*
 609      * constant subs for IO::Poll
 610      */
 611     stash = gv_stashpvn("IO::Poll", 8, TRUE);
 612 #ifdef  POLLIN
 613         newCONSTSUB(stash,"POLLIN",newSViv(POLLIN));
 614 #endif
 615 #ifdef  POLLPRI
 616         newCONSTSUB(stash,"POLLPRI", newSViv(POLLPRI));
 617 #endif
 618 #ifdef  POLLOUT
 619         newCONSTSUB(stash,"POLLOUT", newSViv(POLLOUT));
 620 #endif
 621 #ifdef  POLLRDNORM
 622         newCONSTSUB(stash,"POLLRDNORM", newSViv(POLLRDNORM));
 623 #endif
 624 #ifdef  POLLWRNORM
 625         newCONSTSUB(stash,"POLLWRNORM", newSViv(POLLWRNORM));
 626 #endif
 627 #ifdef  POLLRDBAND
 628         newCONSTSUB(stash,"POLLRDBAND", newSViv(POLLRDBAND));
 629 #endif
 630 #ifdef  POLLWRBAND
 631         newCONSTSUB(stash,"POLLWRBAND", newSViv(POLLWRBAND));
 632 #endif
 633 #ifdef  POLLNORM
 634         newCONSTSUB(stash,"POLLNORM", newSViv(POLLNORM));
 635 #endif
 636 #ifdef  POLLERR
 637         newCONSTSUB(stash,"POLLERR", newSViv(POLLERR));
 638 #endif
 639 #ifdef  POLLHUP
 640         newCONSTSUB(stash,"POLLHUP", newSViv(POLLHUP));
 641 #endif
 642 #ifdef  POLLNVAL
 643         newCONSTSUB(stash,"POLLNVAL", newSViv(POLLNVAL));
 644 #endif
 645     /*
 646      * constant subs for IO::Handle
 647      */
 648     stash = gv_stashpvn("IO::Handle", 10, TRUE);
 649 #ifdef _IOFBF
 650         newCONSTSUB(stash,"_IOFBF", newSViv(_IOFBF));
 651 #endif
 652 #ifdef _IOLBF
 653         newCONSTSUB(stash,"_IOLBF", newSViv(_IOLBF));
 654 #endif
 655 #ifdef _IONBF
 656         newCONSTSUB(stash,"_IONBF", newSViv(_IONBF));
 657 #endif
 658 #ifdef SEEK_SET
 659         newCONSTSUB(stash,"SEEK_SET", newSViv(SEEK_SET));
 660 #endif
 661 #ifdef SEEK_CUR
 662         newCONSTSUB(stash,"SEEK_CUR", newSViv(SEEK_CUR));
 663 #endif
 664 #ifdef SEEK_END
 665         newCONSTSUB(stash,"SEEK_END", newSViv(SEEK_END));
 666 #endif
 667 }
 668