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