ext/IO/IO.xs

   1 #include "EXTERN.h"
   2 #define PERLIO_NOT_STDIO 1
   3 #include "perl.h"
   4 #include "XSUB.h"
   5
   6 #ifdef I_UNISTD
   7 #  include <unistd.h>
   8 #endif
   9 #ifdef I_FCNTL
  10 #  include <fcntl.h>
  11 #endif
  12
  13 #ifdef PerlIO
  14 typedef int SysRet;
  15 typedef PerlIO * InputStream;
  16 typedef PerlIO * OutputStream;
  17 #else
  18 #define PERLIO_IS_STDIO 1
  19 typedef int SysRet;
  20 typedef FILE * InputStream;
  21 typedef FILE * OutputStream;
  22 #endif
  23
  24 static int
  25 not_here(s)
  26 char *s;
  27 {
  28     croak("%s not implemented on this architecture", s);
  29     return -1;
  30 }
  31
  32 static bool
  33 constant(name, pval)
  34 char *name;
  35 IV *pval;
  36 {
  37     switch (*name) {
  38     case '_':
  39         if (strEQ(name, "_IOFBF"))
  40 #ifdef _IOFBF
  41             { *pval = _IOFBF; return TRUE; }
  42 #else
  43             return FALSE;
  44 #endif
  45         if (strEQ(name, "_IOLBF"))
  46 #ifdef _IOLBF
  47             { *pval = _IOLBF; return TRUE; }
  48 #else
  49             return FALSE;
  50 #endif
  51         if (strEQ(name, "_IONBF"))
  52 #ifdef _IONBF
  53             { *pval = _IONBF; return TRUE; }
  54 #else
  55             return FALSE;
  56 #endif
  57         break;
  58     case 'S':
  59         if (strEQ(name, "SEEK_SET"))
  60 #ifdef SEEK_SET
  61             { *pval = SEEK_SET; return TRUE; }
  62 #else
  63             return FALSE;
  64 #endif
  65         if (strEQ(name, "SEEK_CUR"))
  66 #ifdef SEEK_CUR
  67             { *pval = SEEK_CUR; return TRUE; }
  68 #else
  69             return FALSE;
  70 #endif
  71         if (strEQ(name, "SEEK_END"))
  72 #ifdef SEEK_END
  73             { *pval = SEEK_END; return TRUE; }
  74 #else
  75             return FALSE;
  76 #endif
  77         break;
  78     }
  79
  80     return FALSE;
  81 }
  82
  83
  84 MODULE = IO     PACKAGE = IO::Seekable  PREFIX = f
  85
  86 SV *
  87 fgetpos(handle)
  88         InputStream     handle
  89     CODE:
  90         if (handle) {
  91             Fpos_t pos;
  92 #ifdef PerlIO
  93             PerlIO_getpos(handle, &pos);
  94 #else
  95             fgetpos(handle, &pos);
  96 #endif
  97             ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t)));
  98         }
  99         else {
 100             ST(0) = &sv_undef;
 101             errno = EINVAL;
 102         }
 103
 104 SysRet
 105 fsetpos(handle, pos)
 106         InputStream     handle
 107         SV *            pos
 108     CODE:
 109         if (handle)
 110 #ifdef PerlIO
 111             RETVAL = PerlIO_setpos(handle, (Fpos_t*)SvPVX(pos));
 112 #else
 113             RETVAL = fsetpos(handle, (Fpos_t*)SvPVX(pos));
 114 #endif
 115         else {
 116             RETVAL = -1;
 117             errno = EINVAL;
 118         }
 119     OUTPUT:
 120         RETVAL
 121
 122 MODULE = IO     PACKAGE = IO::File      PREFIX = f
 123
 124 OutputStream
 125 new_tmpfile(packname = "IO::File")
 126     char *              packname
 127     CODE:
 128 #ifdef PerlIO
 129         RETVAL = PerlIO_tmpfile();
 130 #else
 131         RETVAL = tmpfile();
 132 #endif
 133     OUTPUT:
 134         RETVAL
 135
 136 MODULE = IO     PACKAGE = IO::Handle    PREFIX = f
 137
 138 SV *
 139 constant(name)
 140         char *          name
 141     CODE:
 142         IV i;
 143         if (constant(name, &i))
 144             ST(0) = sv_2mortal(newSViv(i));
 145         else
 146             ST(0) = &sv_undef;
 147
 148 int
 149 ungetc(handle, c)
 150         InputStream     handle
 151         int             c
 152     CODE:
 153         if (handle)
 154 #ifdef PerlIO
 155             RETVAL = PerlIO_ungetc(handle, c);
 156 #else
 157             RETVAL = ungetc(c, handle);
 158 #endif
 159         else {
 160             RETVAL = -1;
 161             errno = EINVAL;
 162         }
 163     OUTPUT:
 164         RETVAL
 165
 166 int
 167 ferror(handle)
 168         InputStream     handle
 169     CODE:
 170         if (handle)
 171 #ifdef PerlIO
 172             RETVAL = PerlIO_error(handle);
 173 #else
 174             RETVAL = ferror(handle);
 175 #endif
 176         else {
 177             RETVAL = -1;
 178             errno = EINVAL;
 179         }
 180     OUTPUT:
 181         RETVAL
 182
 183 int
 184 clearerr(handle)
 185         InputStream     handle
 186     CODE:
 187         if (handle) {
 188 #ifdef PerlIO
 189             PerlIO_clearerr(handle);
 190 #else
 191             clearerr(handle);
 192 #endif
 193             RETVAL = 0;
 194         }
 195         else {
 196             RETVAL = -1;
 197             errno = EINVAL;
 198         }
 199     OUTPUT:
 200         RETVAL
 201
 202 int
 203 untaint(handle)
 204        SV *     handle
 205     CODE:
 206         IO * io;
 207         io = sv_2io(handle);
 208         if (io) {
 209             IoFLAGS(io) |= IOf_UNTAINT;
 210             RETVAL = 0;
 211         }
 212         else {
 213             RETVAL = -1;
 214             errno = EINVAL;
 215         }
 216     OUTPUT:
 217         RETVAL
 218
 219 SysRet
 220 fflush(handle)
 221         OutputStream    handle
 222     CODE:
 223         if (handle)
 224 #ifdef PerlIO
 225             RETVAL = PerlIO_flush(handle);
 226 #else
 227             RETVAL = Fflush(handle);
 228 #endif
 229         else {
 230             RETVAL = -1;
 231             errno = EINVAL;
 232         }
 233     OUTPUT:
 234         RETVAL
 235
 236 void
 237 setbuf(handle, buf)
 238         OutputStream    handle
 239         char *          buf = SvPOK(ST(1)) ? sv_grow(ST(1), BUFSIZ) : 0;
 240     CODE:
 241         if (handle)
 242 #ifdef PERLIO_IS_STDIO
 243             setbuf(handle, buf);
 244 #else
 245             not_here("IO::Handle::setbuf");
 246 #endif
 247
 248 SysRet
 249 setvbuf(handle, buf, type, size)
 250         OutputStream    handle
 251         char *          buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
 252         int             type
 253         int             size
 254     CODE:
 255 #ifdef PERLIO_IS_STDIO
 256 #ifdef _IOFBF   /* Should be HAS_SETVBUF once Configure tests for that */
 257         if (handle)
 258             RETVAL = setvbuf(handle, buf, type, size);
 259         else {
 260             RETVAL = -1;
 261             errno = EINVAL;
 262         }
 263 #else
 264             RETVAL = (SysRet) not_here("IO::Handle::setvbuf");
 265 #endif /* _IOFBF */
 266 #else
 267             not_here("IO::Handle::setvbuf");
 268 #endif
 269     OUTPUT:
 270         RETVAL
 271
 272