This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
TODO tests for reads from a scalar changed to upgraded after open
[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
14d89041
NIS
9typedef struct {
10 struct _PerlIO base; /* Base "class" info */
11 SV *var;
12 Off_t posn;
f6c77cf1
NIS
13} PerlIOScalar;
14
15IV
14d89041
NIS
16PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
17 PerlIO_funcs * tab)
f6c77cf1 18{
14d89041
NIS
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 */
82505891 25 if (arg && SvOK(arg)) {
cba44c14 26 if (SvROK(arg)) {
47d6f3d6
FC
27 if (SvREADONLY(SvRV(arg)) && !SvIsCOW(SvRV(arg))
28 && mode && *mode != 'r') {
b35bc0c6 29 if (ckWARN(WARN_LAYER))
76c6a213 30 Perl_warner(aTHX_ packWARN(WARN_LAYER), "%s", PL_no_modify);
42bc49da 31 SETERRNO(EINVAL, SS_IVCHAN);
b35bc0c6
RGS
32 return -1;
33 }
14d89041 34 s->var = SvREFCNT_inc(SvRV(arg));
22ccb26d
BM
35 SvGETMAGIC(s->var);
36 if (!SvPOK(s->var) && SvOK(s->var))
37 (void)SvPV_nomg_const_nolen(s->var);
14d89041
NIS
38 }
39 else {
40 s->var =
41 SvREFCNT_inc(perl_get_sv
42 (SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
43 }
564dc057 44 }
14d89041
NIS
45 else {
46 s->var = newSVpvn("", 0);
564dc057 47 }
c5b94a97 48 SvUPGRADE(s->var, SVt_PV);
14d89041 49 code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
47cc46ee 50 if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
526fd1b4
FC
51 {
52 sv_force_normal(s->var);
b162af07 53 SvCUR_set(s->var, 0);
526fd1b4 54 }
02c3c86b
TC
55 if (SvUTF8(s->var) && !sv_utf8_downgrade(s->var, TRUE)) {
56 if (ckWARN(WARN_UTF8))
57 Perl_warner(aTHX_ packWARN(WARN_UTF8), "Strings with code points over 0xFF may not be mapped into in-memory file handles\n");
58 SETERRNO(EINVAL, SS_IVCHAN);
59 SvREFCNT_dec(s->var);
60 s->var = Nullsv;
61 return -1;
62 }
14d89041 63 if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
526fd1b4
FC
64 {
65 sv_force_normal(s->var);
14d89041 66 s->posn = SvCUR(s->var);
526fd1b4 67 }
14d89041
NIS
68 else
69 s->posn = 0;
ffe0bb5a 70 SvSETMAGIC(s->var);
14d89041 71 return code;
f6c77cf1
NIS
72}
73
74IV
14d89041 75PerlIOScalar_popped(pTHX_ PerlIO * f)
f6c77cf1 76{
14d89041
NIS
77 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
78 if (s->var) {
79 SvREFCNT_dec(s->var);
80 s->var = Nullsv;
81 }
82 return 0;
f6c77cf1
NIS
83}
84
85IV
14d89041 86PerlIOScalar_close(pTHX_ PerlIO * f)
f6c77cf1 87{
14d89041
NIS
88 IV code = PerlIOBase_close(aTHX_ f);
89 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
90 return code;
f6c77cf1
NIS
91}
92
93IV
14d89041 94PerlIOScalar_fileno(pTHX_ PerlIO * f)
f6c77cf1 95{
c33e8be1 96 PERL_UNUSED_ARG(f);
14d89041 97 return -1;
f6c77cf1
NIS
98}
99
100IV
14d89041 101PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
f6c77cf1 102{
14d89041 103 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
e94207f0 104
14d89041 105 switch (whence) {
42bc49da 106 case SEEK_SET:
14d89041
NIS
107 s->posn = offset;
108 break;
42bc49da 109 case SEEK_CUR:
14d89041
NIS
110 s->posn = offset + s->posn;
111 break;
42bc49da 112 case SEEK_END:
b6597275
FC
113 {
114 STRLEN oldcur;
115 (void)SvPV(s->var, oldcur);
116 s->posn = offset + oldcur;
14d89041 117 break;
b6597275 118 }
14d89041 119 }
42bc49da
JH
120 if (s->posn < 0) {
121 if (ckWARN(WARN_LAYER))
122 Perl_warner(aTHX_ packWARN(WARN_LAYER), "Offset outside string");
123 SETERRNO(EINVAL, SS_IVCHAN);
124 return -1;
14d89041
NIS
125 }
126 return 0;
f6c77cf1
NIS
127}
128
129Off_t
14d89041 130PerlIOScalar_tell(pTHX_ PerlIO * f)
f6c77cf1 131{
14d89041
NIS
132 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
133 return s->posn;
f6c77cf1
NIS
134}
135
ffe0bb5a
DM
136
137SSize_t
138PerlIOScalar_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
139{
140 if (!f)
141 return 0;
142 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
143 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
144 SETERRNO(EBADF, SS_IVCHAN);
145 return 0;
146 }
147 {
148 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
149 SV *sv = s->var;
150 char *p;
ab9f1586
FC
151 STRLEN len;
152 I32 got;
ffe0bb5a
DM
153 p = SvPV(sv, len);
154 got = len - (STRLEN)(s->posn);
155 if (got <= 0)
156 return 0;
c33e8be1 157 if ((STRLEN)got > (STRLEN)count)
ffe0bb5a
DM
158 got = (STRLEN)count;
159 Copy(p + (STRLEN)(s->posn), vbuf, got, STDCHAR);
160 s->posn += (Off_t)got;
161 return (SSize_t)got;
162 }
163}
164
f6c77cf1 165SSize_t
14d89041 166PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
f6c77cf1 167{
14d89041
NIS
168 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
169 Off_t offset;
170 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
171 SV *sv = s->var;
172 char *dst;
ffe0bb5a 173 SvGETMAGIC(sv);
c5a04db8
FC
174 if (!SvROK(sv)) sv_force_normal(sv);
175 if (SvOK(sv)) SvPV_force_nomg_nolen(sv);
14d89041 176 if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
8af88444 177 dst = SvGROW(sv, SvCUR(sv) + count + 1);
14d89041
NIS
178 offset = SvCUR(sv);
179 s->posn = offset + count;
180 }
181 else {
b6597275
FC
182 STRLEN const cur = SvCUR(sv);
183 if (s->posn > cur) {
8af88444 184 dst = SvGROW(sv, (STRLEN)s->posn + count + 1);
b6597275
FC
185 Zero(SvPVX(sv) + cur, (STRLEN)s->posn - cur, char);
186 }
8af88444
BL
187 else if ((s->posn + count) >= cur)
188 dst = SvGROW(sv, (STRLEN)s->posn + count + 1);
14d89041 189 else
ffe0bb5a 190 dst = SvPVX(sv);
14d89041
NIS
191 offset = s->posn;
192 s->posn += count;
193 }
194 Move(vbuf, dst + offset, count, char);
8af88444 195 if ((STRLEN) s->posn > SvCUR(sv)) {
4a9d6100 196 SvCUR_set(sv, (STRLEN)s->posn);
8af88444
BL
197 dst[(STRLEN) s->posn] = 0;
198 }
ffe0bb5a
DM
199 SvPOK_on(sv);
200 SvSETMAGIC(sv);
14d89041 201 return count;
09bf542c 202 }
14d89041
NIS
203 else
204 return 0;
f6c77cf1
NIS
205}
206
207IV
14d89041 208PerlIOScalar_fill(pTHX_ PerlIO * f)
f6c77cf1 209{
c33e8be1 210 PERL_UNUSED_ARG(f);
14d89041 211 return -1;
f6c77cf1
NIS
212}
213
214IV
14d89041 215PerlIOScalar_flush(pTHX_ PerlIO * f)
f6c77cf1 216{
c33e8be1 217 PERL_UNUSED_ARG(f);
14d89041 218 return 0;
f6c77cf1
NIS
219}
220
221STDCHAR *
14d89041 222PerlIOScalar_get_base(pTHX_ PerlIO * f)
f6c77cf1 223{
14d89041
NIS
224 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
225 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
ffe0bb5a 226 SvGETMAGIC(s->var);
14d89041
NIS
227 return (STDCHAR *) SvPV_nolen(s->var);
228 }
9849c14c 229 return (STDCHAR *) NULL;
f6c77cf1
NIS
230}
231
232STDCHAR *
14d89041 233PerlIOScalar_get_ptr(pTHX_ PerlIO * f)
f6c77cf1 234{
14d89041
NIS
235 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
236 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
237 return PerlIOScalar_get_base(aTHX_ f) + s->posn;
238 }
9849c14c 239 return (STDCHAR *) NULL;
f6c77cf1
NIS
240}
241
242SSize_t
14d89041 243PerlIOScalar_get_cnt(pTHX_ PerlIO * f)
f6c77cf1 244{
14d89041
NIS
245 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
246 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
71edc894 247 STRLEN len;
ffe0bb5a 248 SvGETMAGIC(s->var);
71edc894
FC
249 if (isGV_with_GP(s->var))
250 (void)SvPV(s->var,len);
251 else len = SvCUR(s->var);
252 if (len > (STRLEN) s->posn)
253 return len - (STRLEN)s->posn;
14d89041
NIS
254 else
255 return 0;
256 }
75effbe0 257 return 0;
f6c77cf1
NIS
258}
259
260Size_t
14d89041 261PerlIOScalar_bufsiz(pTHX_ PerlIO * f)
f6c77cf1 262{
14d89041
NIS
263 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
264 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
ffe0bb5a 265 SvGETMAGIC(s->var);
14d89041
NIS
266 return SvCUR(s->var);
267 }
268 return 0;
f6c77cf1
NIS
269}
270
271void
14d89041 272PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
f6c77cf1 273{
14d89041 274 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
71edc894 275 STRLEN len;
c33e8be1 276 PERL_UNUSED_ARG(ptr);
ffe0bb5a 277 SvGETMAGIC(s->var);
71edc894
FC
278 if (isGV_with_GP(s->var)) (void)SvPV(s->var,len);
279 else len = SvCUR(s->var);
280 s->posn = len - cnt;
f6c77cf1
NIS
281}
282
283PerlIO *
14d89041
NIS
284PerlIOScalar_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, IV n,
285 const char *mode, int fd, int imode, int perm,
286 PerlIO * f, int narg, SV ** args)
f6c77cf1 287{
14d89041 288 SV *arg = (narg > 0) ? *args : PerlIOArg;
c33e8be1
Z
289 PERL_UNUSED_ARG(fd);
290 PERL_UNUSED_ARG(imode);
291 PERL_UNUSED_ARG(perm);
14d89041
NIS
292 if (SvROK(arg) || SvPOK(arg)) {
293 if (!f) {
294 f = PerlIO_allocate(aTHX);
295 }
e3feee4e 296 if ( (f = PerlIO_push(aTHX_ f, self, mode, arg)) ) {
14d89041
NIS
297 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
298 }
299 return f;
300 }
301 return NULL;
f6c77cf1
NIS
302}
303
ecdeb87c 304SV *
14d89041 305PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
ecdeb87c 306{
14d89041
NIS
307 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
308 SV *var = s->var;
309 if (flags & PERLIO_DUP_CLONE)
310 var = PerlIO_sv_dup(aTHX_ var, param);
311 else if (flags & PERLIO_DUP_FD) {
312 /* Equivalent (guesses NI-S) of dup() is to create a new scalar */
313 var = newSVsv(var);
314 }
315 else {
316 var = SvREFCNT_inc(var);
317 }
318 return newRV_noinc(var);
ecdeb87c
NIS
319}
320
8cf8f3d1 321PerlIO *
14d89041
NIS
322PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
323 int flags)
8cf8f3d1 324{
49b69fb3
FC
325 /* Duplication causes the scalar layer to be pushed on to clone, caus-
326 ing the cloned scalar to be set to the empty string by
327 PerlIOScalar_pushed. So set aside our scalar temporarily. */
328 PerlIOScalar * const os = PerlIOSelf(o, PerlIOScalar);
7b3cf1c0 329 PerlIOScalar *fs;
49b69fb3
FC
330 SV * const var = os->var;
331 os->var = newSVpvs("");
14d89041 332 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
7b3cf1c0 333 fs = PerlIOSelf(f, PerlIOScalar);
49b69fb3
FC
334 /* var has been set by implicit push, so replace it */
335 SvREFCNT_dec(fs->var);
14d89041 336 }
49b69fb3
FC
337 SvREFCNT_dec(os->var);
338 os->var = var;
7b3cf1c0
FC
339 if (f) {
340 SV * const rv = PerlIOScalar_arg(aTHX_ o, param, flags);
341 fs->var = SvREFCNT_inc(SvRV(rv));
342 SvREFCNT_dec(rv);
343 fs->posn = os->posn;
344 }
14d89041 345 return f;
8cf8f3d1 346}
f6c77cf1 347
27da23d5 348PERLIO_FUNCS_DECL(PerlIO_scalar) = {
14d89041
NIS
349 sizeof(PerlIO_funcs),
350 "scalar",
351 sizeof(PerlIOScalar),
352 PERLIO_K_BUFFERED | PERLIO_K_RAW,
353 PerlIOScalar_pushed,
354 PerlIOScalar_popped,
355 PerlIOScalar_open,
356 PerlIOBase_binmode,
357 PerlIOScalar_arg,
358 PerlIOScalar_fileno,
359 PerlIOScalar_dup,
ffe0bb5a 360 PerlIOScalar_read,
3ff3a8b6 361 NULL, /* unread */
14d89041
NIS
362 PerlIOScalar_write,
363 PerlIOScalar_seek,
364 PerlIOScalar_tell,
365 PerlIOScalar_close,
366 PerlIOScalar_flush,
367 PerlIOScalar_fill,
368 PerlIOBase_eof,
369 PerlIOBase_error,
370 PerlIOBase_clearerr,
371 PerlIOBase_setlinebuf,
372 PerlIOScalar_get_base,
373 PerlIOScalar_bufsiz,
374 PerlIOScalar_get_ptr,
375 PerlIOScalar_get_cnt,
376 PerlIOScalar_set_ptrcnt,
f6c77cf1
NIS
377};
378
379
380#endif /* Layers available */
381
e934609f 382MODULE = PerlIO::scalar PACKAGE = PerlIO::scalar
f6c77cf1 383
acf4de66
A
384PROTOTYPES: ENABLE
385
f6c77cf1
NIS
386BOOT:
387{
388#ifdef PERLIO_LAYERS
27da23d5 389 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_scalar));
f6c77cf1
NIS
390#endif
391}
392