This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix core dump on IO::Seekable::setpos($fh, undef)
[perl5.git] / ext / IO / IO.xs
CommitLineData
8add82fc 1#include "EXTERN.h"
760ac839 2#define PERLIO_NOT_STDIO 1
8add82fc
PP
3#include "perl.h"
4#include "XSUB.h"
760ac839 5
8add82fc
PP
6#ifdef I_UNISTD
7# include <unistd.h>
8#endif
760ac839
LW
9#ifdef I_FCNTL
10# include <fcntl.h>
11#endif
8add82fc 12
2a0cf753 13#ifdef PerlIO
8add82fc 14typedef int SysRet;
760ac839
LW
15typedef PerlIO * InputStream;
16typedef PerlIO * OutputStream;
2a0cf753
PP
17#else
18#define PERLIO_IS_STDIO 1
19typedef int SysRet;
20typedef FILE * InputStream;
21typedef FILE * OutputStream;
22#endif
8add82fc
PP
23
24static int
25not_here(s)
26char *s;
27{
28 croak("%s not implemented on this architecture", s);
29 return -1;
30}
31
32static bool
33constant(name, pval)
34char *name;
35IV *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
8add82fc
PP
77 break;
78 }
79
80 return FALSE;
81}
82
83
84MODULE = IO PACKAGE = IO::Seekable PREFIX = f
85
86SV *
87fgetpos(handle)
88 InputStream handle
89 CODE:
8add82fc
PP
90 if (handle) {
91 Fpos_t pos;
2a0cf753 92#ifdef PerlIO
760ac839 93 PerlIO_getpos(handle, &pos);
2a0cf753
PP
94#else
95 fgetpos(handle, &pos);
96#endif
8add82fc
PP
97 ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t)));
98 }
99 else {
100 ST(0) = &sv_undef;
101 errno = EINVAL;
102 }
8add82fc
PP
103
104SysRet
105fsetpos(handle, pos)
106 InputStream handle
107 SV * pos
108 CODE:
fefb1980
CS
109 char *p;
110 if (handle && (p = SvPVx(pos, na)) && na == sizeof(Fpos_t))
2a0cf753 111#ifdef PerlIO
fefb1980 112 RETVAL = PerlIO_setpos(handle, (Fpos_t*)p);
2a0cf753 113#else
fefb1980 114 RETVAL = fsetpos(handle, (Fpos_t*)p);
2a0cf753 115#endif
8add82fc
PP
116 else {
117 RETVAL = -1;
118 errno = EINVAL;
119 }
8add82fc
PP
120 OUTPUT:
121 RETVAL
122
123MODULE = IO PACKAGE = IO::File PREFIX = f
124
a375a877 125SV *
8add82fc
PP
126new_tmpfile(packname = "IO::File")
127 char * packname
a375a877
GB
128 PREINIT:
129 OutputStream fp;
130 GV *gv;
8add82fc 131 CODE:
2a0cf753 132#ifdef PerlIO
a375a877 133 fp = PerlIO_tmpfile();
2a0cf753 134#else
a375a877 135 fp = tmpfile();
2a0cf753 136#endif
a375a877
GB
137 gv = (GV*)SvREFCNT_inc(newGVgen(packname));
138 hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD);
139 if (do_open(gv, "+>&", 3, FALSE, 0, 0, fp)) {
6d5cdeed 140 ST(0) = sv_2mortal(newRV((SV*)gv));
a375a877 141 sv_bless(ST(0), gv_stashpv(packname, TRUE));
6d5cdeed 142 SvREFCNT_dec(gv); /* undo increment in newRV() */
a375a877
GB
143 }
144 else {
145 ST(0) = &sv_undef;
146 SvREFCNT_dec(gv);
147 }
8add82fc
PP
148
149MODULE = IO PACKAGE = IO::Handle PREFIX = f
150
151SV *
152constant(name)
153 char * name
154 CODE:
155 IV i;
156 if (constant(name, &i))
157 ST(0) = sv_2mortal(newSViv(i));
158 else
159 ST(0) = &sv_undef;
160
161int
162ungetc(handle, c)
163 InputStream handle
164 int c
165 CODE:
166 if (handle)
2a0cf753 167#ifdef PerlIO
760ac839 168 RETVAL = PerlIO_ungetc(handle, c);
2a0cf753
PP
169#else
170 RETVAL = ungetc(c, handle);
171#endif
8add82fc
PP
172 else {
173 RETVAL = -1;
174 errno = EINVAL;
175 }
176 OUTPUT:
177 RETVAL
178
179int
180ferror(handle)
181 InputStream handle
182 CODE:
183 if (handle)
2a0cf753 184#ifdef PerlIO
760ac839 185 RETVAL = PerlIO_error(handle);
2a0cf753
PP
186#else
187 RETVAL = ferror(handle);
188#endif
189 else {
190 RETVAL = -1;
191 errno = EINVAL;
192 }
193 OUTPUT:
194 RETVAL
195
196int
197clearerr(handle)
198 InputStream handle
199 CODE:
200 if (handle) {
201#ifdef PerlIO
202 PerlIO_clearerr(handle);
203#else
204 clearerr(handle);
205#endif
206 RETVAL = 0;
207 }
8add82fc
PP
208 else {
209 RETVAL = -1;
59629a13
RR
210 errno = EINVAL;
211 }
212 OUTPUT:
213 RETVAL
214
215int
216untaint(handle)
217 SV * handle
218 CODE:
7a4c00b4 219#ifdef IOf_UNTAINT
59629a13
RR
220 IO * io;
221 io = sv_2io(handle);
222 if (io) {
223 IoFLAGS(io) |= IOf_UNTAINT;
224 RETVAL = 0;
225 }
226 else {
7a4c00b4 227#endif
59629a13 228 RETVAL = -1;
8add82fc 229 errno = EINVAL;
7a4c00b4 230#ifdef IOf_UNTAINT
8add82fc 231 }
7a4c00b4 232#endif
8add82fc
PP
233 OUTPUT:
234 RETVAL
235
236SysRet
237fflush(handle)
238 OutputStream handle
239 CODE:
240 if (handle)
2a0cf753 241#ifdef PerlIO
760ac839 242 RETVAL = PerlIO_flush(handle);
2a0cf753
PP
243#else
244 RETVAL = Fflush(handle);
245#endif
8add82fc
PP
246 else {
247 RETVAL = -1;
248 errno = EINVAL;
249 }
250 OUTPUT:
251 RETVAL
252
253void
254setbuf(handle, buf)
255 OutputStream handle
256 char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), BUFSIZ) : 0;
257 CODE:
258 if (handle)
760ac839 259#ifdef PERLIO_IS_STDIO
8add82fc 260 setbuf(handle, buf);
760ac839
LW
261#else
262 not_here("IO::Handle::setbuf");
263#endif
8add82fc
PP
264
265SysRet
266setvbuf(handle, buf, type, size)
267 OutputStream handle
268 char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
269 int type
270 int size
271 CODE:
61839fa9
CS
272/* Should check HAS_SETVBUF once Configure tests for that */
273#if defined(PERLIO_IS_STDIO) && defined(_IOFBF)
8add82fc
PP
274 if (handle)
275 RETVAL = setvbuf(handle, buf, type, size);
276 else {
277 RETVAL = -1;
278 errno = EINVAL;
279 }
280#else
61839fa9 281 RETVAL = (SysRet) not_here("IO::Handle::setvbuf");
760ac839 282#endif
8add82fc
PP
283 OUTPUT:
284 RETVAL
285
286