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 #include "EXTERN.h"
   8 #define PERLIO_NOT_STDIO 1
   9 #include "perl.h"
  10 #include "XSUB.h"
  11 #include "poll.h"
  12 #ifdef I_UNISTD
  13 #  include <unistd.h>
  14 #endif
  15 #if defined(I_FCNTL) || defined(HAS_FCNTL)
  16 #  include <fcntl.h>
  17 #endif
  18
  19 #ifdef PerlIO
  20 typedef int SysRet;
  21 typedef PerlIO * InputStream;
  22 typedef PerlIO * OutputStream;
  23 #else
  24 #define PERLIO_IS_STDIO 1
  25 typedef int SysRet;
  26 typedef FILE * InputStream;
  27 typedef FILE * OutputStream;
  28 #endif
  29
  30 #define MY_start_subparse(fmt,flags) start_subparse(fmt,flags)
  31
  32 #ifndef gv_stashpvn
  33 #define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
  34 #endif
  35
  36 static int
  37 not_here(char *s)
  38 {
  39     croak("%s not implemented on this architecture", s);
  40     return -1;
  41 }
  42
  43
  44 #ifndef PerlIO
  45 #define PerlIO_fileno(f) fileno(f)
  46 #endif
  47
  48 static int
  49 io_blocking(InputStream f, int block)
  50 {
  51     int RETVAL;
  52     if(!f) {
  53         errno = EBADF;
  54         return -1;
  55     }
  56 #if defined(HAS_FCNTL)
  57     RETVAL = fcntl(PerlIO_fileno(f), F_GETFL, 0);
  58     if (RETVAL >= 0) {
  59         int mode = RETVAL;
  60 #ifdef O_NONBLOCK
  61         /* POSIX style */
  62 #if defined(O_NDELAY) && O_NDELAY != O_NONBLOCK
  63         /* Ooops has O_NDELAY too - make sure we don't
  64          * get SysV behaviour by mistake
  65          */
  66         RETVAL = RETVAL & O_NONBLOCK ? 0 : 1;
  67
  68         if ((mode & O_NDELAY) || ((block == 0) && !(mode & O_NONBLOCK))) {
  69             int ret;
  70             mode = (mode & ~O_NDELAY) | O_NONBLOCK;
  71             ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
  72             if(ret < 0)
  73                 RETVAL = ret;
  74         }
  75         else if ((mode & O_NDELAY) || ((block > 0) && (mode & O_NONBLOCK))) {
  76             int ret;
  77             mode &= ~(O_NONBLOCK | O_NDELAY);
  78             ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
  79             if(ret < 0)
  80                 RETVAL = ret;
  81         }
  82 #else
  83         /* Standard POSIX */
  84         RETVAL = RETVAL & O_NONBLOCK ? 0 : 1;
  85
  86         if ((block == 0) && !(mode & O_NONBLOCK)) {
  87             int ret;
  88             mode |= O_NONBLOCK;
  89             ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
  90             if(ret < 0)
  91                 RETVAL = ret;
  92          }
  93         else if ((block > 0) && (mode & O_NONBLOCK)) {
  94             int ret;
  95             mode &= ~O_NONBLOCK;
  96             ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
  97             if(ret < 0)
  98                 RETVAL = ret;
  99          }
 100 #endif
 101 #else
 102         /* Not POSIX - better have O_NDELAY or we can't cope.
 103          * for BSD-ish machines this is an acceptable alternative
 104          * for SysV we can't tell "would block" from EOF but that is
 105          * the way SysV is...
 106          */
 107         RETVAL = RETVAL & O_NDELAY ? 0 : 1;
 108
 109         if ((block == 0) && !(mode & O_NDELAY)) {
 110             int ret;
 111             mode |= O_NDELAY;
 112             ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
 113             if(ret < 0)
 114                 RETVAL = ret;
 115          }
 116         else if ((block > 0) && (mode & O_NDELAY)) {
 117             int ret;
 118             mode &= ~O_NDELAY;
 119             ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
 120             if(ret < 0)
 121                 RETVAL = ret;
 122          }
 123 #endif
 124     }
 125     return RETVAL;
 126 #else
 127  return -1;
 128 #endif
 129 }
 130
 131 MODULE = IO     PACKAGE = IO::Seekable  PREFIX = f
 132
 133 SV *
 134 fgetpos(handle)
 135         InputStream     handle
 136     CODE:
 137         if (handle) {
 138             Fpos_t pos;
 139 #ifdef PerlIO
 140             PerlIO_getpos(handle, &pos);
 141 #else
 142             fgetpos(handle, &pos);
 143 #endif
 144             ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t)));
 145         }
 146         else {
 147             ST(0) = &PL_sv_undef;
 148             errno = EINVAL;
 149         }
 150
 151 SysRet
 152 fsetpos(handle, pos)
 153         InputStream     handle
 154         SV *            pos
 155     CODE:
 156         char *p;
 157         STRLEN len;
 158         if (handle && (p = SvPV(pos,len)) && len == sizeof(Fpos_t))
 159 #ifdef PerlIO
 160             RETVAL = PerlIO_setpos(handle, (Fpos_t*)p);
 161 #else
 162             RETVAL = fsetpos(handle, (Fpos_t*)p);
 163 #endif
 164         else {
 165             RETVAL = -1;
 166             errno = EINVAL;
 167         }
 168     OUTPUT:
 169         RETVAL
 170
 171 MODULE = IO     PACKAGE = IO::File      PREFIX = f
 172
 173 SV *
 174 new_tmpfile(packname = "IO::File")
 175     char *              packname
 176     PREINIT:
 177         OutputStream fp;
 178         GV *gv;
 179     CODE:
 180 #ifdef PerlIO
 181         fp = PerlIO_tmpfile();
 182 #else
 183         fp = tmpfile();
 184 #endif
 185         gv = (GV*)SvREFCNT_inc(newGVgen(packname));
 186         hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD);
 187         if (do_open(gv, "+>&", 3, FALSE, 0, 0, fp)) {
 188             ST(0) = sv_2mortal(newRV((SV*)gv));
 189             sv_bless(ST(0), gv_stashpv(packname, TRUE));
 190             SvREFCNT_dec(gv);   /* undo increment in newRV() */
 191         }
 192         else {
 193             ST(0) = &PL_sv_undef;
 194             SvREFCNT_dec(gv);
 195         }
 196
 197 MODULE = IO     PACKAGE = IO::Poll
 198
 199 void
 200 _poll(timeout,...)
 201         int timeout;
 202 PPCODE:
 203 {
 204 #ifdef HAS_POLL
 205     int nfd = (items - 1) / 2;
 206     SV *tmpsv = NEWSV(999,nfd * sizeof(struct pollfd));
 207     struct pollfd *fds = (struct pollfd *)SvPVX(tmpsv);
 208     int i,j,ret;
 209     for(i=1, j=0  ; j < nfd ; j++) {
 210         fds[j].fd = SvIV(ST(i));
 211         i++;
 212         fds[j].events = SvIV(ST(i));
 213         i++;
 214         fds[j].revents = 0;
 215     }
 216     if((ret = poll(fds,nfd,timeout)) >= 0) {
 217         for(i=1, j=0 ; j < nfd ; j++) {
 218             sv_setiv(ST(i), fds[j].fd); i++;
 219             sv_setiv(ST(i), fds[j].revents); i++;
 220         }
 221     }
 222     SvREFCNT_dec(tmpsv);
 223     XSRETURN_IV(ret);
 224 #else
 225         not_here("IO::Poll::poll");
 226 #endif
 227 }
 228
 229 MODULE = IO     PACKAGE = IO::Handle    PREFIX = io_
 230
 231 void
 232 io_blocking(handle,blk=-1)
 233         InputStream     handle
 234         int             blk
 235 PROTOTYPE: $;$
 236 CODE:
 237 {
 238     int ret = io_blocking(handle, items == 1 ? -1 : blk ? 1 : 0);
 239     if(ret >= 0)
 240         XSRETURN_IV(ret);
 241     else
 242         XSRETURN_UNDEF;
 243 }
 244
 245 MODULE = IO     PACKAGE = IO::Handle    PREFIX = f
 246
 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, buf)
 342         OutputStream    handle
 343         char *          buf = SvPOK(ST(1)) ? sv_grow(ST(1), BUFSIZ) : 0;
 344     CODE:
 345         if (handle)
 346 #ifdef PERLIO_IS_STDIO
 347             setbuf(handle, buf);
 348 #else
 349             not_here("IO::Handle::setbuf");
 350 #endif
 351
 352 SysRet
 353 setvbuf(handle, buf, type, size)
 354         OutputStream    handle
 355         char *          buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
 356         int             type
 357         int             size
 358     CODE:
 359 /* Should check HAS_SETVBUF once Configure tests for that */
 360 #if defined(PERLIO_IS_STDIO) && defined(_IOFBF)
 361         if (!handle)                    /* Try input stream. */
 362             handle = IoIFP(sv_2io(ST(0)));
 363         if (handle)
 364             RETVAL = setvbuf(handle, buf, type, size);
 365         else {
 366             RETVAL = -1;
 367             errno = EINVAL;
 368         }
 369 #else
 370         RETVAL = (SysRet) not_here("IO::Handle::setvbuf");
 371 #endif
 372     OUTPUT:
 373         RETVAL
 374
 375
 376 SysRet
 377 fsync(handle)
 378         OutputStream handle
 379     CODE:
 380 #ifdef HAS_FSYNC
 381         if(handle)
 382             RETVAL = fsync(PerlIO_fileno(handle));
 383         else {
 384             RETVAL = -1;
 385             errno = EINVAL;
 386         }
 387 #else
 388         RETVAL = (SysRet) not_here("IO::Handle::sync");
 389 #endif
 390     OUTPUT:
 391         RETVAL
 392
 393
 394 BOOT:
 395 {
 396     HV *stash;
 397     /*
 398      * constant subs for IO::Poll
 399      */
 400     stash = gv_stashpvn("IO::Poll", 8, TRUE);
 401 #ifdef  POLLIN
 402         newCONSTSUB(stash,"POLLIN",newSViv(POLLIN));
 403 #endif
 404 #ifdef  POLLPRI
 405         newCONSTSUB(stash,"POLLPRI", newSViv(POLLPRI));
 406 #endif
 407 #ifdef  POLLOUT
 408         newCONSTSUB(stash,"POLLOUT", newSViv(POLLOUT));
 409 #endif
 410 #ifdef  POLLRDNORM
 411         newCONSTSUB(stash,"POLLRDNORM", newSViv(POLLRDNORM));
 412 #endif
 413 #ifdef  POLLWRNORM
 414         newCONSTSUB(stash,"POLLWRNORM", newSViv(POLLWRNORM));
 415 #endif
 416 #ifdef  POLLRDBAND
 417         newCONSTSUB(stash,"POLLRDBAND", newSViv(POLLRDBAND));
 418 #endif
 419 #ifdef  POLLWRBAND
 420         newCONSTSUB(stash,"POLLWRBAND", newSViv(POLLWRBAND));
 421 #endif
 422 #ifdef  POLLNORM
 423         newCONSTSUB(stash,"POLLNORM", newSViv(POLLNORM));
 424 #endif
 425 #ifdef  POLLERR
 426         newCONSTSUB(stash,"POLLERR", newSViv(POLLERR));
 427 #endif
 428 #ifdef  POLLHUP
 429         newCONSTSUB(stash,"POLLHUP", newSViv(POLLHUP));
 430 #endif
 431 #ifdef  POLLNVAL
 432         newCONSTSUB(stash,"POLLNVAL", newSViv(POLLNVAL));
 433 #endif
 434     /*
 435      * constant subs for IO::Handle
 436      */
 437     stash = gv_stashpvn("IO::Handle", 10, TRUE);
 438 #ifdef _IOFBF
 439         newCONSTSUB(stash,"_IOFBF", newSViv(_IOFBF));
 440 #endif
 441 #ifdef _IOLBF
 442         newCONSTSUB(stash,"_IOLBF", newSViv(_IOLBF));
 443 #endif
 444 #ifdef _IONBF
 445         newCONSTSUB(stash,"_IONBF", newSViv(_IONBF));
 446 #endif
 447 #ifdef SEEK_SET
 448         newCONSTSUB(stash,"SEEK_SET", newSViv(SEEK_SET));
 449 #endif
 450 #ifdef SEEK_CUR
 451         newCONSTSUB(stash,"SEEK_CUR", newSViv(SEEK_CUR));
 452 #endif
 453 #ifdef SEEK_END
 454         newCONSTSUB(stash,"SEEK_END", newSViv(SEEK_END));
 455 #endif
 456     /*
 457      * constant subs for IO
 458      */
 459     stash = gv_stashpvn("IO", 2, TRUE);
 460 #ifdef EINPROGRESS
 461         newCONSTSUB(stash,"EINPROGRESS", newSViv(EINPROGRESS));
 462 #endif
 463 }