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