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