This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Test %main::OVERLOAD, which was almost broken by a proposed fix for
[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 */
25 if (arg) {
cba44c14 26 if (SvROK(arg)) {
b35bc0c6
RGS
27 if (SvREADONLY(SvRV(arg)) && mode && *mode != 'r') {
28 if (ckWARN(WARN_LAYER))
76c6a213 29 Perl_warner(aTHX_ packWARN(WARN_LAYER), "%s", PL_no_modify);
42bc49da 30 SETERRNO(EINVAL, SS_IVCHAN);
b35bc0c6
RGS
31 return -1;
32 }
14d89041 33 s->var = SvREFCNT_inc(SvRV(arg));
22ccb26d
BM
34 SvGETMAGIC(s->var);
35 if (!SvPOK(s->var) && SvOK(s->var))
36 (void)SvPV_nomg_const_nolen(s->var);
14d89041
NIS
37 }
38 else {
39 s->var =
40 SvREFCNT_inc(perl_get_sv
41 (SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
42 }
564dc057 43 }
14d89041
NIS
44 else {
45 s->var = newSVpvn("", 0);
564dc057 46 }
c5b94a97 47 SvUPGRADE(s->var, SVt_PV);
14d89041 48 code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
47cc46ee 49 if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
b162af07 50 SvCUR_set(s->var, 0);
14d89041
NIS
51 if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
52 s->posn = SvCUR(s->var);
53 else
54 s->posn = 0;
ffe0bb5a 55 SvSETMAGIC(s->var);
14d89041 56 return code;
f6c77cf1
NIS
57}
58
59IV
14d89041 60PerlIOScalar_popped(pTHX_ PerlIO * f)
f6c77cf1 61{
14d89041
NIS
62 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
63 if (s->var) {
64 SvREFCNT_dec(s->var);
65 s->var = Nullsv;
66 }
67 return 0;
f6c77cf1
NIS
68}
69
70IV
14d89041 71PerlIOScalar_close(pTHX_ PerlIO * f)
f6c77cf1 72{
14d89041
NIS
73 IV code = PerlIOBase_close(aTHX_ f);
74 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
75 return code;
f6c77cf1
NIS
76}
77
78IV
14d89041 79PerlIOScalar_fileno(pTHX_ PerlIO * f)
f6c77cf1 80{
14d89041 81 return -1;
f6c77cf1
NIS
82}
83
84IV
14d89041 85PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
f6c77cf1 86{
14d89041 87 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
e94207f0 88 STRLEN oldcur;
42bc49da 89 STRLEN newlen;
e94207f0
NC
90
91 SvGETMAGIC(s->var);
92 oldcur = SvCUR(s->var);
93
14d89041 94 switch (whence) {
42bc49da 95 case SEEK_SET:
14d89041
NIS
96 s->posn = offset;
97 break;
42bc49da 98 case SEEK_CUR:
14d89041
NIS
99 s->posn = offset + s->posn;
100 break;
42bc49da 101 case SEEK_END:
14d89041
NIS
102 s->posn = offset + SvCUR(s->var);
103 break;
104 }
42bc49da
JH
105 if (s->posn < 0) {
106 if (ckWARN(WARN_LAYER))
107 Perl_warner(aTHX_ packWARN(WARN_LAYER), "Offset outside string");
108 SETERRNO(EINVAL, SS_IVCHAN);
109 return -1;
14d89041 110 }
42bc49da
JH
111 newlen = (STRLEN) s->posn;
112 if (newlen > oldcur) {
113 (void) SvGROW(s->var, newlen);
114 Zero(SvPVX(s->var) + oldcur, newlen - oldcur, char);
115 /* No SvCUR_set(), though. This is just a seek, not a write. */
116 }
8b8eea96
RGS
117 else if (!SvPVX(s->var)) {
118 /* ensure there's always a character buffer */
119 (void)SvGROW(s->var,1);
120 }
42bc49da 121 SvPOK_on(s->var);
14d89041 122 return 0;
f6c77cf1
NIS
123}
124
125Off_t
14d89041 126PerlIOScalar_tell(pTHX_ PerlIO * f)
f6c77cf1 127{
14d89041
NIS
128 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
129 return s->posn;
f6c77cf1
NIS
130}
131
ffe0bb5a
DM
132
133SSize_t
134PerlIOScalar_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
135{
136 if (!f)
137 return 0;
138 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
139 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
140 SETERRNO(EBADF, SS_IVCHAN);
141 return 0;
142 }
143 {
144 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
145 SV *sv = s->var;
146 char *p;
147 STRLEN len, got;
148 p = SvPV(sv, len);
149 got = len - (STRLEN)(s->posn);
150 if (got <= 0)
151 return 0;
152 if (got > (STRLEN)count)
153 got = (STRLEN)count;
154 Copy(p + (STRLEN)(s->posn), vbuf, got, STDCHAR);
155 s->posn += (Off_t)got;
156 return (SSize_t)got;
157 }
158}
159
f6c77cf1 160SSize_t
14d89041 161PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
f6c77cf1 162{
14d89041
NIS
163 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
164 Off_t offset;
165 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
166 SV *sv = s->var;
167 char *dst;
ffe0bb5a 168 SvGETMAGIC(sv);
14d89041
NIS
169 if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
170 dst = SvGROW(sv, SvCUR(sv) + count);
171 offset = SvCUR(sv);
172 s->posn = offset + count;
173 }
174 else {
175 if ((s->posn + count) > SvCUR(sv))
4a9d6100 176 dst = SvGROW(sv, (STRLEN)s->posn + count);
14d89041 177 else
ffe0bb5a 178 dst = SvPVX(sv);
14d89041
NIS
179 offset = s->posn;
180 s->posn += count;
181 }
182 Move(vbuf, dst + offset, count, char);
183 if ((STRLEN) s->posn > SvCUR(sv))
4a9d6100 184 SvCUR_set(sv, (STRLEN)s->posn);
ffe0bb5a
DM
185 SvPOK_on(sv);
186 SvSETMAGIC(sv);
14d89041 187 return count;
09bf542c 188 }
14d89041
NIS
189 else
190 return 0;
f6c77cf1
NIS
191}
192
193IV
14d89041 194PerlIOScalar_fill(pTHX_ PerlIO * f)
f6c77cf1 195{
14d89041 196 return -1;
f6c77cf1
NIS
197}
198
199IV
14d89041 200PerlIOScalar_flush(pTHX_ PerlIO * f)
f6c77cf1 201{
14d89041 202 return 0;
f6c77cf1
NIS
203}
204
205STDCHAR *
14d89041 206PerlIOScalar_get_base(pTHX_ PerlIO * f)
f6c77cf1 207{
14d89041
NIS
208 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
209 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
ffe0bb5a 210 SvGETMAGIC(s->var);
14d89041
NIS
211 return (STDCHAR *) SvPV_nolen(s->var);
212 }
9849c14c 213 return (STDCHAR *) NULL;
f6c77cf1
NIS
214}
215
216STDCHAR *
14d89041 217PerlIOScalar_get_ptr(pTHX_ PerlIO * f)
f6c77cf1 218{
14d89041
NIS
219 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
220 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
221 return PerlIOScalar_get_base(aTHX_ f) + s->posn;
222 }
9849c14c 223 return (STDCHAR *) NULL;
f6c77cf1
NIS
224}
225
226SSize_t
14d89041 227PerlIOScalar_get_cnt(pTHX_ PerlIO * f)
f6c77cf1 228{
14d89041
NIS
229 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
230 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
ffe0bb5a 231 SvGETMAGIC(s->var);
14d89041 232 if (SvCUR(s->var) > (STRLEN) s->posn)
4a9d6100 233 return SvCUR(s->var) - (STRLEN)s->posn;
14d89041
NIS
234 else
235 return 0;
236 }
75effbe0 237 return 0;
f6c77cf1
NIS
238}
239
240Size_t
14d89041 241PerlIOScalar_bufsiz(pTHX_ PerlIO * f)
f6c77cf1 242{
14d89041
NIS
243 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
244 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
ffe0bb5a 245 SvGETMAGIC(s->var);
14d89041
NIS
246 return SvCUR(s->var);
247 }
248 return 0;
f6c77cf1
NIS
249}
250
251void
14d89041 252PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
f6c77cf1 253{
14d89041 254 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
ffe0bb5a 255 SvGETMAGIC(s->var);
14d89041 256 s->posn = SvCUR(s->var) - cnt;
f6c77cf1
NIS
257}
258
259PerlIO *
14d89041
NIS
260PerlIOScalar_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, IV n,
261 const char *mode, int fd, int imode, int perm,
262 PerlIO * f, int narg, SV ** args)
f6c77cf1 263{
14d89041
NIS
264 SV *arg = (narg > 0) ? *args : PerlIOArg;
265 if (SvROK(arg) || SvPOK(arg)) {
266 if (!f) {
267 f = PerlIO_allocate(aTHX);
268 }
e3feee4e 269 if ( (f = PerlIO_push(aTHX_ f, self, mode, arg)) ) {
14d89041
NIS
270 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
271 }
272 return f;
273 }
274 return NULL;
f6c77cf1
NIS
275}
276
ecdeb87c 277SV *
14d89041 278PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
ecdeb87c 279{
14d89041
NIS
280 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
281 SV *var = s->var;
282 if (flags & PERLIO_DUP_CLONE)
283 var = PerlIO_sv_dup(aTHX_ var, param);
284 else if (flags & PERLIO_DUP_FD) {
285 /* Equivalent (guesses NI-S) of dup() is to create a new scalar */
286 var = newSVsv(var);
287 }
288 else {
289 var = SvREFCNT_inc(var);
290 }
291 return newRV_noinc(var);
ecdeb87c
NIS
292}
293
8cf8f3d1 294PerlIO *
14d89041
NIS
295PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
296 int flags)
8cf8f3d1 297{
14d89041
NIS
298 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
299 PerlIOScalar *fs = PerlIOSelf(f, PerlIOScalar);
300 PerlIOScalar *os = PerlIOSelf(o, PerlIOScalar);
301 /* var has been set by implicit push */
302 fs->posn = os->posn;
303 }
304 return f;
8cf8f3d1 305}
f6c77cf1 306
27da23d5 307PERLIO_FUNCS_DECL(PerlIO_scalar) = {
14d89041
NIS
308 sizeof(PerlIO_funcs),
309 "scalar",
310 sizeof(PerlIOScalar),
311 PERLIO_K_BUFFERED | PERLIO_K_RAW,
312 PerlIOScalar_pushed,
313 PerlIOScalar_popped,
314 PerlIOScalar_open,
315 PerlIOBase_binmode,
316 PerlIOScalar_arg,
317 PerlIOScalar_fileno,
318 PerlIOScalar_dup,
ffe0bb5a 319 PerlIOScalar_read,
3ff3a8b6 320 NULL, /* unread */
14d89041
NIS
321 PerlIOScalar_write,
322 PerlIOScalar_seek,
323 PerlIOScalar_tell,
324 PerlIOScalar_close,
325 PerlIOScalar_flush,
326 PerlIOScalar_fill,
327 PerlIOBase_eof,
328 PerlIOBase_error,
329 PerlIOBase_clearerr,
330 PerlIOBase_setlinebuf,
331 PerlIOScalar_get_base,
332 PerlIOScalar_bufsiz,
333 PerlIOScalar_get_ptr,
334 PerlIOScalar_get_cnt,
335 PerlIOScalar_set_ptrcnt,
f6c77cf1
NIS
336};
337
338
339#endif /* Layers available */
340
e934609f 341MODULE = PerlIO::scalar PACKAGE = PerlIO::scalar
f6c77cf1 342
acf4de66
A
343PROTOTYPES: ENABLE
344
f6c77cf1
NIS
345BOOT:
346{
347#ifdef PERLIO_LAYERS
27da23d5 348 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_scalar));
f6c77cf1
NIS
349#endif
350}
351