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