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