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