ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/cvsroot/staticperl/perl/ext/IO/IO.xs
Revision: 1.1
Committed: Thu Jun 30 14:27:02 2005 UTC (21 years, 3 months ago) by root
Branch: MAIN
CVS Tags: PERL-5-8-7, HEAD
Branch point for: PERL
Log Message:
*** empty log message ***

File Contents

# User Rev Content
1 root 1.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
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
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     int newmode = mode;
77     #ifdef O_NONBLOCK
78     /* POSIX style */
79    
80     # ifndef O_NDELAY
81     # define O_NDELAY O_NONBLOCK
82     # endif
83     /* Note: UNICOS and UNICOS/mk a F_GETFL returns an O_NDELAY
84     * after a successful F_SETFL of an O_NONBLOCK. */
85     RETVAL = RETVAL & (O_NONBLOCK | O_NDELAY) ? 0 : 1;
86    
87     if (block == 0) {
88     newmode &= ~O_NDELAY;
89     newmode |= O_NONBLOCK;
90     } else if (block > 0) {
91     newmode &= ~(O_NDELAY|O_NONBLOCK);
92     }
93     #else
94     /* Not POSIX - better have O_NDELAY or we can't cope.
95     * for BSD-ish machines this is an acceptable alternative
96     * for SysV we can't tell "would block" from EOF but that is
97     * the way SysV is...
98     */
99     RETVAL = RETVAL & O_NDELAY ? 0 : 1;
100    
101     if (block == 0) {
102     newmode |= O_NDELAY;
103     } else if (block > 0) {
104     newmode &= ~O_NDELAY;
105     }
106     #endif
107     if (newmode != mode) {
108     int ret;
109     ret = fcntl(PerlIO_fileno(f),F_SETFL,newmode);
110     if (ret < 0)
111     RETVAL = ret;
112     }
113     }
114     return RETVAL;
115     #else
116     return -1;
117     #endif
118     }
119    
120     MODULE = IO PACKAGE = IO::Seekable PREFIX = f
121    
122     void
123     fgetpos(handle)
124     InputStream handle
125     CODE:
126     if (handle) {
127     #ifdef PerlIO
128     ST(0) = sv_2mortal(newSV(0));
129     if (PerlIO_getpos(handle, ST(0)) != 0) {
130     ST(0) = &PL_sv_undef;
131     }
132     #else
133     if (fgetpos(handle, &pos)) {
134     ST(0) = &PL_sv_undef;
135     } else {
136     ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t)));
137     }
138     #endif
139     }
140     else {
141     ST(0) = &PL_sv_undef;
142     errno = EINVAL;
143     }
144    
145     SysRet
146     fsetpos(handle, pos)
147     InputStream handle
148     SV * pos
149     CODE:
150     if (handle) {
151     #ifdef PerlIO
152     RETVAL = PerlIO_setpos(handle, pos);
153     #else
154     char *p;
155     STRLEN len;
156     if ((p = SvPV(pos,len)) && len == sizeof(Fpos_t)) {
157     RETVAL = fsetpos(handle, (Fpos_t*)p);
158     }
159     else {
160     RETVAL = -1;
161     errno = EINVAL;
162     }
163     #endif
164     }
165     else {
166     RETVAL = -1;
167     errno = EINVAL;
168     }
169     OUTPUT:
170     RETVAL
171    
172     MODULE = IO PACKAGE = IO::File PREFIX = f
173    
174     void
175     new_tmpfile(packname = "IO::File")
176     char * packname
177     PREINIT:
178     OutputStream fp;
179     GV *gv;
180     CODE:
181     #ifdef PerlIO
182     fp = PerlIO_tmpfile();
183     #else
184     fp = tmpfile();
185     #endif
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)) {
189     ST(0) = sv_2mortal(newRV((SV*)gv));
190     sv_bless(ST(0), gv_stashpv(packname, TRUE));
191     SvREFCNT_dec(gv); /* undo increment in newRV() */
192     }
193     else {
194     ST(0) = &PL_sv_undef;
195     SvREFCNT_dec(gv);
196     }
197    
198     MODULE = IO PACKAGE = IO::Poll
199    
200     void
201     _poll(timeout,...)
202     int timeout;
203     PPCODE:
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 = (short)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    
230     MODULE = IO PACKAGE = IO::Handle PREFIX = io_
231    
232     void
233     io_blocking(handle,blk=-1)
234     InputStream handle
235     int blk
236     PROTOTYPE: $;$
237     CODE:
238     {
239     int ret = io_blocking(aTHX_ handle, items == 1 ? -1 : blk ? 1 : 0);
240     if(ret >= 0)
241     XSRETURN_IV(ret);
242     else
243     XSRETURN_UNDEF;
244     }
245    
246     MODULE = IO PACKAGE = IO::Handle PREFIX = f
247    
248     int
249     ungetc(handle, c)
250     InputStream handle
251     int c
252     CODE:
253     if (handle)
254     #ifdef PerlIO
255     RETVAL = PerlIO_ungetc(handle, c);
256     #else
257     RETVAL = ungetc(c, handle);
258     #endif
259     else {
260     RETVAL = -1;
261     errno = EINVAL;
262     }
263     OUTPUT:
264     RETVAL
265    
266     int
267     ferror(handle)
268     InputStream handle
269     CODE:
270     if (handle)
271     #ifdef PerlIO
272     RETVAL = PerlIO_error(handle);
273     #else
274     RETVAL = ferror(handle);
275     #endif
276     else {
277     RETVAL = -1;
278     errno = EINVAL;
279     }
280     OUTPUT:
281     RETVAL
282    
283     int
284     clearerr(handle)
285     InputStream handle
286     CODE:
287     if (handle) {
288     #ifdef PerlIO
289     PerlIO_clearerr(handle);
290     #else
291     clearerr(handle);
292     #endif
293     RETVAL = 0;
294     }
295     else {
296     RETVAL = -1;
297     errno = EINVAL;
298     }
299     OUTPUT:
300     RETVAL
301    
302     int
303     untaint(handle)
304     SV * handle
305     CODE:
306     #ifdef IOf_UNTAINT
307     IO * io;
308     io = sv_2io(handle);
309     if (io) {
310     IoFLAGS(io) |= IOf_UNTAINT;
311     RETVAL = 0;
312     }
313     else {
314     #endif
315     RETVAL = -1;
316     errno = EINVAL;
317     #ifdef IOf_UNTAINT
318     }
319     #endif
320     OUTPUT:
321     RETVAL
322    
323     SysRet
324     fflush(handle)
325     OutputStream handle
326     CODE:
327     if (handle)
328     #ifdef PerlIO
329     RETVAL = PerlIO_flush(handle);
330     #else
331     RETVAL = Fflush(handle);
332     #endif
333     else {
334     RETVAL = -1;
335     errno = EINVAL;
336     }
337     OUTPUT:
338     RETVAL
339    
340     void
341     setbuf(handle, ...)
342     OutputStream handle
343     CODE:
344     if (handle)
345     #ifdef PERLIO_IS_STDIO
346     {
347     char *buf = items == 2 && SvPOK(ST(1)) ?
348     sv_grow(ST(1), BUFSIZ) : 0;
349     setbuf(handle, buf);
350     }
351     #else
352     not_here("IO::Handle::setbuf");
353     #endif
354    
355     SysRet
356     setvbuf(...)
357     CODE:
358     if (items != 4)
359     Perl_croak(aTHX_ "Usage: IO::Handle::setvbuf(handle, buf, type, size)");
360     #if defined(PERLIO_IS_STDIO) && defined(_IOFBF) && defined(HAS_SETVBUF)
361     {
362     OutputStream handle = 0;
363     char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
364     int type;
365     int size;
366    
367     if (items == 4) {
368     handle = IoOFP(sv_2io(ST(0)));
369     buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
370     type = (int)SvIV(ST(2));
371     size = (int)SvIV(ST(3));
372     }
373     if (!handle) /* Try input stream. */
374     handle = IoIFP(sv_2io(ST(0)));
375     if (items == 4 && handle)
376     RETVAL = setvbuf(handle, buf, type, size);
377     else {
378     RETVAL = -1;
379     errno = EINVAL;
380     }
381     }
382     #else
383     RETVAL = (SysRet) not_here("IO::Handle::setvbuf");
384     #endif
385     OUTPUT:
386     RETVAL
387    
388    
389     SysRet
390     fsync(handle)
391     OutputStream handle
392     CODE:
393     #ifdef HAS_FSYNC
394     if(handle)
395     RETVAL = fsync(PerlIO_fileno(handle));
396     else {
397     RETVAL = -1;
398     errno = EINVAL;
399     }
400     #else
401     RETVAL = (SysRet) not_here("IO::Handle::sync");
402     #endif
403     OUTPUT:
404     RETVAL
405    
406    
407     MODULE = IO PACKAGE = IO::Socket
408    
409     SysRet
410     sockatmark (sock)
411     InputStream sock
412     PROTOTYPE: $
413     PREINIT:
414     int fd;
415     CODE:
416     {
417     fd = PerlIO_fileno(sock);
418     #ifdef HAS_SOCKATMARK
419     RETVAL = sockatmark(fd);
420     #else
421     {
422     int flag = 0;
423     # ifdef SIOCATMARK
424     # if defined(NETWARE) || defined(WIN32)
425     if (ioctl(fd, SIOCATMARK, (void*)&flag) != 0)
426     # else
427     if (ioctl(fd, SIOCATMARK, &flag) != 0)
428     # endif
429     XSRETURN_UNDEF;
430     # else
431     not_here("IO::Socket::atmark");
432     # endif
433     RETVAL = flag;
434     }
435     #endif
436     }
437     OUTPUT:
438     RETVAL
439    
440     BOOT:
441     {
442     HV *stash;
443     /*
444     * constant subs for IO::Poll
445     */
446     stash = gv_stashpvn("IO::Poll", 8, TRUE);
447     #ifdef POLLIN
448     newCONSTSUB(stash,"POLLIN",newSViv(POLLIN));
449     #endif
450     #ifdef POLLPRI
451     newCONSTSUB(stash,"POLLPRI", newSViv(POLLPRI));
452     #endif
453     #ifdef POLLOUT
454     newCONSTSUB(stash,"POLLOUT", newSViv(POLLOUT));
455     #endif
456     #ifdef POLLRDNORM
457     newCONSTSUB(stash,"POLLRDNORM", newSViv(POLLRDNORM));
458     #endif
459     #ifdef POLLWRNORM
460     newCONSTSUB(stash,"POLLWRNORM", newSViv(POLLWRNORM));
461     #endif
462     #ifdef POLLRDBAND
463     newCONSTSUB(stash,"POLLRDBAND", newSViv(POLLRDBAND));
464     #endif
465     #ifdef POLLWRBAND
466     newCONSTSUB(stash,"POLLWRBAND", newSViv(POLLWRBAND));
467     #endif
468     #ifdef POLLNORM
469     newCONSTSUB(stash,"POLLNORM", newSViv(POLLNORM));
470     #endif
471     #ifdef POLLERR
472     newCONSTSUB(stash,"POLLERR", newSViv(POLLERR));
473     #endif
474     #ifdef POLLHUP
475     newCONSTSUB(stash,"POLLHUP", newSViv(POLLHUP));
476     #endif
477     #ifdef POLLNVAL
478     newCONSTSUB(stash,"POLLNVAL", newSViv(POLLNVAL));
479     #endif
480     /*
481     * constant subs for IO::Handle
482     */
483     stash = gv_stashpvn("IO::Handle", 10, TRUE);
484     #ifdef _IOFBF
485     newCONSTSUB(stash,"_IOFBF", newSViv(_IOFBF));
486     #endif
487     #ifdef _IOLBF
488     newCONSTSUB(stash,"_IOLBF", newSViv(_IOLBF));
489     #endif
490     #ifdef _IONBF
491     newCONSTSUB(stash,"_IONBF", newSViv(_IONBF));
492     #endif
493     #ifdef SEEK_SET
494     newCONSTSUB(stash,"SEEK_SET", newSViv(SEEK_SET));
495     #endif
496     #ifdef SEEK_CUR
497     newCONSTSUB(stash,"SEEK_CUR", newSViv(SEEK_CUR));
498     #endif
499     #ifdef SEEK_END
500     newCONSTSUB(stash,"SEEK_END", newSViv(SEEK_END));
501     #endif
502     }
503