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