contrib/perl5/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         STRLEN n_a;
 115         if (handle && (p = SvPVx(pos, n_a)) && n_a == sizeof(Fpos_t))
 116 #ifdef PerlIO
 117             RETVAL = PerlIO_setpos(handle, (Fpos_t*)p);
 118 #else
 119             RETVAL = fsetpos(handle, (Fpos_t*)p);
 120 #endif
 121         else {
 122             RETVAL = -1;
 123             errno = EINVAL;
 124         }
 125     OUTPUT:
 126         RETVAL
 127
 128 MODULE = IO     PACKAGE = IO::File      PREFIX = f
 129
 130 SV *
 131 new_tmpfile(packname = "IO::File")
 132     char *              packname
 133     PREINIT:
 134         OutputStream fp;
 135         GV *gv;
 136     CODE:
 137 #ifdef PerlIO
 138         fp = PerlIO_tmpfile();
 139 #else
 140         fp = tmpfile();
 141 #endif
 142         gv = (GV*)SvREFCNT_inc(newGVgen(packname));
 143         hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD);
 144         if (do_open(gv, "+>&", 3, FALSE, 0, 0, fp)) {
 145             ST(0) = sv_2mortal(newRV((SV*)gv));
 146             sv_bless(ST(0), gv_stashpv(packname, TRUE));
 147             SvREFCNT_dec(gv);   /* undo increment in newRV() */
 148         }
 149         else {
 150             ST(0) = &PL_sv_undef;
 151             SvREFCNT_dec(gv);
 152         }
 153
 154 MODULE = IO     PACKAGE = IO::Handle    PREFIX = f
 155
 156 SV *
 157 constant(name)
 158         char *          name
 159     CODE:
 160         IV i;
 161         if (constant(name, &i))
 162             ST(0) = sv_2mortal(newSViv(i));
 163         else
 164             ST(0) = &PL_sv_undef;
 165
 166 int
 167 ungetc(handle, c)
 168         InputStream     handle
 169         int             c
 170     CODE:
 171         if (handle)
 172 #ifdef PerlIO
 173             RETVAL = PerlIO_ungetc(handle, c);
 174 #else
 175             RETVAL = ungetc(c, handle);
 176 #endif
 177         else {
 178             RETVAL = -1;
 179             errno = EINVAL;
 180         }
 181     OUTPUT:
 182         RETVAL
 183
 184 int
 185 ferror(handle)
 186         InputStream     handle
 187     CODE:
 188         if (handle)
 189 #ifdef PerlIO
 190             RETVAL = PerlIO_error(handle);
 191 #else
 192             RETVAL = ferror(handle);
 193 #endif
 194         else {
 195             RETVAL = -1;
 196             errno = EINVAL;
 197         }
 198     OUTPUT:
 199         RETVAL
 200
 201 int
 202 clearerr(handle)
 203         InputStream     handle
 204     CODE:
 205         if (handle) {
 206 #ifdef PerlIO
 207             PerlIO_clearerr(handle);
 208 #else
 209             clearerr(handle);
 210 #endif
 211             RETVAL = 0;
 212         }
 213         else {
 214             RETVAL = -1;
 215             errno = EINVAL;
 216         }
 217     OUTPUT:
 218         RETVAL
 219
 220 int
 221 untaint(handle)
 222        SV *     handle
 223     CODE:
 224 #ifdef IOf_UNTAINT
 225         IO * io;
 226         io = sv_2io(handle);
 227         if (io) {
 228             IoFLAGS(io) |= IOf_UNTAINT;
 229             RETVAL = 0;
 230         }
 231         else {
 232 #endif
 233             RETVAL = -1;
 234             errno = EINVAL;
 235 #ifdef IOf_UNTAINT
 236         }
 237 #endif
 238     OUTPUT:
 239         RETVAL
 240
 241 SysRet
 242 fflush(handle)
 243         OutputStream    handle
 244     CODE:
 245         if (handle)
 246 #ifdef PerlIO
 247             RETVAL = PerlIO_flush(handle);
 248 #else
 249             RETVAL = Fflush(handle);
 250 #endif
 251         else {
 252             RETVAL = -1;
 253             errno = EINVAL;
 254         }
 255     OUTPUT:
 256         RETVAL
 257
 258 void
 259 setbuf(handle, buf)
 260         OutputStream    handle
 261         char *          buf = SvPOK(ST(1)) ? sv_grow(ST(1), BUFSIZ) : 0;
 262     CODE:
 263         if (handle)
 264 #ifdef PERLIO_IS_STDIO
 265             setbuf(handle, buf);
 266 #else
 267             not_here("IO::Handle::setbuf");
 268 #endif
 269
 270 SysRet
 271 setvbuf(handle, buf, type, size)
 272         OutputStream    handle
 273         char *          buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
 274         int             type
 275         int             size
 276     CODE:
 277 /* Should check HAS_SETVBUF once Configure tests for that */
 278 #if defined(PERLIO_IS_STDIO) && defined(_IOFBF)
 279         if (!handle)                    /* Try input stream. */
 280             handle = IoIFP(sv_2io(ST(0)));
 281         if (handle)
 282             RETVAL = setvbuf(handle, buf, type, size);
 283         else {
 284             RETVAL = -1;
 285             errno = EINVAL;
 286         }
 287 #else
 288         RETVAL = (SysRet) not_here("IO::Handle::setvbuf");
 289 #endif
 290     OUTPUT:
 291         RETVAL
 292
 293