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