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_NO_GET_CONTEXT
   8 #include "EXTERN.h"
   9 #define PERLIO_NOT_STDIO 1
  10 #include "perl.h"
  11 #include "XSUB.h"
  12 #include "poll.h"
  13 #ifdef I_UNISTD
  14 #  include <unistd.h>
  15 #endif
  16 #if defined(I_FCNTL) || defined(HAS_FCNTL)
  17 #  include <fcntl.h>
  18 #endif
  19
  20 #ifdef PerlIO
  21 typedef int SysRet;
  22 typedef PerlIO * InputStream;
  23 typedef PerlIO * OutputStream;
  24 #else
  25 #define PERLIO_IS_STDIO 1
  26 typedef int SysRet;
  27 typedef FILE * InputStream;
  28 typedef FILE * OutputStream;
  29 #endif
  30
  31 #define MY_start_subparse(fmt,flags) start_subparse(fmt,flags)
  32
  33 #ifndef gv_stashpvn
  34 #define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
  35 #endif
  36
  37 static int
  38 not_here(char *s)
  39 {
  40     croak("%s not implemented on this architecture", s);
  41     return -1;
  42 }
  43
  44
  45 #ifndef PerlIO
  46 #define PerlIO_fileno(f) fileno(f)
  47 #endif
  48
  49 static int
  50 io_blocking(InputStream f, int block)
  51 {
  52     int RETVAL;
  53     if(!f) {
  54         errno = EBADF;
  55         return -1;
  56     }
  57 #if defined(HAS_FCNTL)
  58     RETVAL = fcntl(PerlIO_fileno(f), F_GETFL, 0);
  59     if (RETVAL >= 0) {
  60         int mode = RETVAL;
  61 #ifdef O_NONBLOCK
  62         /* POSIX style */
  63 #if defined(O_NDELAY) && O_NDELAY != O_NONBLOCK
  64         /* Ooops has O_NDELAY too - make sure we don't
  65          * get SysV behaviour by mistake
  66          */
  67         RETVAL = RETVAL & O_NONBLOCK ? 0 : 1;
  68
  69         if ((mode & O_NDELAY) || ((block == 0) && !(mode & O_NONBLOCK))) {
  70             int ret;
  71             mode = (mode & ~O_NDELAY) | O_NONBLOCK;
  72             ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
  73             if(ret < 0)
  74                 RETVAL = ret;
  75         }
  76         else if ((mode & O_NDELAY) || ((block > 0) && (mode & O_NONBLOCK))) {
  77             int ret;
  78             mode &= ~(O_NONBLOCK | O_NDELAY);
  79             ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
  80             if(ret < 0)
  81                 RETVAL = ret;
  82         }
  83 #else
  84         /* Standard POSIX */
  85         RETVAL = RETVAL & O_NONBLOCK ? 0 : 1;
  86
  87         if ((block == 0) && !(mode & O_NONBLOCK)) {
  88             int ret;
  89             mode |= O_NONBLOCK;
  90             ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
  91             if(ret < 0)
  92                 RETVAL = ret;
  93          }
  94         else if ((block > 0) && (mode & O_NONBLOCK)) {
  95             int ret;
  96             mode &= ~O_NONBLOCK;
  97             ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
  98             if(ret < 0)
  99                 RETVAL = ret;
 100          }
 101 #endif
 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) && !(mode & O_NDELAY)) {
 111             int ret;
 112             mode |= O_NDELAY;
 113             ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
 114             if(ret < 0)
 115                 RETVAL = ret;
 116          }
 117         else if ((block > 0) && (mode & O_NDELAY)) {
 118             int ret;
 119             mode &= ~O_NDELAY;
 120             ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
 121             if(ret < 0)
 122                 RETVAL = ret;
 123          }
 124 #endif
 125     }
 126     return RETVAL;
 127 #else
 128  return -1;
 129 #endif
 130 }
 131
 132 MODULE = IO     PACKAGE = IO::Seekable  PREFIX = f
 133
 134 SV *
 135 fgetpos(handle)
 136         InputStream     handle
 137     CODE:
 138         if (handle) {
 139             Fpos_t pos;
 140 #ifdef PerlIO
 141             PerlIO_getpos(handle, &pos);
 142 #else
 143             fgetpos(handle, &pos);
 144 #endif
 145             ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t)));
 146         }
 147         else {
 148             ST(0) = &PL_sv_undef;
 149             errno = EINVAL;
 150         }
 151
 152 SysRet
 153 fsetpos(handle, pos)
 154         InputStream     handle
 155         SV *            pos
 156     CODE:
 157         char *p;
 158         STRLEN len;
 159         if (handle && (p = SvPV(pos,len)) && len == sizeof(Fpos_t))
 160 #ifdef PerlIO
 161             RETVAL = PerlIO_setpos(handle, (Fpos_t*)p);
 162 #else
 163             RETVAL = fsetpos(handle, (Fpos_t*)p);
 164 #endif
 165         else {
 166             RETVAL = -1;
 167             errno = EINVAL;
 168         }
 169     OUTPUT:
 170         RETVAL
 171
 172 MODULE = IO     PACKAGE = IO::File      PREFIX = f
 173
 174 SV *
 175 new_tmpfile(packname = "IO::File")
 176     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     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 = 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     int ret = io_blocking(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
 249 int
 250 ungetc(handle, c)
 251         InputStream     handle
 252         int             c
 253     CODE:
 254         if (handle)
 255 #ifdef PerlIO
 256             RETVAL = PerlIO_ungetc(handle, c);
 257 #else
 258             RETVAL = ungetc(c, handle);
 259 #endif
 260         else {
 261             RETVAL = -1;
 262             errno = EINVAL;
 263         }
 264     OUTPUT:
 265         RETVAL
 266
 267 int
 268 ferror(handle)
 269         InputStream     handle
 270     CODE:
 271         if (handle)
 272 #ifdef PerlIO
 273             RETVAL = PerlIO_error(handle);
 274 #else
 275             RETVAL = ferror(handle);
 276 #endif
 277         else {
 278             RETVAL = -1;
 279             errno = EINVAL;
 280         }
 281     OUTPUT:
 282         RETVAL
 283
 284 int
 285 clearerr(handle)
 286         InputStream     handle
 287     CODE:
 288         if (handle) {
 289 #ifdef PerlIO
 290             PerlIO_clearerr(handle);
 291 #else
 292             clearerr(handle);
 293 #endif
 294             RETVAL = 0;
 295         }
 296         else {
 297             RETVAL = -1;
 298             errno = EINVAL;
 299         }
 300     OUTPUT:
 301         RETVAL
 302
 303 int
 304 untaint(handle)
 305        SV *     handle
 306     CODE:
 307 #ifdef IOf_UNTAINT
 308         IO * io;
 309         io = sv_2io(handle);
 310         if (io) {
 311             IoFLAGS(io) |= IOf_UNTAINT;
 312             RETVAL = 0;
 313         }
 314         else {
 315 #endif
 316             RETVAL = -1;
 317             errno = EINVAL;
 318 #ifdef IOf_UNTAINT
 319         }
 320 #endif
 321     OUTPUT:
 322         RETVAL
 323
 324 SysRet
 325 fflush(handle)
 326         OutputStream    handle
 327     CODE:
 328         if (handle)
 329 #ifdef PerlIO
 330             RETVAL = PerlIO_flush(handle);
 331 #else
 332             RETVAL = Fflush(handle);
 333 #endif
 334         else {
 335             RETVAL = -1;
 336             errno = EINVAL;
 337         }
 338     OUTPUT:
 339         RETVAL
 340
 341 void
 342 setbuf(handle, buf)
 343         OutputStream    handle
 344         char *          buf = SvPOK(ST(1)) ? sv_grow(ST(1), BUFSIZ) : 0;
 345     CODE:
 346         if (handle)
 347 #ifdef PERLIO_IS_STDIO
 348             setbuf(handle, buf);
 349 #else
 350             not_here("IO::Handle::setbuf");
 351 #endif
 352
 353 SysRet
 354 setvbuf(handle, buf, type, size)
 355         OutputStream    handle
 356         char *          buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
 357         int             type
 358         int             size
 359     CODE:
 360 /* Should check HAS_SETVBUF once Configure tests for that */
 361 #if defined(PERLIO_IS_STDIO) && defined(_IOFBF)
 362         if (!handle)                    /* Try input stream. */
 363             handle = IoIFP(sv_2io(ST(0)));
 364         if (handle)
 365             RETVAL = setvbuf(handle, buf, type, size);
 366         else {
 367             RETVAL = -1;
 368             errno = EINVAL;
 369         }
 370 #else
 371         RETVAL = (SysRet) not_here("IO::Handle::setvbuf");
 372 #endif
 373     OUTPUT:
 374         RETVAL
 375
 376
 377 SysRet
 378 fsync(handle)
 379         OutputStream handle
 380     CODE:
 381 #ifdef HAS_FSYNC
 382         if(handle)
 383             RETVAL = fsync(PerlIO_fileno(handle));
 384         else {
 385             RETVAL = -1;
 386             errno = EINVAL;
 387         }
 388 #else
 389         RETVAL = (SysRet) not_here("IO::Handle::sync");
 390 #endif
 391     OUTPUT:
 392         RETVAL
 393
 394
 395 BOOT:
 396 {
 397     HV *stash;
 398     /*
 399      * constant subs for IO::Poll
 400      */
 401     stash = gv_stashpvn("IO::Poll", 8, TRUE);
 402 #ifdef  POLLIN
 403         newCONSTSUB(stash,"POLLIN",newSViv(POLLIN));
 404 #endif
 405 #ifdef  POLLPRI
 406         newCONSTSUB(stash,"POLLPRI", newSViv(POLLPRI));
 407 #endif
 408 #ifdef  POLLOUT
 409         newCONSTSUB(stash,"POLLOUT", newSViv(POLLOUT));
 410 #endif
 411 #ifdef  POLLRDNORM
 412         newCONSTSUB(stash,"POLLRDNORM", newSViv(POLLRDNORM));
 413 #endif
 414 #ifdef  POLLWRNORM
 415         newCONSTSUB(stash,"POLLWRNORM", newSViv(POLLWRNORM));
 416 #endif
 417 #ifdef  POLLRDBAND
 418         newCONSTSUB(stash,"POLLRDBAND", newSViv(POLLRDBAND));
 419 #endif
 420 #ifdef  POLLWRBAND
 421         newCONSTSUB(stash,"POLLWRBAND", newSViv(POLLWRBAND));
 422 #endif
 423 #ifdef  POLLNORM
 424         newCONSTSUB(stash,"POLLNORM", newSViv(POLLNORM));
 425 #endif
 426 #ifdef  POLLERR
 427         newCONSTSUB(stash,"POLLERR", newSViv(POLLERR));
 428 #endif
 429 #ifdef  POLLHUP
 430         newCONSTSUB(stash,"POLLHUP", newSViv(POLLHUP));
 431 #endif
 432 #ifdef  POLLNVAL
 433         newCONSTSUB(stash,"POLLNVAL", newSViv(POLLNVAL));
 434 #endif
 435     /*
 436      * constant subs for IO::Handle
 437      */
 438     stash = gv_stashpvn("IO::Handle", 10, TRUE);
 439 #ifdef _IOFBF
 440         newCONSTSUB(stash,"_IOFBF", newSViv(_IOFBF));
 441 #endif
 442 #ifdef _IOLBF
 443         newCONSTSUB(stash,"_IOLBF", newSViv(_IOLBF));
 444 #endif
 445 #ifdef _IONBF
 446         newCONSTSUB(stash,"_IONBF", newSViv(_IONBF));
 447 #endif
 448 #ifdef SEEK_SET
 449         newCONSTSUB(stash,"SEEK_SET", newSViv(SEEK_SET));
 450 #endif
 451 #ifdef SEEK_CUR
 452         newCONSTSUB(stash,"SEEK_CUR", newSViv(SEEK_CUR));
 453 #endif
 454 #ifdef SEEK_END
 455         newCONSTSUB(stash,"SEEK_END", newSViv(SEEK_END));
 456 #endif
 457     /*
 458      * constant subs for IO
 459      */
 460     stash = gv_stashpvn("IO", 2, TRUE);
 461 #ifdef EINPROGRESS
 462         newCONSTSUB(stash,"EINPROGRESS", newSViv(EINPROGRESS));
 463 #endif
 464 }