integrate mainline changes
[p5sagit/p5-mst-13.2.git] / ext / IO / IO.xs
CommitLineData
cf7fe8a2 1/*
2 * Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
3 * This program is free software; you can redistribute it and/or
4 * modify it under the same terms as Perl itself.
5 */
6
c5be433b 7#define PERL_NO_GET_CONTEXT
8add82fc 8#include "EXTERN.h"
760ac839 9#define PERLIO_NOT_STDIO 1
8add82fc 10#include "perl.h"
11#include "XSUB.h"
cf7fe8a2 12#include "poll.h"
8add82fc 13#ifdef I_UNISTD
14# include <unistd.h>
15#endif
cf7fe8a2 16#if defined(I_FCNTL) || defined(HAS_FCNTL)
760ac839 17# include <fcntl.h>
18#endif
8add82fc 19
2a0cf753 20#ifdef PerlIO
8add82fc 21typedef int SysRet;
760ac839 22typedef PerlIO * InputStream;
23typedef PerlIO * OutputStream;
2a0cf753 24#else
25#define PERLIO_IS_STDIO 1
26typedef int SysRet;
27typedef FILE * InputStream;
28typedef FILE * OutputStream;
29#endif
8add82fc 30
cceca5ed 31#define MY_start_subparse(fmt,flags) start_subparse(fmt,flags)
cf7fe8a2 32
33#ifndef gv_stashpvn
34#define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
35#endif
36
8add82fc 37static int
a1ea39dc 38not_here(char *s)
8add82fc 39{
40 croak("%s not implemented on this architecture", s);
41 return -1;
42}
43
cf7fe8a2 44
45#ifndef PerlIO
46#define PerlIO_fileno(f) fileno(f)
8add82fc 47#endif
cf7fe8a2 48
49static int
a1ea39dc 50io_blocking(InputStream f, int block)
cf7fe8a2 51{
52 int RETVAL;
53 if(!f) {
54 errno = EBADF;
55 return -1;
56 }
57#if defined(HAS_FCNTL)
58 RETVAL = fcntl(PerlIO_fileno(f), F_GETFL, 0);
59 if (RETVAL >= 0) {
60 int mode = RETVAL;
61#ifdef O_NONBLOCK
62 /* POSIX style */
63#if defined(O_NDELAY) && O_NDELAY != O_NONBLOCK
64 /* Ooops has O_NDELAY too - make sure we don't
65 * get SysV behaviour by mistake
66 */
67 RETVAL = RETVAL & O_NONBLOCK ? 0 : 1;
68
69 if ((mode & O_NDELAY) || ((block == 0) && !(mode & O_NONBLOCK))) {
70 int ret;
71 mode = (mode & ~O_NDELAY) | O_NONBLOCK;
72 ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
73 if(ret < 0)
74 RETVAL = ret;
75 }
76 else if ((mode & O_NDELAY) || ((block > 0) && (mode & O_NONBLOCK))) {
77 int ret;
78 mode &= ~(O_NONBLOCK | O_NDELAY);
79 ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
80 if(ret < 0)
81 RETVAL = ret;
82 }
8add82fc 83#else
cf7fe8a2 84 /* Standard POSIX */
85 RETVAL = RETVAL & O_NONBLOCK ? 0 : 1;
86
87 if ((block == 0) && !(mode & O_NONBLOCK)) {
88 int ret;
89 mode |= O_NONBLOCK;
90 ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
91 if(ret < 0)
92 RETVAL = ret;
93 }
94 else if ((block > 0) && (mode & O_NONBLOCK)) {
95 int ret;
96 mode &= ~O_NONBLOCK;
97 ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
98 if(ret < 0)
99 RETVAL = ret;
100 }
101#endif
8add82fc 102#else
cf7fe8a2 103 /* Not POSIX - better have O_NDELAY or we can't cope.
104 * for BSD-ish machines this is an acceptable alternative
105 * for SysV we can't tell "would block" from EOF but that is
106 * the way SysV is...
107 */
108 RETVAL = RETVAL & O_NDELAY ? 0 : 1;
109
110 if ((block == 0) && !(mode & O_NDELAY)) {
111 int ret;
112 mode |= O_NDELAY;
113 ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
114 if(ret < 0)
115 RETVAL = ret;
116 }
117 else if ((block > 0) && (mode & O_NDELAY)) {
118 int ret;
119 mode &= ~O_NDELAY;
120 ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
121 if(ret < 0)
122 RETVAL = ret;
123 }
8add82fc 124#endif
cf7fe8a2 125 }
126 return RETVAL;
8add82fc 127#else
cf7fe8a2 128 return -1;
8add82fc 129#endif
8add82fc 130}
131
8add82fc 132MODULE = IO PACKAGE = IO::Seekable PREFIX = f
133
134SV *
135fgetpos(handle)
136 InputStream handle
137 CODE:
8add82fc 138 if (handle) {
139 Fpos_t pos;
2a0cf753 140#ifdef PerlIO
760ac839 141 PerlIO_getpos(handle, &pos);
2a0cf753 142#else
143 fgetpos(handle, &pos);
144#endif
8add82fc 145 ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t)));
146 }
147 else {
a1ea39dc 148 ST(0) = &PL_sv_undef;
8add82fc 149 errno = EINVAL;
150 }
8add82fc 151
152SysRet
153fsetpos(handle, pos)
154 InputStream handle
155 SV * pos
156 CODE:
a1ea39dc 157 char *p;
158 STRLEN len;
159 if (handle && (p = SvPV(pos,len)) && len == sizeof(Fpos_t))
2a0cf753 160#ifdef PerlIO
a1ea39dc 161 RETVAL = PerlIO_setpos(handle, (Fpos_t*)p);
2a0cf753 162#else
a1ea39dc 163 RETVAL = fsetpos(handle, (Fpos_t*)p);
2a0cf753 164#endif
8add82fc 165 else {
166 RETVAL = -1;
167 errno = EINVAL;
168 }
8add82fc 169 OUTPUT:
170 RETVAL
171
172MODULE = IO PACKAGE = IO::File PREFIX = f
173
a375a877 174SV *
8add82fc 175new_tmpfile(packname = "IO::File")
176 char * packname
a375a877 177 PREINIT:
178 OutputStream fp;
179 GV *gv;
8add82fc 180 CODE:
2a0cf753 181#ifdef PerlIO
a375a877 182 fp = PerlIO_tmpfile();
2a0cf753 183#else
a375a877 184 fp = tmpfile();
2a0cf753 185#endif
a375a877 186 gv = (GV*)SvREFCNT_inc(newGVgen(packname));
187 hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD);
188 if (do_open(gv, "+>&", 3, FALSE, 0, 0, fp)) {
6d5cdeed 189 ST(0) = sv_2mortal(newRV((SV*)gv));
a375a877 190 sv_bless(ST(0), gv_stashpv(packname, TRUE));
cf7fe8a2 191 SvREFCNT_dec(gv); /* undo increment in newRV() */
a375a877 192 }
193 else {
a1ea39dc 194 ST(0) = &PL_sv_undef;
a375a877 195 SvREFCNT_dec(gv);
196 }
8add82fc 197
cf7fe8a2 198MODULE = IO PACKAGE = IO::Poll
199
200void
201_poll(timeout,...)
202 int timeout;
203PPCODE:
204{
205#ifdef HAS_POLL
206 int nfd = (items - 1) / 2;
207 SV *tmpsv = NEWSV(999,nfd * sizeof(struct pollfd));
208 struct pollfd *fds = (struct pollfd *)SvPVX(tmpsv);
209 int i,j,ret;
210 for(i=1, j=0 ; j < nfd ; j++) {
211 fds[j].fd = SvIV(ST(i));
212 i++;
213 fds[j].events = SvIV(ST(i));
214 i++;
215 fds[j].revents = 0;
216 }
217 if((ret = poll(fds,nfd,timeout)) >= 0) {
218 for(i=1, j=0 ; j < nfd ; j++) {
219 sv_setiv(ST(i), fds[j].fd); i++;
220 sv_setiv(ST(i), fds[j].revents); i++;
221 }
222 }
223 SvREFCNT_dec(tmpsv);
224 XSRETURN_IV(ret);
225#else
226 not_here("IO::Poll::poll");
227#endif
228}
229
230MODULE = IO PACKAGE = IO::Handle PREFIX = io_
231
232void
233io_blocking(handle,blk=-1)
234 InputStream handle
235 int blk
236PROTOTYPE: $;$
237CODE:
238{
239 int ret = io_blocking(handle, items == 1 ? -1 : blk ? 1 : 0);
240 if(ret >= 0)
241 XSRETURN_IV(ret);
242 else
243 XSRETURN_UNDEF;
244}
245
8add82fc 246MODULE = IO PACKAGE = IO::Handle PREFIX = f
247
8add82fc 248
249int
250ungetc(handle, c)
251 InputStream handle
252 int c
253 CODE:
254 if (handle)
2a0cf753 255#ifdef PerlIO
760ac839 256 RETVAL = PerlIO_ungetc(handle, c);
2a0cf753 257#else
258 RETVAL = ungetc(c, handle);
259#endif
8add82fc 260 else {
261 RETVAL = -1;
262 errno = EINVAL;
263 }
264 OUTPUT:
265 RETVAL
266
267int
268ferror(handle)
269 InputStream handle
270 CODE:
271 if (handle)
2a0cf753 272#ifdef PerlIO
760ac839 273 RETVAL = PerlIO_error(handle);
2a0cf753 274#else
275 RETVAL = ferror(handle);
276#endif
277 else {
278 RETVAL = -1;
279 errno = EINVAL;
280 }
281 OUTPUT:
282 RETVAL
283
284int
285clearerr(handle)
286 InputStream handle
287 CODE:
288 if (handle) {
289#ifdef PerlIO
290 PerlIO_clearerr(handle);
291#else
292 clearerr(handle);
293#endif
294 RETVAL = 0;
295 }
8add82fc 296 else {
297 RETVAL = -1;
59629a13 298 errno = EINVAL;
299 }
300 OUTPUT:
301 RETVAL
302
303int
304untaint(handle)
305 SV * handle
306 CODE:
7a4c00b4 307#ifdef IOf_UNTAINT
59629a13 308 IO * io;
309 io = sv_2io(handle);
310 if (io) {
311 IoFLAGS(io) |= IOf_UNTAINT;
312 RETVAL = 0;
313 }
314 else {
7a4c00b4 315#endif
59629a13 316 RETVAL = -1;
8add82fc 317 errno = EINVAL;
7a4c00b4 318#ifdef IOf_UNTAINT
8add82fc 319 }
7a4c00b4 320#endif
8add82fc 321 OUTPUT:
322 RETVAL
323
324SysRet
325fflush(handle)
326 OutputStream handle
327 CODE:
328 if (handle)
2a0cf753 329#ifdef PerlIO
760ac839 330 RETVAL = PerlIO_flush(handle);
2a0cf753 331#else
332 RETVAL = Fflush(handle);
333#endif
8add82fc 334 else {
335 RETVAL = -1;
336 errno = EINVAL;
337 }
338 OUTPUT:
339 RETVAL
340
341void
342setbuf(handle, buf)
343 OutputStream handle
344 char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), BUFSIZ) : 0;
345 CODE:
346 if (handle)
760ac839 347#ifdef PERLIO_IS_STDIO
8add82fc 348 setbuf(handle, buf);
760ac839 349#else
350 not_here("IO::Handle::setbuf");
351#endif
8add82fc 352
353SysRet
354setvbuf(handle, buf, type, size)
355 OutputStream handle
356 char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
357 int type
358 int size
359 CODE:
1d7c1841 360#if defined(PERLIO_IS_STDIO) && defined(_IOFBF) && defined(HAS_SETVBUF)
d924de76 361 if (!handle) /* Try input stream. */
362 handle = IoIFP(sv_2io(ST(0)));
8add82fc 363 if (handle)
364 RETVAL = setvbuf(handle, buf, type, size);
365 else {
366 RETVAL = -1;
367 errno = EINVAL;
368 }
369#else
61839fa9 370 RETVAL = (SysRet) not_here("IO::Handle::setvbuf");
760ac839 371#endif
8add82fc 372 OUTPUT:
373 RETVAL
374
375
cf7fe8a2 376SysRet
377fsync(handle)
378 OutputStream handle
379 CODE:
380#ifdef HAS_FSYNC
381 if(handle)
382 RETVAL = fsync(PerlIO_fileno(handle));
383 else {
384 RETVAL = -1;
385 errno = EINVAL;
386 }
387#else
388 RETVAL = (SysRet) not_here("IO::Handle::sync");
389#endif
390 OUTPUT:
391 RETVAL
392
393
394BOOT:
395{
396 HV *stash;
397 /*
398 * constant subs for IO::Poll
399 */
400 stash = gv_stashpvn("IO::Poll", 8, TRUE);
401#ifdef POLLIN
402 newCONSTSUB(stash,"POLLIN",newSViv(POLLIN));
403#endif
404#ifdef POLLPRI
405 newCONSTSUB(stash,"POLLPRI", newSViv(POLLPRI));
406#endif
407#ifdef POLLOUT
408 newCONSTSUB(stash,"POLLOUT", newSViv(POLLOUT));
409#endif
410#ifdef POLLRDNORM
411 newCONSTSUB(stash,"POLLRDNORM", newSViv(POLLRDNORM));
412#endif
413#ifdef POLLWRNORM
414 newCONSTSUB(stash,"POLLWRNORM", newSViv(POLLWRNORM));
415#endif
416#ifdef POLLRDBAND
417 newCONSTSUB(stash,"POLLRDBAND", newSViv(POLLRDBAND));
418#endif
419#ifdef POLLWRBAND
420 newCONSTSUB(stash,"POLLWRBAND", newSViv(POLLWRBAND));
421#endif
422#ifdef POLLNORM
423 newCONSTSUB(stash,"POLLNORM", newSViv(POLLNORM));
424#endif
425#ifdef POLLERR
426 newCONSTSUB(stash,"POLLERR", newSViv(POLLERR));
427#endif
428#ifdef POLLHUP
429 newCONSTSUB(stash,"POLLHUP", newSViv(POLLHUP));
430#endif
431#ifdef POLLNVAL
432 newCONSTSUB(stash,"POLLNVAL", newSViv(POLLNVAL));
433#endif
434 /*
435 * constant subs for IO::Handle
436 */
437 stash = gv_stashpvn("IO::Handle", 10, TRUE);
438#ifdef _IOFBF
439 newCONSTSUB(stash,"_IOFBF", newSViv(_IOFBF));
440#endif
441#ifdef _IOLBF
442 newCONSTSUB(stash,"_IOLBF", newSViv(_IOLBF));
443#endif
444#ifdef _IONBF
445 newCONSTSUB(stash,"_IONBF", newSViv(_IONBF));
446#endif
447#ifdef SEEK_SET
448 newCONSTSUB(stash,"SEEK_SET", newSViv(SEEK_SET));
449#endif
450#ifdef SEEK_CUR
451 newCONSTSUB(stash,"SEEK_CUR", newSViv(SEEK_CUR));
452#endif
453#ifdef SEEK_END
454 newCONSTSUB(stash,"SEEK_END", newSViv(SEEK_END));
455#endif
456 /*
457 * constant subs for IO
458 */
459 stash = gv_stashpvn("IO", 2, TRUE);
460#ifdef EINPROGRESS
461 newCONSTSUB(stash,"EINPROGRESS", newSViv(EINPROGRESS));
462#endif
463}