Commit | Line | Data |
8add82fc |
1 | #include "EXTERN.h" |
760ac839 |
2 | #define PERLIO_NOT_STDIO 1 |
8add82fc |
3 | #include "perl.h" |
4 | #include "XSUB.h" |
760ac839 |
5 | |
8add82fc |
6 | #ifdef I_UNISTD |
7 | # include <unistd.h> |
8 | #endif |
760ac839 |
9 | #ifdef I_FCNTL |
cd661bb6 |
10 | #if defined(__GNUC__) && defined(__cplusplus) && defined(WIN32) |
11 | #define _NO_OLDNAMES |
12 | #endif |
760ac839 |
13 | # include <fcntl.h> |
cd661bb6 |
14 | #if defined(__GNUC__) && defined(__cplusplus) && defined(WIN32) |
15 | #undef _NO_OLDNAMES |
16 | #endif |
17 | |
760ac839 |
18 | #endif |
8add82fc |
19 | |
2a0cf753 |
20 | #ifdef PerlIO |
8add82fc |
21 | typedef int SysRet; |
760ac839 |
22 | typedef PerlIO * InputStream; |
23 | typedef PerlIO * OutputStream; |
2a0cf753 |
24 | #else |
25 | #define PERLIO_IS_STDIO 1 |
26 | typedef int SysRet; |
27 | typedef FILE * InputStream; |
28 | typedef FILE * OutputStream; |
29 | #endif |
8add82fc |
30 | |
31 | static int |
f0f333f4 |
32 | not_here(char *s) |
8add82fc |
33 | { |
34 | croak("%s not implemented on this architecture", s); |
35 | return -1; |
36 | } |
37 | |
38 | static bool |
f0f333f4 |
39 | constant(char *name, IV *pval) |
8add82fc |
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 |
8add82fc |
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: |
8add82fc |
94 | if (handle) { |
95 | Fpos_t pos; |
2a0cf753 |
96 | #ifdef PerlIO |
760ac839 |
97 | PerlIO_getpos(handle, &pos); |
2a0cf753 |
98 | #else |
99 | fgetpos(handle, &pos); |
100 | #endif |
8add82fc |
101 | ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t))); |
102 | } |
103 | else { |
6b88bc9c |
104 | ST(0) = &PL_sv_undef; |
8add82fc |
105 | errno = EINVAL; |
106 | } |
8add82fc |
107 | |
108 | SysRet |
109 | fsetpos(handle, pos) |
110 | InputStream handle |
111 | SV * pos |
112 | CODE: |
fefb1980 |
113 | char *p; |
6b88bc9c |
114 | if (handle && (p = SvPVx(pos, PL_na)) && PL_na == sizeof(Fpos_t)) |
2a0cf753 |
115 | #ifdef PerlIO |
fefb1980 |
116 | RETVAL = PerlIO_setpos(handle, (Fpos_t*)p); |
2a0cf753 |
117 | #else |
fefb1980 |
118 | RETVAL = fsetpos(handle, (Fpos_t*)p); |
2a0cf753 |
119 | #endif |
8add82fc |
120 | else { |
121 | RETVAL = -1; |
122 | errno = EINVAL; |
123 | } |
8add82fc |
124 | OUTPUT: |
125 | RETVAL |
126 | |
127 | MODULE = IO PACKAGE = IO::File PREFIX = f |
128 | |
a375a877 |
129 | SV * |
8add82fc |
130 | new_tmpfile(packname = "IO::File") |
131 | char * packname |
a375a877 |
132 | PREINIT: |
133 | OutputStream fp; |
134 | GV *gv; |
8add82fc |
135 | CODE: |
2a0cf753 |
136 | #ifdef PerlIO |
a375a877 |
137 | fp = PerlIO_tmpfile(); |
2a0cf753 |
138 | #else |
a375a877 |
139 | fp = tmpfile(); |
2a0cf753 |
140 | #endif |
a375a877 |
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)) { |
6d5cdeed |
144 | ST(0) = sv_2mortal(newRV((SV*)gv)); |
a375a877 |
145 | sv_bless(ST(0), gv_stashpv(packname, TRUE)); |
6d5cdeed |
146 | SvREFCNT_dec(gv); /* undo increment in newRV() */ |
a375a877 |
147 | } |
148 | else { |
6b88bc9c |
149 | ST(0) = &PL_sv_undef; |
a375a877 |
150 | SvREFCNT_dec(gv); |
151 | } |
8add82fc |
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 |
6b88bc9c |
163 | ST(0) = &PL_sv_undef; |
8add82fc |
164 | |
165 | int |
166 | ungetc(handle, c) |
167 | InputStream handle |
168 | int c |
169 | CODE: |
170 | if (handle) |
2a0cf753 |
171 | #ifdef PerlIO |
760ac839 |
172 | RETVAL = PerlIO_ungetc(handle, c); |
2a0cf753 |
173 | #else |
174 | RETVAL = ungetc(c, handle); |
175 | #endif |
8add82fc |
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) |
2a0cf753 |
188 | #ifdef PerlIO |
760ac839 |
189 | RETVAL = PerlIO_error(handle); |
2a0cf753 |
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 | } |
8add82fc |
212 | else { |
213 | RETVAL = -1; |
59629a13 |
214 | errno = EINVAL; |
215 | } |
216 | OUTPUT: |
217 | RETVAL |
218 | |
219 | int |
220 | untaint(handle) |
221 | SV * handle |
222 | CODE: |
7a4c00b4 |
223 | #ifdef IOf_UNTAINT |
59629a13 |
224 | IO * io; |
225 | io = sv_2io(handle); |
226 | if (io) { |
227 | IoFLAGS(io) |= IOf_UNTAINT; |
228 | RETVAL = 0; |
229 | } |
230 | else { |
7a4c00b4 |
231 | #endif |
59629a13 |
232 | RETVAL = -1; |
8add82fc |
233 | errno = EINVAL; |
7a4c00b4 |
234 | #ifdef IOf_UNTAINT |
8add82fc |
235 | } |
7a4c00b4 |
236 | #endif |
8add82fc |
237 | OUTPUT: |
238 | RETVAL |
239 | |
240 | SysRet |
241 | fflush(handle) |
242 | OutputStream handle |
243 | CODE: |
244 | if (handle) |
2a0cf753 |
245 | #ifdef PerlIO |
760ac839 |
246 | RETVAL = PerlIO_flush(handle); |
2a0cf753 |
247 | #else |
248 | RETVAL = Fflush(handle); |
249 | #endif |
8add82fc |
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) |
760ac839 |
263 | #ifdef PERLIO_IS_STDIO |
8add82fc |
264 | setbuf(handle, buf); |
760ac839 |
265 | #else |
266 | not_here("IO::Handle::setbuf"); |
267 | #endif |
8add82fc |
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: |
61839fa9 |
276 | /* Should check HAS_SETVBUF once Configure tests for that */ |
277 | #if defined(PERLIO_IS_STDIO) && defined(_IOFBF) |
d924de76 |
278 | if (!handle) /* Try input stream. */ |
279 | handle = IoIFP(sv_2io(ST(0))); |
8add82fc |
280 | if (handle) |
281 | RETVAL = setvbuf(handle, buf, type, size); |
282 | else { |
283 | RETVAL = -1; |
284 | errno = EINVAL; |
285 | } |
286 | #else |
61839fa9 |
287 | RETVAL = (SysRet) not_here("IO::Handle::setvbuf"); |
760ac839 |
288 | #endif |
8add82fc |
289 | OUTPUT: |
290 | RETVAL |
291 | |
292 | |