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