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