Fix for [perl #40267] PerlIO::scalar doesn't respect readonly-ness
[p5sagit/p5-mst-13.2.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), PL_no_modify);
30                 errno = EINVAL;
31                 return -1;
32             }
33             s->var = SvREFCNT_inc(SvRV(arg));
34             if (!SvPOK(s->var) && SvTYPE(SvRV(arg)) > SVt_NULL)
35                 (void)SvPV_nolen(s->var);
36         }
37         else {
38             s->var =
39                 SvREFCNT_inc(perl_get_sv
40                              (SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
41         }
42     }
43     else {
44         s->var = newSVpvn("", 0);
45     }
46     SvUPGRADE(s->var, SVt_PV);
47     code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
48     if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
49         SvCUR_set(s->var, 0);
50     if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
51         s->posn = SvCUR(s->var);
52     else
53         s->posn = 0;
54     return code;
55 }
56
57 IV
58 PerlIOScalar_popped(pTHX_ PerlIO * f)
59 {
60     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
61     if (s->var) {
62         SvREFCNT_dec(s->var);
63         s->var = Nullsv;
64     }
65     return 0;
66 }
67
68 IV
69 PerlIOScalar_close(pTHX_ PerlIO * f)
70 {
71     IV code = PerlIOBase_close(aTHX_ f);
72     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
73     return code;
74 }
75
76 IV
77 PerlIOScalar_fileno(pTHX_ PerlIO * f)
78 {
79     return -1;
80 }
81
82 IV
83 PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
84 {
85     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
86     switch (whence) {
87     case 0:
88         s->posn = offset;
89         break;
90     case 1:
91         s->posn = offset + s->posn;
92         break;
93     case 2:
94         s->posn = offset + SvCUR(s->var);
95         break;
96     }
97     if ((STRLEN) s->posn > SvCUR(s->var)) {
98         (void) SvGROW(s->var, (STRLEN) s->posn);
99     }
100     return 0;
101 }
102
103 Off_t
104 PerlIOScalar_tell(pTHX_ PerlIO * f)
105 {
106     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
107     return s->posn;
108 }
109
110 SSize_t
111 PerlIOScalar_unread(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
112 {
113     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
114     char *dst = SvGROW(s->var, (STRLEN)s->posn + count);
115     s->posn -= count;
116     Move(vbuf, dst + s->posn, count, char);
117     SvPOK_on(s->var);
118     return count;
119 }
120
121 SSize_t
122 PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
123 {
124     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
125         Off_t offset;
126         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
127         SV *sv = s->var;
128         char *dst;
129         if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
130             dst = SvGROW(sv, SvCUR(sv) + count);
131             offset = SvCUR(sv);
132             s->posn = offset + count;
133         }
134         else {
135             if ((s->posn + count) > SvCUR(sv))
136                 dst = SvGROW(sv, (STRLEN)s->posn + count);
137             else
138                 dst = SvPV_nolen(sv);
139             offset = s->posn;
140             s->posn += count;
141         }
142         Move(vbuf, dst + offset, count, char);
143         if ((STRLEN) s->posn > SvCUR(sv))
144             SvCUR_set(sv, (STRLEN)s->posn);
145         SvPOK_on(s->var);
146         return count;
147     }
148     else
149         return 0;
150 }
151
152 IV
153 PerlIOScalar_fill(pTHX_ PerlIO * f)
154 {
155     return -1;
156 }
157
158 IV
159 PerlIOScalar_flush(pTHX_ PerlIO * f)
160 {
161     return 0;
162 }
163
164 STDCHAR *
165 PerlIOScalar_get_base(pTHX_ PerlIO * f)
166 {
167     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
168     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
169         return (STDCHAR *) SvPV_nolen(s->var);
170     }
171     return (STDCHAR *) Nullch;
172 }
173
174 STDCHAR *
175 PerlIOScalar_get_ptr(pTHX_ PerlIO * f)
176 {
177     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
178         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
179         return PerlIOScalar_get_base(aTHX_ f) + s->posn;
180     }
181     return (STDCHAR *) Nullch;
182 }
183
184 SSize_t
185 PerlIOScalar_get_cnt(pTHX_ PerlIO * f)
186 {
187     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
188         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
189         if (SvCUR(s->var) > (STRLEN) s->posn)
190             return SvCUR(s->var) - (STRLEN)s->posn;
191         else
192             return 0;
193     }
194     return 0;
195 }
196
197 Size_t
198 PerlIOScalar_bufsiz(pTHX_ PerlIO * f)
199 {
200     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
201         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
202         return SvCUR(s->var);
203     }
204     return 0;
205 }
206
207 void
208 PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
209 {
210     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
211     s->posn = SvCUR(s->var) - cnt;
212 }
213
214 PerlIO *
215 PerlIOScalar_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, IV n,
216                   const char *mode, int fd, int imode, int perm,
217                   PerlIO * f, int narg, SV ** args)
218 {
219     SV *arg = (narg > 0) ? *args : PerlIOArg;
220     if (SvROK(arg) || SvPOK(arg)) {
221         if (!f) {
222             f = PerlIO_allocate(aTHX);
223         }
224         if ( (f = PerlIO_push(aTHX_ f, self, mode, arg)) ) {
225             PerlIOBase(f)->flags |= PERLIO_F_OPEN;
226         }
227         return f;
228     }
229     return NULL;
230 }
231
232 SV *
233 PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
234 {
235     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
236     SV *var = s->var;
237     if (flags & PERLIO_DUP_CLONE)
238         var = PerlIO_sv_dup(aTHX_ var, param);
239     else if (flags & PERLIO_DUP_FD) {
240         /* Equivalent (guesses NI-S) of dup() is to create a new scalar */
241         var = newSVsv(var);
242     }
243     else {
244         var = SvREFCNT_inc(var);
245     }
246     return newRV_noinc(var);
247 }
248
249 PerlIO *
250 PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
251                  int flags)
252 {
253     if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
254         PerlIOScalar *fs = PerlIOSelf(f, PerlIOScalar);
255         PerlIOScalar *os = PerlIOSelf(o, PerlIOScalar);
256         /* var has been set by implicit push */
257         fs->posn = os->posn;
258     }
259     return f;
260 }
261
262 PERLIO_FUNCS_DECL(PerlIO_scalar) = {
263     sizeof(PerlIO_funcs),
264     "scalar",
265     sizeof(PerlIOScalar),
266     PERLIO_K_BUFFERED | PERLIO_K_RAW,
267     PerlIOScalar_pushed,
268     PerlIOScalar_popped,
269     PerlIOScalar_open,
270     PerlIOBase_binmode,
271     PerlIOScalar_arg,
272     PerlIOScalar_fileno,
273     PerlIOScalar_dup,
274     PerlIOBase_read,
275     PerlIOScalar_unread,
276     PerlIOScalar_write,
277     PerlIOScalar_seek,
278     PerlIOScalar_tell,
279     PerlIOScalar_close,
280     PerlIOScalar_flush,
281     PerlIOScalar_fill,
282     PerlIOBase_eof,
283     PerlIOBase_error,
284     PerlIOBase_clearerr,
285     PerlIOBase_setlinebuf,
286     PerlIOScalar_get_base,
287     PerlIOScalar_bufsiz,
288     PerlIOScalar_get_ptr,
289     PerlIOScalar_get_cnt,
290     PerlIOScalar_set_ptrcnt,
291 };
292
293
294 #endif /* Layers available */
295
296 MODULE = PerlIO::scalar PACKAGE = PerlIO::scalar
297
298 PROTOTYPES: ENABLE
299
300 BOOT:
301 {
302 #ifdef PERLIO_LAYERS
303  PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_scalar));
304 #endif
305 }
306