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 #if defined(PERLIO_IS_STDIO) && defined(_IOFBF) && defined(HAS_SETVBUF)
 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 }