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     char flags = (char)block;
 126     return ioctl(PerlIO_fileno(f), FIONBIO, &flags);
 127 #   else
 128     return -1;
 129 #   endif
 130 #endif
 131 }
 132
 133 MODULE = IO     PACKAGE = IO::Seekable  PREFIX = f
 134
 135 void
 136 fgetpos(handle)
 137         InputStream     handle
 138     CODE:
 139         if (handle) {
 140 #ifdef PerlIO
 141 #if PERL_VERSION < 8
 142             Fpos_t pos;
 143             ST(0) = sv_newmortal();
 144             if (PerlIO_getpos(handle, &pos) != 0) {
 145                 ST(0) = &PL_sv_undef;
 146             }
 147             else {
 148                 sv_setpvn(ST(0), (char *)&pos, sizeof(Fpos_t));
 149             }
 150 #else
 151             ST(0) = sv_newmortal();
 152             if (PerlIO_getpos(handle, ST(0)) != 0) {
 153                 ST(0) = &PL_sv_undef;
 154             }
 155 #endif
 156 #else
 157             Fpos_t pos;
 158             if (fgetpos(handle, &pos)) {
 159                 ST(0) = &PL_sv_undef;
 160             } else {
 161 #  if PERL_VERSION >= 11
 162                 ST(0) = newSVpvn_flags((char*)&pos, sizeof(Fpos_t), SVs_TEMP);
 163 #  else
 164                 ST(0) = sv_2mortal(newSVpvn((char*)&pos, sizeof(Fpos_t)));
 165 #  endif
 166             }
 167 #endif
 168         }
 169         else {
 170             errno = EINVAL;
 171             ST(0) = &PL_sv_undef;
 172         }
 173
 174 SysRet
 175 fsetpos(handle, pos)
 176         InputStream     handle
 177         SV *            pos
 178     CODE:
 179         if (handle) {
 180 #ifdef PerlIO
 181 #if PERL_VERSION < 8
 182             char *p;
 183             STRLEN len;
 184             if (SvOK(pos) && (p = SvPV(pos,len)) && len == sizeof(Fpos_t)) {
 185                 RETVAL = PerlIO_setpos(handle, (Fpos_t*)p);
 186             }
 187             else {
 188                 RETVAL = -1;
 189                 errno = EINVAL;
 190             }
 191 #else
 192             RETVAL = PerlIO_setpos(handle, pos);
 193 #endif
 194 #else
 195             char *p;
 196             STRLEN len;
 197             if ((p = SvPV(pos,len)) && len == sizeof(Fpos_t)) {
 198                 RETVAL = fsetpos(handle, (Fpos_t*)p);
 199             }
 200             else {
 201                 RETVAL = -1;
 202                 errno = EINVAL;
 203             }
 204 #endif
 205         }
 206         else {
 207             RETVAL = -1;
 208             errno = EINVAL;
 209         }
 210     OUTPUT:
 211         RETVAL
 212
 213 MODULE = IO     PACKAGE = IO::File      PREFIX = f
 214
 215 void
 216 new_tmpfile(packname = "IO::File")
 217     const char * packname
 218     PREINIT:
 219         OutputStream fp;
 220         GV *gv;
 221     CODE:
 222 #ifdef PerlIO
 223         fp = PerlIO_tmpfile();
 224 #else
 225         fp = tmpfile();
 226 #endif
 227         gv = (GV*)SvREFCNT_inc(newGVgen(packname));
 228         if (gv)
 229             hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD);
 230         if (gv && do_open(gv, "+>&", 3, FALSE, 0, 0, fp)) {
 231             ST(0) = sv_2mortal(newRV((SV*)gv));
 232             sv_bless(ST(0), gv_stashpv(packname, TRUE));
 233             SvREFCNT_dec(gv);   /* undo increment in newRV() */
 234         }
 235         else {
 236             ST(0) = &PL_sv_undef;
 237             SvREFCNT_dec(gv);
 238         }
 239
 240 MODULE = IO     PACKAGE = IO::Poll
 241
 242 void
 243 _poll(timeout,...)
 244         int timeout;
 245 PPCODE:
 246 {
 247 #ifdef HAS_POLL
 248     const int nfd = (items - 1) / 2;
 249     SV *tmpsv = NEWSV(999,nfd * sizeof(struct pollfd));
 250     struct pollfd *fds = (struct pollfd *)SvPVX(tmpsv);
 251     int i,j,ret;
 252     for(i=1, j=0  ; j < nfd ; j++) {
 253         fds[j].fd = SvIV(ST(i));
 254         i++;
 255         fds[j].events = (short)SvIV(ST(i));
 256         i++;
 257         fds[j].revents = 0;
 258     }
 259     if((ret = poll(fds,nfd,timeout)) >= 0) {
 260         for(i=1, j=0 ; j < nfd ; j++) {
 261             sv_setiv(ST(i), fds[j].fd); i++;
 262             sv_setiv(ST(i), fds[j].revents); i++;
 263         }
 264     }
 265     SvREFCNT_dec(tmpsv);
 266     XSRETURN_IV(ret);
 267 #else
 268         not_here("IO::Poll::poll");
 269 #endif
 270 }
 271
 272 MODULE = IO     PACKAGE = IO::Handle    PREFIX = io_
 273
 274 void
 275 io_blocking(handle,blk=-1)
 276         InputStream     handle
 277         int             blk
 278 PROTOTYPE: $;$
 279 CODE:
 280 {
 281     const int ret = io_blocking(aTHX_ handle, items == 1 ? -1 : blk ? 1 : 0);
 282     if(ret >= 0)
 283         XSRETURN_IV(ret);
 284     else
 285         XSRETURN_UNDEF;
 286 }
 287
 288 MODULE = IO     PACKAGE = IO::Handle    PREFIX = f
 289
 290 int
 291 ungetc(handle, c)
 292         InputStream     handle
 293         int             c
 294     CODE:
 295         if (handle)
 296 #ifdef PerlIO
 297             RETVAL = PerlIO_ungetc(handle, c);
 298 #else
 299             RETVAL = ungetc(c, handle);
 300 #endif
 301         else {
 302             RETVAL = -1;
 303             errno = EINVAL;
 304         }
 305     OUTPUT:
 306         RETVAL
 307
 308 int
 309 ferror(handle)
 310         InputStream     handle
 311     CODE:
 312         if (handle)
 313 #ifdef PerlIO
 314             RETVAL = PerlIO_error(handle);
 315 #else
 316             RETVAL = ferror(handle);
 317 #endif
 318         else {
 319             RETVAL = -1;
 320             errno = EINVAL;
 321         }
 322     OUTPUT:
 323         RETVAL
 324
 325 int
 326 clearerr(handle)
 327         InputStream     handle
 328     CODE:
 329         if (handle) {
 330 #ifdef PerlIO
 331             PerlIO_clearerr(handle);
 332 #else
 333             clearerr(handle);
 334 #endif
 335             RETVAL = 0;
 336         }
 337         else {
 338             RETVAL = -1;
 339             errno = EINVAL;
 340         }
 341     OUTPUT:
 342         RETVAL
 343
 344 int
 345 untaint(handle)
 346        SV *     handle
 347     CODE:
 348 #ifdef IOf_UNTAINT
 349         IO * io;
 350         io = sv_2io(handle);
 351         if (io) {
 352             IoFLAGS(io) |= IOf_UNTAINT;
 353             RETVAL = 0;
 354         }
 355         else {
 356 #endif
 357             RETVAL = -1;
 358             errno = EINVAL;
 359 #ifdef IOf_UNTAINT
 360         }
 361 #endif
 362     OUTPUT:
 363         RETVAL
 364
 365 SysRet
 366 fflush(handle)
 367         OutputStream    handle
 368     CODE:
 369         if (handle)
 370 #ifdef PerlIO
 371             RETVAL = PerlIO_flush(handle);
 372 #else
 373             RETVAL = Fflush(handle);
 374 #endif
 375         else {
 376             RETVAL = -1;
 377             errno = EINVAL;
 378         }
 379     OUTPUT:
 380         RETVAL
 381
 382 void
 383 setbuf(handle, ...)
 384         OutputStream    handle
 385     CODE:
 386         if (handle)
 387 #ifdef PERLIO_IS_STDIO
 388         {
 389             char *buf = items == 2 && SvPOK(ST(1)) ?
 390               sv_grow(ST(1), BUFSIZ) : 0;
 391             setbuf(handle, buf);
 392         }
 393 #else
 394             not_here("IO::Handle::setbuf");
 395 #endif
 396
 397 SysRet
 398 setvbuf(...)
 399     CODE:
 400         if (items != 4)
 401             Perl_croak(aTHX_ "Usage: IO::Handle::setvbuf(handle, buf, type, size)");
 402 #if defined(PERLIO_IS_STDIO) && defined(_IOFBF) && defined(HAS_SETVBUF)
 403     {
 404         OutputStream    handle = 0;
 405         char *          buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
 406         int             type;
 407         int             size;
 408
 409         if (items == 4) {
 410             handle = IoOFP(sv_2io(ST(0)));
 411             buf    = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
 412             type   = (int)SvIV(ST(2));
 413             size   = (int)SvIV(ST(3));
 414         }
 415         if (!handle)                    /* Try input stream. */
 416             handle = IoIFP(sv_2io(ST(0)));
 417         if (items == 4 && handle)
 418             RETVAL = setvbuf(handle, buf, type, size);
 419         else {
 420             RETVAL = -1;
 421             errno = EINVAL;
 422         }
 423     }
 424 #else
 425         RETVAL = (SysRet) not_here("IO::Handle::setvbuf");
 426 #endif
 427     OUTPUT:
 428         RETVAL
 429
 430
 431 SysRet
 432 fsync(handle)
 433         OutputStream handle
 434     CODE:
 435 #ifdef HAS_FSYNC
 436         if(handle)
 437             RETVAL = fsync(PerlIO_fileno(handle));
 438         else {
 439             RETVAL = -1;
 440             errno = EINVAL;
 441         }
 442 #else
 443         RETVAL = (SysRet) not_here("IO::Handle::sync");
 444 #endif
 445     OUTPUT:
 446         RETVAL
 447
 448
 449 MODULE = IO     PACKAGE = IO::Socket
 450
 451 SysRet
 452 sockatmark (sock)
 453    InputStream sock
 454    PROTOTYPE: $
 455    PREINIT:
 456      int fd;
 457    CODE:
 458    {
 459      fd = PerlIO_fileno(sock);
 460 #ifdef HAS_SOCKATMARK
 461      RETVAL = sockatmark(fd);
 462 #else
 463      {
 464        int flag = 0;
 465 #   ifdef SIOCATMARK
 466 #     if defined(NETWARE) || defined(WIN32)
 467        if (ioctl(fd, SIOCATMARK, (void*)&flag) != 0)
 468 #     else
 469        if (ioctl(fd, SIOCATMARK, &flag) != 0)
 470 #     endif
 471          XSRETURN_UNDEF;
 472 #   else
 473        not_here("IO::Socket::atmark");
 474 #   endif
 475        RETVAL = flag;
 476      }
 477 #endif
 478    }
 479    OUTPUT:
 480      RETVAL
 481
 482 BOOT:
 483 {
 484     HV *stash;
 485     /*
 486      * constant subs for IO::Poll
 487      */
 488     stash = gv_stashpvn("IO::Poll", 8, TRUE);
 489 #ifdef  POLLIN
 490         newCONSTSUB(stash,"POLLIN",newSViv(POLLIN));
 491 #endif
 492 #ifdef  POLLPRI
 493         newCONSTSUB(stash,"POLLPRI", newSViv(POLLPRI));
 494 #endif
 495 #ifdef  POLLOUT
 496         newCONSTSUB(stash,"POLLOUT", newSViv(POLLOUT));
 497 #endif
 498 #ifdef  POLLRDNORM
 499         newCONSTSUB(stash,"POLLRDNORM", newSViv(POLLRDNORM));
 500 #endif
 501 #ifdef  POLLWRNORM
 502         newCONSTSUB(stash,"POLLWRNORM", newSViv(POLLWRNORM));
 503 #endif
 504 #ifdef  POLLRDBAND
 505         newCONSTSUB(stash,"POLLRDBAND", newSViv(POLLRDBAND));
 506 #endif
 507 #ifdef  POLLWRBAND
 508         newCONSTSUB(stash,"POLLWRBAND", newSViv(POLLWRBAND));
 509 #endif
 510 #ifdef  POLLNORM
 511         newCONSTSUB(stash,"POLLNORM", newSViv(POLLNORM));
 512 #endif
 513 #ifdef  POLLERR
 514         newCONSTSUB(stash,"POLLERR", newSViv(POLLERR));
 515 #endif
 516 #ifdef  POLLHUP
 517         newCONSTSUB(stash,"POLLHUP", newSViv(POLLHUP));
 518 #endif
 519 #ifdef  POLLNVAL
 520         newCONSTSUB(stash,"POLLNVAL", newSViv(POLLNVAL));
 521 #endif
 522     /*
 523      * constant subs for IO::Handle
 524      */
 525     stash = gv_stashpvn("IO::Handle", 10, TRUE);
 526 #ifdef _IOFBF
 527         newCONSTSUB(stash,"_IOFBF", newSViv(_IOFBF));
 528 #endif
 529 #ifdef _IOLBF
 530         newCONSTSUB(stash,"_IOLBF", newSViv(_IOLBF));
 531 #endif
 532 #ifdef _IONBF
 533         newCONSTSUB(stash,"_IONBF", newSViv(_IONBF));
 534 #endif
 535 #ifdef SEEK_SET
 536         newCONSTSUB(stash,"SEEK_SET", newSViv(SEEK_SET));
 537 #endif
 538 #ifdef SEEK_CUR
 539         newCONSTSUB(stash,"SEEK_CUR", newSViv(SEEK_CUR));
 540 #endif
 541 #ifdef SEEK_END
 542         newCONSTSUB(stash,"SEEK_END", newSViv(SEEK_END));
 543 #endif
 544 }
 545