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