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