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