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