This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Silence one more format warning
[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_unread(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
f6c77cf1 129{
14d89041 130 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
4a9d6100 131 char *dst = SvGROW(s->var, (STRLEN)s->posn + count);
5735c168 132 s->posn -= count;
14d89041 133 Move(vbuf, dst + s->posn, count, char);
14d89041
NIS
134 SvPOK_on(s->var);
135 return count;
f6c77cf1
NIS
136}
137
138SSize_t
14d89041 139PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
f6c77cf1 140{
14d89041
NIS
141 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
142 Off_t offset;
143 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
144 SV *sv = s->var;
145 char *dst;
146 if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
147 dst = SvGROW(sv, SvCUR(sv) + count);
148 offset = SvCUR(sv);
149 s->posn = offset + count;
150 }
151 else {
152 if ((s->posn + count) > SvCUR(sv))
4a9d6100 153 dst = SvGROW(sv, (STRLEN)s->posn + count);
14d89041
NIS
154 else
155 dst = SvPV_nolen(sv);
156 offset = s->posn;
157 s->posn += count;
158 }
159 Move(vbuf, dst + offset, count, char);
160 if ((STRLEN) s->posn > SvCUR(sv))
4a9d6100 161 SvCUR_set(sv, (STRLEN)s->posn);
14d89041
NIS
162 SvPOK_on(s->var);
163 return count;
09bf542c 164 }
14d89041
NIS
165 else
166 return 0;
f6c77cf1
NIS
167}
168
169IV
14d89041 170PerlIOScalar_fill(pTHX_ PerlIO * f)
f6c77cf1 171{
14d89041 172 return -1;
f6c77cf1
NIS
173}
174
175IV
14d89041 176PerlIOScalar_flush(pTHX_ PerlIO * f)
f6c77cf1 177{
14d89041 178 return 0;
f6c77cf1
NIS
179}
180
181STDCHAR *
14d89041 182PerlIOScalar_get_base(pTHX_ PerlIO * f)
f6c77cf1 183{
14d89041
NIS
184 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
185 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
186 return (STDCHAR *) SvPV_nolen(s->var);
187 }
9849c14c 188 return (STDCHAR *) NULL;
f6c77cf1
NIS
189}
190
191STDCHAR *
14d89041 192PerlIOScalar_get_ptr(pTHX_ PerlIO * f)
f6c77cf1 193{
14d89041
NIS
194 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
195 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
196 return PerlIOScalar_get_base(aTHX_ f) + s->posn;
197 }
9849c14c 198 return (STDCHAR *) NULL;
f6c77cf1
NIS
199}
200
201SSize_t
14d89041 202PerlIOScalar_get_cnt(pTHX_ PerlIO * f)
f6c77cf1 203{
14d89041
NIS
204 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
205 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
206 if (SvCUR(s->var) > (STRLEN) s->posn)
4a9d6100 207 return SvCUR(s->var) - (STRLEN)s->posn;
14d89041
NIS
208 else
209 return 0;
210 }
75effbe0 211 return 0;
f6c77cf1
NIS
212}
213
214Size_t
14d89041 215PerlIOScalar_bufsiz(pTHX_ PerlIO * f)
f6c77cf1 216{
14d89041
NIS
217 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
218 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
219 return SvCUR(s->var);
220 }
221 return 0;
f6c77cf1
NIS
222}
223
224void
14d89041 225PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
f6c77cf1 226{
14d89041
NIS
227 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
228 s->posn = SvCUR(s->var) - cnt;
f6c77cf1
NIS
229}
230
231PerlIO *
14d89041
NIS
232PerlIOScalar_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, IV n,
233 const char *mode, int fd, int imode, int perm,
234 PerlIO * f, int narg, SV ** args)
f6c77cf1 235{
14d89041
NIS
236 SV *arg = (narg > 0) ? *args : PerlIOArg;
237 if (SvROK(arg) || SvPOK(arg)) {
238 if (!f) {
239 f = PerlIO_allocate(aTHX);
240 }
e3feee4e 241 if ( (f = PerlIO_push(aTHX_ f, self, mode, arg)) ) {
14d89041
NIS
242 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
243 }
244 return f;
245 }
246 return NULL;
f6c77cf1
NIS
247}
248
ecdeb87c 249SV *
14d89041 250PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
ecdeb87c 251{
14d89041
NIS
252 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
253 SV *var = s->var;
254 if (flags & PERLIO_DUP_CLONE)
255 var = PerlIO_sv_dup(aTHX_ var, param);
256 else if (flags & PERLIO_DUP_FD) {
257 /* Equivalent (guesses NI-S) of dup() is to create a new scalar */
258 var = newSVsv(var);
259 }
260 else {
261 var = SvREFCNT_inc(var);
262 }
263 return newRV_noinc(var);
ecdeb87c
NIS
264}
265
8cf8f3d1 266PerlIO *
14d89041
NIS
267PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
268 int flags)
8cf8f3d1 269{
14d89041
NIS
270 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
271 PerlIOScalar *fs = PerlIOSelf(f, PerlIOScalar);
272 PerlIOScalar *os = PerlIOSelf(o, PerlIOScalar);
273 /* var has been set by implicit push */
274 fs->posn = os->posn;
275 }
276 return f;
8cf8f3d1 277}
f6c77cf1 278
27da23d5 279PERLIO_FUNCS_DECL(PerlIO_scalar) = {
14d89041
NIS
280 sizeof(PerlIO_funcs),
281 "scalar",
282 sizeof(PerlIOScalar),
283 PERLIO_K_BUFFERED | PERLIO_K_RAW,
284 PerlIOScalar_pushed,
285 PerlIOScalar_popped,
286 PerlIOScalar_open,
287 PerlIOBase_binmode,
288 PerlIOScalar_arg,
289 PerlIOScalar_fileno,
290 PerlIOScalar_dup,
291 PerlIOBase_read,
292 PerlIOScalar_unread,
293 PerlIOScalar_write,
294 PerlIOScalar_seek,
295 PerlIOScalar_tell,
296 PerlIOScalar_close,
297 PerlIOScalar_flush,
298 PerlIOScalar_fill,
299 PerlIOBase_eof,
300 PerlIOBase_error,
301 PerlIOBase_clearerr,
302 PerlIOBase_setlinebuf,
303 PerlIOScalar_get_base,
304 PerlIOScalar_bufsiz,
305 PerlIOScalar_get_ptr,
306 PerlIOScalar_get_cnt,
307 PerlIOScalar_set_ptrcnt,
f6c77cf1
NIS
308};
309
310
311#endif /* Layers available */
312
e934609f 313MODULE = PerlIO::scalar PACKAGE = PerlIO::scalar
f6c77cf1 314
acf4de66
A
315PROTOTYPES: ENABLE
316
f6c77cf1
NIS
317BOOT:
318{
319#ifdef PERLIO_LAYERS
27da23d5 320 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_scalar));
f6c77cf1
NIS
321#endif
322}
323