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
7 #define PERL_EXT_IO
8
9 #define PERL_NO_GET_CONTEXT
10 #include "EXTERN.h"
11 #define PERLIO_NOT_STDIO 1
12 #include "perl.h"
13 #include "XSUB.h"
14 #include "poll.h"
15 #ifdef I_UNISTD
16 # include <unistd.h>
17 #endif
18 #if defined(I_FCNTL) || defined(HAS_FCNTL)
19 # include <fcntl.h>
20 #endif
21
22 #ifndef SIOCATMARK
23 # ifdef I_SYS_SOCKIO
24 # include <sys/sockio.h>
25 # endif
26 #endif
27
28 #ifdef PerlIO
29 #if defined(MACOS_TRADITIONAL) && defined(USE_SFIO)
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
36 typedef int SysRet;
37 typedef PerlIO * InputStream;
38 typedef PerlIO * OutputStream;
39 #else
40 #define PERLIO_IS_STDIO 1
41 typedef int SysRet;
42 typedef FILE * InputStream;
43 typedef FILE * OutputStream;
44 #endif
45
46 #define MY_start_subparse(fmt,flags) start_subparse(fmt,flags)
47
48 #ifndef gv_stashpvn
49 #define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
50 #endif
51
52 static int
not_here(char * s)53 not_here(char *s)
54 {
55 croak("%s not implemented on this architecture", s);
56 return -1;
57 }
58
59
60 #ifndef PerlIO
61 #define PerlIO_fileno(f) fileno(f)
62 #endif
63
64 static int
io_blocking(pTHX_ InputStream f,int block)65 io_blocking(pTHX_ InputStream f, int block)
66 {
67 #if defined(HAS_FCNTL)
68 int RETVAL;
69 if(!f) {
70 errno = EBADF;
71 return -1;
72 }
73 RETVAL = fcntl(PerlIO_fileno(f), F_GETFL, 0);
74 if (RETVAL >= 0) {
75 int mode = RETVAL;
76 #ifdef O_NONBLOCK
77 /* POSIX style */
78 #if defined(O_NDELAY) && O_NDELAY != O_NONBLOCK
79 /* Ooops has O_NDELAY too - make sure we don't
80 * get SysV behaviour by mistake. */
81
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 }
102 }
103 #else
104 /* Standard POSIX */
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 }
121 #endif
122 #else
123 /* Not POSIX - better have O_NDELAY or we can't cope.
124 * for BSD-ish machines this is an acceptable alternative
125 * for SysV we can't tell "would block" from EOF but that is
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 }
144 #endif
145 }
146 return RETVAL;
147 #else
148 return -1;
149 #endif
150 }
151
152 MODULE = IO PACKAGE = IO::Seekable PREFIX = f
153
154 void
155 fgetpos(handle)
156 InputStream handle
157 CODE:
158 if (handle) {
159 #ifdef PerlIO
160 ST(0) = sv_2mortal(newSV(0));
161 if (PerlIO_getpos(handle, ST(0)) != 0) {
162 ST(0) = &PL_sv_undef;
163 }
164 #else
165 if (fgetpos(handle, &pos)) {
166 ST(0) = &PL_sv_undef;
167 } else {
168 ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t)));
169 }
170 #endif
171 }
172 else {
173 ST(0) = &PL_sv_undef;
174 errno = EINVAL;
175 }
176
177 SysRet
178 fsetpos(handle, pos)
179 InputStream handle
180 SV * pos
181 CODE:
182 if (handle) {
183 #ifdef PerlIO
184 RETVAL = PerlIO_setpos(handle, pos);
185 #else
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 }
195 #endif
196 }
197 else {
198 RETVAL = -1;
199 errno = EINVAL;
200 }
201 OUTPUT:
202 RETVAL
203
204 MODULE = IO PACKAGE = IO::File PREFIX = f
205
206 void
207 new_tmpfile(packname = "IO::File")
208 char * packname
209 PREINIT:
210 OutputStream fp;
211 GV *gv;
212 CODE:
213 #ifdef PerlIO
214 fp = PerlIO_tmpfile();
215 #else
216 fp = tmpfile();
217 #endif
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)) {
221 ST(0) = sv_2mortal(newRV((SV*)gv));
222 sv_bless(ST(0), gv_stashpv(packname, TRUE));
223 SvREFCNT_dec(gv); /* undo increment in newRV() */
224 }
225 else {
226 ST(0) = &PL_sv_undef;
227 SvREFCNT_dec(gv);
228 }
229
230 MODULE = IO PACKAGE = IO::Poll
231
232 void
_poll(timeout,...)233 _poll(timeout,...)
234 int timeout;
235 PPCODE:
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 = (short)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
262 MODULE = IO PACKAGE = IO::Handle PREFIX = io_
263
264 void
265 io_blocking(handle,blk=-1)
266 InputStream handle
267 int blk
268 PROTOTYPE: $;$
269 CODE:
270 {
271 int ret = io_blocking(aTHX_ handle, items == 1 ? -1 : blk ? 1 : 0);
272 if(ret >= 0)
273 XSRETURN_IV(ret);
274 else
275 XSRETURN_UNDEF;
276 }
277
278 MODULE = IO PACKAGE = IO::Handle PREFIX = f
279
280 int
281 ungetc(handle, c)
282 InputStream handle
283 int c
284 CODE:
285 if (handle)
286 #ifdef PerlIO
287 RETVAL = PerlIO_ungetc(handle, c);
288 #else
289 RETVAL = ungetc(c, handle);
290 #endif
291 else {
292 RETVAL = -1;
293 errno = EINVAL;
294 }
295 OUTPUT:
296 RETVAL
297
298 int
299 ferror(handle)
300 InputStream handle
301 CODE:
302 if (handle)
303 #ifdef PerlIO
304 RETVAL = PerlIO_error(handle);
305 #else
306 RETVAL = ferror(handle);
307 #endif
308 else {
309 RETVAL = -1;
310 errno = EINVAL;
311 }
312 OUTPUT:
313 RETVAL
314
315 int
316 clearerr(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 }
327 else {
328 RETVAL = -1;
329 errno = EINVAL;
330 }
331 OUTPUT:
332 RETVAL
333
334 int
335 untaint(handle)
336 SV * handle
337 CODE:
338 #ifdef IOf_UNTAINT
339 IO * io;
340 io = sv_2io(handle);
341 if (io) {
342 IoFLAGS(io) |= IOf_UNTAINT;
343 RETVAL = 0;
344 }
345 else {
346 #endif
347 RETVAL = -1;
348 errno = EINVAL;
349 #ifdef IOf_UNTAINT
350 }
351 #endif
352 OUTPUT:
353 RETVAL
354
355 SysRet
356 fflush(handle)
357 OutputStream handle
358 CODE:
359 if (handle)
360 #ifdef PerlIO
361 RETVAL = PerlIO_flush(handle);
362 #else
363 RETVAL = Fflush(handle);
364 #endif
365 else {
366 RETVAL = -1;
367 errno = EINVAL;
368 }
369 OUTPUT:
370 RETVAL
371
372 void
373 setbuf(handle, ...)
374 OutputStream handle
375 CODE:
376 if (handle)
377 #ifdef PERLIO_IS_STDIO
378 {
379 char *buf = items == 2 && SvPOK(ST(1)) ?
380 sv_grow(ST(1), BUFSIZ) : 0;
381 setbuf(handle, buf);
382 }
383 #else
384 not_here("IO::Handle::setbuf");
385 #endif
386
387 SysRet
388 setvbuf(...)
389 CODE:
390 if (items != 4)
391 Perl_croak(aTHX_ "Usage: IO::Handle::setvbuf(handle, buf, type, size)");
392 #if defined(PERLIO_IS_STDIO) && defined(_IOFBF) && defined(HAS_SETVBUF)
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 }
405 if (!handle) /* Try input stream. */
406 handle = IoIFP(sv_2io(ST(0)));
407 if (items == 4 && handle)
408 RETVAL = setvbuf(handle, buf, type, size);
409 else {
410 RETVAL = -1;
411 errno = EINVAL;
412 }
413 }
414 #else
415 RETVAL = (SysRet) not_here("IO::Handle::setvbuf");
416 #endif
417 OUTPUT:
418 RETVAL
419
420
421 SysRet
422 fsync(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
439 MODULE = IO PACKAGE = IO::Socket
440
441 SysRet
sockatmark(sock)442 sockatmark (sock)
443 InputStream sock
444 PROTOTYPE: $
445 PREINIT:
446 int fd;
447 CODE:
448 {
449 fd = PerlIO_fileno(sock);
450 #ifdef HAS_SOCKATMARK
451 RETVAL = sockatmark(fd);
452 #else
453 {
454 int flag = 0;
455 # ifdef SIOCATMARK
456 # if defined(NETWARE) || defined(WIN32)
457 if (ioctl(fd, SIOCATMARK, (void*)&flag) != 0)
458 # else
459 if (ioctl(fd, SIOCATMARK, &flag) != 0)
460 # endif
461 XSRETURN_UNDEF;
462 # else
463 not_here("IO::Socket::atmark");
464 # endif
465 RETVAL = flag;
466 }
467 #endif
468 }
469 OUTPUT:
470 RETVAL
471
472 BOOT:
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
534 }
535
536