This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [PATCH] Add hook for re_dup() into regex engine as reg_dupe (make re pluggable...
[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))
29 Perl_warner(aTHX_ packWARN(WARN_LAYER), PL_no_modify);
30 errno = EINVAL;
31 return -1;
32 }
14d89041 33 s->var = SvREFCNT_inc(SvRV(arg));
03aa69f9 34 if (!SvPOK(s->var) && SvTYPE(SvRV(arg)) > SVt_NULL)
34fcc551 35 (void)SvPV_nolen(s->var);
14d89041
NIS
36 }
37 else {
38 s->var =
39 SvREFCNT_inc(perl_get_sv
40 (SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
41 }
564dc057 42 }
14d89041
NIS
43 else {
44 s->var = newSVpvn("", 0);
564dc057 45 }
c5b94a97 46 SvUPGRADE(s->var, SVt_PV);
14d89041 47 code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
47cc46ee 48 if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
b162af07 49 SvCUR_set(s->var, 0);
14d89041
NIS
50 if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
51 s->posn = SvCUR(s->var);
52 else
53 s->posn = 0;
54 return code;
f6c77cf1
NIS
55}
56
57IV
14d89041 58PerlIOScalar_popped(pTHX_ PerlIO * f)
f6c77cf1 59{
14d89041
NIS
60 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
61 if (s->var) {
62 SvREFCNT_dec(s->var);
63 s->var = Nullsv;
64 }
65 return 0;
f6c77cf1
NIS
66}
67
68IV
14d89041 69PerlIOScalar_close(pTHX_ PerlIO * f)
f6c77cf1 70{
14d89041
NIS
71 IV code = PerlIOBase_close(aTHX_ f);
72 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
73 return code;
f6c77cf1
NIS
74}
75
76IV
14d89041 77PerlIOScalar_fileno(pTHX_ PerlIO * f)
f6c77cf1 78{
14d89041 79 return -1;
f6c77cf1
NIS
80}
81
82IV
14d89041 83PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
f6c77cf1 84{
14d89041
NIS
85 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
86 switch (whence) {
87 case 0:
88 s->posn = offset;
89 break;
90 case 1:
91 s->posn = offset + s->posn;
92 break;
93 case 2:
94 s->posn = offset + SvCUR(s->var);
95 break;
96 }
97 if ((STRLEN) s->posn > SvCUR(s->var)) {
98 (void) SvGROW(s->var, (STRLEN) s->posn);
99 }
100 return 0;
f6c77cf1
NIS
101}
102
103Off_t
14d89041 104PerlIOScalar_tell(pTHX_ PerlIO * f)
f6c77cf1 105{
14d89041
NIS
106 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
107 return s->posn;
f6c77cf1
NIS
108}
109
110SSize_t
14d89041 111PerlIOScalar_unread(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
f6c77cf1 112{
14d89041 113 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
4a9d6100 114 char *dst = SvGROW(s->var, (STRLEN)s->posn + count);
5735c168 115 s->posn -= count;
14d89041 116 Move(vbuf, dst + s->posn, count, char);
14d89041
NIS
117 SvPOK_on(s->var);
118 return count;
f6c77cf1
NIS
119}
120
121SSize_t
14d89041 122PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
f6c77cf1 123{
14d89041
NIS
124 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
125 Off_t offset;
126 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
127 SV *sv = s->var;
128 char *dst;
129 if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
130 dst = SvGROW(sv, SvCUR(sv) + count);
131 offset = SvCUR(sv);
132 s->posn = offset + count;
133 }
134 else {
135 if ((s->posn + count) > SvCUR(sv))
4a9d6100 136 dst = SvGROW(sv, (STRLEN)s->posn + count);
14d89041
NIS
137 else
138 dst = SvPV_nolen(sv);
139 offset = s->posn;
140 s->posn += count;
141 }
142 Move(vbuf, dst + offset, count, char);
143 if ((STRLEN) s->posn > SvCUR(sv))
4a9d6100 144 SvCUR_set(sv, (STRLEN)s->posn);
14d89041
NIS
145 SvPOK_on(s->var);
146 return count;
09bf542c 147 }
14d89041
NIS
148 else
149 return 0;
f6c77cf1
NIS
150}
151
152IV
14d89041 153PerlIOScalar_fill(pTHX_ PerlIO * f)
f6c77cf1 154{
14d89041 155 return -1;
f6c77cf1
NIS
156}
157
158IV
14d89041 159PerlIOScalar_flush(pTHX_ PerlIO * f)
f6c77cf1 160{
14d89041 161 return 0;
f6c77cf1
NIS
162}
163
164STDCHAR *
14d89041 165PerlIOScalar_get_base(pTHX_ PerlIO * f)
f6c77cf1 166{
14d89041
NIS
167 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
168 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
169 return (STDCHAR *) SvPV_nolen(s->var);
170 }
171 return (STDCHAR *) Nullch;
f6c77cf1
NIS
172}
173
174STDCHAR *
14d89041 175PerlIOScalar_get_ptr(pTHX_ PerlIO * f)
f6c77cf1 176{
14d89041
NIS
177 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
178 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
179 return PerlIOScalar_get_base(aTHX_ f) + s->posn;
180 }
181 return (STDCHAR *) Nullch;
f6c77cf1
NIS
182}
183
184SSize_t
14d89041 185PerlIOScalar_get_cnt(pTHX_ PerlIO * f)
f6c77cf1 186{
14d89041
NIS
187 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
188 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
189 if (SvCUR(s->var) > (STRLEN) s->posn)
4a9d6100 190 return SvCUR(s->var) - (STRLEN)s->posn;
14d89041
NIS
191 else
192 return 0;
193 }
75effbe0 194 return 0;
f6c77cf1
NIS
195}
196
197Size_t
14d89041 198PerlIOScalar_bufsiz(pTHX_ PerlIO * f)
f6c77cf1 199{
14d89041
NIS
200 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
201 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
202 return SvCUR(s->var);
203 }
204 return 0;
f6c77cf1
NIS
205}
206
207void
14d89041 208PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
f6c77cf1 209{
14d89041
NIS
210 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
211 s->posn = SvCUR(s->var) - cnt;
f6c77cf1
NIS
212}
213
214PerlIO *
14d89041
NIS
215PerlIOScalar_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, IV n,
216 const char *mode, int fd, int imode, int perm,
217 PerlIO * f, int narg, SV ** args)
f6c77cf1 218{
14d89041
NIS
219 SV *arg = (narg > 0) ? *args : PerlIOArg;
220 if (SvROK(arg) || SvPOK(arg)) {
221 if (!f) {
222 f = PerlIO_allocate(aTHX);
223 }
e3feee4e 224 if ( (f = PerlIO_push(aTHX_ f, self, mode, arg)) ) {
14d89041
NIS
225 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
226 }
227 return f;
228 }
229 return NULL;
f6c77cf1
NIS
230}
231
ecdeb87c 232SV *
14d89041 233PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
ecdeb87c 234{
14d89041
NIS
235 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
236 SV *var = s->var;
237 if (flags & PERLIO_DUP_CLONE)
238 var = PerlIO_sv_dup(aTHX_ var, param);
239 else if (flags & PERLIO_DUP_FD) {
240 /* Equivalent (guesses NI-S) of dup() is to create a new scalar */
241 var = newSVsv(var);
242 }
243 else {
244 var = SvREFCNT_inc(var);
245 }
246 return newRV_noinc(var);
ecdeb87c
NIS
247}
248
8cf8f3d1 249PerlIO *
14d89041
NIS
250PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
251 int flags)
8cf8f3d1 252{
14d89041
NIS
253 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
254 PerlIOScalar *fs = PerlIOSelf(f, PerlIOScalar);
255 PerlIOScalar *os = PerlIOSelf(o, PerlIOScalar);
256 /* var has been set by implicit push */
257 fs->posn = os->posn;
258 }
259 return f;
8cf8f3d1 260}
f6c77cf1 261
27da23d5 262PERLIO_FUNCS_DECL(PerlIO_scalar) = {
14d89041
NIS
263 sizeof(PerlIO_funcs),
264 "scalar",
265 sizeof(PerlIOScalar),
266 PERLIO_K_BUFFERED | PERLIO_K_RAW,
267 PerlIOScalar_pushed,
268 PerlIOScalar_popped,
269 PerlIOScalar_open,
270 PerlIOBase_binmode,
271 PerlIOScalar_arg,
272 PerlIOScalar_fileno,
273 PerlIOScalar_dup,
274 PerlIOBase_read,
275 PerlIOScalar_unread,
276 PerlIOScalar_write,
277 PerlIOScalar_seek,
278 PerlIOScalar_tell,
279 PerlIOScalar_close,
280 PerlIOScalar_flush,
281 PerlIOScalar_fill,
282 PerlIOBase_eof,
283 PerlIOBase_error,
284 PerlIOBase_clearerr,
285 PerlIOBase_setlinebuf,
286 PerlIOScalar_get_base,
287 PerlIOScalar_bufsiz,
288 PerlIOScalar_get_ptr,
289 PerlIOScalar_get_cnt,
290 PerlIOScalar_set_ptrcnt,
f6c77cf1
NIS
291};
292
293
294#endif /* Layers available */
295
e934609f 296MODULE = PerlIO::scalar PACKAGE = PerlIO::scalar
f6c77cf1 297
acf4de66
A
298PROTOTYPES: ENABLE
299
f6c77cf1
NIS
300BOOT:
301{
302#ifdef PERLIO_LAYERS
27da23d5 303 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_scalar));
f6c77cf1
NIS
304#endif
305}
306