This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
e081c17f505bede7af6b5ed1d7d9f26ed9317a0f
[perl5.git] / ext / PerlIO-scalar / scalar.xs
1 #define PERL_NO_GET_CONTEXT
2 #include "EXTERN.h"
3 #include "perl.h"
4 #include "XSUB.h"
5 #ifdef PERLIO_LAYERS
6
7 #include "perliol.h"
8
9 typedef struct {
10     struct _PerlIO base;        /* Base "class" info */
11     SV *var;
12     Off_t posn;
13 } PerlIOScalar;
14
15 IV
16 PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
17                     PerlIO_funcs * tab)
18 {
19     IV code;
20     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
21     /* If called (normally) via open() then arg is ref to scalar we are
22      * using, otherwise arg (from binmode presumably) is either NULL
23      * or the _name_ of the scalar
24      */
25     if (arg) {
26         if (SvROK(arg)) {
27             if (SvREADONLY(SvRV(arg)) && mode && *mode != 'r') {
28                 if (ckWARN(WARN_LAYER))
29                     Perl_warner(aTHX_ packWARN(WARN_LAYER), "%s", PL_no_modify);
30                 SETERRNO(EINVAL, SS_IVCHAN);
31                 return -1;
32             }
33             s->var = SvREFCNT_inc(SvRV(arg));
34             SvGETMAGIC(s->var);
35             if (!SvPOK(s->var) && SvOK(s->var))
36                 (void)SvPV_nomg_const_nolen(s->var);
37         }
38         else {
39             s->var =
40                 SvREFCNT_inc(perl_get_sv
41                              (SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
42         }
43     }
44     else {
45         s->var = newSVpvn("", 0);
46     }
47     SvUPGRADE(s->var, SVt_PV);
48     code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
49     if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
50     {
51         sv_force_normal(s->var);
52         SvCUR_set(s->var, 0);
53     }
54     if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
55     {
56         sv_force_normal(s->var);
57         s->posn = SvCUR(s->var);
58     }
59     else
60         s->posn = 0;
61     SvSETMAGIC(s->var);
62     return code;
63 }
64
65 IV
66 PerlIOScalar_popped(pTHX_ PerlIO * f)
67 {
68     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
69     if (s->var) {
70         SvREFCNT_dec(s->var);
71         s->var = Nullsv;
72     }
73     return 0;
74 }
75
76 IV
77 PerlIOScalar_close(pTHX_ PerlIO * f)
78 {
79     IV code = PerlIOBase_close(aTHX_ f);
80     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
81     return code;
82 }
83
84 IV
85 PerlIOScalar_fileno(pTHX_ PerlIO * f)
86 {
87     PERL_UNUSED_ARG(f);
88     return -1;
89 }
90
91 IV
92 PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
93 {
94     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
95     STRLEN oldcur;
96     STRLEN newlen;
97
98     SvGETMAGIC(s->var);
99     oldcur = SvCUR(s->var);
100
101     switch (whence) {
102     case SEEK_SET:
103         s->posn = offset;
104         break;
105     case SEEK_CUR:
106         s->posn = offset + s->posn;
107         break;
108     case SEEK_END:
109         s->posn = offset + SvCUR(s->var);
110         break;
111     }
112     if (s->posn < 0) {
113         if (ckWARN(WARN_LAYER))
114             Perl_warner(aTHX_ packWARN(WARN_LAYER), "Offset outside string");
115         SETERRNO(EINVAL, SS_IVCHAN);
116         return -1;
117     }
118     newlen = (STRLEN) s->posn;
119     if (newlen > oldcur) {
120         (void) SvGROW(s->var, newlen);
121         Zero(SvPVX(s->var) + oldcur, newlen - oldcur, char);
122         /* No SvCUR_set(), though.  This is just a seek, not a write. */
123     }
124     else if (!SvPVX(s->var)) {
125         /* ensure there's always a character buffer */
126         (void)SvGROW(s->var,1);
127     }
128     SvPOK_on(s->var);
129     return 0;
130 }
131
132 Off_t
133 PerlIOScalar_tell(pTHX_ PerlIO * f)
134 {
135     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
136     return s->posn;
137 }
138
139
140 SSize_t
141 PerlIOScalar_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
142 {
143     if (!f)
144         return 0;
145     if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
146         PerlIOBase(f)->flags |= PERLIO_F_ERROR;
147         SETERRNO(EBADF, SS_IVCHAN);
148         return 0;
149     }
150     {
151         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
152         SV *sv = s->var;
153         char *p;
154         STRLEN len;
155         I32 got;
156         p = SvPV(sv, len);
157         got = len - (STRLEN)(s->posn);
158         if (got <= 0)
159             return 0;
160         if ((STRLEN)got > (STRLEN)count)
161             got = (STRLEN)count;
162         Copy(p + (STRLEN)(s->posn), vbuf, got, STDCHAR);
163         s->posn += (Off_t)got;
164         return (SSize_t)got;
165     }
166 }
167
168 SSize_t
169 PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
170 {
171     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
172         Off_t offset;
173         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
174         SV *sv = s->var;
175         char *dst;
176         SvGETMAGIC(sv);
177         sv_force_normal(sv);
178         if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
179             dst = SvGROW(sv, SvCUR(sv) + count);
180             offset = SvCUR(sv);
181             s->posn = offset + count;
182         }
183         else {
184             if ((s->posn + count) > SvCUR(sv))
185                 dst = SvGROW(sv, (STRLEN)s->posn + count);
186             else
187                 dst = SvPVX(sv);
188             offset = s->posn;
189             s->posn += count;
190         }
191         Move(vbuf, dst + offset, count, char);
192         if ((STRLEN) s->posn > SvCUR(sv))
193             SvCUR_set(sv, (STRLEN)s->posn);
194         SvPOK_on(sv);
195         SvSETMAGIC(sv);
196         return count;
197     }
198     else
199         return 0;
200 }
201
202 IV
203 PerlIOScalar_fill(pTHX_ PerlIO * f)
204 {
205     PERL_UNUSED_ARG(f);
206     return -1;
207 }
208
209 IV
210 PerlIOScalar_flush(pTHX_ PerlIO * f)
211 {
212     PERL_UNUSED_ARG(f);
213     return 0;
214 }
215
216 STDCHAR *
217 PerlIOScalar_get_base(pTHX_ PerlIO * f)
218 {
219     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
220     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
221         SvGETMAGIC(s->var);
222         return (STDCHAR *) SvPV_nolen(s->var);
223     }
224     return (STDCHAR *) NULL;
225 }
226
227 STDCHAR *
228 PerlIOScalar_get_ptr(pTHX_ PerlIO * f)
229 {
230     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
231         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
232         return PerlIOScalar_get_base(aTHX_ f) + s->posn;
233     }
234     return (STDCHAR *) NULL;
235 }
236
237 SSize_t
238 PerlIOScalar_get_cnt(pTHX_ PerlIO * f)
239 {
240     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
241         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
242         SvGETMAGIC(s->var);
243         if (SvCUR(s->var) > (STRLEN) s->posn)
244             return SvCUR(s->var) - (STRLEN)s->posn;
245         else
246             return 0;
247     }
248     return 0;
249 }
250
251 Size_t
252 PerlIOScalar_bufsiz(pTHX_ PerlIO * f)
253 {
254     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
255         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
256         SvGETMAGIC(s->var);
257         return SvCUR(s->var);
258     }
259     return 0;
260 }
261
262 void
263 PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
264 {
265     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
266     PERL_UNUSED_ARG(ptr);
267     SvGETMAGIC(s->var);
268     s->posn = SvCUR(s->var) - cnt;
269 }
270
271 PerlIO *
272 PerlIOScalar_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, IV n,
273                   const char *mode, int fd, int imode, int perm,
274                   PerlIO * f, int narg, SV ** args)
275 {
276     SV *arg = (narg > 0) ? *args : PerlIOArg;
277     PERL_UNUSED_ARG(fd);
278     PERL_UNUSED_ARG(imode);
279     PERL_UNUSED_ARG(perm);
280     if (SvROK(arg) || SvPOK(arg)) {
281         if (!f) {
282             f = PerlIO_allocate(aTHX);
283         }
284         if ( (f = PerlIO_push(aTHX_ f, self, mode, arg)) ) {
285             PerlIOBase(f)->flags |= PERLIO_F_OPEN;
286         }
287         return f;
288     }
289     return NULL;
290 }
291
292 SV *
293 PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
294 {
295     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
296     SV *var = s->var;
297     if (flags & PERLIO_DUP_CLONE)
298         var = PerlIO_sv_dup(aTHX_ var, param);
299     else if (flags & PERLIO_DUP_FD) {
300         /* Equivalent (guesses NI-S) of dup() is to create a new scalar */
301         var = newSVsv(var);
302     }
303     else {
304         var = SvREFCNT_inc(var);
305     }
306     return newRV_noinc(var);
307 }
308
309 PerlIO *
310 PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
311                  int flags)
312 {
313     if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
314         PerlIOScalar *fs = PerlIOSelf(f, PerlIOScalar);
315         PerlIOScalar *os = PerlIOSelf(o, PerlIOScalar);
316         /* var has been set by implicit push */
317         fs->posn = os->posn;
318     }
319     return f;
320 }
321
322 PERLIO_FUNCS_DECL(PerlIO_scalar) = {
323     sizeof(PerlIO_funcs),
324     "scalar",
325     sizeof(PerlIOScalar),
326     PERLIO_K_BUFFERED | PERLIO_K_RAW,
327     PerlIOScalar_pushed,
328     PerlIOScalar_popped,
329     PerlIOScalar_open,
330     PerlIOBase_binmode,
331     PerlIOScalar_arg,
332     PerlIOScalar_fileno,
333     PerlIOScalar_dup,
334     PerlIOScalar_read,
335     NULL, /* unread */
336     PerlIOScalar_write,
337     PerlIOScalar_seek,
338     PerlIOScalar_tell,
339     PerlIOScalar_close,
340     PerlIOScalar_flush,
341     PerlIOScalar_fill,
342     PerlIOBase_eof,
343     PerlIOBase_error,
344     PerlIOBase_clearerr,
345     PerlIOBase_setlinebuf,
346     PerlIOScalar_get_base,
347     PerlIOScalar_bufsiz,
348     PerlIOScalar_get_ptr,
349     PerlIOScalar_get_cnt,
350     PerlIOScalar_set_ptrcnt,
351 };
352
353
354 #endif /* Layers available */
355
356 MODULE = PerlIO::scalar PACKAGE = PerlIO::scalar
357
358 PROTOTYPES: ENABLE
359
360 BOOT:
361 {
362 #ifdef PERLIO_LAYERS
363  PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_scalar));
364 #endif
365 }
366