This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix various compiler warnings from XS code
[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)
526fd1b4
FC
50 {
51 sv_force_normal(s->var);
b162af07 52 SvCUR_set(s->var, 0);
526fd1b4 53 }
14d89041 54 if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
526fd1b4
FC
55 {
56 sv_force_normal(s->var);
14d89041 57 s->posn = SvCUR(s->var);
526fd1b4 58 }
14d89041
NIS
59 else
60 s->posn = 0;
ffe0bb5a 61 SvSETMAGIC(s->var);
14d89041 62 return code;
f6c77cf1
NIS
63}
64
65IV
14d89041 66PerlIOScalar_popped(pTHX_ PerlIO * f)
f6c77cf1 67{
14d89041
NIS
68 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
69 if (s->var) {
70 SvREFCNT_dec(s->var);
71 s->var = Nullsv;
72 }
73 return 0;
f6c77cf1
NIS
74}
75
76IV
14d89041 77PerlIOScalar_close(pTHX_ PerlIO * f)
f6c77cf1 78{
14d89041
NIS
79 IV code = PerlIOBase_close(aTHX_ f);
80 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
81 return code;
f6c77cf1
NIS
82}
83
84IV
14d89041 85PerlIOScalar_fileno(pTHX_ PerlIO * f)
f6c77cf1 86{
c33e8be1 87 PERL_UNUSED_ARG(f);
14d89041 88 return -1;
f6c77cf1
NIS
89}
90
91IV
14d89041 92PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
f6c77cf1 93{
14d89041 94 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
e94207f0 95 STRLEN oldcur;
42bc49da 96 STRLEN newlen;
e94207f0
NC
97
98 SvGETMAGIC(s->var);
99 oldcur = SvCUR(s->var);
100
14d89041 101 switch (whence) {
42bc49da 102 case SEEK_SET:
14d89041
NIS
103 s->posn = offset;
104 break;
42bc49da 105 case SEEK_CUR:
14d89041
NIS
106 s->posn = offset + s->posn;
107 break;
42bc49da 108 case SEEK_END:
14d89041
NIS
109 s->posn = offset + SvCUR(s->var);
110 break;
111 }
42bc49da
JH
112 if (s->posn < 0) {
113 if (ckWARN(WARN_LAYER))
114 Perl_warner(aTHX_ packWARN(WARN_LAYER), "Offset outside string");
115 SETERRNO(EINVAL, SS_IVCHAN);
116 return -1;
14d89041 117 }
42bc49da
JH
118 newlen = (STRLEN) s->posn;
119 if (newlen > oldcur) {
120 (void) SvGROW(s->var, newlen);
121 Zero(SvPVX(s->var) + oldcur, newlen - oldcur, char);
122 /* No SvCUR_set(), though. This is just a seek, not a write. */
123 }
8b8eea96
RGS
124 else if (!SvPVX(s->var)) {
125 /* ensure there's always a character buffer */
126 (void)SvGROW(s->var,1);
127 }
42bc49da 128 SvPOK_on(s->var);
14d89041 129 return 0;
f6c77cf1
NIS
130}
131
132Off_t
14d89041 133PerlIOScalar_tell(pTHX_ PerlIO * f)
f6c77cf1 134{
14d89041
NIS
135 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
136 return s->posn;
f6c77cf1
NIS
137}
138
ffe0bb5a
DM
139
140SSize_t
141PerlIOScalar_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
142{
143 if (!f)
144 return 0;
145 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
146 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
147 SETERRNO(EBADF, SS_IVCHAN);
148 return 0;
149 }
150 {
151 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
152 SV *sv = s->var;
153 char *p;
ab9f1586
FC
154 STRLEN len;
155 I32 got;
ffe0bb5a
DM
156 p = SvPV(sv, len);
157 got = len - (STRLEN)(s->posn);
158 if (got <= 0)
159 return 0;
c33e8be1 160 if ((STRLEN)got > (STRLEN)count)
ffe0bb5a
DM
161 got = (STRLEN)count;
162 Copy(p + (STRLEN)(s->posn), vbuf, got, STDCHAR);
163 s->posn += (Off_t)got;
164 return (SSize_t)got;
165 }
166}
167
f6c77cf1 168SSize_t
14d89041 169PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
f6c77cf1 170{
14d89041
NIS
171 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
172 Off_t offset;
173 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
174 SV *sv = s->var;
175 char *dst;
ffe0bb5a 176 SvGETMAGIC(sv);
526fd1b4 177 sv_force_normal(sv);
14d89041
NIS
178 if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
179 dst = SvGROW(sv, SvCUR(sv) + count);
180 offset = SvCUR(sv);
181 s->posn = offset + count;
182 }
183 else {
184 if ((s->posn + count) > SvCUR(sv))
4a9d6100 185 dst = SvGROW(sv, (STRLEN)s->posn + count);
14d89041 186 else
ffe0bb5a 187 dst = SvPVX(sv);
14d89041
NIS
188 offset = s->posn;
189 s->posn += count;
190 }
191 Move(vbuf, dst + offset, count, char);
192 if ((STRLEN) s->posn > SvCUR(sv))
4a9d6100 193 SvCUR_set(sv, (STRLEN)s->posn);
ffe0bb5a
DM
194 SvPOK_on(sv);
195 SvSETMAGIC(sv);
14d89041 196 return count;
09bf542c 197 }
14d89041
NIS
198 else
199 return 0;
f6c77cf1
NIS
200}
201
202IV
14d89041 203PerlIOScalar_fill(pTHX_ PerlIO * f)
f6c77cf1 204{
c33e8be1 205 PERL_UNUSED_ARG(f);
14d89041 206 return -1;
f6c77cf1
NIS
207}
208
209IV
14d89041 210PerlIOScalar_flush(pTHX_ PerlIO * f)
f6c77cf1 211{
c33e8be1 212 PERL_UNUSED_ARG(f);
14d89041 213 return 0;
f6c77cf1
NIS
214}
215
216STDCHAR *
14d89041 217PerlIOScalar_get_base(pTHX_ PerlIO * f)
f6c77cf1 218{
14d89041
NIS
219 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
220 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
ffe0bb5a 221 SvGETMAGIC(s->var);
14d89041
NIS
222 return (STDCHAR *) SvPV_nolen(s->var);
223 }
9849c14c 224 return (STDCHAR *) NULL;
f6c77cf1
NIS
225}
226
227STDCHAR *
14d89041 228PerlIOScalar_get_ptr(pTHX_ PerlIO * f)
f6c77cf1 229{
14d89041
NIS
230 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
231 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
232 return PerlIOScalar_get_base(aTHX_ f) + s->posn;
233 }
9849c14c 234 return (STDCHAR *) NULL;
f6c77cf1
NIS
235}
236
237SSize_t
14d89041 238PerlIOScalar_get_cnt(pTHX_ PerlIO * f)
f6c77cf1 239{
14d89041
NIS
240 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
241 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
ffe0bb5a 242 SvGETMAGIC(s->var);
14d89041 243 if (SvCUR(s->var) > (STRLEN) s->posn)
4a9d6100 244 return SvCUR(s->var) - (STRLEN)s->posn;
14d89041
NIS
245 else
246 return 0;
247 }
75effbe0 248 return 0;
f6c77cf1
NIS
249}
250
251Size_t
14d89041 252PerlIOScalar_bufsiz(pTHX_ PerlIO * f)
f6c77cf1 253{
14d89041
NIS
254 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
255 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
ffe0bb5a 256 SvGETMAGIC(s->var);
14d89041
NIS
257 return SvCUR(s->var);
258 }
259 return 0;
f6c77cf1
NIS
260}
261
262void
14d89041 263PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
f6c77cf1 264{
14d89041 265 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
c33e8be1 266 PERL_UNUSED_ARG(ptr);
ffe0bb5a 267 SvGETMAGIC(s->var);
14d89041 268 s->posn = SvCUR(s->var) - cnt;
f6c77cf1
NIS
269}
270
271PerlIO *
14d89041
NIS
272PerlIOScalar_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, IV n,
273 const char *mode, int fd, int imode, int perm,
274 PerlIO * f, int narg, SV ** args)
f6c77cf1 275{
14d89041 276 SV *arg = (narg > 0) ? *args : PerlIOArg;
c33e8be1
Z
277 PERL_UNUSED_ARG(fd);
278 PERL_UNUSED_ARG(imode);
279 PERL_UNUSED_ARG(perm);
14d89041
NIS
280 if (SvROK(arg) || SvPOK(arg)) {
281 if (!f) {
282 f = PerlIO_allocate(aTHX);
283 }
e3feee4e 284 if ( (f = PerlIO_push(aTHX_ f, self, mode, arg)) ) {
14d89041
NIS
285 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
286 }
287 return f;
288 }
289 return NULL;
f6c77cf1
NIS
290}
291
ecdeb87c 292SV *
14d89041 293PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
ecdeb87c 294{
14d89041
NIS
295 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
296 SV *var = s->var;
297 if (flags & PERLIO_DUP_CLONE)
298 var = PerlIO_sv_dup(aTHX_ var, param);
299 else if (flags & PERLIO_DUP_FD) {
300 /* Equivalent (guesses NI-S) of dup() is to create a new scalar */
301 var = newSVsv(var);
302 }
303 else {
304 var = SvREFCNT_inc(var);
305 }
306 return newRV_noinc(var);
ecdeb87c
NIS
307}
308
8cf8f3d1 309PerlIO *
14d89041
NIS
310PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
311 int flags)
8cf8f3d1 312{
14d89041
NIS
313 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
314 PerlIOScalar *fs = PerlIOSelf(f, PerlIOScalar);
315 PerlIOScalar *os = PerlIOSelf(o, PerlIOScalar);
316 /* var has been set by implicit push */
317 fs->posn = os->posn;
318 }
319 return f;
8cf8f3d1 320}
f6c77cf1 321
27da23d5 322PERLIO_FUNCS_DECL(PerlIO_scalar) = {
14d89041
NIS
323 sizeof(PerlIO_funcs),
324 "scalar",
325 sizeof(PerlIOScalar),
326 PERLIO_K_BUFFERED | PERLIO_K_RAW,
327 PerlIOScalar_pushed,
328 PerlIOScalar_popped,
329 PerlIOScalar_open,
330 PerlIOBase_binmode,
331 PerlIOScalar_arg,
332 PerlIOScalar_fileno,
333 PerlIOScalar_dup,
ffe0bb5a 334 PerlIOScalar_read,
3ff3a8b6 335 NULL, /* unread */
14d89041
NIS
336 PerlIOScalar_write,
337 PerlIOScalar_seek,
338 PerlIOScalar_tell,
339 PerlIOScalar_close,
340 PerlIOScalar_flush,
341 PerlIOScalar_fill,
342 PerlIOBase_eof,
343 PerlIOBase_error,
344 PerlIOBase_clearerr,
345 PerlIOBase_setlinebuf,
346 PerlIOScalar_get_base,
347 PerlIOScalar_bufsiz,
348 PerlIOScalar_get_ptr,
349 PerlIOScalar_get_cnt,
350 PerlIOScalar_set_ptrcnt,
f6c77cf1
NIS
351};
352
353
354#endif /* Layers available */
355
e934609f 356MODULE = PerlIO::scalar PACKAGE = PerlIO::scalar
f6c77cf1 357
acf4de66
A
358PROTOTYPES: ENABLE
359
f6c77cf1
NIS
360BOOT:
361{
362#ifdef PERLIO_LAYERS
27da23d5 363 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_scalar));
f6c77cf1
NIS
364#endif
365}
366