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