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