This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
RT 43789: "in memory" files don't call STORE
[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         SvCUR_set(s->var, 0);
51     if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
52         s->posn = SvCUR(s->var);
53     else
54         s->posn = 0;
55     SvSETMAGIC(s->var);
56     return code;
57 }
58
59 IV
60 PerlIOScalar_popped(pTHX_ PerlIO * f)
61 {
62     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
63     if (s->var) {
64         SvREFCNT_dec(s->var);
65         s->var = Nullsv;
66     }
67     return 0;
68 }
69
70 IV
71 PerlIOScalar_close(pTHX_ PerlIO * f)
72 {
73     IV code = PerlIOBase_close(aTHX_ f);
74     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
75     return code;
76 }
77
78 IV
79 PerlIOScalar_fileno(pTHX_ PerlIO * f)
80 {
81     return -1;
82 }
83
84 IV
85 PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
86 {
87     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
88     SvGETMAGIC(s->var);
89     STRLEN oldcur = SvCUR(s->var);
90     STRLEN newlen;
91     switch (whence) {
92     case SEEK_SET:
93         s->posn = offset;
94         break;
95     case SEEK_CUR:
96         s->posn = offset + s->posn;
97         break;
98     case SEEK_END:
99         s->posn = offset + SvCUR(s->var);
100         break;
101     }
102     if (s->posn < 0) {
103         if (ckWARN(WARN_LAYER))
104             Perl_warner(aTHX_ packWARN(WARN_LAYER), "Offset outside string");
105         SETERRNO(EINVAL, SS_IVCHAN);
106         return -1;
107     }
108     newlen = (STRLEN) s->posn;
109     if (newlen > oldcur) {
110         (void) SvGROW(s->var, newlen);
111         Zero(SvPVX(s->var) + oldcur, newlen - oldcur, char);
112         /* No SvCUR_set(), though.  This is just a seek, not a write. */
113     }
114     else if (!SvPVX(s->var)) {
115         /* ensure there's always a character buffer */
116         (void)SvGROW(s->var,1);
117     }
118     SvPOK_on(s->var);
119     return 0;
120 }
121
122 Off_t
123 PerlIOScalar_tell(pTHX_ PerlIO * f)
124 {
125     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
126     return s->posn;
127 }
128
129
130 SSize_t
131 PerlIOScalar_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
132 {
133     if (!f)
134         return 0;
135     if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
136         PerlIOBase(f)->flags |= PERLIO_F_ERROR;
137         SETERRNO(EBADF, SS_IVCHAN);
138         return 0;
139     }
140     {
141         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
142         SV *sv = s->var;
143         char *p;
144         STRLEN len, got;
145         p = SvPV(sv, len);
146         got = len - (STRLEN)(s->posn);
147         if (got <= 0)
148             return 0;
149         if (got > (STRLEN)count)
150             got = (STRLEN)count;
151         Copy(p + (STRLEN)(s->posn), vbuf, got, STDCHAR);
152         s->posn += (Off_t)got;
153         return (SSize_t)got;
154     }
155 }
156
157 SSize_t
158 PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
159 {
160     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
161         Off_t offset;
162         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
163         SV *sv = s->var;
164         char *dst;
165         SvGETMAGIC(sv);
166         if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
167             dst = SvGROW(sv, SvCUR(sv) + count);
168             offset = SvCUR(sv);
169             s->posn = offset + count;
170         }
171         else {
172             if ((s->posn + count) > SvCUR(sv))
173                 dst = SvGROW(sv, (STRLEN)s->posn + count);
174             else
175                 dst = SvPVX(sv);
176             offset = s->posn;
177             s->posn += count;
178         }
179         Move(vbuf, dst + offset, count, char);
180         if ((STRLEN) s->posn > SvCUR(sv))
181             SvCUR_set(sv, (STRLEN)s->posn);
182         SvPOK_on(sv);
183         SvSETMAGIC(sv);
184         return count;
185     }
186     else
187         return 0;
188 }
189
190 IV
191 PerlIOScalar_fill(pTHX_ PerlIO * f)
192 {
193     return -1;
194 }
195
196 IV
197 PerlIOScalar_flush(pTHX_ PerlIO * f)
198 {
199     return 0;
200 }
201
202 STDCHAR *
203 PerlIOScalar_get_base(pTHX_ PerlIO * f)
204 {
205     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
206     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
207         SvGETMAGIC(s->var);
208         return (STDCHAR *) SvPV_nolen(s->var);
209     }
210     return (STDCHAR *) NULL;
211 }
212
213 STDCHAR *
214 PerlIOScalar_get_ptr(pTHX_ PerlIO * f)
215 {
216     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
217         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
218         return PerlIOScalar_get_base(aTHX_ f) + s->posn;
219     }
220     return (STDCHAR *) NULL;
221 }
222
223 SSize_t
224 PerlIOScalar_get_cnt(pTHX_ PerlIO * f)
225 {
226     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
227         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
228         SvGETMAGIC(s->var);
229         if (SvCUR(s->var) > (STRLEN) s->posn)
230             return SvCUR(s->var) - (STRLEN)s->posn;
231         else
232             return 0;
233     }
234     return 0;
235 }
236
237 Size_t
238 PerlIOScalar_bufsiz(pTHX_ PerlIO * f)
239 {
240     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
241         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
242         SvGETMAGIC(s->var);
243         return SvCUR(s->var);
244     }
245     return 0;
246 }
247
248 void
249 PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
250 {
251     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
252     SvGETMAGIC(s->var);
253     s->posn = SvCUR(s->var) - cnt;
254 }
255
256 PerlIO *
257 PerlIOScalar_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, IV n,
258                   const char *mode, int fd, int imode, int perm,
259                   PerlIO * f, int narg, SV ** args)
260 {
261     SV *arg = (narg > 0) ? *args : PerlIOArg;
262     if (SvROK(arg) || SvPOK(arg)) {
263         if (!f) {
264             f = PerlIO_allocate(aTHX);
265         }
266         if ( (f = PerlIO_push(aTHX_ f, self, mode, arg)) ) {
267             PerlIOBase(f)->flags |= PERLIO_F_OPEN;
268         }
269         return f;
270     }
271     return NULL;
272 }
273
274 SV *
275 PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
276 {
277     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
278     SV *var = s->var;
279     if (flags & PERLIO_DUP_CLONE)
280         var = PerlIO_sv_dup(aTHX_ var, param);
281     else if (flags & PERLIO_DUP_FD) {
282         /* Equivalent (guesses NI-S) of dup() is to create a new scalar */
283         var = newSVsv(var);
284     }
285     else {
286         var = SvREFCNT_inc(var);
287     }
288     return newRV_noinc(var);
289 }
290
291 PerlIO *
292 PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
293                  int flags)
294 {
295     if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
296         PerlIOScalar *fs = PerlIOSelf(f, PerlIOScalar);
297         PerlIOScalar *os = PerlIOSelf(o, PerlIOScalar);
298         /* var has been set by implicit push */
299         fs->posn = os->posn;
300     }
301     return f;
302 }
303
304 PERLIO_FUNCS_DECL(PerlIO_scalar) = {
305     sizeof(PerlIO_funcs),
306     "scalar",
307     sizeof(PerlIOScalar),
308     PERLIO_K_BUFFERED | PERLIO_K_RAW,
309     PerlIOScalar_pushed,
310     PerlIOScalar_popped,
311     PerlIOScalar_open,
312     PerlIOBase_binmode,
313     PerlIOScalar_arg,
314     PerlIOScalar_fileno,
315     PerlIOScalar_dup,
316     PerlIOScalar_read,
317     NULL, /* unread */
318     PerlIOScalar_write,
319     PerlIOScalar_seek,
320     PerlIOScalar_tell,
321     PerlIOScalar_close,
322     PerlIOScalar_flush,
323     PerlIOScalar_fill,
324     PerlIOBase_eof,
325     PerlIOBase_error,
326     PerlIOBase_clearerr,
327     PerlIOBase_setlinebuf,
328     PerlIOScalar_get_base,
329     PerlIOScalar_bufsiz,
330     PerlIOScalar_get_ptr,
331     PerlIOScalar_get_cnt,
332     PerlIOScalar_set_ptrcnt,
333 };
334
335
336 #endif /* Layers available */
337
338 MODULE = PerlIO::scalar PACKAGE = PerlIO::scalar
339
340 PROTOTYPES: ENABLE
341
342 BOOT:
343 {
344 #ifdef PERLIO_LAYERS
345  PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_scalar));
346 #endif
347 }
348