This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
PerlIO-scalar: Fix fail to detect incomplete seqs at EOF
[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 static const char code_point_warning[] =
10  "Strings with code points over 0xFF may not be mapped into in-memory file handles\n";
11
12 typedef struct {
13     struct _PerlIO base;        /* Base "class" info */
14     SV *var;
15     Off_t posn;
16 } PerlIOScalar;
17
18 IV
19 PerlIOScalar_eof(pTHX_ PerlIO * f)
20 {
21     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
22         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
23         char *p;
24         STRLEN len;
25         p = SvPV(s->var, len);
26         return len - (STRLEN)(s->posn) <= 0;
27     }
28     return 1;
29 }
30
31 static IV
32 PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
33                     PerlIO_funcs * tab)
34 {
35     IV code;
36     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
37     /* If called (normally) via open() then arg is ref to scalar we are
38      * using, otherwise arg (from binmode presumably) is either NULL
39      * or the _name_ of the scalar
40      */
41     if (arg && SvOK(arg)) {
42         if (SvROK(arg)) {
43             if (SvREADONLY(SvRV(arg)) && !SvIsCOW(SvRV(arg))
44              && mode && *mode != 'r') {
45                 if (ckWARN(WARN_LAYER))
46                     Perl_warner(aTHX_ packWARN(WARN_LAYER), "%s", PL_no_modify);
47                 SETERRNO(EINVAL, SS_IVCHAN);
48                 return -1;
49             }
50             s->var = SvREFCNT_inc(SvRV(arg));
51             SvGETMAGIC(s->var);
52             if (!SvPOK(s->var) && SvOK(s->var))
53                 (void)SvPV_nomg_const_nolen(s->var);
54         }
55         else {
56             s->var =
57                 SvREFCNT_inc(perl_get_sv
58                              (SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
59         }
60     }
61     else {
62         s->var = newSVpvs("");
63     }
64     SvUPGRADE(s->var, SVt_PV);
65
66     code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
67     if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
68     {
69         sv_force_normal(s->var);
70         SvCUR_set(s->var, 0);
71         if (SvPOK(s->var)) *SvPVX(s->var) = 0;
72     }
73     if (SvUTF8(s->var) && !sv_utf8_downgrade(s->var, TRUE)) {
74         if (ckWARN(WARN_UTF8))
75             Perl_warner(aTHX_ packWARN(WARN_UTF8), code_point_warning);
76         SETERRNO(EINVAL, SS_IVCHAN);
77         SvREFCNT_dec(s->var);
78         s->var = Nullsv;
79         return -1;
80     }
81     if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
82         s->posn = SvOK(s->var) ? sv_len(s->var) : 0;
83     else
84         s->posn = 0;
85     SvSETMAGIC(s->var);
86     return code;
87 }
88
89 static IV
90 PerlIOScalar_popped(pTHX_ PerlIO * f)
91 {
92     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
93     if (s->var) {
94         SvREFCNT_dec(s->var);
95         s->var = Nullsv;
96     }
97     return 0;
98 }
99
100 static IV
101 PerlIOScalar_close(pTHX_ PerlIO * f)
102 {
103     IV code = PerlIOBase_close(aTHX_ f);
104     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
105     return code;
106 }
107
108 static IV
109 PerlIOScalar_fileno(pTHX_ PerlIO * f)
110 {
111     PERL_UNUSED_ARG(f);
112     return -1;
113 }
114
115 static IV
116 PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
117 {
118     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
119     Off_t new_posn;
120
121     switch (whence) {
122     case SEEK_SET:
123         new_posn = offset;
124         break;
125     case SEEK_CUR:
126         new_posn = offset + s->posn;
127         break;
128     case SEEK_END:
129       {
130         STRLEN oldcur;
131         (void)SvPV(s->var, oldcur);
132         new_posn = offset + oldcur;
133         break;
134       }
135     default:
136         SETERRNO(EINVAL, SS_IVCHAN);
137         return -1;
138     }
139     if (new_posn < 0) {
140         if (ckWARN(WARN_LAYER))
141             Perl_warner(aTHX_ packWARN(WARN_LAYER), "Offset outside string");
142         SETERRNO(EINVAL, SS_IVCHAN);
143         return -1;
144     }
145     s->posn = new_posn;
146     return 0;
147 }
148
149 static Off_t
150 PerlIOScalar_tell(pTHX_ PerlIO * f)
151 {
152     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
153     return s->posn;
154 }
155
156
157 static SSize_t
158 PerlIOScalar_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
159 {
160     if (!f)
161         return 0;
162     if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
163         PerlIOBase(f)->flags |= PERLIO_F_ERROR;
164         SETERRNO(EBADF, SS_IVCHAN);
165         Perl_PerlIO_save_errno(aTHX_ f);
166         return 0;
167     }
168     {
169         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
170         SV *sv = s->var;
171         char *p;
172         STRLEN len;
173         STRLEN got;
174         p = SvPV(sv, len);
175         if (SvUTF8(sv)) {
176             if (sv_utf8_downgrade(sv, TRUE)) {
177                 p = SvPV_nomg(sv, len);
178             }
179             else {
180                 if (ckWARN(WARN_UTF8))
181                     Perl_warner(aTHX_ packWARN(WARN_UTF8), code_point_warning);
182                 SETERRNO(EINVAL, SS_IVCHAN);
183                 return -1;
184             }
185         }
186         /* I assume that Off_t is at least as large as len (which 
187          * seems safe) and that the size of the buffer in our SV is
188          * always less than half the size of the address space
189          */
190         assert(sizeof(Off_t) >= sizeof(len));
191         assert((Off_t)len >= 0);
192         if ((Off_t)len <= s->posn)
193             return 0;
194         got = len - (STRLEN)(s->posn);
195         if ((STRLEN)got > (STRLEN)count)
196             got = (STRLEN)count;
197         Copy(p + (STRLEN)(s->posn), vbuf, got, STDCHAR);
198         s->posn += (Off_t)got;
199         return (SSize_t)got;
200     }
201 }
202
203 static SSize_t
204 PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
205 {
206     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
207         Off_t offset;
208         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
209         SV *sv = s->var;
210         char *dst;
211         SvGETMAGIC(sv);
212         if (!SvROK(sv)) sv_force_normal(sv);
213         if (SvOK(sv)) SvPV_force_nomg_nolen(sv);
214         if (SvUTF8(sv) && !sv_utf8_downgrade(sv, TRUE)) {
215             if (ckWARN(WARN_UTF8))
216                 Perl_warner(aTHX_ packWARN(WARN_UTF8), code_point_warning);
217             SETERRNO(EINVAL, SS_IVCHAN);
218             return 0;
219         }
220         if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
221             dst = SvGROW(sv, SvCUR(sv) + count + 1);
222             offset = SvCUR(sv);
223             s->posn = offset + count;
224         }
225         else {
226             STRLEN const cur = SvCUR(sv);
227
228             /* ensure we don't try to create ridiculously large
229              * SVs on small platforms
230              */
231 #if Size_t_size < Off_t_size
232             if (s->posn > SSize_t_MAX) {
233 #ifdef EFBIG
234                 SETERRNO(EFBIG, SS_BUFFEROVF);
235 #else
236                 SETERRNO(ENOSPC, SS_BUFFEROVF);
237 #endif
238                 return 0;
239             }
240 #endif
241
242             if ((STRLEN)s->posn > cur) {
243                 dst = SvGROW(sv, (STRLEN)s->posn + count + 1);
244                 Zero(SvPVX(sv) + cur, (STRLEN)s->posn - cur, char);
245             }
246             else if ((s->posn + count) >= cur)
247                 dst = SvGROW(sv, (STRLEN)s->posn + count + 1);
248             else
249                 dst = SvPVX(sv);
250             offset = s->posn;
251             s->posn += count;
252         }
253         Move(vbuf, dst + offset, count, char);
254         if ((STRLEN) s->posn > SvCUR(sv)) {
255             SvCUR_set(sv, (STRLEN)s->posn);
256             dst[(STRLEN) s->posn] = 0;
257         }
258         SvPOK_on(sv);
259         SvSETMAGIC(sv);
260         return count;
261     }
262     else
263         return 0;
264 }
265
266 static IV
267 PerlIOScalar_fill(pTHX_ PerlIO * f)
268 {
269     PERL_UNUSED_ARG(f);
270     return -1;
271 }
272
273 static IV
274 PerlIOScalar_flush(pTHX_ PerlIO * f)
275 {
276     PERL_UNUSED_ARG(f);
277     return 0;
278 }
279
280 static STDCHAR *
281 PerlIOScalar_get_base(pTHX_ PerlIO * f)
282 {
283     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
284     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
285         SvGETMAGIC(s->var);
286         return (STDCHAR *) SvPV_nolen(s->var);
287     }
288     return (STDCHAR *) NULL;
289 }
290
291 static STDCHAR *
292 PerlIOScalar_get_ptr(pTHX_ PerlIO * f)
293 {
294     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
295         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
296         return PerlIOScalar_get_base(aTHX_ f) + s->posn;
297     }
298     return (STDCHAR *) NULL;
299 }
300
301 static SSize_t
302 PerlIOScalar_get_cnt(pTHX_ PerlIO * f)
303 {
304     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
305         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
306         STRLEN len;
307         (void)SvPV(s->var,len);
308         if ((Off_t)len > s->posn)
309             return len - (STRLEN)s->posn;
310         else
311             return 0;
312     }
313     return 0;
314 }
315
316 static Size_t
317 PerlIOScalar_bufsiz(pTHX_ PerlIO * f)
318 {
319     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
320         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
321         SvGETMAGIC(s->var);
322         return SvCUR(s->var);
323     }
324     return 0;
325 }
326
327 static void
328 PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
329 {
330     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
331     STRLEN len;
332     PERL_UNUSED_ARG(ptr);
333     (void)SvPV(s->var,len);
334     s->posn = len - cnt;
335 }
336
337 static PerlIO *
338 PerlIOScalar_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, IV n,
339                   const char *mode, int fd, int imode, int perm,
340                   PerlIO * f, int narg, SV ** args)
341 {
342     SV *arg = (narg > 0) ? *args : PerlIOArg;
343     PERL_UNUSED_ARG(fd);
344     PERL_UNUSED_ARG(imode);
345     PERL_UNUSED_ARG(perm);
346     if (SvROK(arg) || SvPOK(arg)) {
347         if (!f) {
348             f = PerlIO_allocate(aTHX);
349         }
350         if ( (f = PerlIO_push(aTHX_ f, self, mode, arg)) ) {
351             PerlIOBase(f)->flags |= PERLIO_F_OPEN;
352         }
353         return f;
354     }
355     return NULL;
356 }
357
358 static SV *
359 PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
360 {
361     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
362     SV *var = s->var;
363     if (flags & PERLIO_DUP_CLONE)
364         var = PerlIO_sv_dup(aTHX_ var, param);
365     else if (flags & PERLIO_DUP_FD) {
366         /* Equivalent (guesses NI-S) of dup() is to create a new scalar */
367         var = newSVsv(var);
368     }
369     else {
370         var = SvREFCNT_inc(var);
371     }
372     return newRV_noinc(var);
373 }
374
375 static PerlIO *
376 PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
377                  int flags)
378 {
379     /* Duplication causes the scalar layer to be pushed on to clone, caus-
380        ing the cloned scalar to be set to the empty string by
381        PerlIOScalar_pushed.  So set aside our scalar temporarily. */
382     PerlIOScalar * const os = PerlIOSelf(o, PerlIOScalar);
383     PerlIOScalar *fs = NULL; /* avoid "may be used uninitialized" warning */
384     SV * const var = os->var;
385     os->var = newSVpvs("");
386     if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
387         fs = PerlIOSelf(f, PerlIOScalar);
388         /* var has been set by implicit push, so replace it */
389         SvREFCNT_dec(fs->var);
390     }
391     SvREFCNT_dec(os->var);
392     os->var = var;
393     if (f) {
394         SV * const rv = PerlIOScalar_arg(aTHX_ o, param, flags);
395         fs->var = SvREFCNT_inc(SvRV(rv));
396         SvREFCNT_dec(rv);
397         fs->posn = os->posn;
398     }
399     return f;
400 }
401
402 static PERLIO_FUNCS_DECL(PerlIO_scalar) = {
403     sizeof(PerlIO_funcs),
404     "scalar",
405     sizeof(PerlIOScalar),
406     PERLIO_K_BUFFERED | PERLIO_K_RAW,
407     PerlIOScalar_pushed,
408     PerlIOScalar_popped,
409     PerlIOScalar_open,
410     PerlIOBase_binmode,
411     PerlIOScalar_arg,
412     PerlIOScalar_fileno,
413     PerlIOScalar_dup,
414     PerlIOScalar_read,
415     NULL, /* unread */
416     PerlIOScalar_write,
417     PerlIOScalar_seek,
418     PerlIOScalar_tell,
419     PerlIOScalar_close,
420     PerlIOScalar_flush,
421     PerlIOScalar_fill,
422     PerlIOScalar_eof,
423     PerlIOBase_error,
424     PerlIOBase_clearerr,
425     PerlIOBase_setlinebuf,
426     PerlIOScalar_get_base,
427     PerlIOScalar_bufsiz,
428     PerlIOScalar_get_ptr,
429     PerlIOScalar_get_cnt,
430     PerlIOScalar_set_ptrcnt,
431 };
432
433
434 #endif /* Layers available */
435
436 MODULE = PerlIO::scalar PACKAGE = PerlIO::scalar
437
438 PROTOTYPES: ENABLE
439
440 BOOT:
441 {
442 #ifdef PERLIO_LAYERS
443  PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_scalar));
444 #endif
445 }
446