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