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