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
CommitLineData
f6c77cf1
NIS
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
b38d579d
TC
9static const char code_point_warning[] =
10 "Strings with code points over 0xFF may not be mapped into in-memory file handles\n";
11
14d89041
NIS
12typedef struct {
13 struct _PerlIO base; /* Base "class" info */
14 SV *var;
15 Off_t posn;
f6c77cf1
NIS
16} PerlIOScalar;
17
c47992b4
CH
18IV
19PerlIOScalar_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
0b057af7 31static IV
14d89041
NIS
32PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
33 PerlIO_funcs * tab)
f6c77cf1 34{
14d89041
NIS
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 */
82505891 41 if (arg && SvOK(arg)) {
cba44c14 42 if (SvROK(arg)) {
47d6f3d6
FC
43 if (SvREADONLY(SvRV(arg)) && !SvIsCOW(SvRV(arg))
44 && mode && *mode != 'r') {
b35bc0c6 45 if (ckWARN(WARN_LAYER))
76c6a213 46 Perl_warner(aTHX_ packWARN(WARN_LAYER), "%s", PL_no_modify);
42bc49da 47 SETERRNO(EINVAL, SS_IVCHAN);
b35bc0c6
RGS
48 return -1;
49 }
14d89041 50 s->var = SvREFCNT_inc(SvRV(arg));
22ccb26d
BM
51 SvGETMAGIC(s->var);
52 if (!SvPOK(s->var) && SvOK(s->var))
53 (void)SvPV_nomg_const_nolen(s->var);
14d89041
NIS
54 }
55 else {
56 s->var =
57 SvREFCNT_inc(perl_get_sv
58 (SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
59 }
564dc057 60 }
14d89041 61 else {
c2b90b61 62 s->var = newSVpvs("");
564dc057 63 }
5a2bc23b 64 SvUPGRADE(s->var, SVt_PV);
552908b1 65
14d89041 66 code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
47cc46ee 67 if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
526fd1b4
FC
68 {
69 sv_force_normal(s->var);
b162af07 70 SvCUR_set(s->var, 0);
2b2b0f4f 71 if (SvPOK(s->var)) *SvPVX(s->var) = 0;
526fd1b4 72 }
02c3c86b
TC
73 if (SvUTF8(s->var) && !sv_utf8_downgrade(s->var, TRUE)) {
74 if (ckWARN(WARN_UTF8))
b38d579d 75 Perl_warner(aTHX_ packWARN(WARN_UTF8), code_point_warning);
02c3c86b
TC
76 SETERRNO(EINVAL, SS_IVCHAN);
77 SvREFCNT_dec(s->var);
78 s->var = Nullsv;
79 return -1;
80 }
14d89041 81 if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
7f7e7b58 82 s->posn = SvOK(s->var) ? sv_len(s->var) : 0;
14d89041
NIS
83 else
84 s->posn = 0;
ffe0bb5a 85 SvSETMAGIC(s->var);
14d89041 86 return code;
f6c77cf1
NIS
87}
88
0b057af7 89static IV
14d89041 90PerlIOScalar_popped(pTHX_ PerlIO * f)
f6c77cf1 91{
14d89041
NIS
92 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
93 if (s->var) {
94 SvREFCNT_dec(s->var);
95 s->var = Nullsv;
96 }
97 return 0;
f6c77cf1
NIS
98}
99
0b057af7 100static IV
14d89041 101PerlIOScalar_close(pTHX_ PerlIO * f)
f6c77cf1 102{
14d89041
NIS
103 IV code = PerlIOBase_close(aTHX_ f);
104 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
105 return code;
f6c77cf1
NIS
106}
107
0b057af7 108static IV
14d89041 109PerlIOScalar_fileno(pTHX_ PerlIO * f)
f6c77cf1 110{
c33e8be1 111 PERL_UNUSED_ARG(f);
14d89041 112 return -1;
f6c77cf1
NIS
113}
114
0b057af7 115static IV
14d89041 116PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
f6c77cf1 117{
14d89041 118 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
1d050e55 119 Off_t new_posn;
e94207f0 120
14d89041 121 switch (whence) {
42bc49da 122 case SEEK_SET:
1d050e55 123 new_posn = offset;
14d89041 124 break;
42bc49da 125 case SEEK_CUR:
1d050e55 126 new_posn = offset + s->posn;
14d89041 127 break;
42bc49da 128 case SEEK_END:
b6597275
FC
129 {
130 STRLEN oldcur;
131 (void)SvPV(s->var, oldcur);
1d050e55 132 new_posn = offset + oldcur;
14d89041 133 break;
b6597275 134 }
1d050e55
TC
135 default:
136 SETERRNO(EINVAL, SS_IVCHAN);
137 return -1;
14d89041 138 }
1d050e55 139 if (new_posn < 0) {
42bc49da
JH
140 if (ckWARN(WARN_LAYER))
141 Perl_warner(aTHX_ packWARN(WARN_LAYER), "Offset outside string");
142 SETERRNO(EINVAL, SS_IVCHAN);
143 return -1;
14d89041 144 }
1d050e55 145 s->posn = new_posn;
14d89041 146 return 0;
f6c77cf1
NIS
147}
148
0b057af7 149static Off_t
14d89041 150PerlIOScalar_tell(pTHX_ PerlIO * f)
f6c77cf1 151{
14d89041
NIS
152 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
153 return s->posn;
f6c77cf1
NIS
154}
155
ffe0bb5a 156
0b057af7 157static SSize_t
ffe0bb5a
DM
158PerlIOScalar_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);
0ea86a10 165 Perl_PerlIO_save_errno(aTHX_ f);
ffe0bb5a
DM
166 return 0;
167 }
168 {
169 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
170 SV *sv = s->var;
171 char *p;
ab9f1586 172 STRLEN len;
63d073d2 173 STRLEN got;
ffe0bb5a 174 p = SvPV(sv, len);
b38d579d
TC
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 }
63d073d2
TC
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)
ffe0bb5a 193 return 0;
63d073d2 194 got = len - (STRLEN)(s->posn);
c33e8be1 195 if ((STRLEN)got > (STRLEN)count)
ffe0bb5a
DM
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
0b057af7 203static SSize_t
14d89041 204PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
f6c77cf1 205{
14d89041
NIS
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;
ffe0bb5a 211 SvGETMAGIC(sv);
c5a04db8
FC
212 if (!SvROK(sv)) sv_force_normal(sv);
213 if (SvOK(sv)) SvPV_force_nomg_nolen(sv);
eeee3e08
TC
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 }
14d89041 220 if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
8af88444 221 dst = SvGROW(sv, SvCUR(sv) + count + 1);
14d89041
NIS
222 offset = SvCUR(sv);
223 s->posn = offset + count;
224 }
225 else {
b6597275 226 STRLEN const cur = SvCUR(sv);
4388f261
TC
227
228 /* ensure we don't try to create ridiculously large
229 * SVs on small platforms
230 */
d1992db0 231#if Size_t_size < Off_t_size
4388f261
TC
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
8380d35a 242 if ((STRLEN)s->posn > cur) {
8af88444 243 dst = SvGROW(sv, (STRLEN)s->posn + count + 1);
b6597275
FC
244 Zero(SvPVX(sv) + cur, (STRLEN)s->posn - cur, char);
245 }
8af88444
BL
246 else if ((s->posn + count) >= cur)
247 dst = SvGROW(sv, (STRLEN)s->posn + count + 1);
14d89041 248 else
ffe0bb5a 249 dst = SvPVX(sv);
14d89041
NIS
250 offset = s->posn;
251 s->posn += count;
252 }
253 Move(vbuf, dst + offset, count, char);
8af88444 254 if ((STRLEN) s->posn > SvCUR(sv)) {
4a9d6100 255 SvCUR_set(sv, (STRLEN)s->posn);
8af88444
BL
256 dst[(STRLEN) s->posn] = 0;
257 }
ffe0bb5a
DM
258 SvPOK_on(sv);
259 SvSETMAGIC(sv);
14d89041 260 return count;
09bf542c 261 }
14d89041
NIS
262 else
263 return 0;
f6c77cf1
NIS
264}
265
0b057af7 266static IV
14d89041 267PerlIOScalar_fill(pTHX_ PerlIO * f)
f6c77cf1 268{
c33e8be1 269 PERL_UNUSED_ARG(f);
14d89041 270 return -1;
f6c77cf1
NIS
271}
272
0b057af7 273static IV
14d89041 274PerlIOScalar_flush(pTHX_ PerlIO * f)
f6c77cf1 275{
c33e8be1 276 PERL_UNUSED_ARG(f);
14d89041 277 return 0;
f6c77cf1
NIS
278}
279
0b057af7 280static STDCHAR *
14d89041 281PerlIOScalar_get_base(pTHX_ PerlIO * f)
f6c77cf1 282{
14d89041
NIS
283 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
284 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
ffe0bb5a 285 SvGETMAGIC(s->var);
14d89041
NIS
286 return (STDCHAR *) SvPV_nolen(s->var);
287 }
9849c14c 288 return (STDCHAR *) NULL;
f6c77cf1
NIS
289}
290
0b057af7 291static STDCHAR *
14d89041 292PerlIOScalar_get_ptr(pTHX_ PerlIO * f)
f6c77cf1 293{
14d89041
NIS
294 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
295 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
296 return PerlIOScalar_get_base(aTHX_ f) + s->posn;
297 }
9849c14c 298 return (STDCHAR *) NULL;
f6c77cf1
NIS
299}
300
0b057af7 301static SSize_t
14d89041 302PerlIOScalar_get_cnt(pTHX_ PerlIO * f)
f6c77cf1 303{
14d89041
NIS
304 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
305 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
71edc894 306 STRLEN len;
5a2bc23b 307 (void)SvPV(s->var,len);
696efa16 308 if ((Off_t)len > s->posn)
71edc894 309 return len - (STRLEN)s->posn;
14d89041
NIS
310 else
311 return 0;
312 }
75effbe0 313 return 0;
f6c77cf1
NIS
314}
315
0b057af7 316static Size_t
14d89041 317PerlIOScalar_bufsiz(pTHX_ PerlIO * f)
f6c77cf1 318{
14d89041
NIS
319 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
320 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
ffe0bb5a 321 SvGETMAGIC(s->var);
14d89041
NIS
322 return SvCUR(s->var);
323 }
324 return 0;
f6c77cf1
NIS
325}
326
0b057af7 327static void
14d89041 328PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
f6c77cf1 329{
14d89041 330 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
71edc894 331 STRLEN len;
c33e8be1 332 PERL_UNUSED_ARG(ptr);
5a2bc23b 333 (void)SvPV(s->var,len);
71edc894 334 s->posn = len - cnt;
f6c77cf1
NIS
335}
336
0b057af7 337static PerlIO *
14d89041
NIS
338PerlIOScalar_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)
f6c77cf1 341{
14d89041 342 SV *arg = (narg > 0) ? *args : PerlIOArg;
c33e8be1
Z
343 PERL_UNUSED_ARG(fd);
344 PERL_UNUSED_ARG(imode);
345 PERL_UNUSED_ARG(perm);
14d89041
NIS
346 if (SvROK(arg) || SvPOK(arg)) {
347 if (!f) {
348 f = PerlIO_allocate(aTHX);
349 }
e3feee4e 350 if ( (f = PerlIO_push(aTHX_ f, self, mode, arg)) ) {
14d89041
NIS
351 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
352 }
353 return f;
354 }
355 return NULL;
f6c77cf1
NIS
356}
357
0b057af7 358static SV *
14d89041 359PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
ecdeb87c 360{
14d89041
NIS
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);
ecdeb87c
NIS
373}
374
0b057af7 375static PerlIO *
14d89041
NIS
376PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
377 int flags)
8cf8f3d1 378{
49b69fb3
FC
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);
8380d35a 383 PerlIOScalar *fs = NULL; /* avoid "may be used uninitialized" warning */
49b69fb3
FC
384 SV * const var = os->var;
385 os->var = newSVpvs("");
14d89041 386 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
7b3cf1c0 387 fs = PerlIOSelf(f, PerlIOScalar);
49b69fb3
FC
388 /* var has been set by implicit push, so replace it */
389 SvREFCNT_dec(fs->var);
14d89041 390 }
49b69fb3
FC
391 SvREFCNT_dec(os->var);
392 os->var = var;
7b3cf1c0
FC
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 }
14d89041 399 return f;
8cf8f3d1 400}
f6c77cf1 401
0b057af7 402static PERLIO_FUNCS_DECL(PerlIO_scalar) = {
14d89041
NIS
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,
ffe0bb5a 414 PerlIOScalar_read,
3ff3a8b6 415 NULL, /* unread */
14d89041
NIS
416 PerlIOScalar_write,
417 PerlIOScalar_seek,
418 PerlIOScalar_tell,
419 PerlIOScalar_close,
420 PerlIOScalar_flush,
421 PerlIOScalar_fill,
c47992b4 422 PerlIOScalar_eof,
14d89041
NIS
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,
f6c77cf1
NIS
431};
432
433
434#endif /* Layers available */
435
e934609f 436MODULE = PerlIO::scalar PACKAGE = PerlIO::scalar
f6c77cf1 437
acf4de66
A
438PROTOTYPES: ENABLE
439
f6c77cf1
NIS
440BOOT:
441{
442#ifdef PERLIO_LAYERS
27da23d5 443 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_scalar));
f6c77cf1
NIS
444#endif
445}
446