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             Fpos_t pos;
 145             if (
 146 #ifdef PerlIO
 147                 PerlIO_getpos(handle, &pos)
 148 #else
 149                 fgetpos(handle, &pos)
 150 #endif
 151                 ) {
 152                 ST(0) = &PL_sv_undef;
 153             } else {
 154                 ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t)));
 155             }
 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         char *p;
 168         STRLEN len;
 169         if (handle && (p = SvPV(pos,len)) && len == sizeof(Fpos_t))
 170 #ifdef PerlIO
 171             RETVAL = PerlIO_setpos(handle, (Fpos_t*)p);
 172 #else
 173             RETVAL = fsetpos(handle, (Fpos_t*)p);
 174 #endif
 175         else {
 176             RETVAL = -1;
 177             errno = EINVAL;
 178         }
 179     OUTPUT:
 180         RETVAL
 181
 182 MODULE = IO     PACKAGE = IO::File      PREFIX = f
 183
 184 SV *
 185 new_tmpfile(packname = "IO::File")
 186     char *              packname
 187     PREINIT:
 188         OutputStream fp;
 189         GV *gv;
 190     CODE:
 191 #ifdef PerlIO
 192         fp = PerlIO_tmpfile();
 193 #else
 194         fp = tmpfile();
 195 #endif
 196         gv = (GV*)SvREFCNT_inc(newGVgen(packname));
 197         hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD);
 198         if (do_open(gv, "+>&", 3, FALSE, 0, 0, fp)) {
 199             ST(0) = sv_2mortal(newRV((SV*)gv));
 200             sv_bless(ST(0), gv_stashpv(packname, TRUE));
 201             SvREFCNT_dec(gv);   /* undo increment in newRV() */
 202         }
 203         else {
 204             ST(0) = &PL_sv_undef;
 205             SvREFCNT_dec(gv);
 206         }
 207
 208 MODULE = IO     PACKAGE = IO::Poll
 209
 210 void
 211 _poll(timeout,...)
 212         int timeout;
 213 PPCODE:
 214 {
 215 #ifdef HAS_POLL
 216     int nfd = (items - 1) / 2;
 217     SV *tmpsv = NEWSV(999,nfd * sizeof(struct pollfd));
 218     struct pollfd *fds = (struct pollfd *)SvPVX(tmpsv);
 219     int i,j,ret;
 220     for(i=1, j=0  ; j < nfd ; j++) {
 221         fds[j].fd = SvIV(ST(i));
 222         i++;
 223         fds[j].events = SvIV(ST(i));
 224         i++;
 225         fds[j].revents = 0;
 226     }
 227     if((ret = poll(fds,nfd,timeout)) >= 0) {
 228         for(i=1, j=0 ; j < nfd ; j++) {
 229             sv_setiv(ST(i), fds[j].fd); i++;
 230             sv_setiv(ST(i), fds[j].revents); i++;
 231         }
 232     }
 233     SvREFCNT_dec(tmpsv);
 234     XSRETURN_IV(ret);
 235 #else
 236         not_here("IO::Poll::poll");
 237 #endif
 238 }
 239
 240 MODULE = IO     PACKAGE = IO::Handle    PREFIX = io_
 241
 242 void
 243 io_blocking(handle,blk=-1)
 244         InputStream     handle
 245         int             blk
 246 PROTOTYPE: $;$
 247 CODE:
 248 {
 249     int ret = io_blocking(handle, items == 1 ? -1 : blk ? 1 : 0);
 250     if(ret >= 0)
 251         XSRETURN_IV(ret);
 252     else
 253         XSRETURN_UNDEF;
 254 }
 255
 256 MODULE = IO     PACKAGE = IO::Handle    PREFIX = f
 257
 258
 259 int
 260 ungetc(handle, c)
 261         InputStream     handle
 262         int             c
 263     CODE:
 264         if (handle)
 265 #ifdef PerlIO
 266             RETVAL = PerlIO_ungetc(handle, c);
 267 #else
 268             RETVAL = ungetc(c, handle);
 269 #endif
 270         else {
 271             RETVAL = -1;
 272             errno = EINVAL;
 273         }
 274     OUTPUT:
 275         RETVAL
 276
 277 int
 278 ferror(handle)
 279         InputStream     handle
 280     CODE:
 281         if (handle)
 282 #ifdef PerlIO
 283             RETVAL = PerlIO_error(handle);
 284 #else
 285             RETVAL = ferror(handle);
 286 #endif
 287         else {
 288             RETVAL = -1;
 289             errno = EINVAL;
 290         }
 291     OUTPUT:
 292         RETVAL
 293
 294 int
 295 clearerr(handle)
 296         InputStream     handle
 297     CODE:
 298         if (handle) {
 299 #ifdef PerlIO
 300             PerlIO_clearerr(handle);
 301 #else
 302             clearerr(handle);
 303 #endif
 304             RETVAL = 0;
 305         }
 306         else {
 307             RETVAL = -1;
 308             errno = EINVAL;
 309         }
 310     OUTPUT:
 311         RETVAL
 312
 313 int
 314 untaint(handle)
 315        SV *     handle
 316     CODE:
 317 #ifdef IOf_UNTAINT
 318         IO * io;
 319         io = sv_2io(handle);
 320         if (io) {
 321             IoFLAGS(io) |= IOf_UNTAINT;
 322             RETVAL = 0;
 323         }
 324         else {
 325 #endif
 326             RETVAL = -1;
 327             errno = EINVAL;
 328 #ifdef IOf_UNTAINT
 329         }
 330 #endif
 331     OUTPUT:
 332         RETVAL
 333
 334 SysRet
 335 fflush(handle)
 336         OutputStream    handle
 337     CODE:
 338         if (handle)
 339 #ifdef PerlIO
 340             RETVAL = PerlIO_flush(handle);
 341 #else
 342             RETVAL = Fflush(handle);
 343 #endif
 344         else {
 345             RETVAL = -1;
 346             errno = EINVAL;
 347         }
 348     OUTPUT:
 349         RETVAL
 350
 351 void
 352 setbuf(handle, buf)
 353         OutputStream    handle
 354         char *          buf = SvPOK(ST(1)) ? sv_grow(ST(1), BUFSIZ) : 0;
 355     CODE:
 356         if (handle)
 357 #ifdef PERLIO_IS_STDIO
 358             setbuf(handle, buf);
 359 #else
 360             not_here("IO::Handle::setbuf");
 361 #endif
 362
 363 SysRet
 364 setvbuf(handle, buf, type, size)
 365         OutputStream    handle
 366         char *          buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
 367         int             type
 368         int             size
 369     CODE:
 370 #if defined(PERLIO_IS_STDIO) && defined(_IOFBF) && defined(HAS_SETVBUF)
 371         if (!handle)                    /* Try input stream. */
 372             handle = IoIFP(sv_2io(ST(0)));
 373         if (handle)
 374             RETVAL = setvbuf(handle, buf, type, size);
 375         else {
 376             RETVAL = -1;
 377             errno = EINVAL;
 378         }
 379 #else
 380         RETVAL = (SysRet) not_here("IO::Handle::setvbuf");
 381 #endif
 382     OUTPUT:
 383         RETVAL
 384
 385
 386 SysRet
 387 fsync(handle)
 388         OutputStream handle
 389     CODE:
 390 #ifdef HAS_FSYNC
 391         if(handle)
 392             RETVAL = fsync(PerlIO_fileno(handle));
 393         else {
 394             RETVAL = -1;
 395             errno = EINVAL;
 396         }
 397 #else
 398         RETVAL = (SysRet) not_here("IO::Handle::sync");
 399 #endif
 400     OUTPUT:
 401         RETVAL
 402
 403
 404 BOOT:
 405 {
 406     HV *stash;
 407     /*
 408      * constant subs for IO::Poll
 409      */
 410     stash = gv_stashpvn("IO::Poll", 8, TRUE);
 411 #ifdef  POLLIN
 412         newCONSTSUB(stash,"POLLIN",newSViv(POLLIN));
 413 #endif
 414 #ifdef  POLLPRI
 415         newCONSTSUB(stash,"POLLPRI", newSViv(POLLPRI));
 416 #endif
 417 #ifdef  POLLOUT
 418         newCONSTSUB(stash,"POLLOUT", newSViv(POLLOUT));
 419 #endif
 420 #ifdef  POLLRDNORM
 421         newCONSTSUB(stash,"POLLRDNORM", newSViv(POLLRDNORM));
 422 #endif
 423 #ifdef  POLLWRNORM
 424         newCONSTSUB(stash,"POLLWRNORM", newSViv(POLLWRNORM));
 425 #endif
 426 #ifdef  POLLRDBAND
 427         newCONSTSUB(stash,"POLLRDBAND", newSViv(POLLRDBAND));
 428 #endif
 429 #ifdef  POLLWRBAND
 430         newCONSTSUB(stash,"POLLWRBAND", newSViv(POLLWRBAND));
 431 #endif
 432 #ifdef  POLLNORM
 433         newCONSTSUB(stash,"POLLNORM", newSViv(POLLNORM));
 434 #endif
 435 #ifdef  POLLERR
 436         newCONSTSUB(stash,"POLLERR", newSViv(POLLERR));
 437 #endif
 438 #ifdef  POLLHUP
 439         newCONSTSUB(stash,"POLLHUP", newSViv(POLLHUP));
 440 #endif
 441 #ifdef  POLLNVAL
 442         newCONSTSUB(stash,"POLLNVAL", newSViv(POLLNVAL));
 443 #endif
 444     /*
 445      * constant subs for IO::Handle
 446      */
 447     stash = gv_stashpvn("IO::Handle", 10, TRUE);
 448 #ifdef _IOFBF
 449         newCONSTSUB(stash,"_IOFBF", newSViv(_IOFBF));
 450 #endif
 451 #ifdef _IOLBF
 452         newCONSTSUB(stash,"_IOLBF", newSViv(_IOLBF));
 453 #endif
 454 #ifdef _IONBF
 455         newCONSTSUB(stash,"_IONBF", newSViv(_IONBF));
 456 #endif
 457 #ifdef SEEK_SET
 458         newCONSTSUB(stash,"SEEK_SET", newSViv(SEEK_SET));
 459 #endif
 460 #ifdef SEEK_CUR
 461         newCONSTSUB(stash,"SEEK_CUR", newSViv(SEEK_CUR));
 462 #endif
 463 #ifdef SEEK_END
 464         newCONSTSUB(stash,"SEEK_END", newSViv(SEEK_END));
 465 #endif
 466 }