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