This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ext/ + -Wall
[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
9typedef struct
10{
11 struct _PerlIO base; /* Base "class" info */
12 SV * var;
13 Off_t posn;
14} PerlIOScalar;
15
16IV
17PerlIOScalar_pushed(PerlIO *f, const char *mode, SV *arg)
18{
564dc057 19 dTHX;
09bf542c 20 IV code;
564dc057
NIS
21 PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
22 /* If called (normally) via open() then arg is ref to scalar we are
23 using, otherwise arg (from binmode presumably) is either NULL
24 or the _name_ of the scalar
25 */
26 if (arg)
27 {
28 if (SvROK(arg))
29 {
30 s->var = SvREFCNT_inc(SvRV(arg));
31 }
32 else
33 {
34 s->var = SvREFCNT_inc(perl_get_sv(SvPV_nolen(arg),GV_ADD|GV_ADDMULTI));
35 }
36 }
37 else
38 {
39 s->var = newSVpvn("",0);
40 }
41 sv_upgrade(s->var,SVt_PV);
09bf542c
BS
42 code = PerlIOBase_pushed(f,mode,Nullsv);
43 if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
c350b88c
BS
44 s->posn = SvCUR(SvRV(arg));
45 else
46 s->posn = 0;
ae1204bf
BS
47 if ((PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
48 SvCUR(SvRV(arg)) = 0;
09bf542c 49 return code;
f6c77cf1
NIS
50}
51
52IV
53PerlIOScalar_popped(PerlIO *f)
54{
55 PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
56 if (s->var)
57 {
58 dTHX;
59 SvREFCNT_dec(s->var);
60 s->var = Nullsv;
61 }
62 return 0;
63}
64
65IV
66PerlIOScalar_close(PerlIO *f)
67{
f6c77cf1 68 IV code = PerlIOBase_close(f);
f6c77cf1
NIS
69 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
70 return code;
71}
72
73IV
74PerlIOScalar_fileno(PerlIO *f)
75{
76 return -1;
77}
78
79IV
80PerlIOScalar_seek(PerlIO *f, Off_t offset, int whence)
81{
82 PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
83 switch(whence)
84 {
85 case 0:
86 s->posn = offset;
87 break;
88 case 1:
89 s->posn = offset + s->posn;
90 break;
91 case 2:
92 s->posn = offset + SvCUR(s->var);
93 break;
94 }
95 if (s->posn > SvCUR(s->var))
96 {
97 dTHX;
98 (void) SvGROW(s->var,s->posn);
99 }
100 return 0;
101}
102
103Off_t
104PerlIOScalar_tell(PerlIO *f)
105{
106 PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
107 return s->posn;
108}
109
110SSize_t
111PerlIOScalar_unread(PerlIO *f, const void *vbuf, Size_t count)
112{
113 dTHX;
114 PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
115 char *dst = SvGROW(s->var,s->posn+count);
773aa825 116 Move(vbuf,dst+s->posn,count,char);
f6c77cf1
NIS
117 s->posn += count;
118 SvCUR_set(s->var,s->posn);
119 SvPOK_on(s->var);
120 return count;
121}
122
123SSize_t
124PerlIOScalar_write(PerlIO *f, const void *vbuf, Size_t count)
125{
126 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
127 {
09bf542c
BS
128 dTHX;
129 Off_t offset;
130 PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
131 SV *sv = s->var;
132 char *dst;
133 if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
134 {
135 dst = SvGROW(sv,SvCUR(sv)+count);
136 offset = SvCUR(sv);
137 s->posn = offset+count;
138 }
139 else
140 {
141 if ((s->posn+count) > SvCUR(sv))
142 dst = SvGROW(sv,s->posn+count);
143 else
144 dst = SvPV_nolen(sv);
145 offset = s->posn;
146 s->posn += count;
147 }
148 Move(vbuf,dst+offset,count,char);
149 if (s->posn > SvCUR(sv))
150 SvCUR_set(sv,s->posn);
151 SvPOK_on(s->var);
152 return count;
f6c77cf1 153 }
09bf542c
BS
154 else
155 return 0;
f6c77cf1
NIS
156}
157
158IV
159PerlIOScalar_fill(PerlIO *f)
160{
161 return -1;
162}
163
164IV
165PerlIOScalar_flush(PerlIO *f)
166{
167 return 0;
168}
169
170STDCHAR *
171PerlIOScalar_get_base(PerlIO *f)
172{
173 PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
174 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
175 {
176 dTHX;
177 return (STDCHAR *)SvPV_nolen(s->var);
178 }
a144b989 179 return (STDCHAR *) Nullch;
f6c77cf1
NIS
180}
181
182STDCHAR *
183PerlIOScalar_get_ptr(PerlIO *f)
184{
185 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
186 {
187 PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
188 return PerlIOScalar_get_base(f)+s->posn;
189 }
190 return (STDCHAR *) Nullch;
191}
192
193SSize_t
194PerlIOScalar_get_cnt(PerlIO *f)
195{
196 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
197 {
198 PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
75effbe0
BS
199 if (SvCUR(s->var) > s->posn)
200 return SvCUR(s->var) - s->posn;
201 else
202 return 0;
f6c77cf1
NIS
203 }
204 return 0;
205}
206
207Size_t
208PerlIOScalar_bufsiz(PerlIO *f)
209{
210 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
211 {
212 PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
213 return SvCUR(s->var);
214 }
215 return 0;
216}
217
218void
219PerlIOScalar_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
220{
221 PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
222 s->posn = SvCUR(s->var)-cnt;
223}
224
225PerlIO *
226PerlIOScalar_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
227{
228 PerlIOScalar *s;
564dc057
NIS
229 SV *arg = (narg > 0) ? *args : PerlIOArg;
230 if (SvROK(arg) || SvPOK(arg))
f6c77cf1 231 {
564dc057
NIS
232 f = PerlIO_allocate(aTHX);
233 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,arg),PerlIOScalar);
234 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
235 return f;
f6c77cf1
NIS
236 }
237 return NULL;
238}
239
240
241PerlIO_funcs PerlIO_scalar = {
242 "Scalar",
243 sizeof(PerlIOScalar),
244 PERLIO_K_BUFFERED,
245 PerlIOScalar_pushed,
246 PerlIOScalar_popped,
247 PerlIOScalar_open,
248 NULL,
249 PerlIOScalar_fileno,
250 PerlIOBase_read,
251 PerlIOScalar_unread,
252 PerlIOScalar_write,
253 PerlIOScalar_seek,
254 PerlIOScalar_tell,
255 PerlIOScalar_close,
256 PerlIOScalar_flush,
257 PerlIOScalar_fill,
258 PerlIOBase_eof,
259 PerlIOBase_error,
260 PerlIOBase_clearerr,
261 PerlIOBase_setlinebuf,
262 PerlIOScalar_get_base,
263 PerlIOScalar_bufsiz,
264 PerlIOScalar_get_ptr,
265 PerlIOScalar_get_cnt,
266 PerlIOScalar_set_ptrcnt,
267};
268
269
270#endif /* Layers available */
271
272MODULE = PerlIO::Scalar PACKAGE = PerlIO::Scalar
273
acf4de66
A
274PROTOTYPES: ENABLE
275
f6c77cf1
NIS
276BOOT:
277{
278#ifdef PERLIO_LAYERS
279 PerlIO_define_layer(aTHX_ &PerlIO_scalar);
280#endif
281}
282