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