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