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