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