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