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